FontyFruity 0.5.3.4 → 0.5.3.5
raw patch · 12 files changed
+1660/−1661 lines, 12 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Graphics.Text.TrueType.Internal: HorizontalMetricsTable :: !(Vector HorizontalMetric) -> HorizontalMetricsTable
+ Graphics.Text.TrueType.Internal: HorizontalMetricsTable :: !Vector HorizontalMetric -> HorizontalMetricsTable
- Graphics.Text.TrueType.Internal: [_glyphMetrics] :: HorizontalMetricsTable -> !(Vector HorizontalMetric)
+ Graphics.Text.TrueType.Internal: [_glyphMetrics] :: HorizontalMetricsTable -> !Vector HorizontalMetric
Files
- FontyFruity.cabal +1/−1
- changelog +4/−0
- src/Graphics/Text/TrueType/Bytecode.hs +448/−448
- src/Graphics/Text/TrueType/CharacterMap.hs +385/−385
- src/Graphics/Text/TrueType/FontFolders.hs +241/−241
- src/Graphics/Text/TrueType/Glyph.hs +4/−5
- src/Graphics/Text/TrueType/Header.hs +142/−143
- src/Graphics/Text/TrueType/HorizontalInfo.hs +120/−120
- src/Graphics/Text/TrueType/MaxpTable.hs +58/−59
- src/Graphics/Text/TrueType/Name.hs +120/−122
- src/Graphics/Text/TrueType/OffsetTable.hs +89/−89
- src/Graphics/Text/TrueType/Types.hs +48/−48
FontyFruity.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: FontyFruity -version: 0.5.3.4 +version: 0.5.3.5 synopsis: A true type file format loader description: A haskell Truetype file parser.
changelog view
@@ -1,5 +1,9 @@ -*-change-log-*- +v0.5.3.5 Septermeber 2019 + * Fix: GHC 8.8.1 compat + how regular + v0.5.3.4 September 2018 * Fix: GHC 8.6.1 compat
src/Graphics/Text/TrueType/Bytecode.hs view
@@ -1,448 +1,448 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Bytecode where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-import Data.Monoid( mempty )-#endif--import Prelude hiding ( EQ, GT, LT )-{-import Control.Monad.State.Strict( modify )-}-import Data.Bits( (.&.), testBit )-import Data.Binary.Get( Get, getWord8, getWord16be )-import Data.Int( Int32 )-import qualified Data.Map as M-import Data.Word( Word8, Word16 )-import qualified Data.Vector.Unboxed as VU--import Graphics.Text.TrueType.Types--type InstructionFlag = Bool--data Instruction- -- | Pop one argument from the stack- = AA - | ABS- | ADD- | ALIGNPTS- | ALIGNRP- | AND- | CALL- | CEILING- | CINDEX- | CLEAR- | DEBUG- | DELTAC1- | DELTAC2- | DELTAC3- | DELTAP1- | DELTAP2- | DELTAP3- | DEPTH- | DIV- | DUP- | EIF- | ELSE- | ENDF- | EQ- | EVEN- | FDEF- | FLIPOFF- | FLIPON- | FLIPPT- | FLIPRGOFF- | FLIPRGON- | FLOOR- | GC PositionSource- | GETINFO- -- | Get Freedom vector- | GFV- | GPV- | GT- | GTEQ- | IDEF- | IF- | INSTCTRL- | IP- | ISECT- | IUP Direction- | JMPR- | JROF- | JROT- | LOOPCALL- | LT- | LTEQ- | MAX- | MD PositionSource- | MDAP Rounding- | MDRP PointReset DistanceKeeping Rounding Word8- | MIAP Rounding- | MIN- | MINDEX- | MIRP PointReset DistanceKeeping Rounding Word8- | MPPEM- | MPS- | MSIRP PointReset- | MUL- | NEG- | NEQ- | NOT- | NPUSHB (VU.Vector Word8)- | NPUSHW (VU.Vector Word16)- | NROUND Word8- | ODD- | OR- | POP- | PUSHB (VU.Vector Word8)- | PUSHW (VU.Vector Word16)- | RCVT- | RDTG- | ROFF- | ROLL- | ROUND Word8- | RS- | RTDG- | RTG- | RTHG- | RUTG- | S45ROUND- | SANGW- | SCANCTRL- | SCANTYPE- | SCFS- | SCVTCI- | SDB- | SDPVTL Parallelism- | SDS- | SFVFS- | SFVTCA Direction- | SFVTL Parallelism- | SFVTPV- | SHC CountourRef- | SHP CountourRef- | SHPIX- | SHZ CountourRef- | SLOOP- | SMD- | SPVFS- | SPVTCA Direction- | SPVTL Parallelism- | SROUND- | SRP0- | SRP1- | SRP2- | SSW- | SSWCI- | SUB- | SVTCA Direction- | SWAP- | SZP0- | SZP1- | SZP2- | SZPS- | UTP- | WCVTF- | WCVTP- | WS- deriving (Eq, Show)--data CountourRef- = UseRP2InZP1- | UseRP1InZP0- deriving (Eq, Show)--data Parallelism- = VectorParallel- | VectorPerpendicular- deriving (Eq, Show)--data PositionSource- = PositionCurrent- | PositionOriginal- deriving (Eq, Show)--data Direction- = DirectionX- | DirectionY- deriving (Eq, Show)--data Rounding- = RoundingNone- | Rounding- deriving (Eq, Show)--data PointReset- = ResetNot- | ResetRP0- deriving (Eq, Show)--data DistanceKeeping- = DistanceFree- | DistanceGreaterThanMin- deriving (Eq, Show)--data ByteCodeProgram- = If [ByteCodeProgram]- | IfElse [ByteCodeProgram] [ByteCodeProgram]- | Function [ByteCodeProgram]- | Sequence [Instruction]- deriving (Eq, Show)--instructionToProgram :: [Instruction]-> [ByteCodeProgram]-instructionToProgram = firstOfThird . go []- where- firstOfThird (f, _, _) = f-- go acc [] = (reverse acc, [], [])- go acc (IF : rest) =- case go [] rest of- (ifBranch, [], final) -> go (If ifBranch : acc) final- (ifBranch, elseBranch, final) ->- go (IfElse ifBranch elseBranch : acc) final- go acc (EIF : rest) = (reverse acc, [], rest)- go acc (ELSE : rest) = (acc, elseBranch, final)- where (elseBranch, _, final) = go [] rest- go acc (FDEF : rest) = go (Function def: acc) final- where (def, _, final) = go [] rest- go acc (ENDF : rest) = (reverse acc, [], rest)- go acc (x : xs) = go (Sequence [x] : acc) xs---inRange :: Ord a => a -> (a, a) -> Bool-inRange v (lo, hi) = lo <= v && v <= hi--getInstr :: Get Instruction -getInstr = getWord8 >>= go- where- mirpParse x constructor = constructor reset distance rounding distanceType- where- reset | x `testBit` 4 = ResetRP0- | otherwise = ResetNot-- distance | x `testBit` 3 = DistanceGreaterThanMin- | otherwise = DistanceFree-- rounding | x `testBit` 2 = Rounding- | otherwise = RoundingNone-- distanceType = x .&. 0x3-- go w = case w of- 0x7F -> return AA- 0x64 -> return ABS- 0x60 -> return ADD- 0x27 -> return ALIGNPTS- 0x3C -> return ALIGNRP- 0x5A -> return AND- 0x2B -> return CALL- 0x67 -> return CEILING- 0x25 -> return CINDEX- 0x22 -> return CLEAR- 0x4F -> return DEBUG- 0x73 -> return DELTAC1- 0x74 -> return DELTAC2- 0x75 -> return DELTAC3- 0x5D -> return DELTAP1- 0x71 -> return DELTAP2- 0x72 -> return DELTAP3- 0x24 -> return DEPTH- 0x62 -> return DIV- 0x20 -> return DUP- 0x59 -> return EIF- 0x1B -> return ELSE- 0x2D -> return ENDF- 0x54 -> return EQ- 0x57 -> return EVEN- 0x2C -> return FDEF- 0x4E -> return FLIPOFF- 0x4D -> return FLIPON- 0x80 -> return FLIPPT- 0x82 -> return FLIPRGOFF- 0x81 -> return FLIPRGON- 0x66 -> return FLOOR- 0x46 -> return $ GC PositionCurrent- 0x47 -> return $ GC PositionOriginal- 0x88 -> return GETINFO- 0x0D -> return GFV- 0x0C -> return GPV- 0x52 -> return GT- 0x53 -> return GTEQ- 0x89 -> return IDEF- 0x58 -> return IF- 0x8E -> return INSTCTRL- 0x39 -> return IP- 0x0F -> return ISECT- 0x30 -> return $ IUP DirectionY- 0x31 -> return $ IUP DirectionX- 0x1C -> return JMPR- 0x79 -> return JROF- 0x78 -> return JROT- 0x2A -> return LOOPCALL- 0x50 -> return LT- 0x51 -> return LTEQ- 0x8B -> return MAX- 0x49 -> return $ MD PositionCurrent- 0x4A -> return $ MD PositionOriginal- 0x2E -> return $ MDAP RoundingNone- 0x2F -> return $ MDAP Rounding- x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP- 0x3E -> return $ MIAP RoundingNone- 0x3F -> return $ MIAP Rounding- 0x8C -> return MIN- 0x26 -> return MINDEX- x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP- 0x4B -> return MPPEM- 0x4C -> return MPS- 0x3A -> return $ MSIRP ResetNot- 0x3B -> return $ MSIRP ResetRP0- 0x63 -> return MUL- 0x65 -> return NEG- 0x55 -> return NEQ- 0x5C -> return NOT- 0x40 -> do- count <- fromIntegral <$> getWord8- NPUSHB <$> VU.replicateM count getWord8-- 0x41 -> do- count <- fromIntegral <$> getWord8- NPUSHW <$> VU.replicateM count getWord16be- x | x `inRange` (0x6C, 0x6F) ->- return . NROUND $ x .&. 3- 0x56 -> return ODD- 0x5B -> return OR- 0x21 -> return POP- x | x `inRange` (0xB0, 0xB7) -> do- let count = fromIntegral $ (x .&. 0x7) + 1- PUSHB <$> VU.replicateM count getWord8- x | x `inRange` (0xB8, 0xBF) -> do- let count = fromIntegral $ (x .&. 0x7) + 1- PUSHW <$> VU.replicateM count getWord16be- 0x45 -> return RCVT- 0x7D -> return RDTG- 0x7A -> return ROFF- 0x8A -> return ROLL- x | x `inRange` (0x68, 0x6B) ->- return $ ROUND (x .&. 0x3)- 0x43 -> return RS- 0x3D -> return RTDG- 0x18 -> return RTG- 0x19 -> return RTHG- 0x7C -> return RUTG- 0x77 -> return S45ROUND- 0x7E -> return SANGW- 0x85 -> return SCANCTRL- 0x8D -> return SCANTYPE- 0x48 -> return SCFS- 0x1D -> return SCVTCI- 0x5E -> return SDB- 0x86 -> return $ SDPVTL VectorParallel- 0x87 -> return $ SDPVTL VectorPerpendicular- 0x5F -> return SDS- 0x0B -> return SFVFS- 0x04 -> return $ SFVTCA DirectionY- 0x05 -> return $ SFVTCA DirectionX- 0x08 -> return $ SFVTL VectorParallel- 0x09 -> return $ SFVTL VectorPerpendicular- 0x0E -> return SFVTPV- 0x34 -> return $ SHC UseRP2InZP1- 0x35 -> return $ SHC UseRP1InZP0- 0x32 -> return $ SHP UseRP2InZP1- 0x33 -> return $ SHP UseRP1InZP0- 0x38 -> return SHPIX- 0x36 -> return $ SHZ UseRP2InZP1- 0x37 -> return $ SHZ UseRP1InZP0- 0x17 -> return SLOOP- 0x1A -> return SMD- 0x0A -> return SPVFS- 0x02 -> return $ SPVTCA DirectionY- 0x03 -> return $ SPVTCA DirectionX- 0x06 -> return $ SPVTL VectorParallel- 0x07 -> return $ SPVTL VectorPerpendicular- 0x76 -> return SROUND- 0x10 -> return SRP0- 0x11 -> return SRP1- 0x12 -> return SRP2- 0x1F -> return SSW- 0x1E -> return SSWCI- 0x61 -> return SUB- 0x00 -> return $ SVTCA DirectionY- 0x01 -> return $ SVTCA DirectionX- 0x23 -> return SWAP- 0x13 -> return SZP0- 0x14 -> return SZP1- 0x15 -> return SZP2- 0x16 -> return SZPS- 0x29 -> return UTP- 0x70 -> return WCVTF- 0x44 -> return WCVTP- 0x42 -> return WS- _ -> fail "instruction reader coverage pleaser"--type Point = (F26Dot6, F26Dot6)--data GraphicalState = GraphicalState- { _stAutoFlip :: !Bool- , _stCutIn :: {-# UNPACK #-} !F26Dot6- , _stDeltaBase :: {-# UNPACK #-} !Int32- , _stDeltaShift :: {-# UNPACK #-} !Int32- , _stDualProjection :: !(Maybe Point)- , _stFreedomVector :: !Point- , _stInstructionControl :: !Bool- , _stLoop :: {-# UNPACK #-} !Int32- , _stMinDistance :: {-# UNPACK #-} !F26Dot6- , _stProjectionVector :: !Point- , _stRoundState :: {-# UNPACK #-} !Int32- , _stRp0 :: {-# UNPACK #-} !Int32- , _stRp1 :: {-# UNPACK #-} !Int32- , _stRp2 :: {-# UNPACK #-} !Int32- , _stScanControl :: !Bool- , _stSingleWidthCutIn :: {-# UNPACK #-} !F26Dot6- , _stSingleWidthValue :: {-# UNPACK #-} !F26Dot6- , _stZp0 :: {-# UNPACK #-} !Int32- , _stZp1 :: {-# UNPACK #-} !Int32- , _stZp2 :: {-# UNPACK #-} !Int32- , _stFunctions :: !(M.Map Int32 [ByteCodeProgram])- }- deriving (Eq, Show)--initialState :: GraphicalState-initialState = GraphicalState- { _stAutoFlip = True- , _stCutIn = 17 / 16- , _stDeltaBase = 9- , _stDeltaShift = 3- , _stDualProjection = Nothing- , _stFreedomVector = (1, 0)- , _stInstructionControl = False- , _stLoop = 1- , _stMinDistance = 1- , _stProjectionVector = (1, 0)- , _stRoundState = 1- , _stRp0 = 0- , _stRp1 = 0- , _stRp2 = 0- , _stScanControl = False- , _stSingleWidthCutIn = 0- , _stSingleWidthValue = 0- , _stZp0 = 1- , _stZp1 = 1- , _stZp2 = 1- , _stFunctions = mempty- }--#if 0--evaluate :: [ByteCodeProgram] -> ()-evaluate instrs =- where- byteExec [] stack = stack- byteExec (If _ : instr) (0:stack) = byteExec instr stack- byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack- byteExec (IfElse _ elseBody) (0:stack) = byteExec (elseBody ++ instr) stack- byteExec (IfElse thenBody _) (_:stack) = byteExec (thenBody ++ instr) stack- byteExec (Function functionBody : instr) (id:stack) =- modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack- byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest--#endif-+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.Bytecode where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +import Data.Monoid( mempty ) +#endif + +import Prelude hiding ( EQ, GT, LT ) +{-import Control.Monad.State.Strict( modify )-} +import Data.Bits( (.&.), testBit ) +import Data.Binary.Get( Get, getWord8, getWord16be ) +import Data.Int( Int32 ) +import qualified Data.Map as M +import Data.Word( Word8, Word16 ) +import qualified Data.Vector.Unboxed as VU + +import Graphics.Text.TrueType.Types + +type InstructionFlag = Bool + +data Instruction + -- | Pop one argument from the stack + = AA + | ABS + | ADD + | ALIGNPTS + | ALIGNRP + | AND + | CALL + | CEILING + | CINDEX + | CLEAR + | DEBUG + | DELTAC1 + | DELTAC2 + | DELTAC3 + | DELTAP1 + | DELTAP2 + | DELTAP3 + | DEPTH + | DIV + | DUP + | EIF + | ELSE + | ENDF + | EQ + | EVEN + | FDEF + | FLIPOFF + | FLIPON + | FLIPPT + | FLIPRGOFF + | FLIPRGON + | FLOOR + | GC PositionSource + | GETINFO + -- | Get Freedom vector + | GFV + | GPV + | GT + | GTEQ + | IDEF + | IF + | INSTCTRL + | IP + | ISECT + | IUP Direction + | JMPR + | JROF + | JROT + | LOOPCALL + | LT + | LTEQ + | MAX + | MD PositionSource + | MDAP Rounding + | MDRP PointReset DistanceKeeping Rounding Word8 + | MIAP Rounding + | MIN + | MINDEX + | MIRP PointReset DistanceKeeping Rounding Word8 + | MPPEM + | MPS + | MSIRP PointReset + | MUL + | NEG + | NEQ + | NOT + | NPUSHB (VU.Vector Word8) + | NPUSHW (VU.Vector Word16) + | NROUND Word8 + | ODD + | OR + | POP + | PUSHB (VU.Vector Word8) + | PUSHW (VU.Vector Word16) + | RCVT + | RDTG + | ROFF + | ROLL + | ROUND Word8 + | RS + | RTDG + | RTG + | RTHG + | RUTG + | S45ROUND + | SANGW + | SCANCTRL + | SCANTYPE + | SCFS + | SCVTCI + | SDB + | SDPVTL Parallelism + | SDS + | SFVFS + | SFVTCA Direction + | SFVTL Parallelism + | SFVTPV + | SHC CountourRef + | SHP CountourRef + | SHPIX + | SHZ CountourRef + | SLOOP + | SMD + | SPVFS + | SPVTCA Direction + | SPVTL Parallelism + | SROUND + | SRP0 + | SRP1 + | SRP2 + | SSW + | SSWCI + | SUB + | SVTCA Direction + | SWAP + | SZP0 + | SZP1 + | SZP2 + | SZPS + | UTP + | WCVTF + | WCVTP + | WS + deriving (Eq, Show) + +data CountourRef + = UseRP2InZP1 + | UseRP1InZP0 + deriving (Eq, Show) + +data Parallelism + = VectorParallel + | VectorPerpendicular + deriving (Eq, Show) + +data PositionSource + = PositionCurrent + | PositionOriginal + deriving (Eq, Show) + +data Direction + = DirectionX + | DirectionY + deriving (Eq, Show) + +data Rounding + = RoundingNone + | Rounding + deriving (Eq, Show) + +data PointReset + = ResetNot + | ResetRP0 + deriving (Eq, Show) + +data DistanceKeeping + = DistanceFree + | DistanceGreaterThanMin + deriving (Eq, Show) + +data ByteCodeProgram + = If [ByteCodeProgram] + | IfElse [ByteCodeProgram] [ByteCodeProgram] + | Function [ByteCodeProgram] + | Sequence [Instruction] + deriving (Eq, Show) + +instructionToProgram :: [Instruction]-> [ByteCodeProgram] +instructionToProgram = firstOfThird . go [] + where + firstOfThird (f, _, _) = f + + go acc [] = (reverse acc, [], []) + go acc (IF : rest) = + case go [] rest of + (ifBranch, [], final) -> go (If ifBranch : acc) final + (ifBranch, elseBranch, final) -> + go (IfElse ifBranch elseBranch : acc) final + go acc (EIF : rest) = (reverse acc, [], rest) + go acc (ELSE : rest) = (acc, elseBranch, final) + where (elseBranch, _, final) = go [] rest + go acc (FDEF : rest) = go (Function def: acc) final + where (def, _, final) = go [] rest + go acc (ENDF : rest) = (reverse acc, [], rest) + go acc (x : xs) = go (Sequence [x] : acc) xs + + +inRange :: Ord a => a -> (a, a) -> Bool +inRange v (lo, hi) = lo <= v && v <= hi + +getInstr :: Get Instruction +getInstr = getWord8 >>= go + where + mirpParse x constructor = constructor reset distance rounding distanceType + where + reset | x `testBit` 4 = ResetRP0 + | otherwise = ResetNot + + distance | x `testBit` 3 = DistanceGreaterThanMin + | otherwise = DistanceFree + + rounding | x `testBit` 2 = Rounding + | otherwise = RoundingNone + + distanceType = x .&. 0x3 + + go w = case w of + 0x7F -> return AA + 0x64 -> return ABS + 0x60 -> return ADD + 0x27 -> return ALIGNPTS + 0x3C -> return ALIGNRP + 0x5A -> return AND + 0x2B -> return CALL + 0x67 -> return CEILING + 0x25 -> return CINDEX + 0x22 -> return CLEAR + 0x4F -> return DEBUG + 0x73 -> return DELTAC1 + 0x74 -> return DELTAC2 + 0x75 -> return DELTAC3 + 0x5D -> return DELTAP1 + 0x71 -> return DELTAP2 + 0x72 -> return DELTAP3 + 0x24 -> return DEPTH + 0x62 -> return DIV + 0x20 -> return DUP + 0x59 -> return EIF + 0x1B -> return ELSE + 0x2D -> return ENDF + 0x54 -> return EQ + 0x57 -> return EVEN + 0x2C -> return FDEF + 0x4E -> return FLIPOFF + 0x4D -> return FLIPON + 0x80 -> return FLIPPT + 0x82 -> return FLIPRGOFF + 0x81 -> return FLIPRGON + 0x66 -> return FLOOR + 0x46 -> return $ GC PositionCurrent + 0x47 -> return $ GC PositionOriginal + 0x88 -> return GETINFO + 0x0D -> return GFV + 0x0C -> return GPV + 0x52 -> return GT + 0x53 -> return GTEQ + 0x89 -> return IDEF + 0x58 -> return IF + 0x8E -> return INSTCTRL + 0x39 -> return IP + 0x0F -> return ISECT + 0x30 -> return $ IUP DirectionY + 0x31 -> return $ IUP DirectionX + 0x1C -> return JMPR + 0x79 -> return JROF + 0x78 -> return JROT + 0x2A -> return LOOPCALL + 0x50 -> return LT + 0x51 -> return LTEQ + 0x8B -> return MAX + 0x49 -> return $ MD PositionCurrent + 0x4A -> return $ MD PositionOriginal + 0x2E -> return $ MDAP RoundingNone + 0x2F -> return $ MDAP Rounding + x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP + 0x3E -> return $ MIAP RoundingNone + 0x3F -> return $ MIAP Rounding + 0x8C -> return MIN + 0x26 -> return MINDEX + x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP + 0x4B -> return MPPEM + 0x4C -> return MPS + 0x3A -> return $ MSIRP ResetNot + 0x3B -> return $ MSIRP ResetRP0 + 0x63 -> return MUL + 0x65 -> return NEG + 0x55 -> return NEQ + 0x5C -> return NOT + 0x40 -> do + count <- fromIntegral <$> getWord8 + NPUSHB <$> VU.replicateM count getWord8 + + 0x41 -> do + count <- fromIntegral <$> getWord8 + NPUSHW <$> VU.replicateM count getWord16be + x | x `inRange` (0x6C, 0x6F) -> + return . NROUND $ x .&. 3 + 0x56 -> return ODD + 0x5B -> return OR + 0x21 -> return POP + x | x `inRange` (0xB0, 0xB7) -> do + let count = fromIntegral $ (x .&. 0x7) + 1 + PUSHB <$> VU.replicateM count getWord8 + x | x `inRange` (0xB8, 0xBF) -> do + let count = fromIntegral $ (x .&. 0x7) + 1 + PUSHW <$> VU.replicateM count getWord16be + 0x45 -> return RCVT + 0x7D -> return RDTG + 0x7A -> return ROFF + 0x8A -> return ROLL + x | x `inRange` (0x68, 0x6B) -> + return $ ROUND (x .&. 0x3) + 0x43 -> return RS + 0x3D -> return RTDG + 0x18 -> return RTG + 0x19 -> return RTHG + 0x7C -> return RUTG + 0x77 -> return S45ROUND + 0x7E -> return SANGW + 0x85 -> return SCANCTRL + 0x8D -> return SCANTYPE + 0x48 -> return SCFS + 0x1D -> return SCVTCI + 0x5E -> return SDB + 0x86 -> return $ SDPVTL VectorParallel + 0x87 -> return $ SDPVTL VectorPerpendicular + 0x5F -> return SDS + 0x0B -> return SFVFS + 0x04 -> return $ SFVTCA DirectionY + 0x05 -> return $ SFVTCA DirectionX + 0x08 -> return $ SFVTL VectorParallel + 0x09 -> return $ SFVTL VectorPerpendicular + 0x0E -> return SFVTPV + 0x34 -> return $ SHC UseRP2InZP1 + 0x35 -> return $ SHC UseRP1InZP0 + 0x32 -> return $ SHP UseRP2InZP1 + 0x33 -> return $ SHP UseRP1InZP0 + 0x38 -> return SHPIX + 0x36 -> return $ SHZ UseRP2InZP1 + 0x37 -> return $ SHZ UseRP1InZP0 + 0x17 -> return SLOOP + 0x1A -> return SMD + 0x0A -> return SPVFS + 0x02 -> return $ SPVTCA DirectionY + 0x03 -> return $ SPVTCA DirectionX + 0x06 -> return $ SPVTL VectorParallel + 0x07 -> return $ SPVTL VectorPerpendicular + 0x76 -> return SROUND + 0x10 -> return SRP0 + 0x11 -> return SRP1 + 0x12 -> return SRP2 + 0x1F -> return SSW + 0x1E -> return SSWCI + 0x61 -> return SUB + 0x00 -> return $ SVTCA DirectionY + 0x01 -> return $ SVTCA DirectionX + 0x23 -> return SWAP + 0x13 -> return SZP0 + 0x14 -> return SZP1 + 0x15 -> return SZP2 + 0x16 -> return SZPS + 0x29 -> return UTP + 0x70 -> return WCVTF + 0x44 -> return WCVTP + 0x42 -> return WS + _ -> fail "instruction reader coverage pleaser" + +type Point = (F26Dot6, F26Dot6) + +data GraphicalState = GraphicalState + { _stAutoFlip :: !Bool + , _stCutIn :: {-# UNPACK #-} !F26Dot6 + , _stDeltaBase :: {-# UNPACK #-} !Int32 + , _stDeltaShift :: {-# UNPACK #-} !Int32 + , _stDualProjection :: !(Maybe Point) + , _stFreedomVector :: !Point + , _stInstructionControl :: !Bool + , _stLoop :: {-# UNPACK #-} !Int32 + , _stMinDistance :: {-# UNPACK #-} !F26Dot6 + , _stProjectionVector :: !Point + , _stRoundState :: {-# UNPACK #-} !Int32 + , _stRp0 :: {-# UNPACK #-} !Int32 + , _stRp1 :: {-# UNPACK #-} !Int32 + , _stRp2 :: {-# UNPACK #-} !Int32 + , _stScanControl :: !Bool + , _stSingleWidthCutIn :: {-# UNPACK #-} !F26Dot6 + , _stSingleWidthValue :: {-# UNPACK #-} !F26Dot6 + , _stZp0 :: {-# UNPACK #-} !Int32 + , _stZp1 :: {-# UNPACK #-} !Int32 + , _stZp2 :: {-# UNPACK #-} !Int32 + , _stFunctions :: !(M.Map Int32 [ByteCodeProgram]) + } + deriving (Eq, Show) + +initialState :: GraphicalState +initialState = GraphicalState + { _stAutoFlip = True + , _stCutIn = 17 / 16 + , _stDeltaBase = 9 + , _stDeltaShift = 3 + , _stDualProjection = Nothing + , _stFreedomVector = (1, 0) + , _stInstructionControl = False + , _stLoop = 1 + , _stMinDistance = 1 + , _stProjectionVector = (1, 0) + , _stRoundState = 1 + , _stRp0 = 0 + , _stRp1 = 0 + , _stRp2 = 0 + , _stScanControl = False + , _stSingleWidthCutIn = 0 + , _stSingleWidthValue = 0 + , _stZp0 = 1 + , _stZp1 = 1 + , _stZp2 = 1 + , _stFunctions = mempty + } + +#if 0 + +evaluate :: [ByteCodeProgram] -> () +evaluate instrs = + where + byteExec [] stack = stack + byteExec (If _ : instr) (0:stack) = byteExec instr stack + byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack + byteExec (IfElse _ elseBody) (0:stack) = byteExec (elseBody ++ instr) stack + byteExec (IfElse thenBody _) (_:stack) = byteExec (thenBody ++ instr) stack + byteExec (Function functionBody : instr) (id:stack) = + modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack + byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest + +#endif +
src/Graphics/Text/TrueType/CharacterMap.hs view
@@ -1,385 +1,385 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.CharacterMap- ( TtfEncoding( .. )- , CharacterMaps- , LangId- , findCharGlyph- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Control.Monad( replicateM, when, foldM )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get- , skip- , bytesRead- , getWord8- , getWord16be- , getWord32be )--import Data.Binary.Put( putWord16be- , putWord32be )-import Data.Int( Int16 )-import Data.List( find, sort, sortBy )-import qualified Data.Map.Strict as M-import Data.Maybe( fromMaybe )-import Data.Word( Word8, Word16, Word32 )-import Data.Ord( comparing )--import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as VU--import Graphics.Text.TrueType.LanguageIds--------------------------------------------------------- TtfEncoding----------------------------------------------------data TtfEncoding- = EncodingSymbol- | EncodingUnicode- | EncodingShiftJIS- | EncodingBig5- | EncodingPRC- | EncodingWansung- | EncodingJohab- deriving (Eq, Show)--instance Binary TtfEncoding where- put EncodingSymbol = putWord16be 0- put EncodingUnicode = putWord16be 1- put EncodingShiftJIS = putWord16be 2- put EncodingBig5 = putWord16be 3- put EncodingPRC = putWord16be 4- put EncodingWansung = putWord16be 5- put EncodingJohab = putWord16be 6-- get = do- v <- getWord16be- case v of- 0 -> return EncodingSymbol- 1 -> return EncodingUnicode- 2 -> return EncodingShiftJIS- 3 -> return EncodingBig5- 4 -> return EncodingPRC- 5 -> return EncodingWansung- 6 -> return EncodingJohab- _ -> fail "Unknown encoding"--class CharMappeable a where- -- | Given a group a character, return a valid glyph- -- id and the rest of the string.- glyphIdFromTable :: a -> Char -> Int-- -- | Given a table, retrieve the language code- langIdOfCharMap :: a -> LangId--type LangId = Word16--------------------------------------------------------- CharacterMaps----------------------------------------------------data CharacterMap = CharacterMap- { _charMapPlatformId :: !PlatformId- , _charMapPlatformSpecific :: !Word16- , _charMap :: !CharacterTable- }- deriving (Eq, Show)--instance NFData CharacterMap where- rnf (CharacterMap {}) = ()--instance Ord CharacterMap where- compare = comparing _charMap--newtype CharacterMaps = CharacterMaps [CharacterMap]- deriving (Eq, Show)--instance NFData CharacterMaps where- rnf (CharacterMaps maps) = rnf maps `seq` ()--instance Binary CharacterMaps where- put _ = fail "Unimplemented"- get = do- startIndex <- bytesRead- versionNumber <- getWord16be- when (versionNumber /= 0)- (fail "Characte map - invalid version number")- tableCount <- fromIntegral <$> getWord16be- let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be- third (_, _, t) = t- tableDesc <-- sortBy (comparing third) <$> replicateM tableCount descFetcher- -- let fetcher (allMaps, lst) (platformId, platformSpecific, offset)- | M.member offset allMaps = case M.lookup offset allMaps of- Nothing -> fail "Impossible"- Just table ->- return (allMaps, CharacterMap platformId platformSpecific table : lst)- fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do- currentOffset <- fromIntegral <$> bytesRead- let toSkip = fromIntegral offset - currentOffset + startIndex- when (toSkip > 0)- (skip $ fromIntegral toSkip)- mapData <- get- let charMap = CharacterMap platformId platformSpecific mapData- return (M.insert offset mapData allMaps, charMap : lst)- - (_, tables) <- foldM fetcher (M.empty, []) tableDesc- return . CharacterMaps $ sortBy (comparing _charMap) tables--data CharMapOffset = CharMapOffset- { _cmoPlatformId :: !Word16- , _cmoEncodingId :: !TtfEncoding- , _cmoOffset :: !Word32- }- deriving (Eq, Show)--instance Binary CharMapOffset where- get = CharMapOffset <$> getWord16be <*> get <*> getWord32be- put (CharMapOffset platform encoding offset) =- putWord16be platform >> put encoding >> putWord32be offset--------------------------------------------------------- CharacterTable----------------------------------------------------data CharacterTable- = TableFormat0 !Format0- | TableFormat2 !Format2- | TableFormat4 !Format4- | TableFormat6 !Format6- | TableFormatUnknown !Word16- deriving (Eq, Show)--charTableMap :: (forall table . (CharMappeable table) => table -> a)- -> CharacterTable -> a-charTableMap f = go- where- go (TableFormat0 t) = f t- go (TableFormat2 t) = f t- go (TableFormat4 t) = f t- go (TableFormat6 t) = f t- go (TableFormatUnknown v) = f v--findCharGlyph :: CharacterMaps -> LangId -> Char -> Int-findCharGlyph (CharacterMaps charMaps) langId character =- fromMaybe 0 . find (/= 0) . map snd . sort $- [(_charMapPlatformId allMap, charTableMap (`glyphIdFromTable` character) m)- | allMap <- charMaps- , let m = _charMap allMap- , isLangCompatible m]- where- isLangCompatible v = tableLang == 0 || tableLang == langId - where tableLang = charTableMap langIdOfCharMap v--instance Ord CharacterTable where- compare (TableFormat0 v1) (TableFormat0 v2) =- comparing langIdOfCharMap v1 v2- compare (TableFormat2 v1) (TableFormat2 v2) =- comparing langIdOfCharMap v1 v2- compare (TableFormat4 v1) (TableFormat4 v2) =- comparing langIdOfCharMap v1 v2- compare (TableFormat6 v1) (TableFormat6 v2) =- comparing langIdOfCharMap v1 v2- compare (TableFormat0 _) _ = LT- compare (TableFormat2 _) _ = LT- compare (TableFormat4 _) _ = LT- compare (TableFormat6 _) _ = LT- compare _ _ = GT--instance Binary CharacterTable where- put _ = fail "Binary.put CharacterTable - Unimplemented"- get = do- format <- getWord16be- case format of- 0 -> TableFormat0 <$> get- 2 -> TableFormat2 <$> get- 4 -> TableFormat4 <$> get- 6 -> TableFormat6 <$> get- n -> return $ TableFormatUnknown n--instance CharMappeable Word16 where- glyphIdFromTable _ _ = 0- langIdOfCharMap _ = 0---------------------------------------------------------- Format4----------------------------------------------------data Format4 = Format4- { _f4Language :: {-# UNPACK #-} !LangId- , _f4Map :: M.Map Word16 Word16- }- deriving (Eq, Show)--instance CharMappeable Format4 where- glyphIdFromTable tab v =- fromIntegral . M.findWithDefault 0 wc $ _f4Map tab- where wc = fromIntegral $ fromEnum v- langIdOfCharMap = _f4Language--instance Binary Format4 where- put _ = error "put Format4 - unimplemented"- get = do- startIndex <- bytesRead- tableLength <- fromIntegral <$> getWord16be- language <- getWord16be- -- 2 * segCount- segCount <- (`div` 2) . fromIntegral <$> getWord16be- -- 2 * (2**FLOOR(log2(segCount)))- _searchRange <- getWord16be- -- log2(searchRange/2)- _entrySelector <- getWord16be- -- (2 * segCount) - searchRange- _rangeShift <- getWord16be-- let fetcher :: Get (VU.Vector Int)- fetcher =- VU.replicateM segCount (fromIntegral <$> getWord16be)-- endCodes <- fetcher- _reservedPad <- getWord16be- startCodes <- fetcher- idDelta <-- VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16)- idRangeOffset <- fetcher-- tableBeginIndex <- bytesRead- let idDeltaInt = VU.map fromIntegral idDelta- rangeInfo = init . VU.toList $- VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $- VU.enumFromN 0 segCount-- indexLeft = fromIntegral $- (tableLength - (tableBeginIndex - startIndex + 2))- `div` 2-- indexTable <- VU.replicateM indexLeft getWord16be-- endIndex <- bytesRead- let toSkip = endIndex - startIndex - tableLength + 2- if toSkip < 0 then- fail $ "Read to much Format4 table " ++ show toSkip- else- skip $ fromIntegral toSkip--- return . Format4 language . M.fromList- $ concatMap (prepare segCount indexTable) rangeInfo- where- prepare _ _ (start, end, delta, 0, _) =- [(fromIntegral char, fromIntegral $ char + delta)- | char <- [start .. end]]- prepare segCount indexTable- (start, end, delta, rangeOffset, ix) =- -- this is... so convoluted oO- [( fromIntegral char- , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta))- | char <- [start .. end]- , let index =- (rangeOffset `div` 2) + (char - start) + ix- - segCount- , index < VU.length indexTable- , let glyphId = indexTable VU.! index- ]--------------------------------------------------------- Format0----------------------------------------------------data Format0 = Format0- { _format0Language :: {-# UNPACK #-} !LangId- , _format0Table :: !(VU.Vector Word8)- }- deriving (Eq, Show)--instance CharMappeable Format0 where- glyphIdFromTable Format0 { _format0Table = table } v- | ic > VU.length table = 0- | otherwise = fromIntegral $ table VU.! ic- where ic = fromEnum v- - langIdOfCharMap = _format0Language--instance Binary Format0 where- put _ = fail "Binary.Format0.put - unimplemented"- get = do- tableSize <- getWord16be- when (tableSize /= 262) $- fail ("table cmap format 0, invalid size: "- ++ show tableSize)- Format0 <$> getWord16be <*> VU.replicateM 256 getWord8--------------------------------------------------------- Format2----------------------------------------------------data Format2 = Format2- { _format2Language :: {-# UNPACK #-} !LangId- , _format2SubKeys :: !(VU.Vector Word16)- , _format2SubHeaders :: !(V.Vector Format2SubHeader)- }- deriving (Eq, Show)--data Format2SubHeader = Format2SubHeader- { _f2SubCode :: {-# UNPACK #-} !Word16- , _f2EntryCount :: {-# UNPACK #-} !Word16- , _f2IdDelta :: {-# UNPACK #-} !Int16- , _f2IdRangeOffset :: {-# UNPACK #-} !Word16- }- deriving (Eq, Show)--instance CharMappeable Format2 where- glyphIdFromTable _ _ = 0- langIdOfCharMap = _format2Language--instance Binary Format2SubHeader where- put (Format2SubHeader a b c d) =- p16 a >> p16 b >> pi16 c >> p16 d- where- p16 = putWord16be- pi16 = p16 . fromIntegral-- get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16- where g16 = getWord16be---instance Binary Format2 where- put _ = fail "Format2.put - unimplemented"- get = do- _tableSize <- getWord16be- lang <- getWord16be- subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be- let maxSubIndex = VU.maximum subKeys- subHeaders <- V.replicateM (fromIntegral maxSubIndex) get- -- TODO finish the parsing of format 2- return $ Format2 lang subKeys subHeaders--------------------------------------------------------- Format6----------------------------------------------------data Format6 = Format6- { _format6Language :: {-# UNPACK #-} !LangId- , _format6FirstCode :: {-# UNPACK #-} !Word16- , _format6ArrayIndex :: !(VU.Vector Word16)- }- deriving (Eq, Show)--instance CharMappeable Format6 where- glyphIdFromTable Format6 { _format6ArrayIndex = table } v- | ic < VU.length table = fromIntegral $ table VU.! ic- | otherwise = 0- where ic = fromEnum v-- langIdOfCharMap = _format6Language--instance Binary Format6 where- put _ = fail "Format6.put - unimplemented"- get = do- _length <- getWord16be- language <- getWord16be- firstCode <- getWord16be- entryCount <- fromIntegral <$> getWord16be- Format6 language firstCode <$> VU.replicateM entryCount getWord16be+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.CharacterMap + ( TtfEncoding( .. ) + , CharacterMaps + , LangId + , findCharGlyph + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Control.DeepSeq( NFData( .. ) ) +import Control.Monad( replicateM, when, foldM ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , skip + , bytesRead + , getWord8 + , getWord16be + , getWord32be ) + +import Data.Binary.Put( putWord16be + , putWord32be ) +import Data.Int( Int16 ) +import Data.List( find, sort, sortBy ) +import qualified Data.Map.Strict as M +import Data.Maybe( fromMaybe ) +import Data.Word( Word8, Word16, Word32 ) +import Data.Ord( comparing ) + +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU + +import Graphics.Text.TrueType.LanguageIds + +-------------------------------------------------- +---- TtfEncoding +-------------------------------------------------- +data TtfEncoding + = EncodingSymbol + | EncodingUnicode + | EncodingShiftJIS + | EncodingBig5 + | EncodingPRC + | EncodingWansung + | EncodingJohab + deriving (Eq, Show) + +instance Binary TtfEncoding where + put EncodingSymbol = putWord16be 0 + put EncodingUnicode = putWord16be 1 + put EncodingShiftJIS = putWord16be 2 + put EncodingBig5 = putWord16be 3 + put EncodingPRC = putWord16be 4 + put EncodingWansung = putWord16be 5 + put EncodingJohab = putWord16be 6 + + get = do + v <- getWord16be + case v of + 0 -> return EncodingSymbol + 1 -> return EncodingUnicode + 2 -> return EncodingShiftJIS + 3 -> return EncodingBig5 + 4 -> return EncodingPRC + 5 -> return EncodingWansung + 6 -> return EncodingJohab + _ -> fail "Unknown encoding" + +class CharMappeable a where + -- | Given a group a character, return a valid glyph + -- id and the rest of the string. + glyphIdFromTable :: a -> Char -> Int + + -- | Given a table, retrieve the language code + langIdOfCharMap :: a -> LangId + +type LangId = Word16 + +-------------------------------------------------- +---- CharacterMaps +-------------------------------------------------- +data CharacterMap = CharacterMap + { _charMapPlatformId :: !PlatformId + , _charMapPlatformSpecific :: !Word16 + , _charMap :: !CharacterTable + } + deriving (Eq, Show) + +instance NFData CharacterMap where + rnf (CharacterMap {}) = () + +instance Ord CharacterMap where + compare = comparing _charMap + +newtype CharacterMaps = CharacterMaps [CharacterMap] + deriving (Eq, Show) + +instance NFData CharacterMaps where + rnf (CharacterMaps maps) = rnf maps `seq` () + +instance Binary CharacterMaps where + put _ = error "Unimplemented" + get = do + startIndex <- bytesRead + versionNumber <- getWord16be + when (versionNumber /= 0) + (fail "Characte map - invalid version number") + tableCount <- fromIntegral <$> getWord16be + let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be + third (_, _, t) = t + tableDesc <- + sortBy (comparing third) <$> replicateM tableCount descFetcher + + + let fetcher (allMaps, lst) (platformId, platformSpecific, offset) + | M.member offset allMaps = case M.lookup offset allMaps of + Nothing -> fail "Impossible" + Just table -> + return (allMaps, CharacterMap platformId platformSpecific table : lst) + fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do + currentOffset <- fromIntegral <$> bytesRead + let toSkip = fromIntegral offset - currentOffset + startIndex + when (toSkip > 0) + (skip $ fromIntegral toSkip) + mapData <- get + let charMap = CharacterMap platformId platformSpecific mapData + return (M.insert offset mapData allMaps, charMap : lst) + + (_, tables) <- foldM fetcher (M.empty, []) tableDesc + return . CharacterMaps $ sortBy (comparing _charMap) tables + +data CharMapOffset = CharMapOffset + { _cmoPlatformId :: !Word16 + , _cmoEncodingId :: !TtfEncoding + , _cmoOffset :: !Word32 + } + deriving (Eq, Show) + +instance Binary CharMapOffset where + get = CharMapOffset <$> getWord16be <*> get <*> getWord32be + put (CharMapOffset platform encoding offset) = + putWord16be platform >> put encoding >> putWord32be offset + +-------------------------------------------------- +---- CharacterTable +-------------------------------------------------- +data CharacterTable + = TableFormat0 !Format0 + | TableFormat2 !Format2 + | TableFormat4 !Format4 + | TableFormat6 !Format6 + | TableFormatUnknown !Word16 + deriving (Eq, Show) + +charTableMap :: (forall table . (CharMappeable table) => table -> a) + -> CharacterTable -> a +charTableMap f = go + where + go (TableFormat0 t) = f t + go (TableFormat2 t) = f t + go (TableFormat4 t) = f t + go (TableFormat6 t) = f t + go (TableFormatUnknown v) = f v + +findCharGlyph :: CharacterMaps -> LangId -> Char -> Int +findCharGlyph (CharacterMaps charMaps) langId character = + fromMaybe 0 . find (/= 0) . map snd . sort $ + [(_charMapPlatformId allMap, charTableMap (`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 _ = error "Binary.put CharacterTable - Unimplemented" + get = do + format <- getWord16be + case format of + 0 -> TableFormat0 <$> get + 2 -> TableFormat2 <$> get + 4 -> TableFormat4 <$> get + 6 -> TableFormat6 <$> get + n -> return $ TableFormatUnknown n + +instance CharMappeable Word16 where + glyphIdFromTable _ _ = 0 + langIdOfCharMap _ = 0 + + +-------------------------------------------------- +---- Format4 +-------------------------------------------------- +data Format4 = Format4 + { _f4Language :: {-# UNPACK #-} !LangId + , _f4Map :: M.Map Word16 Word16 + } + deriving (Eq, Show) + +instance CharMappeable Format4 where + glyphIdFromTable tab v = + fromIntegral . M.findWithDefault 0 wc $ _f4Map tab + where wc = fromIntegral $ fromEnum v + langIdOfCharMap = _f4Language + +instance Binary Format4 where + put _ = error "put Format4 - unimplemented" + get = do + startIndex <- bytesRead + tableLength <- fromIntegral <$> getWord16be + language <- getWord16be + -- 2 * segCount + segCount <- (`div` 2) . fromIntegral <$> getWord16be + -- 2 * (2**FLOOR(log2(segCount))) + _searchRange <- getWord16be + -- log2(searchRange/2) + _entrySelector <- getWord16be + -- (2 * segCount) - searchRange + _rangeShift <- getWord16be + + let fetcher :: Get (VU.Vector Int) + fetcher = + VU.replicateM segCount (fromIntegral <$> getWord16be) + + endCodes <- fetcher + _reservedPad <- getWord16be + startCodes <- fetcher + idDelta <- + VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16) + idRangeOffset <- fetcher + + tableBeginIndex <- bytesRead + let idDeltaInt = VU.map fromIntegral idDelta + rangeInfo = init . VU.toList $ + VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $ + VU.enumFromN 0 segCount + + indexLeft = fromIntegral $ + (tableLength - (tableBeginIndex - startIndex + 2)) + `div` 2 + + indexTable <- VU.replicateM indexLeft getWord16be + + endIndex <- bytesRead + let toSkip = endIndex - startIndex - tableLength + 2 + if toSkip < 0 then + fail $ "Read to much Format4 table " ++ show toSkip + else + skip $ fromIntegral toSkip + + + return . Format4 language . M.fromList + $ concatMap (prepare segCount indexTable) rangeInfo + where + prepare _ _ (start, end, delta, 0, _) = + [(fromIntegral char, fromIntegral $ char + delta) + | char <- [start .. end]] + prepare segCount indexTable + (start, end, delta, rangeOffset, ix) = + -- this is... so convoluted oO + [( fromIntegral char + , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta)) + | char <- [start .. end] + , let index = + (rangeOffset `div` 2) + (char - start) + ix + - segCount + , index < VU.length indexTable + , let glyphId = indexTable VU.! index + ] + +-------------------------------------------------- +---- Format0 +-------------------------------------------------- +data Format0 = Format0 + { _format0Language :: {-# UNPACK #-} !LangId + , _format0Table :: !(VU.Vector Word8) + } + deriving (Eq, Show) + +instance CharMappeable Format0 where + glyphIdFromTable Format0 { _format0Table = table } v + | ic > VU.length table = 0 + | otherwise = fromIntegral $ table VU.! ic + where ic = fromEnum v + + langIdOfCharMap = _format0Language + +instance Binary Format0 where + put _ = error "Binary.Format0.put - unimplemented" + get = do + tableSize <- getWord16be + when (tableSize /= 262) $ + fail ("table cmap format 0, invalid size: " + ++ show tableSize) + Format0 <$> getWord16be <*> VU.replicateM 256 getWord8 + +-------------------------------------------------- +---- Format2 +-------------------------------------------------- +data Format2 = Format2 + { _format2Language :: {-# UNPACK #-} !LangId + , _format2SubKeys :: !(VU.Vector Word16) + , _format2SubHeaders :: !(V.Vector Format2SubHeader) + } + deriving (Eq, Show) + +data Format2SubHeader = Format2SubHeader + { _f2SubCode :: {-# UNPACK #-} !Word16 + , _f2EntryCount :: {-# UNPACK #-} !Word16 + , _f2IdDelta :: {-# UNPACK #-} !Int16 + , _f2IdRangeOffset :: {-# UNPACK #-} !Word16 + } + deriving (Eq, Show) + +instance CharMappeable Format2 where + glyphIdFromTable _ _ = 0 + langIdOfCharMap = _format2Language + +instance Binary Format2SubHeader where + put (Format2SubHeader a b c d) = + p16 a >> p16 b >> pi16 c >> p16 d + where + p16 = putWord16be + pi16 = p16 . fromIntegral + + get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16 + where g16 = getWord16be + + +instance Binary Format2 where + put _ = error "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 _ = error "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/FontFolders.hs view
@@ -1,241 +1,241 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.FontFolders- ( loadUnixFontFolderList- , loadWindowsFontFolderList- , fontFolders- , findFont- , descriptorOf- , FontCache( .. )- , FontDescriptor( .. )- , emptyFontCache- , buildFontCache- , enumerateFonts- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--#if !MIN_VERSION_base(4,6,0)-import Control.Monad( guard )-import Control.Exception( tryJust )-import System.IO.Error( isDoesNotExistError )-import System.Environment( getEnv )-#else-import System.Environment( lookupEnv )-#endif--import Control.Monad( when, replicateM )-import System.Directory( getDirectoryContents- , getHomeDirectory- , doesDirectoryExist- , doesFileExist- )-import qualified Data.ByteString as B-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get- , getWord32be- , getByteString- )-import Data.Binary.Put( Put- , putWord32be- , putByteString )-import qualified Data.Map.Strict as M-import System.FilePath( (</>) )--import Text.XML.Light( elChildren- , elName- , onlyElems- , parseXML- , qName- , strContent )--import qualified Control.Exception as E-import qualified Data.Text as T-import qualified Data.Text.IO as T (readFile)--import Graphics.Text.TrueType.FontType-import Graphics.Text.TrueType.Header-import Graphics.Text.TrueType.Name--import Control.DeepSeq (($!!))--catchAny :: IO a -> (E.SomeException -> IO a) -> IO a-catchAny = E.catch--loadParseFontsConf :: IO [FilePath]-loadParseFontsConf = getPaths <$> T.readFile "/etc/fonts/fonts.conf"- where- getPaths s = map strContent- $ filter ((== "dir") . qName . elName)- $ concatMap elChildren- $ onlyElems- $ parseXML s--#if !MIN_VERSION_base(4,6,0)-lookupEnv :: String -> IO (Maybe String)-lookupEnv varName = do- v <- tryJust (guard . isDoesNotExistError) $ getEnv varName- case v of- Left _ -> return Nothing- Right val -> return $ Just val-#endif--loadUnixFontFolderList :: IO [FilePath]-loadUnixFontFolderList = catchAny- (do conf <- loadParseFontsConf- return $!! conf ++ map (</> "truetype") conf)- (const $ return defaults)- where- defaults = ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"]--loadWindowsFontFolderList :: IO [FilePath]-loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir"- where toFontFolder (Just a) = [a </> "Fonts"]- toFontFolder Nothing = []--loadOsXFontFolderList :: IO [FilePath]-loadOsXFontFolderList = do- home <- getHomeDirectory- return [home </> "Library" </> "Fonts"- ,"/" </> "Library" </> "Fonts"- ,"/" </> "System" </> "Library" </> "Fonts"- ,"/" </> "System Folder" </> "Fonts"- ]---fontFolders :: IO [FilePath]-fontFolders = do- unix <- loadUnixFontFolderList- win <- loadWindowsFontFolderList- osx <- loadOsXFontFolderList- return $ unix ++ win ++ osx---- | A font descriptor is a key used to find a font--- in a font cache.-data FontDescriptor = FontDescriptor- { -- | The family name of the font- _descriptorFamilyName :: !T.Text- -- | The desired style- , _descriptorStyle :: !FontStyle- }- deriving (Eq, Ord, Show)--instance Binary FontDescriptor where- put (FontDescriptor t s) = put (T.unpack t) >> put s- get = FontDescriptor <$> (T.pack <$> get) <*> get---- | A font cache is a cache listing all the found--- fonts on the system, allowing faster font lookup--- once created------ FontCache is an instance of binary, to get okish--- performance you should save it in a file somewhere--- instead of rebuilding it everytime!------ The font cache is dependent on the version--- of rasterific, you must rebuild it for every--- version.-newtype FontCache =- FontCache (M.Map FontDescriptor FilePath)- deriving Show---- | Font cache with no pre-existing fonts in it.-emptyFontCache :: FontCache-emptyFontCache = FontCache M.empty--signature :: B.ByteString-signature = "FontyFruity__FONTCACHE:0.5"--putFontCache :: FontCache -> Put-putFontCache (FontCache cache) = do- putByteString signature- putWord32be . fromIntegral $ M.size cache- mapM_ put $ M.toList cache--getFontCache :: Get FontCache-getFontCache = do- str <- getByteString $ B.length signature- when (str /= signature) $- fail "Invalid font cache"- count <- fromIntegral <$> getWord32be- FontCache . M.fromList <$> replicateM count get--instance Binary FontCache where- put = putFontCache- get = getFontCache---- | Returns a list of descriptors of fonts stored in the given cache.-enumerateFonts :: FontCache -> [FontDescriptor]-enumerateFonts (FontCache fs) = M.keys fs----- | If possible, returns a descriptor of the Font.-descriptorOf :: Font -> Maybe FontDescriptor-descriptorOf font = do- hdr <- _fontHeader font- names <- _fontNames font- return $ FontDescriptor (fontFamilyName names) (_fHdrMacStyle hdr)----- | Look in the system's folder for usable fonts.-buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache-buildFontCache loader = do- folders <- fontFolders- found <- build [("", v) | v <- folders]- return . FontCache- $ M.fromList [(d, path) | (Just d, path) <- found- , _descriptorFamilyName d /= ""]- where- build [] = return []- build ((".", _):rest) = build rest- build (("..", _):rest) = build rest- build ((_, n):rest) = do- isDirectory <- doesDirectoryExist n-- if isDirectory then do- sub <- getDirectoryContents n- (++) <$> build [(s, n </> s) | s <- sub]- <*> build rest- else do- isFile <- doesFileExist n- if isFile then do- f <- loader n- case f of- Nothing -> build rest- Just fo -> ((descriptorOf fo, n) :) <$> build rest- else build rest--findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle- -> IO (Maybe FilePath)-findFont loader fontName fontStyle = do- folders <- fontFolders- searchIn [("", v) | v <- folders]- where- fontNameText = T.pack fontName- isMatching n (Font { _fontHeader = Just hdr- , _fontNames = Just names})- | _fHdrMacStyle hdr == fontStyle &&- fontFamilyName names == fontNameText = Just n- isMatching _ _ = Nothing-- searchIn [] = return Nothing- searchIn ((".", _):rest) = searchIn rest- searchIn (("..", _):rest) = searchIn rest- searchIn ((_, n):rest) = do- isDirectory <- doesDirectoryExist n-- let findOrRest Nothing = searchIn rest- findOrRest l = return l-- if isDirectory then do- sub <- getDirectoryContents n- subRez <- searchIn [(s, n </> s) | s <- sub]- findOrRest subRez- else do- isFile <- doesFileExist n- if isFile then do- font <- loader n- findOrRest $ font >>= isMatching n- else searchIn rest+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.FontFolders + ( loadUnixFontFolderList + , loadWindowsFontFolderList + , fontFolders + , findFont + , descriptorOf + , FontCache( .. ) + , FontDescriptor( .. ) + , emptyFontCache + , buildFontCache + , enumerateFonts + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +#if !MIN_VERSION_base(4,6,0) +import Control.Monad( guard ) +import Control.Exception( tryJust ) +import System.IO.Error( isDoesNotExistError ) +import System.Environment( getEnv ) +#else +import System.Environment( lookupEnv ) +#endif + +import Control.Monad( when, replicateM ) +import System.Directory( getDirectoryContents + , getHomeDirectory + , doesDirectoryExist + , doesFileExist + ) +import qualified Data.ByteString as B +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord32be + , getByteString + ) +import Data.Binary.Put( Put + , putWord32be + , putByteString ) +import qualified Data.Map.Strict as M +import System.FilePath( (</>) ) + +import Text.XML.Light( elChildren + , elName + , onlyElems + , parseXML + , qName + , strContent ) + +import qualified Control.Exception as E +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) + +import Graphics.Text.TrueType.FontType +import Graphics.Text.TrueType.Header +import Graphics.Text.TrueType.Name + +import Control.DeepSeq (($!!)) + +catchAny :: IO a -> (E.SomeException -> IO a) -> IO a +catchAny = E.catch + +loadParseFontsConf :: IO [FilePath] +loadParseFontsConf = getPaths <$> T.readFile "/etc/fonts/fonts.conf" + where + getPaths s = map strContent + $ filter ((== "dir") . qName . elName) + $ concatMap elChildren + $ onlyElems + $ parseXML s + +#if !MIN_VERSION_base(4,6,0) +lookupEnv :: String -> IO (Maybe String) +lookupEnv varName = do + v <- tryJust (guard . isDoesNotExistError) $ getEnv varName + case v of + Left _ -> return Nothing + Right val -> return $ Just val +#endif + +loadUnixFontFolderList :: IO [FilePath] +loadUnixFontFolderList = catchAny + (do conf <- loadParseFontsConf + return $!! conf ++ map (</> "truetype") conf) + (const $ return defaults) + where + defaults = ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"] + +loadWindowsFontFolderList :: IO [FilePath] +loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir" + where toFontFolder (Just a) = [a </> "Fonts"] + toFontFolder Nothing = [] + +loadOsXFontFolderList :: IO [FilePath] +loadOsXFontFolderList = do + home <- getHomeDirectory + return [home </> "Library" </> "Fonts" + ,"/" </> "Library" </> "Fonts" + ,"/" </> "System" </> "Library" </> "Fonts" + ,"/" </> "System Folder" </> "Fonts" + ] + + +fontFolders :: IO [FilePath] +fontFolders = do + unix <- loadUnixFontFolderList + win <- loadWindowsFontFolderList + osx <- loadOsXFontFolderList + return $ unix ++ win ++ osx + +-- | A font descriptor is a key used to find a font +-- in a font cache. +data FontDescriptor = FontDescriptor + { -- | The family name of the font + _descriptorFamilyName :: !T.Text + -- | The desired style + , _descriptorStyle :: !FontStyle + } + deriving (Eq, Ord, Show) + +instance Binary FontDescriptor where + put (FontDescriptor t s) = put (T.unpack t) >> put s + get = FontDescriptor <$> (T.pack <$> get) <*> get + +-- | A font cache is a cache listing all the found +-- fonts on the system, allowing faster font lookup +-- once created +-- +-- FontCache is an instance of binary, to get okish +-- performance you should save it in a file somewhere +-- instead of rebuilding it everytime! +-- +-- The font cache is dependent on the version +-- of rasterific, you must rebuild it for every +-- version. +newtype FontCache = + FontCache (M.Map FontDescriptor FilePath) + deriving Show + +-- | Font cache with no pre-existing fonts in it. +emptyFontCache :: FontCache +emptyFontCache = FontCache M.empty + +signature :: B.ByteString +signature = "FontyFruity__FONTCACHE:0.5" + +putFontCache :: FontCache -> Put +putFontCache (FontCache cache) = do + putByteString signature + putWord32be . fromIntegral $ M.size cache + mapM_ put $ M.toList cache + +getFontCache :: Get FontCache +getFontCache = do + str <- getByteString $ B.length signature + when (str /= signature) $ + fail "Invalid font cache" + count <- fromIntegral <$> getWord32be + FontCache . M.fromList <$> replicateM count get + +instance Binary FontCache where + put = putFontCache + get = getFontCache + +-- | Returns a list of descriptors of fonts stored in the given cache. +enumerateFonts :: FontCache -> [FontDescriptor] +enumerateFonts (FontCache fs) = M.keys fs + + +-- | If possible, returns a descriptor of the Font. +descriptorOf :: Font -> Maybe FontDescriptor +descriptorOf font = do + hdr <- _fontHeader font + names <- _fontNames font + return $ FontDescriptor (fontFamilyName names) (_fHdrMacStyle hdr) + + +-- | Look in the system's folder for usable fonts. +buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache +buildFontCache loader = do + folders <- fontFolders + found <- build [("", v) | v <- folders] + return . FontCache + $ M.fromList [(d, path) | (Just d, path) <- found + , _descriptorFamilyName d /= ""] + where + build [] = return [] + build ((".", _):rest) = build rest + build (("..", _):rest) = build rest + build ((_, n):rest) = do + isDirectory <- doesDirectoryExist n + + if isDirectory then do + sub <- getDirectoryContents n + (++) <$> build [(s, n </> s) | s <- sub] + <*> build rest + else do + isFile <- doesFileExist n + if isFile then do + f <- loader n + case f of + Nothing -> build rest + Just fo -> ((descriptorOf fo, n) :) <$> build rest + else build rest + +findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle + -> IO (Maybe FilePath) +findFont loader fontName fontStyle = do + folders <- fontFolders + searchIn [("", v) | v <- folders] + where + fontNameText = T.pack fontName + isMatching n (Font { _fontHeader = Just hdr + , _fontNames = Just names}) + | _fHdrMacStyle hdr == fontStyle && + fontFamilyName names == fontNameText = Just n + isMatching _ _ = Nothing + + searchIn [] = return Nothing + searchIn ((".", _):rest) = searchIn rest + searchIn (("..", _):rest) = searchIn rest + searchIn ((_, n):rest) = do + isDirectory <- doesDirectoryExist n + + let findOrRest Nothing = searchIn rest + findOrRest l = return l + + if isDirectory then do + sub <- getDirectoryContents n + subRez <- searchIn [(s, n </> s) | s <- sub] + findOrRest subRez + else do + isFile <- doesFileExist n + if isFile then do + font <- loader n + findOrRest $ font >>= isMatching n + else searchIn rest
src/Graphics/Text/TrueType/Glyph.hs view
@@ -254,7 +254,7 @@ let fetcher | isShort flag && isSame flag = (prevCoord +) . fromIntegral <$> getWord8 - | isShort flag = + | isShort flag = (prevCoord - ) . fromIntegral <$> getWord8 | isSame flag = return prevCoord @@ -273,7 +273,7 @@ (_, flagGroup) = mapAccumL (\acc v -> swap $ splitAt (VU.length v) acc) allFlags coords - go (flags, coord) + go (flags, coord) | VU.null coord = mempty | otherwise = VU.fromList . (firstPoint :) $ expand mixed where @@ -288,7 +288,7 @@ expand [(onp, on, prevPoint, currPoint)] | onp == on = (prevPoint `midPoint` currPoint) : endJunction | otherwise = endJunction - where endJunction + where endJunction | on && firstOnCurve = [currPoint, currPoint `midPoint` firstPoint, firstPoint] | otherwise = [currPoint, firstPoint] @@ -313,10 +313,9 @@ where breaker array ix = VU.splitAt (fromIntegral ix + 1) array instance Binary Glyph where - put _ = fail "Glyph.put - unimplemented" + put _ = error "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,143 +1,142 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Header- ( FontHeader( .. )- , FontStyle( .. )- , HeaderFlags( .. )- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Data.Bits( (.|.), setBit, testBit )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be- , getWord32be- , getWord64be- )--import Data.Binary.Put( putWord16be)--import Data.Int( Int16 )-import Data.List( foldl' )-import Data.Word( Word16, Word32, Word64 )--import Graphics.Text.TrueType.Types---- | Describe the basic stylistic properties--- of a font.-data FontStyle = FontStyle- { _fontStyleBold :: !Bool -- ^ If the font is bold.- , _fontStyleItalic :: !Bool -- ^ If the font is italic.- }- deriving (Eq, Ord, Show)--instance Binary FontStyle where- put style = putWord16be $ italicByte .|. boldByte- where- boldByte- | _fontStyleBold style = 1- | otherwise = 0-- italicByte- | _fontStyleItalic style = 2- | otherwise = 0-- get = do- styleWord <- getWord16be - let bitAt = testBit styleWord- return $ FontStyle (bitAt 0) (bitAt 1)---- | Font header-data FontHeader = FontHeader- { -- | Table version number 0x00010000 for version 1.0.- _fHdrVersionNumber :: !Fixed- -- | fontRevision Set by font manufacturer.- , _fHdrFontRevision :: !Fixed- -- | To compute: set it to 0, sum the entire font as- -- ULONG, then store 0xB1B0AFBA - sum.- , _fHdrChecksumAdjust :: !Word32- - -- | Should be equal to 0x5F0F3CF5.- , _fHdrMagicNumber :: !Word32- , _fHdrFlags :: !HeaderFlags-- -- | Valid range is from 16 to 16384- , _fUnitsPerEm :: !Word16- -- | International date (8-byte field).- , _fHdrCreateTime :: !Word64- -- | International date (8-byte field).- , _fHdrModificationTime :: !Word64-- -- | For all glyph bounding boxes.- , _fHdrxMin :: !FWord- -- | For all glyph bounding boxes.- , _fHdrYMin :: !FWord- -- | For all glyph bounding boxes.- , _fHdrXMax :: !FWord- -- | For all glyph bounding boxes.- , _fHdrYMax :: !FWord- -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1)- , _fHdrMacStyle :: !FontStyle- -- | Smallest readable size in pixels.- , _fHdrLowestRecPPEM :: !Word16-- -- | 0 Fully mixed directional glyphs;- -- 1 Only strongly left to right;- -- 2 Like 1 but also contains neutrals ;- -- -1 Only strongly right to left;- -- -2 Like -1 but also contains neutrals.- , _fHdrFontDirectionHint :: !Int16- -- | 0 for short offsets, 1 for long.- , _fHdrIndexToLocFormat :: !Int16- -- | 0 for current format.- , _fHdrGlyphDataFormat :: !Int16- }- deriving (Eq, Show)--instance NFData FontHeader where- rnf (FontHeader {}) = ()--instance Binary FontHeader where- put _ = fail "Unimplemented"- get =- FontHeader <$> get <*> get <*> g32 <*> g32 <*> get- <*> g16 <*> g64 <*> g64 <*> get <*> get- <*> get <*> get <*> get <*> g16 <*> gi16- <*> gi16 <*> gi16- where g16 = getWord16be- g32 = getWord32be- gi16 = fromIntegral <$> getWord16be- g64 = getWord64be----- | Header flags.-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-+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.Header + ( FontHeader( .. ) + , FontStyle( .. ) + , HeaderFlags( .. ) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Control.DeepSeq( NFData( .. ) ) +import Data.Bits( (.|.), setBit, testBit ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be + , getWord32be + , getWord64be + ) + +import Data.Binary.Put( putWord16be) + +import Data.Int( Int16 ) +import Data.List( foldl' ) +import Data.Word( Word16, Word32, Word64 ) + +import Graphics.Text.TrueType.Types + +-- | Describe the basic stylistic properties +-- of a font. +data FontStyle = FontStyle + { _fontStyleBold :: !Bool -- ^ If the font is bold. + , _fontStyleItalic :: !Bool -- ^ If the font is italic. + } + deriving (Eq, Ord, Show) + +instance Binary FontStyle where + put style = putWord16be $ italicByte .|. boldByte + where + boldByte + | _fontStyleBold style = 1 + | otherwise = 0 + + italicByte + | _fontStyleItalic style = 2 + | otherwise = 0 + + get = do + styleWord <- getWord16be + let bitAt = testBit styleWord + return $ FontStyle (bitAt 0) (bitAt 1) + +-- | Font header +data FontHeader = FontHeader + { -- | Table version number 0x00010000 for version 1.0. + _fHdrVersionNumber :: !Fixed + -- | fontRevision Set by font manufacturer. + , _fHdrFontRevision :: !Fixed + -- | To compute: set it to 0, sum the entire font as + -- ULONG, then store 0xB1B0AFBA - sum. + , _fHdrChecksumAdjust :: !Word32 + + -- | Should be equal to 0x5F0F3CF5. + , _fHdrMagicNumber :: !Word32 + , _fHdrFlags :: !HeaderFlags + + -- | Valid range is from 16 to 16384 + , _fUnitsPerEm :: !Word16 + -- | International date (8-byte field). + , _fHdrCreateTime :: !Word64 + -- | International date (8-byte field). + , _fHdrModificationTime :: !Word64 + + -- | For all glyph bounding boxes. + , _fHdrxMin :: !FWord + -- | For all glyph bounding boxes. + , _fHdrYMin :: !FWord + -- | For all glyph bounding boxes. + , _fHdrXMax :: !FWord + -- | For all glyph bounding boxes. + , _fHdrYMax :: !FWord + -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1) + , _fHdrMacStyle :: !FontStyle + -- | Smallest readable size in pixels. + , _fHdrLowestRecPPEM :: !Word16 + + -- | 0 Fully mixed directional glyphs; + -- 1 Only strongly left to right; + -- 2 Like 1 but also contains neutrals ; + -- -1 Only strongly right to left; + -- -2 Like -1 but also contains neutrals. + , _fHdrFontDirectionHint :: !Int16 + -- | 0 for short offsets, 1 for long. + , _fHdrIndexToLocFormat :: !Int16 + -- | 0 for current format. + , _fHdrGlyphDataFormat :: !Int16 + } + deriving (Eq, Show) + +instance NFData FontHeader where + rnf (FontHeader {}) = () + +instance Binary FontHeader where + put _ = error "Unimplemented" + get = + FontHeader <$> get <*> get <*> g32 <*> g32 <*> get + <*> g16 <*> g64 <*> g64 <*> get <*> get + <*> get <*> get <*> get <*> g16 <*> gi16 + <*> gi16 <*> gi16 + where g16 = getWord16be + g32 = getWord32be + gi16 = fromIntegral <$> getWord16be + g64 = getWord64be + + +-- | Header flags. +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,120 +1,120 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.HorizontalInfo- ( HorizontalHeader( .. )- , HorizontalMetricsTable( .. )- , HorizontalMetric( .. )- , getHorizontalMetrics- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Control.Monad( when, replicateM_ )-import Data.Word( Word16 )-import Data.Int( Int16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get, getWord16be, getWord32be )-import Data.Binary.Put( putWord16be, putWord32be )-import qualified Data.Vector as V--import Graphics.Text.TrueType.Types---- | Describe the "hhea" TrueType table.-data HorizontalHeader = HorizontalHeader- { -- | Distance from baseline of highest ascender- _hheaAscent :: {-# UNPACK #-} !FWord- -- | Distance from baseline of lowest descender- , _hheaDescent :: {-# UNPACK #-} !FWord- -- | typographic line gap- , _hheaLineGap :: {-# UNPACK #-} !FWord- -- | must be consistent with horizontal metrics- , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord- -- | must be consistent with horizontal metrics- , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord- -- | must be consistent with horizontal metrics- , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord- -- | max(lsb + (xMax-xMin))- , _hheaXmaxExtent :: {-# UNPACK #-} !FWord- -- | used to calculate the slope of the caret - -- (rise/run) set to 1 for vertical caret- , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16- -- | 0 for vertical- , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16- -- | set value to 0 for non-slanted fonts- , _hheaCaretOffset :: {-# UNPACK #-} !FWord- -- | 0 for current format- , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16- -- | number of advance widths in metrics table- , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16- }- deriving (Eq, Show)--instance NFData HorizontalHeader where- rnf (HorizontalHeader {}) = ()--instance Binary HorizontalHeader where- put hdr = do- putWord32be 0x00010000- put $ _hheaAscent hdr- put $ _hheaDescent hdr- put $ _hheaLineGap hdr- put $ _hheaAdvanceWidthMax hdr- put $ _hheaMinLeftSideBearing hdr- put $ _hheaMinRightSideBearing hdr- put $ _hheaXmaxExtent hdr- putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr- putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr- put $ _hheaCaretOffset hdr- replicateM_ 4 $ putWord16be 0- putWord16be . fromIntegral $ _hheaMetricDataFormat hdr- putWord16be $ _hheaLongHorMetricCount hdr-- get = do- ver <- getWord32be- when (ver /= 0x00010000)- (fail "Invalid HorizontalHeader (hhea) version")- startHdr <- HorizontalHeader- <$> get <*> get <*> get <*> get- <*> get <*> get <*> get- <*> (fromIntegral <$> getWord16be)- <*> (fromIntegral <$> getWord16be)- <*> get- replicateM_ 4 getWord16be -- reserved, don't care- startHdr <$> (fromIntegral <$> getWord16be)- <*> getWord16be---- | Information of horizontal advance.-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---- | For every glyph (indexed by the glyph index),--- provide horizontal information.-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 -+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.HorizontalInfo + ( HorizontalHeader( .. ) + , HorizontalMetricsTable( .. ) + , HorizontalMetric( .. ) + , getHorizontalMetrics + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Control.DeepSeq( NFData( .. ) ) +import Control.Monad( when, replicateM_ ) +import Data.Word( Word16 ) +import Data.Int( Int16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get, getWord16be, getWord32be ) +import Data.Binary.Put( putWord16be, putWord32be ) +import qualified Data.Vector as V + +import Graphics.Text.TrueType.Types + +-- | Describe the "hhea" TrueType table. +data HorizontalHeader = HorizontalHeader + { -- | Distance from baseline of highest ascender + _hheaAscent :: {-# UNPACK #-} !FWord + -- | Distance from baseline of lowest descender + , _hheaDescent :: {-# UNPACK #-} !FWord + -- | typographic line gap + , _hheaLineGap :: {-# UNPACK #-} !FWord + -- | must be consistent with horizontal metrics + , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord + -- | must be consistent with horizontal metrics + , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord + -- | must be consistent with horizontal metrics + , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord + -- | max(lsb + (xMax-xMin)) + , _hheaXmaxExtent :: {-# UNPACK #-} !FWord + -- | used to calculate the slope of the caret + -- (rise/run) set to 1 for vertical caret + , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16 + -- | 0 for vertical + , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16 + -- | set value to 0 for non-slanted fonts + , _hheaCaretOffset :: {-# UNPACK #-} !FWord + -- | 0 for current format + , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16 + -- | number of advance widths in metrics table + , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16 + } + deriving (Eq, Show) + +instance NFData HorizontalHeader where + rnf (HorizontalHeader {}) = () + +instance Binary HorizontalHeader where + put hdr = do + putWord32be 0x00010000 + put $ _hheaAscent hdr + put $ _hheaDescent hdr + put $ _hheaLineGap hdr + put $ _hheaAdvanceWidthMax hdr + put $ _hheaMinLeftSideBearing hdr + put $ _hheaMinRightSideBearing hdr + put $ _hheaXmaxExtent hdr + putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr + putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr + put $ _hheaCaretOffset hdr + replicateM_ 4 $ putWord16be 0 + putWord16be . fromIntegral $ _hheaMetricDataFormat hdr + putWord16be $ _hheaLongHorMetricCount hdr + + get = do + ver <- getWord32be + when (ver /= 0x00010000) + (fail "Invalid HorizontalHeader (hhea) version") + startHdr <- HorizontalHeader + <$> get <*> get <*> get <*> get + <*> get <*> get <*> get + <*> (fromIntegral <$> getWord16be) + <*> (fromIntegral <$> getWord16be) + <*> get + replicateM_ 4 getWord16be -- reserved, don't care + startHdr <$> (fromIntegral <$> getWord16be) + <*> getWord16be + +-- | Information of horizontal advance. +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 + +-- | For every glyph (indexed by the glyph index), +-- provide horizontal information. +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/MaxpTable.hs view
@@ -1,59 +1,58 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Data.Word( Word16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be )--import Graphics.Text.TrueType.Types--data MaxpTable = MaxpTable - { -- | version number 0x00010000 for version 1.0.- _maxpTableVersion :: !Fixed- -- | The number of glyphs in the font.- , _maxpnumGlyphs :: !Word16- -- | Maximum points in a non-composite glyph.- , _maxpmaxPoints :: !Word16- -- | Maximum contours in a non-composite glyph.- , _maxpmaxContours :: !Word16- -- | Maximum points in a composite glyph.- , _maxpmaxCompositePoints :: !Word16- -- | Maximum contours in a composite glyph.- , _maxpmaxCompositeContours :: !Word16- -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases.- , _maxpmaxZones :: !Word16- -- | Maximum points used in Z0.- , _maxpmaxTwilightPoints :: !Word16- -- | Number of Storage Area locations. - , _maxpmaxStorage :: !Word16- -- | Number of FDEFs.- , _maxpmaxFunctionDefs :: !Word16- -- | Number of IDEFs.- , _maxpmaxInstructionDefs :: !Word16- -- | Maximum stack depth .- , _maxpmaxStackElements :: !Word16- -- | Maximum byte count for glyph instructions.- , _maxpmaxSizeOfInstructions :: !Word16- -- | Maximum number of components referenced at "top level" for any composite glyph.- , _maxpmaxComponentElements :: !Word16- -- | Maximum levels of recursion; 1 for simple components.- , _maxpmaxComponentDepth :: !Word16- }- deriving (Eq, Show)--instance NFData MaxpTable where- rnf (MaxpTable {}) = ()--instance Binary MaxpTable where- put _ = fail "Unimplemented"- get = MaxpTable - <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16- <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16- <*> g16 <*> g16 <*> g16- where g16 = getWord16be-+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Control.DeepSeq( NFData( .. ) ) +import Data.Word( Word16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be ) + +import Graphics.Text.TrueType.Types + +data MaxpTable = MaxpTable + { -- | version number 0x00010000 for version 1.0. + _maxpTableVersion :: !Fixed + -- | The number of glyphs in the font. + , _maxpnumGlyphs :: !Word16 + -- | Maximum points in a non-composite glyph. + , _maxpmaxPoints :: !Word16 + -- | Maximum contours in a non-composite glyph. + , _maxpmaxContours :: !Word16 + -- | Maximum points in a composite glyph. + , _maxpmaxCompositePoints :: !Word16 + -- | Maximum contours in a composite glyph. + , _maxpmaxCompositeContours :: !Word16 + -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases. + , _maxpmaxZones :: !Word16 + -- | Maximum points used in Z0. + , _maxpmaxTwilightPoints :: !Word16 + -- | Number of Storage Area locations. + , _maxpmaxStorage :: !Word16 + -- | Number of FDEFs. + , _maxpmaxFunctionDefs :: !Word16 + -- | Number of IDEFs. + , _maxpmaxInstructionDefs :: !Word16 + -- | Maximum stack depth . + , _maxpmaxStackElements :: !Word16 + -- | Maximum byte count for glyph instructions. + , _maxpmaxSizeOfInstructions :: !Word16 + -- | Maximum number of components referenced at "top level" for any composite glyph. + , _maxpmaxComponentElements :: !Word16 + -- | Maximum levels of recursion; 1 for simple components. + , _maxpmaxComponentDepth :: !Word16 + } + deriving (Eq, Show) + +instance NFData MaxpTable where + rnf (MaxpTable {}) = () + +instance Binary MaxpTable where + put _ = error "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/Name.hs view
@@ -1,122 +1,120 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Name- ( NameTable- , NameRecords- , fontFamilyName- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( (<$>), (<*>), pure )-#endif--import Control.DeepSeq( NFData( .. ) )-import Control.Monad( when, replicateM )-import Data.Foldable( asum )-import Data.Function( on )-import Data.List( maximumBy )-import Data.Maybe( fromMaybe )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be, getByteString )-import Data.Binary.Put( putWord16be )-import Data.Word( Word16 )-import qualified Data.Vector as V-import qualified Data.ByteString as B-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE--import Graphics.Text.TrueType.LanguageIds--data NameTable = NameTable- { _ntRecords :: !(V.Vector NameRecords) }- deriving Show--instance NFData NameTable where- rnf (NameTable {}) = ()--instance Binary NameTable where- put _ = fail "Binary.put NameTable - unimplemented"- get = do- nameFormatId <- getWord16be- when (nameFormatId /= 0) $- fail "Invalid name table format"- count <- getWord16be- stringOffset <- getWord16be- records <- replicateM (fromIntegral count) get- let maxRec = maximumBy (compare `on` _nrOffset) records- toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec)- - fromIntegral stringOffset-- strTable <- getByteString toFetch- let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable }- where iLength = fromIntegral $ _nrLength r- iOffset = fromIntegral $ _nrOffset r-- return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records--data NameRecords = NameRecords- { _nrPlatoformId :: {-# UNPACK #-} !Word16- , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16- , _nrLanguageId :: {-# UNPACK #-} !Word16- , _nrNameId :: {-# UNPACK #-} !Word16- , _nrLength :: {-# UNPACK #-} !Word16- , _nrOffset :: {-# UNPACK #-} !Word16- , _nrString :: !B.ByteString- }- deriving Show--fontFamilyName :: NameTable -> T.Text-fontFamilyName (NameTable { _ntRecords = records }) =- fromMaybe T.empty . asum $ transform <$>- [ (selectorUnicode, utf16Decoder)- , (selectorMac, utf8Decoder)- , (selectorWin0, utf16Decoder)- , (selectorWin1, utf16Decoder)- ]- where- utf16Decoder = TE.decodeUtf16BE . _nrString- utf8Decoder = TE.decodeUtf8 . _nrString- transform (selector, decoder) =- decoder <$> V.find selector records-- fontFamilyId = 1-- windowsPlatform =- platformToWord PlatformWindows- selectorWin0 r =- _nrNameId r == fontFamilyId &&- _nrPlatoformId r == windowsPlatform &&- _nrPlatformSpecificId r == 0-- selectorWin1 r =- _nrNameId r == fontFamilyId &&- _nrPlatoformId r == windowsPlatform &&- _nrPlatformSpecificId r == 1-- macPlatform =- platformToWord PlatformMacintosh- selectorMac r =- _nrNameId r == fontFamilyId &&- _nrPlatoformId r == macPlatform &&- _nrPlatformSpecificId r == 0-- unicodePlatform =- platformToWord PlatformUnicode- semanticUnicode2 =- unicodePlatformSpecificToId UnicodeBMPOnly2_0- selectorUnicode r =- _nrNameId r == fontFamilyId &&- _nrPlatoformId r == unicodePlatform &&- _nrPlatformSpecificId r == semanticUnicode2--instance Binary NameRecords where- get = NameRecords <$> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 - <*> pure mempty- where g16 = getWord16be-- put (NameRecords p ps l n len ofs _) =- p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs- where p16 = putWord16be--+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.Name + ( NameTable + , NameRecords + , fontFamilyName + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.DeepSeq( NFData( .. ) ) +import Control.Monad( when, replicateM ) +import Data.Foldable( asum ) +import Data.Function( on ) +import Data.List( maximumBy ) +import Data.Maybe( fromMaybe ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be, getByteString ) +import Data.Binary.Put( putWord16be ) +import Data.Word( Word16 ) +import qualified Data.Vector as V +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Graphics.Text.TrueType.LanguageIds + +data NameTable = NameTable + { _ntRecords :: !(V.Vector NameRecords) } + deriving Show + +instance NFData NameTable where + rnf (NameTable {}) = () + +instance Binary NameTable where + put _ = error "Binary.put NameTable - unimplemented" + get = do + nameFormatId <- getWord16be + when (nameFormatId /= 0) $ + fail "Invalid name table format" + count <- getWord16be + stringOffset <- getWord16be + records <- replicateM (fromIntegral count) get + let maxRec = maximumBy (compare `on` _nrOffset) records + toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec) + - fromIntegral stringOffset + + strTable <- getByteString toFetch + let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable } + where iLength = fromIntegral $ _nrLength r + iOffset = fromIntegral $ _nrOffset r + + return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records + +data NameRecords = NameRecords + { _nrPlatoformId :: {-# UNPACK #-} !Word16 + , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16 + , _nrLanguageId :: {-# UNPACK #-} !Word16 + , _nrNameId :: {-# UNPACK #-} !Word16 + , _nrLength :: {-# UNPACK #-} !Word16 + , _nrOffset :: {-# UNPACK #-} !Word16 + , _nrString :: !B.ByteString + } + deriving Show + +fontFamilyName :: NameTable -> T.Text +fontFamilyName (NameTable { _ntRecords = records }) = + fromMaybe T.empty . asum $ transform <$> + [ (selectorUnicode, utf16Decoder) + , (selectorMac, utf8Decoder) + , (selectorWin0, utf16Decoder) + , (selectorWin1, utf16Decoder) + ] + where + utf16Decoder = TE.decodeUtf16BE . _nrString + utf8Decoder = TE.decodeUtf8 . _nrString + transform (selector, decoder) = + decoder <$> V.find selector records + + fontFamilyId = 1 + + windowsPlatform = + platformToWord PlatformWindows + selectorWin0 r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == windowsPlatform && + _nrPlatformSpecificId r == 0 + + selectorWin1 r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == windowsPlatform && + _nrPlatformSpecificId r == 1 + + macPlatform = + platformToWord PlatformMacintosh + selectorMac r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == macPlatform && + _nrPlatformSpecificId r == 0 + + unicodePlatform = + platformToWord PlatformUnicode + semanticUnicode2 = + unicodePlatformSpecificToId UnicodeBMPOnly2_0 + selectorUnicode r = + _nrNameId r == fontFamilyId && + _nrPlatoformId r == unicodePlatform && + _nrPlatformSpecificId r == semanticUnicode2 + +instance Binary NameRecords where + get = NameRecords <$> g16 <*> g16 <*> g16 + <*> g16 <*> g16 <*> g16 + <*> pure mempty + where g16 = getWord16be + + put (NameRecords p ps l n len ofs _) = + p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs + where p16 = putWord16be
src/Graphics/Text/TrueType/OffsetTable.hs view
@@ -1,89 +1,89 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.OffsetTable- ( OffsetTableHeader( .. )- , OffsetTable( .. )- , TableDirectoryEntry( .. )- , filterTable- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Data.Word( Word16, Word32 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be- , getWord32be- , getByteString- )--import Data.Binary.Put( putWord16be- , putWord32be- , putByteString- )--import qualified Data.Vector as V-import qualified Data.ByteString.Char8 as BC--import Graphics.Text.TrueType.Types--data OffsetTableHeader = OffsetTableHeader- { -- | sfnt version 0x00010000 for version 1.0.- _othSfntVersion :: !Fixed- -- | numTables Number of tables.- , _othTableCount :: !Word16- -- | searchRange (Maximum power of 2 ? numTables) x 16.- , _othSearchRange :: !Word16- -- | entrySelector Log2(maximum power of 2 ? numTables).- , _othEntrySelector :: !Word16- -- | rangeShift NumTables x 16-searchRange.- , _othRangeShift :: !Word16- }- deriving (Eq, Show)--instance Binary OffsetTableHeader where- get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16- where g16 = getWord16be- put (OffsetTableHeader ver c sr es rs) =- put ver >> p16 c >> p16 sr >> p16 es >> p16 rs- where p16 = putWord16be--data TableDirectoryEntry = TableDirectoryEntry- { -- | tag 4 -byte identifier.- _tdeTag :: !BC.ByteString- -- | CheckSum for this table.- , _tdeChecksum :: !Word32- -- | Offset from beginning of TrueType font file.- , _tdeOffset :: !Word32- -- | Length of this table.- , _tdeLength :: !Word32- }- deriving (Eq, Show)--filterTable :: (BC.ByteString -> Bool) -> OffsetTable- -> OffsetTable-filterTable f table =- table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table }--instance Binary TableDirectoryEntry where- get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32- where g32 = getWord32be- put (TableDirectoryEntry tag chk offset ln) =- putByteString tag >> p32 chk >> p32 offset >> p32 ln- where p32 = putWord32be--data OffsetTable = OffsetTable- { _otHeader :: !OffsetTableHeader- , _otEntries :: !(V.Vector TableDirectoryEntry)- }- deriving (Eq, Show)--instance Binary OffsetTable where- put (OffsetTable hdr entries) =- put hdr >> V.forM_ entries put-- get = do- hdr <- get- let count = fromIntegral $ _othTableCount hdr- OffsetTable hdr <$> V.replicateM count get-+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.OffsetTable + ( OffsetTableHeader( .. ) + , OffsetTable( .. ) + , TableDirectoryEntry( .. ) + , filterTable + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Data.Word( Word16, Word32 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be + , getWord32be + , getByteString + ) + +import Data.Binary.Put( putWord16be + , putWord32be + , putByteString + ) + +import qualified Data.Vector as V +import qualified Data.ByteString.Char8 as BC + +import Graphics.Text.TrueType.Types + +data OffsetTableHeader = OffsetTableHeader + { -- | sfnt version 0x00010000 for version 1.0. + _othSfntVersion :: !Fixed + -- | numTables Number of tables. + , _othTableCount :: !Word16 + -- | searchRange (Maximum power of 2 ? numTables) x 16. + , _othSearchRange :: !Word16 + -- | entrySelector Log2(maximum power of 2 ? numTables). + , _othEntrySelector :: !Word16 + -- | rangeShift NumTables x 16-searchRange. + , _othRangeShift :: !Word16 + } + deriving (Eq, Show) + +instance Binary OffsetTableHeader where + get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16 + where g16 = getWord16be + put (OffsetTableHeader ver c sr es rs) = + put ver >> p16 c >> p16 sr >> p16 es >> p16 rs + where p16 = putWord16be + +data TableDirectoryEntry = TableDirectoryEntry + { -- | tag 4 -byte identifier. + _tdeTag :: !BC.ByteString + -- | CheckSum for this table. + , _tdeChecksum :: !Word32 + -- | Offset from beginning of TrueType font file. + , _tdeOffset :: !Word32 + -- | Length of this table. + , _tdeLength :: !Word32 + } + deriving (Eq, Show) + +filterTable :: (BC.ByteString -> Bool) -> OffsetTable + -> OffsetTable +filterTable f table = + table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table } + +instance Binary TableDirectoryEntry where + get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32 + where g32 = getWord32be + put (TableDirectoryEntry tag chk offset ln) = + putByteString tag >> p32 chk >> p32 offset >> p32 ln + where p32 = putWord32be + +data OffsetTable = OffsetTable + { _otHeader :: !OffsetTableHeader + , _otEntries :: !(V.Vector TableDirectoryEntry) + } + deriving (Eq, Show) + +instance Binary OffsetTable where + put (OffsetTable hdr entries) = + put hdr >> V.forM_ entries put + + get = do + hdr <- get + let count = fromIntegral $ _othTableCount hdr + OffsetTable hdr <$> V.replicateM count get +
src/Graphics/Text/TrueType/Types.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Types- ( Fixed( .. )- , FWord( .. )- , F26Dot6( .. )- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), (<*>) )-#endif--import Data.Int( Int32 )-import Data.Word( Word16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be)-import Data.Binary.Put( putWord16be )--data Fixed = Fixed Word16 Word16- deriving (Eq, Show)--instance Binary Fixed where- get = Fixed <$> getWord16be <*> getWord16be- put (Fixed a b) = putWord16be a >> putWord16be b--newtype FWord = FWord Word16- deriving (Eq, Show)--instance Binary FWord where- put (FWord w) = putWord16be w- get = FWord <$> getWord16be--newtype F26Dot6 = F26Dot6 Int32- deriving (Eq, Show, Ord)--instance Num F26Dot6 where- (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b- (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b- (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64- negate (F26Dot6 a) = F26Dot6 $ negate a- abs (F26Dot6 a) = F26Dot6 $ abs a- signum (F26Dot6 a) = F26Dot6 $ signum a * 64- fromInteger a = F26Dot6 $ fromInteger a * 64--instance Fractional F26Dot6 where- fromRational a = F26Dot6 $ floor ad- where ad = fromRational a * 64 :: Double- (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b-+{-# LANGUAGE CPP #-} +module Graphics.Text.TrueType.Types + ( Fixed( .. ) + , FWord( .. ) + , F26Dot6( .. ) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>) ) +#endif + +import Data.Int( Int32 ) +import Data.Word( Word16 ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( getWord16be) +import Data.Binary.Put( putWord16be ) + +data Fixed = Fixed Word16 Word16 + deriving (Eq, Show) + +instance Binary Fixed where + get = Fixed <$> getWord16be <*> getWord16be + put (Fixed a b) = putWord16be a >> putWord16be b + +newtype FWord = FWord Word16 + deriving (Eq, Show) + +instance Binary FWord where + put (FWord w) = putWord16be w + get = FWord <$> getWord16be + +newtype F26Dot6 = F26Dot6 Int32 + deriving (Eq, Show, Ord) + +instance Num F26Dot6 where + (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b + (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b + (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64 + negate (F26Dot6 a) = F26Dot6 $ negate a + abs (F26Dot6 a) = F26Dot6 $ abs a + signum (F26Dot6 a) = F26Dot6 $ signum a * 64 + fromInteger a = F26Dot6 $ fromInteger a * 64 + +instance Fractional F26Dot6 where + fromRational a = F26Dot6 $ floor ad + where ad = fromRational a * 64 :: Double + (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b +