Modify the parser to save less outline flags
… than coordinates if the repeated value is given.
This commit is contained in:
parent
22d37b0972
commit
1bcff4c519
GPG Key ID:
A27FDC1E8EE902C0
@ -83,6 +83,7 @@ import Graphics.Fountainhead.TrueType
|
||||
, Panose(..)
|
||||
, SimpleGlyphDefinition(..)
|
||||
, CVTable(..)
|
||||
, OutlineFlag (..)
|
||||
)
|
||||
import qualified Text.Megaparsec as Megaparsec
|
||||
import Graphics.Fountainhead.Parser
|
||||
@ -101,13 +102,14 @@ import Graphics.Fountainhead.Parser
|
||||
, cvTableP
|
||||
, glyfTableP
|
||||
)
|
||||
import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch)
|
||||
import Graphics.Fountainhead.Type (Fixed32(..), succIntegral, ttfEpoch)
|
||||
import Data.Foldable (Foldable(..), find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
|
||||
import Data.Bits (Bits(..), (.>>.))
|
||||
import Data.Bifunctor (Bifunctor(first))
|
||||
import Data.List (intersperse)
|
||||
import Prelude hiding (repeat)
|
||||
|
||||
data DumpError
|
||||
= DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
|
||||
@ -664,36 +666,41 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
|
||||
<> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
|
||||
<> newlineBuilder <> " Flags" <> newlineBuilder
|
||||
<> " -----" <> newlineBuilder
|
||||
<> foldMap dumpFlag (Vector.indexed coordinates) <> newlineBuilder
|
||||
<> fst (Vector.foldl' foldFlag ("", 0) flags) <> newlineBuilder
|
||||
<> " Coordinates" <> newlineBuilder
|
||||
<> " -----------" <> newlineBuilder
|
||||
<> dumpCoordinates coordinates
|
||||
<> fst (Vector.ifoldl' foldCoordinate mempty coordinates)
|
||||
dumpGlyphDefinition _ = "" -- TODO
|
||||
dumpFlag (coordinateIndex, GlyphCoordinate{..}) -- TODO
|
||||
= " " <> justifyNumber 2 coordinateIndex <> ": "
|
||||
<> (if onCurve then "On" else "Off")
|
||||
<> newlineBuilder
|
||||
dumpCoordinates coordinates =
|
||||
let initial = ("", GlyphCoordinate 0 0 True)
|
||||
in fst $ Vector.ifoldl' foldCoordinate initial coordinates
|
||||
dumpFlag lineValue coordinateIndex
|
||||
= " " <> justifyNumber 2 coordinateIndex <> lineValue
|
||||
foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int)
|
||||
foldFlag (accumulator, coordinateIndex) OutlineFlag{..} =
|
||||
let lineValue = ": "
|
||||
<> (if thisYIsSame then "YDual " else " ")
|
||||
<> (if thisXIsSame then "XDual " else " ")
|
||||
<> (if repeat > 0 then "Repeat " else " ")
|
||||
<> (if yShortVector then "Y-Short " else " ")
|
||||
<> (if xShortVector then "X-Short " else " ")
|
||||
<> (if onCurve then "On" else "Off")
|
||||
<> newlineBuilder
|
||||
repeatN = succIntegral repeat
|
||||
repeatedLines = fold
|
||||
$ Vector.cons accumulator
|
||||
$ dumpFlag lineValue
|
||||
<$> Vector.enumFromN coordinateIndex repeatN
|
||||
in (repeatedLines, coordinateIndex + repeatN)
|
||||
foldCoordinate
|
||||
:: (Text.Builder.Builder, GlyphCoordinate)
|
||||
-> Int
|
||||
-> GlyphCoordinate
|
||||
-> (Text.Builder.Builder, GlyphCoordinate)
|
||||
foldCoordinate (accumulator, absCoordinate) coordinateIndex relCoordinate =
|
||||
let nextAbs = GlyphCoordinate
|
||||
{ coordinateX = sumCoordinate (getField @"coordinateX") relCoordinate absCoordinate
|
||||
, coordinateY = sumCoordinate (getField @"coordinateY") relCoordinate absCoordinate
|
||||
, onCurve = getField @"onCurve" relCoordinate -- Not used.
|
||||
}
|
||||
let nextAbs = relCoordinate <> absCoordinate
|
||||
newLine = " " <> justifyNumber 2 coordinateIndex
|
||||
<> " Rel " <> dumpCoordinate relCoordinate
|
||||
<> " -> Abs " <> dumpCoordinate nextAbs
|
||||
<> newlineBuilder
|
||||
in (accumulator <> newLine, nextAbs)
|
||||
sumCoordinate getAxis relCoordinate absCoordinate =
|
||||
getAxis relCoordinate + getAxis absCoordinate
|
||||
dumpCoordinate GlyphCoordinate{..}
|
||||
= "(" <> justifyNumber 7 coordinateX <> ", "
|
||||
<> justifyNumber 7 coordinateY <> ")"
|
||||
|
||||
@ -142,7 +142,12 @@ import Graphics.Fountainhead.TrueType
|
||||
, VariationSelectorMap
|
||||
, unLocaTable
|
||||
)
|
||||
import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), ttfEpoch)
|
||||
import Graphics.Fountainhead.Type
|
||||
( F2Dot14(..)
|
||||
, Fixed32(..)
|
||||
, succIntegral
|
||||
, ttfEpoch
|
||||
)
|
||||
import Text.Megaparsec ((<?>))
|
||||
import qualified Text.Megaparsec as Megaparsec
|
||||
import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary
|
||||
@ -561,60 +566,62 @@ simpleGlyphDefinitionP numberOfContours' = do
|
||||
instructions' <- vectorNP instructionLength
|
||||
(Megaparsec.Binary.word8 <?> "simple glyph instruction")
|
||||
flags' <- flagsP numberOfPoints mempty <?> "flags"
|
||||
xs <- Vector.foldM (coordinateP xFlagPair) mempty flags'
|
||||
ys <- Vector.foldM (coordinateP yFlagPair) mempty flags'
|
||||
xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags'
|
||||
ys <- Vector.foldM (coordinatesP yFlagPair) mempty flags'
|
||||
pure $ SimpleGlyphDefinition
|
||||
{ endPtsOfContours = endPtsOfContours'
|
||||
, instructions = instructions'
|
||||
, coordinates = mkCoordinate <$> Vector.zip3 xs ys flags'
|
||||
, flags = flags'
|
||||
, coordinates = mkCoordinate <$> Vector.zip xs ys
|
||||
}
|
||||
where
|
||||
mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve
|
||||
mkCoordinate (x, y) = GlyphCoordinate x y
|
||||
xFlagPair :: OutlineFlag -> (Bool, Bool)
|
||||
xFlagPair OutlineFlag{ xShortVector, thisXIsSame } =
|
||||
(xShortVector, thisXIsSame)
|
||||
yFlagPair :: OutlineFlag -> (Bool, Bool)
|
||||
yFlagPair OutlineFlag{ yShortVector, thisYIsSame } =
|
||||
(yShortVector, thisYIsSame)
|
||||
coordinateP
|
||||
coordinateP :: Bool -> Bool -> Parser Int16
|
||||
coordinateP True True = fromIntegral
|
||||
<$> Megaparsec.Binary.word8
|
||||
<?> "1 byte long positive coordinate"
|
||||
coordinateP True False = negate . fromIntegral
|
||||
<$> Megaparsec.Binary.word8
|
||||
<?> "1 byte long negative coordinate"
|
||||
coordinateP False False = Megaparsec.Binary.int16be
|
||||
<?> "2 bytes long coordinate"
|
||||
coordinateP False True = pure 0
|
||||
coordinatesP
|
||||
:: (OutlineFlag -> (Bool, Bool))
|
||||
-> Vector Int16
|
||||
-> OutlineFlag
|
||||
-> Parser (Vector Int16)
|
||||
coordinateP get accumulator first =
|
||||
case get first of
|
||||
(True, True) -> Vector.snoc accumulator . fromIntegral
|
||||
<$> Megaparsec.Binary.word8
|
||||
<?> "1 byte long positive coordinate"
|
||||
(True, False)
|
||||
-> Vector.snoc accumulator . negate . fromIntegral
|
||||
<$> Megaparsec.Binary.word8
|
||||
<?> "1 byte long negative coordinate"
|
||||
(False, False) -> Vector.snoc accumulator
|
||||
<$> Megaparsec.Binary.int16be
|
||||
<?> "2 bytes long coordinate"
|
||||
(False, True) -> pure $ Vector.snoc accumulator 0
|
||||
coordinatesP get accumulator first =
|
||||
let parser = uncurry coordinateP $ get first
|
||||
repeatN = succIntegral $ getField @"repeat" first
|
||||
in (accumulator <>) <$> vectorNP repeatN parser
|
||||
flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag)
|
||||
flagsP remaining accumulator
|
||||
| remaining < 0 = pure accumulator
|
||||
| otherwise = do
|
||||
flag <- Megaparsec.Binary.word8 <?> "outline flags"
|
||||
repeatN <-
|
||||
if testBit flag 3
|
||||
then fromIntegral
|
||||
<$> Megaparsec.Binary.word8
|
||||
<?> "flag repeat count"
|
||||
else pure 0
|
||||
let flag' = OutlineFlag
|
||||
{ onCurve = testBit flag 0
|
||||
, xShortVector = testBit flag 1
|
||||
, yShortVector = testBit flag 2
|
||||
, repeat = fromIntegral repeatN
|
||||
, thisXIsSame = testBit flag 4
|
||||
, thisYIsSame = testBit flag 5
|
||||
}
|
||||
repeatN <-
|
||||
if testBit flag 3
|
||||
then (1 +)
|
||||
. fromIntegral
|
||||
<$> Megaparsec.Binary.word8
|
||||
<?> "flag repeat count"
|
||||
else pure 1
|
||||
flagsP (remaining - repeatN)
|
||||
$ accumulator <> Vector.replicate repeatN flag'
|
||||
flagsP (remaining - repeatN - 1)
|
||||
$ Vector.snoc accumulator flag'
|
||||
|
||||
glyfTableP :: LocaTable -> Parser GlyfTable
|
||||
glyfTableP locaTable
|
||||
@ -871,7 +878,7 @@ cmapFormat2TableP = do
|
||||
length' <- fromIntegral <$> Megaparsec.Binary.word16be
|
||||
language' <- Megaparsec.Binary.word16be
|
||||
subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be
|
||||
let maxIndex = succ $ fromIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys'
|
||||
let maxIndex = succIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys'
|
||||
subHeaders' <- vectorNP maxIndex cmapFormat2SubheaderP
|
||||
let glyphIndexLength = div (length' - 518 - maxIndex * 8) 2
|
||||
glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be
|
||||
|
||||
@ -341,6 +341,8 @@ data SimpleGlyphDefinition = SimpleGlyphDefinition
|
||||
{ endPtsOfContours :: Vector Word16
|
||||
-- | Array of instructions for this glyph.
|
||||
, instructions :: Vector Word8
|
||||
-- Array of flags.
|
||||
, flags :: Vector OutlineFlag
|
||||
-- | Array of coordinates; the first is relative to (0,0), others are
|
||||
-- relative to previous point.
|
||||
, coordinates :: Vector GlyphCoordinate
|
||||
@ -366,9 +368,19 @@ data ComponentGlyphFlags = ComponentGlyphFlags
|
||||
data GlyphCoordinate = GlyphCoordinate
|
||||
{ coordinateX :: Int16
|
||||
, coordinateY :: Int16
|
||||
, onCurve :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance Semigroup GlyphCoordinate
|
||||
where
|
||||
lhs <> rhs =
|
||||
let GlyphCoordinate{ coordinateX = lhX, coordinateY = lhY } = lhs
|
||||
GlyphCoordinate{ coordinateX = rhX, coordinateY = rhY } = rhs
|
||||
in GlyphCoordinate{ coordinateX = lhX + rhX, coordinateY = lhY + rhY }
|
||||
|
||||
instance Monoid GlyphCoordinate
|
||||
where
|
||||
mempty = GlyphCoordinate 0 0
|
||||
|
||||
data ComponentGlyphPartDescription = ComponentGlyphPartDescription
|
||||
{ flags :: ComponentGlyphFlags
|
||||
, glyphIndex :: Word16
|
||||
@ -383,6 +395,7 @@ data OutlineFlag = OutlineFlag
|
||||
{ onCurve :: Bool
|
||||
, xShortVector :: Bool
|
||||
, yShortVector :: Bool
|
||||
, repeat :: Word8
|
||||
, thisXIsSame :: Bool
|
||||
, thisYIsSame :: Bool
|
||||
} deriving (Eq, Show)
|
||||
|
||||
@ -8,6 +8,7 @@ module Graphics.Fountainhead.Type
|
||||
, Fixed32(..)
|
||||
, FWord
|
||||
, UFWord
|
||||
, succIntegral
|
||||
, ttfEpoch
|
||||
) where
|
||||
|
||||
@ -27,3 +28,6 @@ type UFWord = Word16
|
||||
|
||||
ttfEpoch :: Day
|
||||
ttfEpoch = fromOrdinalDate 1904 1
|
||||
|
||||
succIntegral :: Integral a => a -> Int
|
||||
succIntegral = succ . fromIntegral
|
||||
|
||||
Loading…
Reference in New Issue
Block a user