{-# 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
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
glyphIdFromTable :: a -> Char -> Int
langIdOfCharMap :: a -> LangId
type LangId = Word16
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
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
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
segCount <- (`div` 2) . fromIntegral <$> getWord16be
_searchRange <- getWord16be
_entrySelector <- getWord16be
_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) =
[( 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
]
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
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
return $ Format2 lang subKeys subHeaders
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