module Opentype.Fileformat.Glyph where
import Opentype.Fileformat.Types
import Opentype.Fileformat.Maxp
import Opentype.Fileformat.Hhea
import Opentype.Fileformat.Head
import qualified Data.Vector as V
import Data.Foldable (traverse_, for_, foldlM)
import Control.Monad
import Control.Monad.Cont
import Data.List (foldl')
import Data.Maybe (isJust, fromMaybe)
import Data.Function (fix)
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString as Strict
import Data.Word
import Data.Int
import Data.Bits
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Lens.Micro
newtype GlyfTable = GlyfTable {glyphVector :: (V.Vector (Glyph Int))}
deriving Show
type StandardGlyph = Glyph Int
emptyGlyfTable :: GlyfTable
emptyGlyfTable = GlyfTable V.empty
data Glyph a = Glyph {
glyphName :: String,
advanceWidth :: Word16,
leftSideBearing :: Int16,
glyphXmin :: FWord,
glyphYmin :: FWord,
glyphXmax :: FWord,
glyphYmax :: FWord,
glyphOutlines :: GlyphOutlines a}
deriving (Show, Functor, Foldable, Traversable)
data GlyphOutlines a =
GlyphContours [[CurvePoint]] Instructions |
CompositeGlyph [GlyphComponent a]
deriving (Show, Functor, Foldable, Traversable)
_glyphContours :: Traversal' StandardGlyph [[CurvePoint]]
_glyphContours f glyph = case glyphOutlines glyph of
GlyphContours pts instrs -> (\pts2 -> glyph {glyphOutlines = GlyphContours pts2 instrs})
<$> f pts
_ -> pure glyph
_glyphInstructions :: Traversal' StandardGlyph Instructions
_glyphInstructions f glyph = case glyphOutlines glyph of
GlyphContours pts instrs -> (\instrs2 -> glyph {glyphOutlines = GlyphContours pts instrs2})
<$> f instrs
_ -> pure glyph
_glyphComponents :: Traversal' StandardGlyph [GlyphComponent Int]
_glyphComponents f glyph = case glyphOutlines glyph of
CompositeGlyph comps -> (\c -> glyph {glyphOutlines = CompositeGlyph c}) <$> f comps
_ -> pure glyph
data CurvePoint = CurvePoint FWord FWord Bool
deriving Show
type Instructions = V.Vector Word8
data GlyphComponent a =
GlyphComponent {
componentID :: a,
componentInstructions :: Maybe Instructions,
componentXX :: ShortFrac,
componentXY :: ShortFrac,
componentYX :: ShortFrac,
componentYY :: ShortFrac,
componentX :: Int,
componentY :: Int,
matchPoints :: Bool,
roundXYtoGrid :: Bool,
useMyMetrics :: Bool,
overlapCompound :: Bool,
scaledComponentOffset :: Maybe Bool
}
deriving (Show, Functor, Foldable, Traversable)
sum' :: Num a => [a] -> a
sum' = foldl' (+) 0
emptyGlyph :: StandardGlyph
emptyGlyph = Glyph ".notdef" 0 0 0 0 0 0 (GlyphContours [] V.empty)
readHmetrics :: Int -> Int -> Get [(Word16, Int16)]
readHmetrics 1 m = do
aw <- getWord16be
lsb <- getInt16be
((aw, lsb):) <$> replicateM (m1) ((aw,) <$> getInt16be)
readHmetrics 0 _ = fail "no horizontal metrics found"
readHmetrics n m = do
aw <- getWord16be
lsb <- getInt16be
((aw, lsb):) <$> readHmetrics (n1) (m1)
readGlyphLocs :: Bool -> Int -> Get [Int]
readGlyphLocs long n =
replicateM (n+1) $
if long then fromIntegral <$> getWord32be
else (*2).fromIntegral <$> getWord16be
readGlyphTable :: [(Int, Int)] -> [(Word16, Int16)] -> Strict.ByteString
-> Either String (V.Vector StandardGlyph)
readGlyphTable glyphSizes hmetrics glyfBs =
V.fromList <$> zipWithM readGlyph glyphSizes hmetrics
where
readGlyph (offset, size) (aw, lsb)
| offset + size > Strict.length glyfBs =
Left "glyph past table bounds."
| otherwise =
case runGetOrFail getGlyph (Lazy.fromStrict $ Strict.drop offset glyfBs) of
Left (_, _, err) -> Left err
Right (_, _, g) -> Right $ g {advanceWidth = aw, leftSideBearing = lsb}
writeGlyphs :: Bool -> V.Vector StandardGlyph -> PutM (V.Vector Int)
writeGlyphs scale vec = traverse (writeGlyph . updateBB scale vec) vec
writeGlyph :: StandardGlyph -> PutM Int
writeGlyph g = do
putLazyByteString bs
replicateM_ pad (putWord8 0)
return $ fromIntegral (len+pad)
where bs = runPut $ putGlyph g
len = fromIntegral $ Lazy.length bs
pad = ( fromIntegral len) .&. 3
writeLoca :: V.Vector Int -> PutM Bool
writeLoca vec
| V.last offsets > 0xffff =
do traverse_ (putWord32be . fromIntegral) offsets
return True
| otherwise =
do traverse_ (putWord16be . (`quot` 2) . fromIntegral) offsets
return False
where
offsets = V.scanl (+) 0 vec
writeHmtx :: V.Vector StandardGlyph -> PutM Int
writeHmtx gs
| V.null gs = return 0
| otherwise =
do traverse_ (\g -> do putWord16be (advanceWidth g)
putInt16be (leftSideBearing g)
) dbl
traverse_ (putInt16be.leftSideBearing) sngl
return (lentl)
where
findTail i cnt
| i < 0 = cnt
| advanceWidth (V.unsafeIndex gs i) == aw =
findTail (i1) (cnt+1)
| otherwise = cnt
aw = advanceWidth (V.unsafeLast gs)
len = V.length gs
tl = findTail (len2) 0
(dbl, sngl) = V.splitAt (lentl) gs
putGlyph :: StandardGlyph -> Put
putGlyph (Glyph _ _ _ xmin ymin xmax ymax outlines) = do
putInt16be $ case outlines of
GlyphContours pts _ -> fromIntegral $ length pts
_ -> 1
putInt16be xmin
putInt16be ymin
putInt16be xmax
putInt16be ymax
case outlines of
GlyphContours pts instrs ->
putContour pts instrs
CompositeGlyph comps -> do
traverse_ (putComponent True) (init comps)
putComponent False $ last comps
getGlyph :: Get StandardGlyph
getGlyph = do
n <- getInt16be
xmin <- getInt16be
ymin <- getInt16be
xmax <- getInt16be
ymax <- getInt16be
outlines <-
if n >= 0
then getContour (fromIntegral n)
else fmap CompositeGlyph $ fix $ \nextComponent -> do
(c, more) <- getComponent
if more then (c:) <$> nextComponent
else return [c]
return $ Glyph "" 0 0 xmin ymin xmax ymax outlines
isShort :: FWord -> Bool
isShort n = abs n <= 255
putCompressFlags :: [Word8] -> Put
putCompressFlags [] = return ()
putCompressFlags (a:r) =
do if null as
then putWord8 a
else do putWord8 (a .|. 8)
putWord8 $ fromIntegral $ length as
putCompressFlags r2
where
(as, r2) = span (== a) r
contourFlag :: CurvePoint -> Word8
contourFlag (CurvePoint x y oc) =
fromIntegral $
makeFlag [oc, sx && x /= 0, sy && y /= 0, False,
x == 0 || (sx && x >= 0),
y == 0 || (sy && y >= 0)]
where
sx = isShort x
sy = isShort y
firstFlag :: CurvePoint -> Word8
firstFlag (CurvePoint x y oc) =
fromIntegral $
makeFlag [oc, sx, sy, False, sx && x >= 0, sy && y >= 0]
where sx = isShort x
sy = isShort y
putCoordX :: CurvePoint -> Word8 -> Put
putCoordX (CurvePoint x _ _) flag
| byteAt flag 1 = putWord8 (fromIntegral $ abs x)
| byteAt flag 4 = return ()
| otherwise = putInt16be (fromIntegral x)
putCoordY :: CurvePoint -> Word8 -> Put
putCoordY (CurvePoint _ y _) flag
| byteAt flag 2 = putWord8 (fromIntegral $ abs y)
| byteAt flag 5 = return ()
| otherwise = putInt16be (fromIntegral y)
putContour :: [[CurvePoint]] -> V.Vector Word8 -> Put
putContour points instr = do
traverse_ (putWord16be.fromIntegral) endPts
putWord16be $ fromIntegral $ V.length instr
traverse_ putWord8 instr
putCompressFlags flags
zipWithM_ putCoordX allPts flags
zipWithM_ putCoordY allPts flags
where
endPts = tail $ scanl (+) (1) $ map length points
allPts = case concat points of
[] -> []
pts@(p: pts2) -> p: zipWith subCoord pts2 pts
subCoord (CurvePoint x2 y2 on) (CurvePoint x1 y1 _) =
CurvePoint (x2x1) (y2y1) on
flags = case allPts of
[] -> []
(p:pts) -> firstFlag p : map contourFlag pts
getFlags :: Int -> Get [Word8]
getFlags n
| n <= 0 = return []
| otherwise = do
flag <- getWord8
if flag .&. 8 /= 0 && n > 1
then do m <- fromIntegral <$> getWord8
(replicate (min (m+1) n) flag ++) <$> getFlags (nm1)
else (flag:) <$> getFlags (n1)
getXcoords, getYcoords :: [Word8] -> Get [FWord]
getXcoords [] = return []
getXcoords (f:r)
| byteAt f 1 = do
x <- getWord8
let x' | byteAt f 4 = fromIntegral x
| otherwise = fromIntegral x
(x':) <$> getXcoords r
| byteAt f 4 = (0:) <$> getXcoords r
| otherwise = do
x <- fromIntegral <$> getInt16be
(x:) <$> getXcoords r
getYcoords [] = return []
getYcoords (f:r)
| byteAt f 2 = do
y <- getWord8
let y' | byteAt f 5 = fromIntegral y
| otherwise = fromIntegral y
(y':) <$> getYcoords r
| byteAt f 5 = (0:) <$> getYcoords r
| otherwise = do
y <- fromIntegral <$> getInt16be
(y:) <$> getYcoords r
getPoint :: FWord -> FWord -> Word8 -> CurvePoint
getPoint x y flag = CurvePoint x y (byteAt flag 0)
reGroup :: [a] -> [Int] -> [[a]]
reGroup _ [] = []
reGroup l (n:ns) = c : reGroup r ns
where
(c, r) = splitAt n l
toOffsets :: (Num a) => [a] -> [a]
toOffsets = tail . scanl (+) 0
getContour :: Int -> Get (GlyphOutlines Int)
getContour 0 = return $ GlyphContours [] V.empty
getContour nContours = do
lastPts <- replicateM nContours (fromIntegral <$> getWord16be)
iLen <- fromIntegral <$> getWord16be
instructions <- V.replicateM iLen getWord8
flags <- getFlags $ last lastPts + 1
xCoords <- toOffsets <$> getXcoords flags
yCoords <- toOffsets <$> getYcoords flags
let coords = zipWith3 getPoint xCoords yCoords flags
contours = reGroup coords $
zipWith () lastPts ((1):lastPts)
return $ GlyphContours contours instructions
isShortInt :: Int -> Bool
isShortInt x = x <= 127 && x >= 128
glyphExtent, glyphRsb :: StandardGlyph -> Int16
glyphRsb g =
fromIntegral (advanceWidth g) glyphExtent g
glyphExtent glyf = leftSideBearing glyf + (glyphXmax glyf glyphXmin glyf)
extendBB :: (FWord, FWord, FWord, FWord)
-> (FWord, FWord, FWord, FWord)
-> (FWord, FWord, FWord, FWord)
extendBB (xMin1, yMin1, xMax1, yMax1)
(xMin2, yMin2, xMax2, yMax2) =
(min xMin1 xMin2, min yMin1 yMin2,
max xMax1 xMax2, max yMax1 yMax2)
extendBB2 :: (FWord, FWord, FWord, FWord) -> CurvePoint
-> (FWord, FWord, FWord, FWord)
extendBB2 (xMin1, yMin1, xMax1, yMax1) (CurvePoint x y _) =
(min xMin1 x, min yMin1 y, max xMax1 x, max yMax1 y)
minBB :: (FWord, FWord, FWord, FWord)
minBB = (maxBound, maxBound, minBound, minBound)
safeIndex :: Int -> [a] -> Maybe a
safeIndex _ [] = Nothing
safeIndex 0 (x:_) = Just x
safeIndex n (_:l) = safeIndex (n1) l
onCurve :: CurvePoint -> Bool
onCurve (CurvePoint _ _ on) = on
getScaledContours' :: Int -> Bool -> V.Vector StandardGlyph -> StandardGlyph -> [[CurvePoint]]
getScaledContours' d scale vec glyph
| d <= 0 = []
| otherwise =
case glyphOutlines glyph of
GlyphContours cp _ -> cp
CompositeGlyph comps ->
flip runCont id $ foldlM scalePoints [] comps
where
getCompContours :: GlyphComponent Int -> [[CurvePoint]]
getCompContours comp =
case vec V.!? componentID comp of
Nothing -> []
Just g2 -> getScaledContours' (d1) scale vec g2
scalePoints :: [[CurvePoint]] -> GlyphComponent Int -> Cont [[CurvePoint]] [[CurvePoint]]
scalePoints pts comp
| matchPoints comp = cont $ \next ->
let pts2 = getCompContours comp
(tx, ty) = fromMaybe (0, 0) $ do
CurvePoint x1 y1 _ <- safeIndex (componentX comp) $ concat pts
CurvePoint x2 y2 _ <- safeIndex (componentY comp) $ concat pts2
return (realToFrac $ x1x2, realToFrac $ y1y2)
in if useMyMetrics comp
then map (map (scalePt tx ty)) pts2
else next $ pts ++ map (map (scalePt tx ty)) pts2
| otherwise = cont $ \next ->
if useMyMetrics comp
then map (map (scalePt offsetX offsetY)) (getCompContours comp)
else next $ pts ++ map (map (scalePt offsetX offsetY)) (getCompContours comp)
where
sqr x = x*x
(offsetX, offsetY) =
if fromMaybe scale (scaledComponentOffset comp)
then (realToFrac (componentX comp) *
sqrt (sqr (realToFrac (componentXX comp)) +
sqr (realToFrac (componentYX comp))),
realToFrac (componentY comp) *
sqrt (sqr (realToFrac (componentXY comp)) +
sqr (realToFrac (componentYY comp))))
else (realToFrac (componentX comp), realToFrac (componentY comp))
xx, xy, yx, yy :: Double
(xx, xy, yx, yy) =
(realToFrac (componentXX comp),
realToFrac (componentXY comp),
realToFrac (componentYX comp),
realToFrac (componentYY comp))
scalePt tx ty (CurvePoint x y on) =
if roundXYtoGrid comp then
CurvePoint
(round tx + round (realToFrac x * xx + realToFrac y * xy))
(round ty + round (realToFrac x * yx + realToFrac y * yy))
on
else
CurvePoint
(round $ realToFrac x * xx + realToFrac y * xy + tx)
(round $ realToFrac x * yx + realToFrac y * yy + ty)
on
glyphBB :: Bool -> V.Vector StandardGlyph -> StandardGlyph -> (FWord, FWord, FWord, FWord)
glyphBB scale vec glyph =
foldl' extendBB2 minBB $
filter onCurve $ concat $
getScaledContours' 10 scale vec glyph
updateBB :: Bool -> V.Vector StandardGlyph -> StandardGlyph -> StandardGlyph
updateBB scale vec glyph =
glyph {glyphXmin = xMin_,
glyphYmin = yMin_,
glyphXmax = xMax_,
glyphYmax = yMax_}
where
(xMin_, yMin_, xMax_, yMax_) = glyphBB scale vec glyph
updateHhea :: V.Vector StandardGlyph -> HheaTable -> HheaTable
updateHhea v h = V.foldl' updateHhea1
(h {advanceWidthMax = minBound,
minLeftSideBearing = maxBound,
minRightSideBearing = maxBound,
xMaxExtent = minBound})
v
updateMinMax :: (FWord, FWord, FWord, FWord, Double)
-> StandardGlyph -> (FWord, FWord, FWord, FWord, Double)
updateMinMax (xmin, ymin, xmax, ymax, totWidth) g =
(min xmin (glyphXmin g),
min ymin (glyphYmin g),
max xmax (glyphXmax g),
max ymax (glyphYmax g),
totWidth + realToFrac (glyphXmax g glyphXmin g))
getMinMax :: V.Vector StandardGlyph -> (FWord, FWord, FWord, FWord, FWord)
getMinMax vec =
over _5 (round . (/ realToFrac (V.length vec))) $
V.foldl' updateMinMax (maxBound, maxBound, minBound, minBound, 0) vec
updateHhea1 :: HheaTable -> StandardGlyph -> HheaTable
updateHhea1 hhea g =
hhea {advanceWidthMax = max (advanceWidthMax hhea)
(advanceWidth g),
minLeftSideBearing = min (minLeftSideBearing hhea)
(leftSideBearing g),
minRightSideBearing = min (minRightSideBearing hhea)
(glyphRsb g),
xMaxExtent = max (xMaxExtent hhea)
(glyphExtent g)}
updateMaxp :: V.Vector StandardGlyph -> MaxpTable -> MaxpTable
updateMaxp vec tbl = V.foldl' (updateMaxp1 vec)
(tbl {numGlyphs = 0,
maxPoints = 0,
maxContours = 0,
maxComponentPoints = 0,
maxComponentContours = 0,
maxComponentElements = 0,
maxComponentDepth = 0})
vec
updateMaxp1 :: V.Vector StandardGlyph -> MaxpTable -> StandardGlyph -> MaxpTable
updateMaxp1 vec maxp glyf =
maxp {numGlyphs = numGlyphs maxp + 1,
maxPoints = max (maxPoints maxp) $
glyfPoints vec glyf,
maxContours = max (maxContours maxp) $
glyfContours vec glyf,
maxComponentPoints = max (maxComponentPoints maxp) $
componentPoints vec glyf,
maxComponentContours = max (maxComponentContours maxp) $
componentContours vec glyf,
maxComponentElements = max (maxComponentElements maxp) $
componentRefs vec glyf,
maxComponentDepth = max (maxComponentDepth maxp) $
componentDepth vec glyf}
overComponents :: ([[CurvePoint]] -> Word16) -> ([Word16] -> Word16)
-> Int -> Bool -> V.Vector StandardGlyph -> StandardGlyph -> Word16
overComponents f h maxD d v g
| maxD <= 0 = 0
| otherwise =
case glyphOutlines g of
GlyphContours p _
| d -> 0
| otherwise -> f p
CompositeGlyph comps ->
h $ map overSub comps
where overSub comp = case v V.!? componentID comp of
Nothing -> 0
Just g2 -> overComponents f h (maxD1) False v g2
glyfPoints, glyfContours, componentRefs, componentDepth, componentPoints, componentContours :: V.Vector StandardGlyph -> StandardGlyph -> Word16
glyfPoints =
overComponents (sum' . map (fromIntegral.length)) (const 0) 2 False
glyfContours =
overComponents (fromIntegral.length) (const 0) 2 False
componentRefs =
overComponents (const 0) (fromIntegral.length) 2 True
componentPoints =
overComponents (sum' . map (fromIntegral . length)) sum' 10 True
componentDepth =
overComponents (const 0) ((+1).maximum) 10 True
componentContours =
overComponents (fromIntegral.length) sum' 10 True
putComponent :: Bool -> GlyphComponent Int -> Put
putComponent more c = do
putWord16be flag
putWord16be $ fromIntegral $ componentID c
case (byteAt flag 0, byteAt flag 1) of
(False, False) -> do
putWord8 $ fromIntegral $ componentX c
putWord8 $ fromIntegral $ componentY c
(False, True) -> do
putInt8 $ fromIntegral $ componentX c
putInt8 $ fromIntegral $ componentY c
(True, False) -> do
putWord16be $ fromIntegral $ componentX c
putWord16be $ fromIntegral $ componentY c
(True, True) -> do
putInt16be $ fromIntegral $ componentX c
putInt16be $ fromIntegral $ componentY c
when (flag .&. (shift 1 3 + shift 1 6 + shift 1 7) /= 0) $
putShortFrac $ componentXX c
when (byteAt flag 7) $ do
putShortFrac $ componentXY c
putShortFrac $ componentYX c
when (flag .&. (shift 1 6 + shift 1 7) /= 0) $
putShortFrac $ componentYY c
for_ (componentInstructions c) $ \instr -> do
putWord16be $ fromIntegral $ V.length instr
traverse_ putWord8 instr
where
flag = makeFlag [
if matchPoints c
then componentX c > 0xff ||
componentY c > 0xff
else not (isShortInt $ componentX c) ||
not (isShortInt $ componentY c),
not $ matchPoints c,
roundXYtoGrid c,
componentXX c /= 1 &&
componentXX c == componentYY c &&
componentXY c == 0 && componentYX c == 0,
False,
more,
componentXX c /= componentYY c &&
componentXY c == 0 && componentYX c == 0,
componentXY c /= 0 || componentYX c /= 0,
isJust (componentInstructions c),
useMyMetrics c,
overlapCompound c,
fromMaybe False (scaledComponentOffset c),
not $ fromMaybe True (scaledComponentOffset c)]
getComponent :: Get (GlyphComponent Int, Bool)
getComponent = do
flag <- getWord16be
gID <- getWord16be
(cX, cY) <-
if | byteAt flag 0 && byteAt flag 1 ->
liftM2 (,)
(fromIntegral <$> getInt16be)
(fromIntegral <$> getInt16be)
| byteAt flag 0 ->
liftM2 (,)
(fromIntegral <$> getWord16be)
(fromIntegral <$> getWord16be)
| byteAt flag 1 ->
liftM2 (,)
(fromIntegral <$> getInt8)
(fromIntegral <$> getInt8)
| otherwise ->
liftM2 (,)
(fromIntegral <$> getWord8)
(fromIntegral <$> getWord8)
(tXX, tXY, tYX, tYY) <-
if | byteAt flag 3 -> do
x <- ShortFrac <$> getInt16be
return (x, 0, 0, x)
| byteAt flag 6 -> do
x <- ShortFrac <$> getInt16be
y <- ShortFrac <$> getInt16be
return (x, 0, 0, y)
| byteAt flag 7 -> do
xx <- ShortFrac <$> getInt16be
xy <- ShortFrac <$> getInt16be
yx <- ShortFrac <$> getInt16be
yy <- ShortFrac <$> getInt16be
return (xx, xy, yx, yy)
| otherwise -> return (1, 0, 0, 1)
instructions <-
if byteAt flag 8
then Just <$> do
l <- fromIntegral <$> getWord16be
V.replicateM l getWord8
else return Nothing
return (
GlyphComponent (fromIntegral gID) instructions tXX tXY tYX tYY
cX cY (not $ byteAt flag 1) (byteAt flag 2)
(byteAt flag 9) (byteAt flag 10)
(if | (byteAt flag 11) -> Just True
| (byteAt flag 12) -> Just False
| otherwise -> Nothing),
byteAt flag 5)