summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Graphics/Fountainhead/Dumper.hs41
-rw-r--r--src/Graphics/Fountainhead/Parser.hs65
-rw-r--r--src/Graphics/Fountainhead/TrueType.hs15
-rw-r--r--src/Graphics/Fountainhead/Type.hs4
4 files changed, 78 insertions, 47 deletions
diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs
index 84d8661..06756cb 100644
--- a/src/Graphics/Fountainhead/Dumper.hs
+++ b/src/Graphics/Fountainhead/Dumper.hs
@@ -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 <> ")"
diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs
index bb74ea7..72ea36d 100644
--- a/src/Graphics/Fountainhead/Parser.hs
+++ b/src/Graphics/Fountainhead/Parser.hs
@@ -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
diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs
index 3828f38..0c15081 100644
--- a/src/Graphics/Fountainhead/TrueType.hs
+++ b/src/Graphics/Fountainhead/TrueType.hs
@@ -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)
diff --git a/src/Graphics/Fountainhead/Type.hs b/src/Graphics/Fountainhead/Type.hs
index 06274dc..07031e4 100644
--- a/src/Graphics/Fountainhead/Type.hs
+++ b/src/Graphics/Fountainhead/Type.hs
@@ -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
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 19:23:07 +0000