diff --git a/Opentype/Fileformat.hs b/Opentype/Fileformat.hs --- a/Opentype/Fileformat.hs +++ b/Opentype/Fileformat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, TemplateHaskell #-} -- | This module provides opentype file loading and writing. An -- attempt was made to have a higher level interface without @@ -6,22 +6,30 @@ module Opentype.Fileformat (-- * Types - ShortFrac (..), Fixed, FWord, UFWord, GlyphID, + ShortFrac (..), Fixed, FWord, UFWord, GlyphID, WordMap, -- * Main datatype - OpentypeFont (..), maxpTable, glyfTable, OutlineTables (..), GenericTables, + OpentypeFont (..), OutlineTables (..), GenericTables, + -- ** OpentypeFont lenses + _headTable, _hheaTable, _cmapTable, + _nameTable, _postTable, _os2Table, _kernTable, _outlineTables, _otherTables, + _maxpTable, _glyfTable, -- * IO readOTFile, writeOTFile, -- * Head table HeadTable(..), -- * Glyf table - GlyfTable(..), Glyph(..), GlyphOutlines(..), + GlyfTable(..), Glyph(..), StandardGlyph, GlyphOutlines(..), getScaledContours, + emptyGlyfTable, CurvePoint(..), Instructions, GlyphComponent(..), + -- ** Glyf table lenses + _glyphContours, _glyphInstructions, _glyphComponents, -- * CMap table CmapTable(..), CMap(..), PlatformID(..), MapFormat (..), + emptyCmapTable, -- * Hhea table HheaTable(..), -- * Maxp table - MaxpTable(..), + MaxpTable(..), emptyMaxpTable, -- * Name table NameTable(..), NameRecord(..), -- * Post table @@ -29,7 +37,7 @@ -- * OS/2 table OS2Table(..), -- * Kern table - KernTable(..), KernPair(..) + KernTable(..), KernPair(..), _kernPairs ) where import Opentype.Fileformat.Types import Opentype.Fileformat.Head @@ -53,6 +61,10 @@ import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict import Data.ByteString.Unsafe +import Lens.Micro hiding (strict) +import Lens.Micro.TH +import Lens.Micro.Extras +import qualified Data.Vector as V import qualified Data.Map as M type GenericTables = M.Map String Lazy.ByteString @@ -82,21 +94,21 @@ } deriving Show + -- | tables for quadratic outlines (truetype or opentype) data OutlineTables = QuadTables MaxpTable GlyfTable | CubicTables deriving Show -maxpTable :: OpentypeFont -> Maybe MaxpTable -maxpTable font = case outlineTables font of - QuadTables m _ -> Just m - _ -> Nothing - -glyfTable :: OpentypeFont -> Maybe GlyfTable -glyfTable font = case outlineTables font of - QuadTables _ g -> Just g - _ -> Nothing +makeLensesFor [("headTable", "_headTable"), + ("hheaTable", "_hheaTable"), + ("cmapTable", "_cmapTable"), + ("nameTable", "_nameTable"), + ("postTable", "_postTable"), + ("outlineTables", "_outlineTables"), + ("otherTables", "_otherTables")] + ''OpentypeFont data ScalerType = -- opentype with cff @@ -110,6 +122,50 @@ type SfntLocs = M.Map Scaler (Word32, Word32) type Scaler = Word32 +_maxpTable :: Traversal' OpentypeFont MaxpTable +_maxpTable f font = case outlineTables font of + QuadTables m g -> (\m2 -> font { outlineTables = QuadTables m2 g }) + <$> f m + _ -> pure font + +_glyfTable :: Traversal' OpentypeFont GlyfTable +_glyfTable f font = case outlineTables font of + QuadTables m g -> (\g2 -> font {outlineTables = QuadTables m g2}) + <$> f g + _ -> pure font + +_os2Table :: Traversal' OpentypeFont OS2Table +_os2Table f font = case os2Table font of + Just t -> (\t2 -> font {os2Table = Just t2}) <$> f t + Nothing -> pure font + +_kernTable :: Traversal' OpentypeFont KernTable +_kernTable f font = case kernTable font of + Just t -> (\t2 -> font {kernTable = Just t2}) <$> f t + Nothing -> pure font + +-- | @getScaledContours scaleOffset glyfTable glyph@: Get the scaled +-- contours for a simple or composite glyph. +getScaledContours :: OpentypeFont -> StandardGlyph -> [[CurvePoint]] +getScaledContours font glyph = + case preview _glyfTable font of + Nothing -> [] + Just (GlyfTable vec) -> + getScaledContours' 10 (appleScaler font) vec glyph + +getWindowsMap :: OpentypeFont -> Maybe CMap +getWindowsMap font = + find (\cm -> cmapPlatform cm == MicrosoftPlatform && + cmapEncoding cm `elem` [0, 1]) $ + getCmaps $ cmapTable font + +getUnicodeChar :: OpentypeFont -> Word32 -> Maybe (Glyph Int) +getUnicodeChar font c = do + mp <- getWindowsMap font + gID <- fmap fromIntegral $ M.lookup c $ glyphMap mp + (V.!? gID) =<< glyphVector <$> + preview _glyfTable font + -- | write an opentype font to a file writeOTFile :: OpentypeFont -> FilePath -> IO () writeOTFile font file = @@ -117,16 +173,31 @@ CubicTables -> error "cubic splines are not yet supported" QuadTables maxpTbl (GlyfTable glyphs) -> - let (lengths, glyphBs) = runPutM $ writeGlyphs glyphs + let (lengths, glyphBs) = runPutM $ writeGlyphs (appleScaler font) glyphs (format, locaBs) = runPutM $ writeLoca lengths (longHor, hmtxBs) = runPutM $ writeHmtx glyphs - head2 = updateHead glyphs $ - (headTable font) { + (xmin, ymin, xmax, ymax, _avgWdt) = getMinMax glyphs + head2 = (headTable font) { headVersion = 0x00010000, + xMin = xmin, + yMin = ymin, + xMax = xmax, + yMax = ymax, fontDirectionHint = 2, longLocIndices = format } + theAscent | ascent (hheaTable font) == 0 = fromIntegral ymax + | otherwise = ascent (hheaTable font) + theDescent | descent (hheaTable font) == 0 = fromIntegral ymin + | otherwise = descent (hheaTable font) + theLineGap = case os2Table font of + Just os2 -> fromIntegral (unitsPerEm head2) + sTypoLineGap os2 - + ascent hhea2 + descent hhea2 + Nothing -> lineGap (hheaTable font) hhea2 = updateHhea glyphs $ - (hheaTable font) {numOfLongHorMetrics = fromIntegral longHor} + (hheaTable font) {numOfLongHorMetrics = fromIntegral longHor, + ascent = theAscent, + descent= theDescent, + lineGap= theLineGap} maxp2 = updateMaxp glyphs $ maxpTbl {maxpVersion = 0x00010000} headBs = Lazy.toStrict $ runPut $ putHeadTable head2 @@ -135,7 +206,28 @@ maxpBs = Lazy.toStrict $ runPut $ putMaxpTable maxp2 nameBs = Lazy.toStrict $ runPut $ putNameTable $ nameTable font postBs = Lazy.toStrict $ runPut $ putPostTable $ postTable font - os2Bs = (Lazy.toStrict . runPut . putOS2Table) <$> os2Table font + os2Bs = (Lazy.toStrict . runPut . putOS2Table . + (\os2 -> os2 { + usWinAscent = fromIntegral theAscent, + usWinDescent = fromIntegral $ -theDescent, + usFirstCharIndex = fromMaybe 0 $ do + mp <- getWindowsMap font + Just $ fromIntegral $ fst $ M.findMin $ glyphMap mp, + usLastCharIndex = fromMaybe 0xffff $ do + mp <- getWindowsMap font + let l = fst $ M.findMax $ glyphMap mp + if l > 0xffff then Nothing else Just $ fromIntegral l, + sxHeight = + if sxHeight os2 == 0 + then fromMaybe 0 $ + glyphYmax <$> getUnicodeChar font 0x0078 + else sxHeight os2, + sCapHeight = + if sCapHeight os2 == 0 + then fromMaybe 0 $ + glyphYmax <$> getUnicodeChar font 0x0048 + else sCapHeight os2})) + <$> os2Table font kernBs = (Lazy.toStrict . runPut . putKernTable) <$> kernTable font scaler | appleScaler font = AppleScaler | otherwise = QuadScaler diff --git a/Opentype/Fileformat/Cmap.hs b/Opentype/Fileformat/Cmap.hs --- a/Opentype/Fileformat/Cmap.hs +++ b/Opentype/Fileformat/Cmap.hs @@ -63,9 +63,12 @@ -- * 5: Johab -- * 10: Unicode UCS-4 -data CmapTable = CmapTable [CMap] +newtype CmapTable = CmapTable {getCmaps :: [CMap]} deriving Show +emptyCmapTable :: CmapTable +emptyCmapTable = CmapTable [] + data CMap = CMap { cmapPlatform :: PlatformID, cmapEncoding :: Word16, @@ -351,7 +354,7 @@ size, segCount, searchRange, entrySelector :: Word16 entrySelector = iLog2 segCount searchRange = 1 `shift` (fromIntegral $ entrySelector+1) - segments = getSegments $ M.toList $ glyphMap cmap + segments = getSegments $ M.toList $ subIntMap 0 0xffff $ glyphMap cmap (codeSize, layout) = mapAccumL foldLayout (segCount*2) segments foldLayout offset (RangeSegment start len code) = (offset-2, Segment4layout (fromIntegral $ start+len-1) diff --git a/Opentype/Fileformat/FontInfo.hs b/Opentype/Fileformat/FontInfo.hs new file mode 100644 --- /dev/null +++ b/Opentype/Fileformat/FontInfo.hs @@ -0,0 +1,568 @@ +-- | This module implements a somewhat more logical structure +-- containing font information, without the need for an in-depth study +-- of the opentype spec. +module Opentype.Fileformat.FontInfo (FontInfo(..), Weight(..), + Width(..), Slant(..), Decoration(..), + EmbedLicence(..), infoToTables) +where +import Opentype.Fileformat +import Opentype.Fileformat.Types +import Data.Maybe +import Data.Word +import Data.Time +import Data.Char +import Data.Bits +import Data.Binary.Put +import Data.Foldable +import Text.Printf +import Lens.Micro +import Lens.Micro.Extras +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString as Strict + +data Weight = Thin | ExtraLight | Light | NormalWeight | MediumWeight + | SemiBold | Bold | ExtraBold | Heavy + deriving (Eq, Ord) + +instance Show Weight where + show Thin = "Thin" + show ExtraLight = "Extra Light" + show Light = "Light" + show NormalWeight = "Regular" + show MediumWeight = "Medium" + show SemiBold = "Semibold" + show Bold = "Bold" + show ExtraBold = "Extra Bold" + show Heavy = "Heavy" + +data Width = UltraCondensed | ExtraCondensed | Condensed | SemiCondensed + | MediumWidth | SemiExpanded | Expanded | ExtraExpanded | UltraExpanded + deriving (Eq, Ord) + +instance Show Width where + show UltraCondensed = "Ultra Condensed" + show ExtraCondensed = "Extra Condensed" + show Condensed = "Condensed" + show SemiCondensed = "Semi Condensed" + show MediumWidth = "Regular" + show SemiExpanded = "Semi Expanded" + show Expanded = "Expanded" + show ExtraExpanded = "Extra Expanded" + show UltraExpanded = "Ultra Expanded" + +data Slant = Italic | Oblique | NoSlant + deriving Eq + +instance Show Slant where + show Italic = "Italic" + show Oblique = "Oblique" + show NoSlant = "Regular" + +data Decoration = Underscore | Negative | Outlined | StrikeOut | Shadow + deriving Eq + +data EmbedLicence = + -- | Fonts must not be modified, embedded or exchanged in any manner + -- without first obtaining permission of the legal owner. Caution: + -- For Restricted License embedding to take effect, it must be the + -- only level of embedding selected. + RestrictedEmbedding | + -- | The font may be embedded, and temporarily loaded on the remote + -- system. Documents containing Preview & Print fonts must be opened + -- “read-only;” no edits can be applied to the document. + PrintPreview | + -- | The font may be embedded but must only be installed temporarily + -- on other systems. In contrast to Preview & Print fonts, documents + -- containing Editable fonts may be opened for reading, editing is + -- permitted, and changes may be saved. + EditEmbed | + -- | When this bit is set, the font may not be subsetted prior to + -- embedding. Other embedding restrictions also apply. + NoSubsetEmbed | + -- | When this bit is set, only bitmaps contained in the font may be + -- embedded. No outline data may be embedded. If there are no + -- bitmaps available in the font, then the font is considered + -- unembeddable and the embedding services will fail. Other + -- embedding restrictions specified in bits 0-3 and 8 also apply. + OnlyBitmapEmbed + +licenceBit :: EmbedLicence -> Int +licenceBit RestrictedEmbedding = 0x0002 +licenceBit PrintPreview = 0x0004 +licenceBit EditEmbed = 0x0008 +licenceBit NoSubsetEmbed = 0x0100 +licenceBit OnlyBitmapEmbed = 0x0200 + +embeddedBits :: [EmbedLicence] -> Word16 +embeddedBits = fromIntegral . sum . map licenceBit + +-- | Currently only english strings are supported. +data FontInfo = FontInfo { + -- | Font Family name, without subfamily classifiers such as /Bold/, /Italic/, etc... + fontFamily :: String, + -- | Font version, multiplied by 1000, for example use 1500 for + -- version 1.5 + fontVersion :: Int, + -- | Number of units in an em-square. Should be a power of 2. + -- Typical values are 1024 or 2048. + fontUnitsPerEm :: FWord, + -- | Distance between the bottom of the em-square and the baseline + -- in font design units. + fontEmBase :: FWord, + -- | Linegap in font design units. Defined as distance between + -- baselines - height of em square (`fontUnitsPerEm`). + fontLineGap :: FWord, + -- | Weight of the font. /default/: `NormalWeight` + fontWeight :: Weight, + -- | Width of the font. /default/: `MediumWidth` + fontWidth :: Width, + -- | Slant of the font. /default/: `NoSlant` + fontSlant :: Slant, + -- | fixed width font. /default/: False + fontMonospaced :: Maybe Bool, + -- | Smallest readable size in pixels. /default/: 6 + fontLowestRecPPEM :: Maybe Int, + -- | talic angle in counter-clockwise degrees from the + -- vertical. Zero for upright text, negative for text that leans to + -- the right (forward). /default/: 0 + fontItalicAngle :: Maybe Double, + -- | The amount by which a slanted highlight on a glyph needs to be + -- shifted to produce the best appearance. /default/: 0 + fontCaretOffset :: Maybe FWord, + -- | The recommended size in font design units for subscripts for + -- this font. /default/: (fontUnitsPerEM/2, fontUnitsPerEM/2) + fontSubScriptSize :: Maybe (FWord, FWord), + -- | The recommended offset in font design units for subscripts for + -- this font. /default/: (0, -fontUnitsPerEM/4) + fontSubScriptOffset :: Maybe (FWord, FWord), + -- | The recommended size in font design units for superscripts for + -- this font. /default/: (fontUnitsPerEM/2, fontUnitsPerEM/2) + fontSuperScriptSize :: Maybe (FWord, FWord), + -- | The recommended offset in font design units for superscripts for + -- this font. /default/: (cos(90 + italicAngle)*snd superscriptYOffset, (fontUnitsPerEM-fontEmBase)/2) + fontSuperScriptOffset :: Maybe (FWord, FWord), + -- | ndicates font embedding licensing rights for the + -- font. Embeddable fonts may be stored in a document. When a + -- document with embedded fonts is opened on a system that does not + -- have the font installed (the remote system), the embedded font + -- may be loaded for temporary (and in some cases, permanent) use on + -- that system by an embedding-aware application. Embedding + -- licensing rights are granted by the vendor of the font. + -- /default/: [] + fontEmbeddingLicence :: [EmbedLicence], + -- | Width of the strikeout stroke in font design units. This field + -- should normally be the width of the em dash for the current + -- font. If the size is one, the strikeout line will be the line + -- represented by the strikeout position field. If the value is two, + -- the strikeout line will be the line represented by the strikeout + -- position and the line immediately above the strikeout + -- position. /default/: fontUnitsPerEm/20 + fontStrikoutSize :: Maybe FWord, + -- | The position of the top of the strikeout stroke relative to the + -- baseline in font design units. Positive values represent + -- distances above the baseline, while negative values represent + -- distances below the baseline. A value of zero falls directly on + -- the baseline, while a value of one falls one pel above the + -- baseline. The value of strikeout position should not interfere + -- with the recognition of standard characters, and therefore should + -- not line up with crossbars in the + -- font. /default/. fontUnitsPerEm/5.5 + fontStrikeoutPosition :: Maybe FWord, + -- | The font class and font subclass are registered values assigned + -- by IBM to each font family. This parameter is intended for use in + -- selecting an alternate font when the requested font is not + -- available. The font class is the most general and the font + -- subclass is the most specific. The high byte of this field + -- contains the family class, while the low byte contains the family + -- subclass. See + -- for more information. + -- /default/: (0,0) + fontFamilyClass :: Maybe (Int, Int), + -- | The four character identifier for the vendor of the given type + -- face. This is not the royalty owner of the original artwork. This + -- is the company responsible for the marketing and distribution of + -- the typeface that is being classified. It is reasonable to assume + -- that there will be 6 vendors of ITC Zapf Dingbats for use on + -- desktop platforms in the near future (if not already). It is also + -- likely that the vendors will have other inherent benefits in + -- their fonts (more kern pairs, unregularized data, hand hinted, + -- etc.). This identifier will allow for the correct vendor's type + -- to be used over another, possibly inferior, font file. The Vendor + -- ID value is not required. + -- /default/: (' ', ' ', ' ', ' ') + fontVendorID :: Maybe (Char, Char, Char, Char), + -- | Panose-1 Classification. /default/: (0, 0, 0, 0, 0, 0, 0, 0, 0, 0) + fontPanose :: Maybe (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int), + -- | Supported Unicode Ranges: See + -- https://www.microsoft.com/typography/otspec/os2.htm#ur. + -- /default/ (3, 0, 0, 0) + fontUnicodeRanges :: Maybe (Word32, Word32, Word32, Word32), + -- | Supported Codepage Ranges. See + -- https://www.microsoft.com/typography/otspec/os2.htm#cpr. + -- /default/: (1, 0) + fontCodepageRanges :: Maybe (Word32, Word32), + -- | This metric specifies the distance between the baseline and the + -- approximate height of non-ascending lowercase letters measured in + -- FUnits. /default/ height of glyph at U+0078 (LATIN SMALL LETTER + -- X) + fontXHeight :: Maybe FWord, + -- | This metric specifies the distance between the baseline and the + -- approximate height of uppercase letters measured in FUnits. + -- /default/ height of glyph at U+0048 (LATIN CAPITAL LETTER H). + fontCapHeight :: Maybe FWord, + -- | This field is used for fonts with multiple optical styles. + -- + -- This value is the lower value of the size range for which this + -- font has been designed. The units for this field are TWIPs + -- (one-twentieth of a point, or 1440 per inch). The value is + -- inclusive—meaning that that font was designed to work best at + -- this point size through, but not including, the point size + -- indicated by usUpperOpticalPointSize. When used with other + -- optical fonts that set usLowerOpticalPointSize and + -- usUpperOpticalPointSize, it would be expected that another font + -- has this same value as this entry in the usUpperOpticalPointSize + -- field, unless this font is designed for the lowest size + -- range. The smallest font in an optical size set should set this + -- value to 0.When working across multiple optical fonts, there + -- should be no intentional gaps or overlaps in the + -- ranges. usLowerOpticalPointSize must be less than + -- usUpperOpticalPointSize. The maximum valid value is 0xFFFE. + -- /default/: 0 + fontLowerOpticalPointSize :: Maybe Int, + -- | fontUpperOptThis field is used for fonts with multiple optical styles. + -- + -- This value is the upper value of the size range for which this + -- font has been designed. The units for this field are TWIPs + -- (one-twentieth of a point, or 1440 per inch). The value is + -- exclusive—meaning that that font was designed to work best below + -- this point size down to the usLowerOpticalPointSize + -- threshold. When used with other optical fonts that set + -- usLowerOpticalPointSize and usUpperOpticalPointSize, it would be + -- expected that another font has this same value as this entry in + -- the usLowerOpticalPointSize field, unless this font is designed + -- for the highest size range. The largest font in an optical size + -- set should set this value to 0xFFFF, which is interpreted as + -- infinity. When working across multiple optical fonts, there + -- should be no intentional or overlaps left in the + -- ranges. usUpperOpticalPointSize must be greater than + -- usLowerOpticalPointSize. The minimum valid value for this field + -- is 2 (two). The largest possible inclusive point size represented + -- by this field is 3276.65 points, any higher values would be + -- represented as infinity. /default/: 0xffff + fontUpperOpticalPointSize :: Maybe Int, + -- | This is the suggested distance of the top of the underline from + -- the baseline (negative values indicate below baseline). The + -- PostScript definition of this FontInfo dictionary key (the y + -- coordinate of the center of the stroke) is not used for + -- historical reasons. The value of the PostScript key may be + -- calculated by subtracting half the underlineThickness from the + -- value of this field. /default/: /default/ -fontUnitsPerEm/8 + fontUnderlinePosition :: Maybe FWord, + -- | suggested values for the underline thickness. /default/ fontUnitsPerEm/10 + fontUnderlineThickness :: Maybe FWord, + -- | This field is used when the font has a subfamily other than + -- Weight, Width or Slant. Should not include any width, weight or + -- slant descriptions. /default/: "" + fontSubFamilyExtra :: String, + -- | Set if the font has any of these decorations. /default/: [] + fontDecoration :: [Decoration], + -- | Copyright notice. Default: [] + fontCopyright :: String, + -- | Unique font identifier + fontID :: String, + -- | postscriptName. /default/: full name with hyphen substituted for spaces. + fontPsName :: String, + -- | trademark. /default/: "" + fontTrademark :: String, + -- | Manufacturer Name. /default/: "" + fontManufacturer :: String, + -- | name of the designer of the typeface. /default/: "" + fontDesigner :: String, + -- | description of how the font may be legally used, or different + -- example scenarios for licensed use. This field should be written + -- in plain language, not legalese. /default/: "" + fontLicence :: String, + -- | description of the typeface. Can contain revision information, + -- usage recommendations, history, features, etc. + fontDescription :: String, + -- | URL where additional licensing information can be found. + -- /default/ "" + fontLicenceUrl :: String, + -- | URL of typeface designer (with protocol, e.g., http://, ftp://). + fontDesignerUrl :: String, + -- | URL of font vendor (with protocol, e.g., http://, ftp://). If a + -- unique serial number is embedded in the URL, it can be used to + -- register the font. + fontVendorUrl :: String, + -- | This can be the font name, or any other text that the designer + -- thinks is the best sample to display the font in. /default/: "" + fontSampleText :: String, + -- | This ID, if used in the CPAL table’s Palette Labels Array, + -- specifies that the corresponding color palette in the CPAL table + -- is appropriate to use with the font when displaying it on a light + -- background such as white. Name table strings for this ID specify + -- the user interface strings associated with this + -- palette. /default/ "" + fontLightPalette :: String, + -- | Dark Backgound Palette. This ID, if used in the CPAL table’s + -- Palette Labels Array, specifies that the corresponding color + -- palette in the CPAL table is appropriate to use with the font + -- when displaying it on a dark background such as black. Name table + -- strings for this ID specify the user interface strings associated + -- with this palette + fontDarkPalette :: String, + -- | font creation time + fontCreated :: UTCTime, + -- | font modification time. /default/: creation time. + fontModified :: Maybe UTCTime + } + +weightClass :: Weight -> Word16 +weightClass Thin = 100 +weightClass ExtraLight = 200 +weightClass Light = 300 +weightClass NormalWeight = 400 +weightClass MediumWeight = 500 +weightClass SemiBold = 600 +weightClass Bold = 700 +weightClass ExtraBold = 800 +weightClass Heavy = 900 + +widthClass :: Width -> Word16 +widthClass UltraCondensed = 1 +widthClass ExtraCondensed = 2 +widthClass Condensed = 3 +widthClass SemiCondensed = 4 +widthClass MediumWidth = 5 +widthClass SemiExpanded = 6 +widthClass Expanded = 7 +widthClass ExtraExpanded = 8 +widthClass UltraExpanded = 9 + +(+++) :: String -> String -> String +s +++ "" = s +s +++ t = s ++ " " ++ t + +notRegular :: (Show a, Eq a) => a -> a -> String +notRegular reg sub = + if reg == sub then "" else show sub + +(///) :: Maybe c -> c -> c +(///) = flip fromMaybe + +-- | Fill in font information into the font tables +infoToTables :: FontInfo -> (HeadTable, HheaTable, NameTable, PostTable, OS2Table) +infoToTables fi = (headTbl, hheaTbl, nameTbl, postTbl, os2Tbl) + where + headTbl = HeadTable { + headVersion = 0x00010000, + fontRevision = fromIntegral $ + fromIntegral (fontVersion fi) * 0x00010000 `quot` + (1000 :: Integer), + baselineYZero = True, + sidebearingXZero = True, + pointsizeDepend = False, + integerScaling = False, + alterAdvanceWidth = False, + verticalFont = False, + linguisticRenderingLayout = False, + metamorphosisEffects = False, + rightToLeftGlyphs = False, + indicRearrangements = False, + losslessFontData = False, + convertedFont = False, + clearTypeOptimized = False, + lastResortFont = False, + unitsPerEm = fromIntegral $ fontUnitsPerEm fi, + created = fontCreated fi, + modified = fontModified fi /// fontCreated fi, + xMin = 0, + yMin = 0, + xMax = 0, + yMax = 0, + boldStyle = fontWeight fi > NormalWeight, + italicStyle = fontSlant fi == Italic, + underlineStyle = Underscore `elem` fontDecoration fi, + outlineStyle = Outlined `elem` fontDecoration fi, + shadowStyle = Shadow `elem` fontDecoration fi, + condensedStyle = fontWidth fi < MediumWidth, + extendedStyle = fontWidth fi > MediumWidth, + lowerRecPPEM = (fromIntegral <$> fontLowestRecPPEM fi) /// 6, + fontDirectionHint = 2, + longLocIndices = False, + glyphDataFormat = 0} + hheaTbl = HheaTable { + version = 0x00010000, + ascent = 0, + descent = 0, + lineGap = 0, + advanceWidthMax = 0, + minLeftSideBearing = 0, + minRightSideBearing = 0, + xMaxExtent = 0, + caretSlopeRise = case fontItalicAngle fi /// 0 of + 0 -> 1 + -90 -> 0 + a -> round $ cos (pi*a/180 + pi/2) * 2048, + caretSlopeRun = case fontItalicAngle fi /// 0 of + 0 -> 0 + -90 -> 1 + a -> round $ sin (pi*a/180 + pi/2) * 2048, + caretOffset = fontCaretOffset fi /// 0, + numOfLongHorMetrics = 0} + mkNameRecords _ "" = [] + mkNameRecords nid ns = + [NameRecord MacintoshPlatform 0 0 nid $ + Strict.pack $ map (fromIntegral . (.&.0xff) . ord) ns, + NameRecord MicrosoftPlatform 1 0x0409 nid $ + Lazy.toStrict $ runPut (traverse_ (putWord16be . fromIntegral . ord) ns)] + (versionMajor, versionMinor) = fontVersion fi `quotRem` 1000 + fullName = fontFamily fi +++ subFamily + subFamily = fontSubFamilyExtra fi +++ + notRegular NormalWeight (fontWeight fi) +++ + notRegular MediumWidth (fontWidth fi) +++ + notRegular NoSlant (fontSlant fi) + wsSubFamily + | fontWeight fi == NormalWeight && fontSlant fi == NoSlant + = "Regular" + | otherwise = weightName +++ notRegular NoSlant (fontSlant fi) + where + weightName + | fontWeight fi < NormalWeight = "Thin" + | fontWeight fi > NormalWeight = "Bold" + | otherwise = "" + + nameTbl = NameTable $ + concat [ + mkNameRecords 0 $ fontCopyright fi, + mkNameRecords 1 $ fontFamily fi +++ fontSubFamilyExtra fi +++ + notRegular MediumWidth (fontWidth fi), + mkNameRecords 2 wsSubFamily, + mkNameRecords 3 $ fontID fi, + mkNameRecords 4 fullName, + mkNameRecords 5 $ printf "Version %d.%03d" versionMajor versionMinor, + mkNameRecords 6 $ if null (fontPsName fi) + then take 63 $ map (\c -> if c == ' ' then '-' else c) fullName + else fontPsName fi, + mkNameRecords 7 $ fontTrademark fi, + mkNameRecords 8 $ fontManufacturer fi, + mkNameRecords 9 $ fontDesigner fi, + mkNameRecords 10 $ fontDescription fi, + mkNameRecords 11 $ fontVendorUrl fi, + mkNameRecords 12 $ fontDesignerUrl fi, + mkNameRecords 13 $ fontLicence fi, + mkNameRecords 14 $ fontLicenceUrl fi, + mkNameRecords 16 $ fontFamily fi, + mkNameRecords 17 subFamily, + mkNameRecords 19 $ fontSampleText fi, + mkNameRecords 21 $ + if null (fontSubFamilyExtra fi) then "" + else fontFamily fi +++ fontSubFamilyExtra fi, + mkNameRecords 22 $ + if null (fontSubFamilyExtra fi) then "" + else notRegular NormalWeight (fontWeight fi) +++ + notRegular MediumWidth (fontWidth fi) +++ + notRegular NoSlant (fontSlant fi), + mkNameRecords 23 $ fontLightPalette fi, + mkNameRecords 24 $ fontDarkPalette fi] + postTbl = PostTable { + postVersion = PostTable2, + italicAngle = round $ (fontItalicAngle fi /// 0) + * 0x00010000, + underlinePosition = fontUnderlinePosition fi /// + (- fromIntegral (fontUnitsPerEm fi `quot` 8)), + underlineThickness = fontUnderlineThickness fi /// + fromIntegral (fontUnitsPerEm fi `quot` 10), + isFixedPitch = fromIntegral $ fromEnum $ + fontMonospaced fi /// False, + minMemType42 = 0, + maxMemType42 = 0, + minMemType1 = 0, + maxMemType1 = 0, + glyphNameIndex = [], + postStrings = []} + (panose1, panose2, panose3, panose4, panose5, + panose6, panose7, panose8, panose9, panose10) = + fontPanose fi /// (0, 0, 0, 0, 0, 0, 0, 0, 0, 0) + vendorID = case fontVendorID fi of + Nothing -> 0x20202020 + Just (a, b, c, d) -> fromIntegral $ + ord a `shift` 24 .|. ord b `shift` 16 .|. + ord c `shift` 8 .|. ord d + selectionFlags = makeFlag + [fontSlant fi == Italic, + Underscore `elem` fontDecoration fi, + Negative `elem` fontDecoration fi, + Outlined `elem` fontDecoration fi, + StrikeOut `elem` fontDecoration fi, + fontWeight fi > NormalWeight, + fontWeight fi == NormalWeight && + fontWidth fi == MediumWidth && + fontSlant fi == NoSlant && + null (fontSubFamilyExtra fi), + True, + null (fontSubFamilyExtra fi), + fontSlant fi == Oblique] + os2Tbl = OS2Table { + os2version = 5, + xAvgCharWidth = 0, + usWeightClass = weightClass $ fontWeight fi, + usWidthClass = widthClass $ fontWidth fi, + fsType = embeddedBits $ fontEmbeddingLicence fi, + ySubscriptXSize = (fst <$> fontSubScriptSize fi) /// + (fontUnitsPerEm fi `quot` 2), + ySubscriptYSize = (snd <$> fontSubScriptSize fi) /// + (fontUnitsPerEm fi `quot` 2), + ySubscriptXOffset = (fst <$> fontSubScriptOffset fi) /// 0, + ySubscriptYOffset = (snd <$> fontSubScriptOffset fi) /// + (- (fontUnitsPerEm fi `quot` 4)), + ySuperscriptXSize = (fst <$> fontSuperScriptSize fi) /// + (fontUnitsPerEm fi `quot` 2), + ySuperscriptYSize = (snd <$> fontSuperScriptSize fi) /// + (fontUnitsPerEm fi `quot` 2), + ySuperscriptXOffset = (fst <$> fontSuperScriptOffset fi) /// + round (realToFrac (ySubscriptYOffset os2Tbl) * + cos (pi/180*((fontItalicAngle fi /// 0) + pi/2))), + ySuperscriptYOffset = (snd <$> fontSuperScriptOffset fi) /// + ((fontUnitsPerEm fi - fontEmBase fi) `quot` 2), + yStrikeoutSize = fontStrikoutSize fi /// + fromIntegral (fontUnitsPerEm fi `quot` 20), + yStrikeoutPosition = fontStrikeoutPosition fi /// + fromIntegral (fontUnitsPerEm fi*10 `quot` 55), + bFamilyClass = fromIntegral $ + ((\(x,y) -> (x `shift` 8 .|. y)) <$> fontFamilyClass fi) + /// 0, + bFamilyType = fromIntegral panose1, + bSerifStyle = fromIntegral panose2, + bWeight = fromIntegral panose3, + bProportion = fromIntegral panose4, + bContrast = fromIntegral panose5, + bStrokeVariation = fromIntegral panose6, + bArmStyle = fromIntegral panose7, + bLetterform = fromIntegral panose8, + bMidline = fromIntegral panose9, + bXHeight = fromIntegral panose10, + ulUnicodeRange1 = (view _1 <$> fontUnicodeRanges fi) /// 3, + ulUnicodeRange2 = (view _2 <$> fontUnicodeRanges fi) /// 0, + ulUnicodeRange3 = (view _3 <$> fontUnicodeRanges fi) /// 0, + ulUnicodeRange4 = (view _4 <$> fontUnicodeRanges fi) /// 0, + achVendID = vendorID, + fsSelection = selectionFlags, + usFirstCharIndex = 0, + usLastCharIndex = 0, + sTypoAscender = fontUnitsPerEm fi - fontEmBase fi, + sTypoDescender = fromIntegral $ - fontEmBase fi, + sTypoLineGap = fontLineGap fi, + usWinAscent = 0, + usWinDescent = 0, + ulCodePageRange1 = (fst <$> fontCodepageRanges fi) /// 1, + ulCodePageRange2 = (snd <$> fontCodepageRanges fi) /// 0, + sxHeight = 0, + sCapHeight = fontCapHeight fi /// 0, + usDefaultChar = 0, + usBreakChar = 0, + usMaxContext = 1, + usLowerOpticalPointSize = fromIntegral $ + fontLowerOpticalPointSize fi /// 0, + usUpperOpticalPointSize = fromIntegral $ + fontUpperOpticalPointSize fi /// 0xffff} diff --git a/Opentype/Fileformat/Glyph.hs b/Opentype/Fileformat/Glyph.hs --- a/Opentype/Fileformat/Glyph.hs +++ b/Opentype/Fileformat/Glyph.hs @@ -1,23 +1,25 @@ -{-# LANGUAGE MultiWayIf, TupleSections #-} +{-# LANGUAGE MultiWayIf, TupleSections, DeriveTraversable #-} 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_) +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.Maybe (isJust) import Data.Bits import Data.Binary import Data.Binary.Put import Data.Binary.Get - +import Lens.Micro -- | This table contains the data that defines the appearance of -- the glyphs in the font. This includes specification of the points @@ -25,24 +27,57 @@ -- instructions that grid-fit that glyph. The glyf table supports the -- definition of simple glyphs and compound glyphs, that is, glyphs -- that are made up of other glyphs. -data GlyfTable = GlyfTable (V.Vector Glyph) +newtype GlyfTable = GlyfTable {glyphVector :: (V.Vector (Glyph Int))} deriving Show -data Glyph = Glyph { +type StandardGlyph = Glyph Int + +emptyGlyfTable :: GlyfTable +emptyGlyfTable = GlyfTable V.empty + +-- | The glyph type is parametrized over the type of glyph reference for compound glyphs. +data Glyph a = Glyph { + -- | The name of the glyph. This field isn't used when writing + -- truetype files. + glyphName :: String, advanceWidth :: Word16, leftSideBearing :: Int16, + -- | Bounding box: /will be overwritten/ glyphXmin :: FWord, + -- | Bounding box: /will be overwritten/ glyphYmin :: FWord, + -- | Bounding box: /will be overwritten/ glyphXmax :: FWord, + -- | Bounding box: /will be overwritten/ glyphYmax :: FWord, - glyphOutlines :: GlyphOutlines} - deriving Show + glyphOutlines :: GlyphOutlines a} + deriving (Show, Functor, Foldable, Traversable) -data GlyphOutlines = +data GlyphOutlines a = GlyphContours [[CurvePoint]] Instructions | - CompositeGlyph [GlyphComponent] - deriving Show + CompositeGlyph [GlyphComponent a] + deriving (Show, Functor, Foldable, Traversable) +-- | traversal over simple glyph contours +_glyphContours :: Traversal' StandardGlyph [[CurvePoint]] +_glyphContours f glyph = case glyphOutlines glyph of + GlyphContours pts instrs -> (\pts2 -> glyph {glyphOutlines = GlyphContours pts2 instrs}) + <$> f pts + _ -> pure glyph + +-- | instructions for simple glyphs +_glyphInstructions :: Traversal' StandardGlyph Instructions +_glyphInstructions f glyph = case glyphOutlines glyph of + GlyphContours pts instrs -> (\instrs2 -> glyph {glyphOutlines = GlyphContours pts instrs2}) + <$> f instrs + _ -> pure glyph + +-- | traversal over compound glyph components +_glyphComponents :: Traversal' StandardGlyph [GlyphComponent Int] +_glyphComponents f glyph = case glyphOutlines glyph of + CompositeGlyph comps -> (\c -> glyph {glyphOutlines = CompositeGlyph c}) <$> f comps + _ -> pure glyph + -- | @CurvePoint x y onCurve@: Points used to describe the outline -- using lines and quadratic beziers. Coordinates are absolute (not -- relative). If two off-curve points follow each other, an on-curve @@ -53,9 +88,9 @@ -- | TODO: make a proper datatype for instructions. type Instructions = V.Vector Word8 -data GlyphComponent = +data GlyphComponent a = GlyphComponent { - componentID :: Int, + componentID :: a, componentInstructions :: Maybe Instructions, -- | transformation matrix for scaling the glyph componentXX :: ShortFrac, @@ -75,7 +110,7 @@ -- offset is unscaled (microsoft and opentype default) in the -- rasterizer. componentY :: Int, - -- | see previous + -- | see previous matchPoints :: Bool, -- | For the xy values if `matchPoints` is `False`. roundXYtoGrid :: Bool, @@ -87,16 +122,20 @@ -- affect behaviors in some platforms, however. (See Apple’s -- specification for details regarding behavior in Apple platforms.) overlapCompound :: Bool, - -- | The component offset is scaled by the rasterizer (apple). Should be - -- set to `False` (opentype default), unless the font is meant to work - -- with old apple software. - scaledComponentOffset :: Bool + -- | If Just True, The component offset should be scaled by the + -- rasterizer. If the value is set to Nothing, it is platform + -- dependent (False for opentype). Set this value to "Just False" + -- for new fonts. + scaledComponentOffset :: Maybe Bool } - deriving Show + deriving (Show, Functor, Foldable, Traversable) -emptyGlyph :: Glyph -emptyGlyph = Glyph 0 0 0 0 0 0 (GlyphContours [] V.empty) +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 @@ -116,7 +155,7 @@ else (*2).fromIntegral <$> getWord16be readGlyphTable :: [(Int, Int)] -> [(Word16, Int16)] -> Strict.ByteString - -> Either String (V.Vector Glyph) + -> Either String (V.Vector StandardGlyph) readGlyphTable glyphSizes hmetrics glyfBs = V.fromList <$> zipWithM readGlyph glyphSizes hmetrics where @@ -129,10 +168,10 @@ Right (_, _, g) -> Right $ g {advanceWidth = aw, leftSideBearing = lsb} -- return bytestring lengths -writeGlyphs :: V.Vector Glyph -> PutM (V.Vector Int) -writeGlyphs = traverse writeGlyph +writeGlyphs :: Bool -> V.Vector StandardGlyph -> PutM (V.Vector Int) +writeGlyphs scale vec = traverse (writeGlyph . updateBB scale vec) vec -writeGlyph :: Glyph -> PutM Int +writeGlyph :: StandardGlyph -> PutM Int writeGlyph g = do putLazyByteString bs replicateM_ pad (putWord8 0) @@ -153,7 +192,7 @@ where offsets = V.scanl (+) 0 vec -writeHmtx :: V.Vector Glyph -> PutM Int +writeHmtx :: V.Vector StandardGlyph -> PutM Int writeHmtx gs | V.null gs = return 0 | otherwise = @@ -173,8 +212,8 @@ tl = findTail (len-2) 0 (dbl, sngl) = V.splitAt (len-tl) gs -putGlyph :: Glyph -> Put -putGlyph (Glyph _ _ xmin ymin xmax ymax outlines) = do +putGlyph :: StandardGlyph -> Put +putGlyph (Glyph _ _ _ xmin ymin xmax ymax outlines) = do putInt16be $ case outlines of GlyphContours pts _ -> fromIntegral $ length pts _ -> -1 @@ -189,7 +228,7 @@ traverse_ (putComponent True) (init comps) putComponent False $ last comps -getGlyph :: Get Glyph +getGlyph :: Get StandardGlyph getGlyph = do n <- getInt16be xmin <- getInt16be @@ -203,7 +242,7 @@ (c, more) <- getComponent if more then (c:) <$> nextComponent else return [c] - return $ Glyph 0 0 xmin ymin xmax ymax outlines + return $ Glyph "" 0 0 xmin ymin xmax ymax outlines isShort :: FWord -> Bool isShort n = abs n <= 255 @@ -261,7 +300,7 @@ allPts = case concat points of [] -> [] pts@(p: pts2) -> p: zipWith subCoord pts2 pts - subCoord (CurvePoint x1 y1 _) (CurvePoint x2 y2 on) = + subCoord (CurvePoint x2 y2 on) (CurvePoint x1 y1 _) = CurvePoint (x2-x1) (y2-y1) on flags = case allPts of [] -> [] @@ -312,10 +351,9 @@ (c, r) = splitAt n l toOffsets :: (Num a) => [a] -> [a] -toOffsets [] = [] -toOffsets (x:xs) = scanl (-) x xs +toOffsets = tail . scanl (+) 0 -getContour :: Int -> Get GlyphOutlines +getContour :: Int -> Get (GlyphOutlines Int) getContour 0 = return $ GlyphContours [] V.empty getContour nContours = do lastPts <- replicateM nContours (fromIntegral <$> getWord16be) @@ -332,14 +370,113 @@ isShortInt :: Int -> Bool isShortInt x = x <= 127 && x >= -128 -glyphExtent, glyphRsb :: Glyph -> Int16 +glyphExtent, glyphRsb :: StandardGlyph -> Int16 glyphRsb g = fromIntegral (advanceWidth g) - glyphExtent g glyphExtent glyf = leftSideBearing glyf + (glyphXmax glyf - glyphXmin glyf) -updateHhea :: V.Vector Glyph -> HheaTable -> HheaTable -updateHhea v h = V.foldl updateHhea1 +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 (n-1) l + +onCurve :: CurvePoint -> Bool +onCurve (CurvePoint _ _ on) = on + +-- get scaled on-curve points +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' (d-1) 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 $ x1-x2, realToFrac $ y1-y2) + 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, @@ -347,22 +484,21 @@ v -updateMinMax :: (FWord, FWord, FWord, FWord) - -> Glyph -> (FWord, FWord, FWord, FWord) -updateMinMax (xmin, ymin, xmax, ymax) g = +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)) - -updateHead :: V.Vector Glyph -> HeadTable -> HeadTable -updateHead vec headTbl = - headTbl {xMin = xmin, yMin = ymin, - xMax = xmax, yMax = ymax} - where (xmin, ymin, xmax, ymax) = - V.foldl updateMinMax (maxBound, maxBound, minBound, minBound) vec + max ymax (glyphYmax g), + totWidth + realToFrac (glyphXmax g - glyphXmin g)) -updateHhea1 :: HheaTable -> Glyph -> HheaTable +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), @@ -372,8 +508,8 @@ (glyphRsb g), xMaxExtent = max (xMaxExtent hhea) (glyphExtent g)} -updateMaxp :: V.Vector Glyph -> MaxpTable -> MaxpTable -updateMaxp vec tbl = V.foldl (updateMaxp1 vec) +updateMaxp :: V.Vector StandardGlyph -> MaxpTable -> MaxpTable +updateMaxp vec tbl = V.foldl' (updateMaxp1 vec) (tbl {numGlyphs = 0, maxPoints = 0, maxContours = 0, @@ -383,7 +519,7 @@ maxComponentDepth = 0}) vec -updateMaxp1 :: V.Vector Glyph -> MaxpTable -> Glyph -> MaxpTable +updateMaxp1 :: V.Vector StandardGlyph -> MaxpTable -> StandardGlyph -> MaxpTable updateMaxp1 vec maxp glyf = maxp {numGlyphs = numGlyphs maxp + 1, maxPoints = max (maxPoints maxp) $ @@ -400,7 +536,7 @@ componentDepth vec glyf} overComponents :: ([[CurvePoint]] -> Word16) -> ([Word16] -> Word16) - -> Int -> Bool -> V.Vector Glyph -> Glyph -> Word16 + -> Int -> Bool -> V.Vector StandardGlyph -> StandardGlyph -> Word16 overComponents f h maxD d v g | maxD <= 0 = 0 | otherwise = @@ -414,10 +550,10 @@ Nothing -> 0 Just g2 -> overComponents f h (maxD-1) False v g2 -glyfPoints, glyfContours, componentRefs, componentDepth, componentPoints, componentContours :: V.Vector Glyph -> Glyph -> Word16 +glyfPoints, glyfContours, componentRefs, componentDepth, componentPoints, componentContours :: V.Vector StandardGlyph -> StandardGlyph -> Word16 glyfPoints = - overComponents (sum . map (fromIntegral.length)) (const 0) 2 False + overComponents (sum' . map (fromIntegral.length)) (const 0) 2 False glyfContours = overComponents (fromIntegral.length) (const 0) 2 False @@ -426,15 +562,15 @@ overComponents (const 0) (fromIntegral.length) 2 True componentPoints = - overComponents (sum . map (fromIntegral . length)) sum 10 True + overComponents (sum' . map (fromIntegral . length)) sum' 10 True componentDepth = overComponents (const 0) ((+1).maximum) 10 True componentContours = - overComponents (fromIntegral.length) sum 10 True + overComponents (fromIntegral.length) sum' 10 True -putComponent :: Bool -> GlyphComponent -> Put +putComponent :: Bool -> GlyphComponent Int -> Put putComponent more c = do putWord16be flag putWord16be $ fromIntegral $ componentID c @@ -466,8 +602,8 @@ if matchPoints c then componentX c > 0xff || componentY c > 0xff - else (not $ isShortInt $ componentX c) || - (not $ isShortInt $ componentY c), + else not (isShortInt $ componentX c) || + not (isShortInt $ componentY c), not $ matchPoints c, roundXYtoGrid c, componentXX c /= 1 && @@ -481,10 +617,10 @@ isJust (componentInstructions c), useMyMetrics c, overlapCompound c, - scaledComponentOffset c, - not $ scaledComponentOffset c] + fromMaybe False (scaledComponentOffset c), + not $ fromMaybe True (scaledComponentOffset c)] -getComponent :: Get (GlyphComponent, Bool) +getComponent :: Get (GlyphComponent Int, Bool) getComponent = do flag <- getWord16be gID <- getWord16be @@ -529,6 +665,9 @@ return ( GlyphComponent (fromIntegral gID) instructions tXX tXY tYX tYY cX cY (not $ byteAt flag 1) (byteAt flag 2) - (byteAt flag 9) (byteAt flag 10) (byteAt flag 11), + (byteAt flag 9) (byteAt flag 10) + (if | (byteAt flag 11) -> Just True + | (byteAt flag 12) -> Just False + | otherwise -> Nothing), byteAt flag 5) -- more components diff --git a/Opentype/Fileformat/Head.hs b/Opentype/Fileformat/Head.hs --- a/Opentype/Fileformat/Head.hs +++ b/Opentype/Fileformat/Head.hs @@ -15,7 +15,7 @@ -- most likely to be written and other information about the placement -- of glyphs in the em square. data HeadTable = HeadTable { - -- | 0x00010000 for version 1.0. /Will be auto written./ + -- | 0x00010000 for version 1.0. /Will be overwritten./ headVersion :: Fixed, -- | set by font manufacturer. fontRevision :: Fixed, @@ -77,13 +77,13 @@ -- bit 15 zero unitsPerEm :: Word16, created :: UTCTime, modified :: UTCTime, - -- | /Will be auto written./ + -- | /Will be overwritten./ xMin :: FWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ yMin :: FWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ xMax :: FWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ yMax :: FWord, -- macStyle @@ -98,9 +98,9 @@ lowerRecPPEM :: Word16, -- | deprecated, will be set to 2 fontDirectionHint :: Int16, - -- | 0 for short offsets, 1 for long. /Will be auto written./ + -- | 0 for short offsets, 1 for long. /Will be overwritten./ longLocIndices :: Bool, - -- | 0 for current format. /Will be auto written./ + -- | 0 for current format. /Will be overwritten./ glyphDataFormat :: Int16 } deriving Show diff --git a/Opentype/Fileformat/Hhea.hs b/Opentype/Fileformat/Hhea.hs --- a/Opentype/Fileformat/Hhea.hs +++ b/Opentype/Fileformat/Hhea.hs @@ -9,21 +9,21 @@ -- | This table contains information for horizontal layout. data HheaTable = HheaTable { - -- | 0x00010000 (1.0), will be auto written. + -- | 0x00010000 (1.0), will be overwritten. version :: Fixed, - -- | Distance from baseline of highest ascender + -- | Distance from baseline of highest ascender. /Will be overwritten./ ascent :: FWord, - -- | Distance from baseline of lowest descender + -- | Distance from baseline of lowest descender. /Will be overwritten./ descent :: FWord, - -- | typographic line gap + -- | typographic line gap. Will be overwritten when OS/2 table is present. lineGap :: FWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ advanceWidthMax :: UFWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ minLeftSideBearing :: FWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ minRightSideBearing :: FWord, - -- | /Will be auto written./ + -- | /Will be overwritten./ xMaxExtent :: FWord, -- | used to calculate the slope of the caret (rise/run) set to 1 for vertical caret caretSlopeRise :: Int16, @@ -31,7 +31,7 @@ caretSlopeRun :: Int16, -- | set value to 0 for non-slanted fonts caretOffset :: FWord, - -- | number of advance widths in metrics table. /Will be auto written./ + -- | number of advance widths in metrics table. /Will be overwritten./ numOfLongHorMetrics :: Word16} deriving Show diff --git a/Opentype/Fileformat/Kern.hs b/Opentype/Fileformat/Kern.hs --- a/Opentype/Fileformat/Kern.hs +++ b/Opentype/Fileformat/Kern.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} module Opentype.Fileformat.Kern where import Opentype.Fileformat.Types @@ -7,6 +8,7 @@ import Data.Bits import Control.Monad import Data.Foldable +import Lens.Micro.TH -- | @KernPair left right adjustment@: Pair of kerning values. left -- and right are indices in the glyph table. @@ -14,11 +16,13 @@ deriving Show data KernTable = KernTable { - -- | various flags + -- | various flags, will be overwritten with 1 (default) coverage :: Word8, kernPairs :: [KernPair]} deriving Show +makeLensesFor [("kernPairs", "_kernPairs")] ''KernTable + getKernTable :: Get KernTable getKernTable = do version <- getWord16be @@ -40,12 +44,12 @@ KernPair <$> getWord16be <*> getWord16be <*> getInt16be putKernTable :: KernTable -> Put -putKernTable (KernTable cov pairs) = do +putKernTable (KernTable _ pairs) = do putWord16be 0 putWord16be 1 putWord16be 0 putWord16be $ fromIntegral $ 14+6 * length pairs - putWord16be $ fromIntegral cov + putWord16be $ fromIntegral 1 putWord16be $ fromIntegral len putWord16be searchRange putWord16be entrySelector diff --git a/Opentype/Fileformat/Maxp.hs b/Opentype/Fileformat/Maxp.hs --- a/Opentype/Fileformat/Maxp.hs +++ b/Opentype/Fileformat/Maxp.hs @@ -43,6 +43,9 @@ maxComponentDepth :: Word16} deriving Show +emptyMaxpTable :: MaxpTable +emptyMaxpTable = MaxpTable 0x00010000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + putMaxpTable :: MaxpTable -> Put putMaxpTable maxp = do putWord32be $ maxpVersion maxp diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -1,12 +1,15 @@ module Opentype.Fileformat.Name where import Opentype.Fileformat.Types -import Data.List (sort) +import Data.List (sort, foldl') +import Data.Maybe (fromMaybe) import Data.Word import Control.Monad import Data.Binary.Put +import Data.Tuple (swap) import Data.Foldable (for_, traverse_) import Data.Traversable (for) +import qualified Data.HashMap.Strict as HM import qualified Data.ByteString as Strict -- | This table allows multilingual strings to be associated with the @@ -33,7 +36,7 @@ -- encodingID. This library doesn't do any conversion. For more -- information see the opentype specification: -- https://www.microsoft.com/typography/otspec/name.htm -data NameTable = NameTable [NameRecord] +data NameTable = NameTable {nameRecords :: [NameRecord]} deriving Show data NameRecord = NameRecord { @@ -59,18 +62,25 @@ putWord16be 0 putWord16be $ fromIntegral len putWord16be $ fromIntegral $ len * 12 + 6 - for_ (zip offsets records) $ \(offset, r) -> do + for_ records $ \r -> do putPf $ namePlatform r putWord16be $ nameEncoding r putWord16be $ nameLanguage r putWord16be $ nameID r putWord16be $ fromIntegral $ Strict.length $ nameString r - putWord16be offset - traverse_ (putByteString.nameString) records + putWord16be $ fromMaybe 0 $ fromIntegral <$> + HM.lookup (nameString r) offsets + traverse_ putByteString $ reverse noDups where len = length records records = sort records_ - lengths = map (fromIntegral . Strict.length . nameString) records - offsets = scanl (+) 0 lengths + (noDups, offsets) = snd $ foldl' + (\(offset, (noDups, mp)) r -> + if HM.member (nameString r) mp + then (offset, (noDups, mp)) + else (Strict.length (nameString r) + offset, + (nameString r:noDups, HM.insert (nameString r) offset mp))) + (0, ([], HM.empty)) records + readNameTable :: Strict.ByteString -> Either String NameTable readNameTable bs = do diff --git a/Opentype/Fileformat/Post.hs b/Opentype/Fileformat/Post.hs --- a/Opentype/Fileformat/Post.hs +++ b/Opentype/Fileformat/Post.hs @@ -35,8 +35,6 @@ -- vertical. Zero for upright text, negative for text that leans to -- the right (forward). italicAngle :: Fixed, - -- | suggested values for the underline thickness. - underlinePosition :: FWord, -- | This is the suggested distance of the top of the underline from -- the baseline (negative values indicate below baseline). -- @@ -45,6 +43,8 @@ -- historical reasons. The value of the PostScript key may be -- calculated by subtracting half the underlineThickness from the -- value of this field. + underlinePosition :: FWord, + -- | suggested values for the underline thickness. underlineThickness :: FWord, -- | Set to 0 if the font is proportionally spaced, non-zero if the -- font is not proportionally spaced (i.e. monospaced). diff --git a/Opentype/Fileformat/Unicode.hs b/Opentype/Fileformat/Unicode.hs new file mode 100644 --- /dev/null +++ b/Opentype/Fileformat/Unicode.hs @@ -0,0 +1,111 @@ +-- | Utilities for making it easier to create Tables from Unicode +-- data. +module Opentype.Fileformat.Unicode + (-- * Unicode tables + UnicodeGlyphMap, UnicodeKernPairs, makeUnicodeTables, + -- * Postscript Names + module Opentype.Fileformat.Unicode.PostNames, + ) + +where +import Opentype.Fileformat.Unicode.PostNames +import Opentype.Fileformat +import Opentype.Fileformat.FontInfo +import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import qualified Data.Vector as V +import qualified Data.Map as M +import Data.IntSet as IS (empty) +import Data.List (sortBy) +import Data.Either +import Control.Applicative ((<|>)) +import qualified Data.HashMap.Strict as HM +import Data.Function + +-- | A map from glyphnames to glyphs. Unicode points are derived +-- using `nameToCodepoint`. Names without matching codepoint can only +-- be used in composite glyphs. If the `glyphName` has no matching +-- key in the map, it will be substituted by the empty glyph +type UnicodeGlyphMap = HM.HashMap String (Glyph String) +type UnicodeKernPairs = [(String, String, FWord)] + +-- | Create an opentype font from a `UnicodeGlyphMap` and `FontInfo` +-- structure. +makeUnicodeFont :: UnicodeGlyphMap -> UnicodeKernPairs -> FontInfo -> OpentypeFont +makeUnicodeFont uniGlyphs kernPrs info = + OpentypeFont False headTbl hheaTbl cmapTbl + nameTbl postTbl (Just os2Tbl) (if null (kernPairs kernTbl) then Nothing else Just kernTbl) + (QuadTables emptyMaxpTable glyfTbl) M.empty + where + (headTbl, hheaTbl, nameTbl, postTbl', os2Tbl) = + infoToTables info + (cmapTbl, glyfTbl, postTbl, kernTbl) = + makeUnicodeTables uniGlyphs kernPrs postTbl' + + +-- | Given a `UnicodeGlyphMap`, create a `CmapTable`, `GlyfTable` and +-- `KernTable` and update the `PostTable`. +makeUnicodeTables :: UnicodeGlyphMap -> UnicodeKernPairs -> PostTable -> (CmapTable, GlyfTable, PostTable, KernTable) +makeUnicodeTables uniGlyphs kernPrs postTbl = + (cmapTbl, GlyfTable glyphVector, + postTbl {postVersion = PostTable2, + glyphNameIndex = postscriptNameIndex, + postStrings = postscriptExtraNames}, + KernTable 1 realKernPairs) + where + uniqueCodepoints, codepoints :: [(String, (Int, Glyph String))] + glyphComps :: [(String, Glyph String)] + uniqueCodepoints = + filter (\(s, (_, g)) -> glyphName g == s) + codepoints + (codepoints, glyphComps) = + partitionEithers $ map getCodePoint $ + HM.toList uniGlyphs + nameMap :: HM.HashMap String GlyphID + nameMap = + HM.fromList $ flip zip [1..] $ + map fst (sortBy (compare `on` (fst.snd)) uniqueCodepoints) + ++ map fst glyphComps + postscriptNameMap :: HM.HashMap String Int + postscriptNameMap = + HM.fromList $ zip postscriptExtraNames [258..] + postscriptExtraNames :: [String] + postscriptExtraNames = + filter (isNothing . postscriptIndex) $ + map fst uniqueCodepoints + postscriptNameIndex :: [Int] + postscriptNameIndex = + flip map uniqueCodepoints $ \(n, _) -> + fromMaybe 0 $ + HM.lookup n postscriptNameMap + <|> postscriptIndex n + glyphVector :: V.Vector StandardGlyph + glyphVector = + V.fromList $ + map (normalizeGlyph.snd.snd) uniqueCodepoints ++ + map (normalizeGlyph.snd) glyphComps + codepointMap :: WordMap GlyphID + codepointMap = + M.fromList $ + flip map codepoints $ \(_, (code, g)) -> + (fromIntegral code, + fromMaybe 0 $ HM.lookup (glyphName g) nameMap) + normalizeGlyph :: Glyph String -> StandardGlyph + normalizeGlyph = + fmap (fromIntegral . fromMaybe 0 . (`HM.lookup` nameMap)) + getCodePoint (name, g) = + case nameToCodepoint name of + Nothing -> Right (name, g) + Just cp -> Left (name, (cp, g)) + cmapTbl = CmapTable $ bmpCmap : fullCmap + bmpCmap = CMap MicrosoftPlatform 1 0 MapFormat4 IS.empty codepointMap + fullCmap + | M.null codepointMap || + fst (M.findMax codepointMap) <= 0xffff = [] + | otherwise = + [CMap MicrosoftPlatform 10 0 + MapFormat12 IS.empty codepointMap] + realKernPairs = flip mapMaybe kernPrs $ \(s1, s2, x) -> do + c1 <- HM.lookup s1 nameMap + c2 <- HM.lookup s2 nameMap + return $ KernPair c1 c2 x + diff --git a/Opentype/Fileformat/Unicode/PostNames.hs b/Opentype/Fileformat/Unicode/PostNames.hs new file mode 100644 --- /dev/null +++ b/Opentype/Fileformat/Unicode/PostNames.hs @@ -0,0 +1,919 @@ +module Opentype.Fileformat.Unicode.PostNames + (CodePoint, codepointName, hasDescriptiveName, nameToCodepoint, + postscriptIndex, postscriptName, postscriptNames) +where +import qualified Data.Map.Strict as M +import qualified Data.HashMap.Strict as HM +import Text.Printf +import qualified Data.Set as S +import Opentype.Fileformat +import Data.Tuple (swap) +import Data.Word +import qualified Data.Vector as V +import Data.Char +import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) + +type CodePoint = Int + +-- | Standard name for this codepoint. Will be a descriptive name if +-- one is available, otherwise uni. +codepointName :: CodePoint -> String +codepointName cp = + case M.lookup cp codeMap of + Just n -> n + Nothing + | cp > 0xffff -> printf "u%06x" cp + | otherwise -> printf "uni%04x" cp + +hasDescriptiveName :: CodePoint -> Bool +hasDescriptiveName cp = M.member cp codeMap + +nameToCodepoint :: String -> Maybe CodePoint +nameToCodepoint name + | prefix == "uni" && + nDigits == 4 = + Just $ foldl (\t d -> t*16 + fromIntegral (digitToInt d)) + 0 hexNum + | prefix == "u" && + nDigits >= 4 && + nDigits <= 6 = + Just $ foldl (\t d -> t*16 + fromIntegral (digitToInt d)) + 0 hexNum + | otherwise = HM.lookup prefix nameMap + where + (prefix, r) = span isAlpha name + hexNum = takeWhile isHexDigit r + nDigits = length hexNum + +nameMap :: HM.HashMap String CodePoint +nameMap = HM.fromList $ map swap aglfn + +codeMap :: M.Map CodePoint String +codeMap = M.fromList aglfn + +-- | index of the string in the list of standard postscript names, if any. +postscriptIndex :: String -> Maybe Int +postscriptIndex n = HM.lookup n postscriptIndexMap + +-- | standard postscript name at index, if any. +postscriptName :: Int -> Maybe String +postscriptName i + | i < 0 || i >= V.length postscriptNames = Nothing + | otherwise = Just $ postscriptNames V.! i + +postscriptIndexMap :: HM.HashMap String Int +postscriptIndexMap = + HM.fromList $ + zip (V.toList postscriptNames) [1..] + +aglfn :: [(CodePoint, String)] +aglfn = [(0x0041,"A"), + (0x00C6,"AE"), + (0x01FC,"AEacute"), + (0x00C1,"Aacute"), + (0x0102,"Abreve"), + (0x00C2,"Acircumflex"), + (0x00C4,"Adieresis"), + (0x00C0,"Agrave"), + (0x0391,"Alpha"), + (0x0386,"Alphatonos"), + (0x0100,"Amacron"), + (0x0104,"Aogonek"), + (0x00C5,"Aring"), + (0x01FA,"Aringacute"), + (0x00C3,"Atilde"), + (0x0042,"B"), + (0x0392,"Beta"), + (0x0043,"C"), + (0x0106,"Cacute"), + (0x010C,"Ccaron"), + (0x00C7,"Ccedilla"), + (0x0108,"Ccircumflex"), + (0x010A,"Cdotaccent"), + (0x03A7,"Chi"), + (0x0044,"D"), + (0x010E,"Dcaron"), + (0x0110,"Dcroat"), + (0x2206,"Delta"), + (0x0045,"E"), + (0x00C9,"Eacute"), + (0x0114,"Ebreve"), + (0x011A,"Ecaron"), + (0x00CA,"Ecircumflex"), + (0x00CB,"Edieresis"), + (0x0116,"Edotaccent"), + (0x00C8,"Egrave"), + (0x0112,"Emacron"), + (0x014A,"Eng"), + (0x0118,"Eogonek"), + (0x0395,"Epsilon"), + (0x0388,"Epsilontonos"), + (0x0397,"Eta"), + (0x0389,"Etatonos"), + (0x00D0,"Eth"), + (0x20AC,"Euro"), + (0x0046,"F"), + (0x0047,"G"), + (0x0393,"Gamma"), + (0x011E,"Gbreve"), + (0x01E6,"Gcaron"), + (0x011C,"Gcircumflex"), + (0x0120,"Gdotaccent"), + (0x0048,"H"), + (0x25CF,"H18533"), + (0x25AA,"H18543"), + (0x25AB,"H18551"), + (0x25A1,"H22073"), + (0x0126,"Hbar"), + (0x0124,"Hcircumflex"), + (0x0049,"I"), + (0x0132,"IJ"), + (0x00CD,"Iacute"), + (0x012C,"Ibreve"), + (0x00CE,"Icircumflex"), + (0x00CF,"Idieresis"), + (0x0130,"Idotaccent"), + (0x2111,"Ifraktur"), + (0x00CC,"Igrave"), + (0x012A,"Imacron"), + (0x012E,"Iogonek"), + (0x0399,"Iota"), + (0x03AA,"Iotadieresis"), + (0x038A,"Iotatonos"), + (0x0128,"Itilde"), + (0x004A,"J"), + (0x0134,"Jcircumflex"), + (0x004B,"K"), + (0x039A,"Kappa"), + (0x004C,"L"), + (0x0139,"Lacute"), + (0x039B,"Lambda"), + (0x013D,"Lcaron"), + (0x013F,"Ldot"), + (0x0141,"Lslash"), + (0x004D,"M"), + (0x039C,"Mu"), + (0x004E,"N"), + (0x0143,"Nacute"), + (0x0147,"Ncaron"), + (0x00D1,"Ntilde"), + (0x039D,"Nu"), + (0x004F,"O"), + (0x0152,"OE"), + (0x00D3,"Oacute"), + (0x014E,"Obreve"), + (0x00D4,"Ocircumflex"), + (0x00D6,"Odieresis"), + (0x00D2,"Ograve"), + (0x01A0,"Ohorn"), + (0x0150,"Ohungarumlaut"), + (0x014C,"Omacron"), + (0x2126,"Omega"), + (0x038F,"Omegatonos"), + (0x039F,"Omicron"), + (0x038C,"Omicrontonos"), + (0x00D8,"Oslash"), + (0x01FE,"Oslashacute"), + (0x00D5,"Otilde"), + (0x0050,"P"), + (0x03A6,"Phi"), + (0x03A0,"Pi"), + (0x03A8,"Psi"), + (0x0051,"Q"), + (0x0052,"R"), + (0x0154,"Racute"), + (0x0158,"Rcaron"), + (0x211C,"Rfraktur"), + (0x03A1,"Rho"), + (0x0053,"S"), + (0x250C,"SF010000"), + (0x2514,"SF020000"), + (0x2510,"SF030000"), + (0x2518,"SF040000"), + (0x253C,"SF050000"), + (0x252C,"SF060000"), + (0x2534,"SF070000"), + (0x251C,"SF080000"), + (0x2524,"SF090000"), + (0x2500,"SF100000"), + (0x2502,"SF110000"), + (0x2561,"SF190000"), + (0x2562,"SF200000"), + (0x2556,"SF210000"), + (0x2555,"SF220000"), + (0x2563,"SF230000"), + (0x2551,"SF240000"), + (0x2557,"SF250000"), + (0x255D,"SF260000"), + (0x255C,"SF270000"), + (0x255B,"SF280000"), + (0x255E,"SF360000"), + (0x255F,"SF370000"), + (0x255A,"SF380000"), + (0x2554,"SF390000"), + (0x2569,"SF400000"), + (0x2566,"SF410000"), + (0x2560,"SF420000"), + (0x2550,"SF430000"), + (0x256C,"SF440000"), + (0x2567,"SF450000"), + (0x2568,"SF460000"), + (0x2564,"SF470000"), + (0x2565,"SF480000"), + (0x2559,"SF490000"), + (0x2558,"SF500000"), + (0x2552,"SF510000"), + (0x2553,"SF520000"), + (0x256B,"SF530000"), + (0x256A,"SF540000"), + (0x015A,"Sacute"), + (0x0160,"Scaron"), + (0x015E,"Scedilla"), + (0x015C,"Scircumflex"), + (0x03A3,"Sigma"), + (0x0054,"T"), + (0x03A4,"Tau"), + (0x0166,"Tbar"), + (0x0164,"Tcaron"), + (0x0398,"Theta"), + (0x00DE,"Thorn"), + (0x0055,"U"), + (0x00DA,"Uacute"), + (0x016C,"Ubreve"), + (0x00DB,"Ucircumflex"), + (0x00DC,"Udieresis"), + (0x00D9,"Ugrave"), + (0x01AF,"Uhorn"), + (0x0170,"Uhungarumlaut"), + (0x016A,"Umacron"), + (0x0172,"Uogonek"), + (0x03A5,"Upsilon"), + (0x03D2,"Upsilon1"), + (0x03AB,"Upsilondieresis"), + (0x038E,"Upsilontonos"), + (0x016E,"Uring"), + (0x0168,"Utilde"), + (0x0056,"V"), + (0x0057,"W"), + (0x1E82,"Wacute"), + (0x0174,"Wcircumflex"), + (0x1E84,"Wdieresis"), + (0x1E80,"Wgrave"), + (0x0058,"X"), + (0x039E,"Xi"), + (0x0059,"Y"), + (0x00DD,"Yacute"), + (0x0176,"Ycircumflex"), + (0x0178,"Ydieresis"), + (0x1EF2,"Ygrave"), + (0x005A,"Z"), + (0x0179,"Zacute"), + (0x017D,"Zcaron"), + (0x017B,"Zdotaccent"), + (0x0396,"Zeta"), + (0x0061,"a"), + (0x00E1,"aacute"), + (0x0103,"abreve"), + (0x00E2,"acircumflex"), + (0x00B4,"acute"), + (0x0301,"acutecomb"), + (0x00E4,"adieresis"), + (0x00E6,"ae"), + (0x01FD,"aeacute"), + (0x00E0,"agrave"), + (0x2135,"aleph"), + (0x03B1,"alpha"), + (0x03AC,"alphatonos"), + (0x0101,"amacron"), + (0x0026,"ampersand"), + (0x2220,"angle"), + (0x2329,"angleleft"), + (0x232A,"angleright"), + (0x0387,"anoteleia"), + (0x0105,"aogonek"), + (0x2248,"approxequal"), + (0x00E5,"aring"), + (0x01FB,"aringacute"), + (0x2194,"arrowboth"), + (0x21D4,"arrowdblboth"), + (0x21D3,"arrowdbldown"), + (0x21D0,"arrowdblleft"), + (0x21D2,"arrowdblright"), + (0x21D1,"arrowdblup"), + (0x2193,"arrowdown"), + (0x2190,"arrowleft"), + (0x2192,"arrowright"), + (0x2191,"arrowup"), + (0x2195,"arrowupdn"), + (0x21A8,"arrowupdnbse"), + (0x005E,"asciicircum"), + (0x007E,"asciitilde"), + (0x002A,"asterisk"), + (0x2217,"asteriskmath"), + (0x0040,"at"), + (0x00E3,"atilde"), + (0x0062,"b"), + (0x005C,"backslash"), + (0x007C,"bar"), + (0x03B2,"beta"), + (0x2588,"block"), + (0x007B,"braceleft"), + (0x007D,"braceright"), + (0x005B,"bracketleft"), + (0x005D,"bracketright"), + (0x02D8,"breve"), + (0x00A6,"brokenbar"), + (0x2022,"bullet"), + (0x0063,"c"), + (0x0107,"cacute"), + (0x02C7,"caron"), + (0x21B5,"carriagereturn"), + (0x010D,"ccaron"), + (0x00E7,"ccedilla"), + (0x0109,"ccircumflex"), + (0x010B,"cdotaccent"), + (0x00B8,"cedilla"), + (0x00A2,"cent"), + (0x03C7,"chi"), + (0x25CB,"circle"), + (0x2297,"circlemultiply"), + (0x2295,"circleplus"), + (0x02C6,"circumflex"), + (0x2663,"club"), + (0x003A,"colon"), + (0x20A1,"colonmonetary"), + (0x002C,"comma"), + (0x2245,"congruent"), + (0x00A9,"copyright"), + (0x00A4,"currency"), + (0x0064,"d"), + (0x2020,"dagger"), + (0x2021,"daggerdbl"), + (0x010F,"dcaron"), + (0x0111,"dcroat"), + (0x00B0,"degree"), + (0x03B4,"delta"), + (0x2666,"diamond"), + (0x00A8,"dieresis"), + (0x0385,"dieresistonos"), + (0x00F7,"divide"), + (0x2593,"dkshade"), + (0x2584,"dnblock"), + (0x0024,"dollar"), + (0x20AB,"dong"), + (0x02D9,"dotaccent"), + (0x0323,"dotbelowcomb"), + (0x0131,"dotlessi"), + (0x22C5,"dotmath"), + (0x0065,"e"), + (0x00E9,"eacute"), + (0x0115,"ebreve"), + (0x011B,"ecaron"), + (0x00EA,"ecircumflex"), + (0x00EB,"edieresis"), + (0x0117,"edotaccent"), + (0x00E8,"egrave"), + (0x0038,"eight"), + (0x2208,"element"), + (0x2026,"ellipsis"), + (0x0113,"emacron"), + (0x2014,"emdash"), + (0x2205,"emptyset"), + (0x2013,"endash"), + (0x014B,"eng"), + (0x0119,"eogonek"), + (0x03B5,"epsilon"), + (0x03AD,"epsilontonos"), + (0x003D,"equal"), + (0x2261,"equivalence"), + (0x212E,"estimated"), + (0x03B7,"eta"), + (0x03AE,"etatonos"), + (0x00F0,"eth"), + (0x0021,"exclam"), + (0x203C,"exclamdbl"), + (0x00A1,"exclamdown"), + (0x2203,"existential"), + (0x0066,"f"), + (0x2640,"female"), + (0x2012,"figuredash"), + (0x25A0,"filledbox"), + (0x25AC,"filledrect"), + (0x0035,"five"), + (0x215D,"fiveeighths"), + (0x0192,"florin"), + (0x0034,"four"), + (0x2044,"fraction"), + (0x20A3,"franc"), + (0x0067,"g"), + (0x03B3,"gamma"), + (0x011F,"gbreve"), + (0x01E7,"gcaron"), + (0x011D,"gcircumflex"), + (0x0121,"gdotaccent"), + (0x00DF,"germandbls"), + (0x2207,"gradient"), + (0x0060,"grave"), + (0x0300,"gravecomb"), + (0x003E,"greater"), + (0x2265,"greaterequal"), + (0x00AB,"guillemotleft"), + (0x00BB,"guillemotright"), + (0x2039,"guilsinglleft"), + (0x203A,"guilsinglright"), + (0x0068,"h"), + (0x0127,"hbar"), + (0x0125,"hcircumflex"), + (0x2665,"heart"), + (0x0309,"hookabovecomb"), + (0x2302,"house"), + (0x02DD,"hungarumlaut"), + (0x002D,"hyphen"), + (0x0069,"i"), + (0x00ED,"iacute"), + (0x012D,"ibreve"), + (0x00EE,"icircumflex"), + (0x00EF,"idieresis"), + (0x00EC,"igrave"), + (0x0133,"ij"), + (0x012B,"imacron"), + (0x221E,"infinity"), + (0x222B,"integral"), + (0x2321,"integralbt"), + (0x2320,"integraltp"), + (0x2229,"intersection"), + (0x25D8,"invbullet"), + (0x25D9,"invcircle"), + (0x263B,"invsmileface"), + (0x012F,"iogonek"), + (0x03B9,"iota"), + (0x03CA,"iotadieresis"), + (0x0390,"iotadieresistonos"), + (0x03AF,"iotatonos"), + (0x0129,"itilde"), + (0x006A,"j"), + (0x0135,"jcircumflex"), + (0x006B,"k"), + (0x03BA,"kappa"), + (0x0138,"kgreenlandic"), + (0x006C,"l"), + (0x013A,"lacute"), + (0x03BB,"lambda"), + (0x013E,"lcaron"), + (0x0140,"ldot"), + (0x003C,"less"), + (0x2264,"lessequal"), + (0x258C,"lfblock"), + (0x20A4,"lira"), + (0x2227,"logicaland"), + (0x00AC,"logicalnot"), + (0x2228,"logicalor"), + (0x017F,"longs"), + (0x25CA,"lozenge"), + (0x0142,"lslash"), + (0x2591,"ltshade"), + (0x006D,"m"), + (0x00AF,"macron"), + (0x2642,"male"), + (0x2212,"minus"), + (0x2032,"minute"), + (0x00B5,"mu"), + (0x00D7,"multiply"), + (0x266A,"musicalnote"), + (0x266B,"musicalnotedbl"), + (0x006E,"n"), + (0x0144,"nacute"), + (0x0149,"napostrophe"), + (0x0148,"ncaron"), + (0x0039,"nine"), + (0x2209,"notelement"), + (0x2260,"notequal"), + (0x2284,"notsubset"), + (0x00F1,"ntilde"), + (0x03BD,"nu"), + (0x0023,"numbersign"), + (0x006F,"o"), + (0x00F3,"oacute"), + (0x014F,"obreve"), + (0x00F4,"ocircumflex"), + (0x00F6,"odieresis"), + (0x0153,"oe"), + (0x02DB,"ogonek"), + (0x00F2,"ograve"), + (0x01A1,"ohorn"), + (0x0151,"ohungarumlaut"), + (0x014D,"omacron"), + (0x03C9,"omega"), + (0x03D6,"omega1"), + (0x03CE,"omegatonos"), + (0x03BF,"omicron"), + (0x03CC,"omicrontonos"), + (0x0031,"one"), + (0x2024,"onedotenleader"), + (0x215B,"oneeighth"), + (0x00BD,"onehalf"), + (0x00BC,"onequarter"), + (0x2153,"onethird"), + (0x25E6,"openbullet"), + (0x00AA,"ordfeminine"), + (0x00BA,"ordmasculine"), + (0x221F,"orthogonal"), + (0x00F8,"oslash"), + (0x01FF,"oslashacute"), + (0x00F5,"otilde"), + (0x0070,"p"), + (0x00B6,"paragraph"), + (0x0028,"parenleft"), + (0x0029,"parenright"), + (0x2202,"partialdiff"), + (0x0025,"percent"), + (0x002E,"period"), + (0x00B7,"periodcentered"), + (0x22A5,"perpendicular"), + (0x2030,"perthousand"), + (0x20A7,"peseta"), + (0x03C6,"phi"), + (0x03D5,"phi1"), + (0x03C0,"pi"), + (0x002B,"plus"), + (0x00B1,"plusminus"), + (0x211E,"prescription"), + (0x220F,"product"), + (0x2282,"propersubset"), + (0x2283,"propersuperset"), + (0x221D,"proportional"), + (0x03C8,"psi"), + (0x0071,"q"), + (0x003F,"question"), + (0x00BF,"questiondown"), + (0x0022,"quotedbl"), + (0x201E,"quotedblbase"), + (0x201C,"quotedblleft"), + (0x201D,"quotedblright"), + (0x2018,"quoteleft"), + (0x201B,"quotereversed"), + (0x2019,"quoteright"), + (0x201A,"quotesinglbase"), + (0x0027,"quotesingle"), + (0x0072,"r"), + (0x0155,"racute"), + (0x221A,"radical"), + (0x0159,"rcaron"), + (0x2286,"reflexsubset"), + (0x2287,"reflexsuperset"), + (0x00AE,"registered"), + (0x2310,"revlogicalnot"), + (0x03C1,"rho"), + (0x02DA,"ring"), + (0x2590,"rtblock"), + (0x0073,"s"), + (0x015B,"sacute"), + (0x0161,"scaron"), + (0x015F,"scedilla"), + (0x015D,"scircumflex"), + (0x2033,"second"), + (0x00A7,"section"), + (0x003B,"semicolon"), + (0x0037,"seven"), + (0x215E,"seveneighths"), + (0x2592,"shade"), + (0x03C3,"sigma"), + (0x03C2,"sigma1"), + (0x223C,"similar"), + (0x0036,"six"), + (0x002F,"slash"), + (0x263A,"smileface"), + (0x0020,"space"), + (0x2660,"spade"), + (0x00A3,"sterling"), + (0x220B,"suchthat"), + (0x2211,"summation"), + (0x263C,"sun"), + (0x0074,"t"), + (0x03C4,"tau"), + (0x0167,"tbar"), + (0x0165,"tcaron"), + (0x2234,"therefore"), + (0x03B8,"theta"), + (0x03D1,"theta1"), + (0x00FE,"thorn"), + (0x0033,"three"), + (0x215C,"threeeighths"), + (0x00BE,"threequarters"), + (0x02DC,"tilde"), + (0x0303,"tildecomb"), + (0x0384,"tonos"), + (0x2122,"trademark"), + (0x25BC,"triagdn"), + (0x25C4,"triaglf"), + (0x25BA,"triagrt"), + (0x25B2,"triagup"), + (0x0032,"two"), + (0x2025,"twodotenleader"), + (0x2154,"twothirds"), + (0x0075,"u"), + (0x00FA,"uacute"), + (0x016D,"ubreve"), + (0x00FB,"ucircumflex"), + (0x00FC,"udieresis"), + (0x00F9,"ugrave"), + (0x01B0,"uhorn"), + (0x0171,"uhungarumlaut"), + (0x016B,"umacron"), + (0x005F,"underscore"), + (0x2017,"underscoredbl"), + (0x222A,"union"), + (0x2200,"universal"), + (0x0173,"uogonek"), + (0x2580,"upblock"), + (0x03C5,"upsilon"), + (0x03CB,"upsilondieresis"), + (0x03B0,"upsilondieresistonos"), + (0x03CD,"upsilontonos"), + (0x016F,"uring"), + (0x0169,"utilde"), + (0x0076,"v"), + (0x0077,"w"), + (0x1E83,"wacute"), + (0x0175,"wcircumflex"), + (0x1E85,"wdieresis"), + (0x2118,"weierstrass"), + (0x1E81,"wgrave"), + (0x0078,"x"), + (0x03BE,"xi"), + (0x0079,"y"), + (0x00FD,"yacute"), + (0x0177,"ycircumflex"), + (0x00FF,"ydieresis"), + (0x00A5,"yen"), + (0x1EF3,"ygrave"), + (0x007A,"z"), + (0x017A,"zacute"), + (0x017E,"zcaron"), + (0x017C,"zdotaccent"), + (0x0030,"zero"), + (0x03B6,"zeta")] + +-- | vector of standard postscript names. +postscriptNames :: V.Vector String +postscriptNames = + V.fromList + [".notdef", + ".null", + "nonmarkingreturn", + "space", + "exclam", + "quotedbl", + "numbersign", + "dollar", + "percent", + "ampersand", + "quotesingle", + "parenleft", + "parenright", + "asterisk", + "plus", + "comma", + "hyphen", + "period", + "slash", + "zero", + "one", + "two", + "three", + "four", + "five", + "six", + "seven", + "eight", + "nine", + "colon", + "semicolon", + "less", + "equal", + "greater", + "question", + "at", + "A", + "B", + "C", + "D", + "E", + "F", + "G", + "H", + "I", + "J", + "K", + "L", + "M", + "N", + "O", + "P", + "Q", + "R", + "S", + "T", + "U", + "V", + "W", + "X", + "Y", + "Z", + "bracketleft", + "backslash", + "bracketright", + "asciicircum", + "underscore", + "grave", + "a", + "b", + "c", + "d", + "e", + "f", + "g", + "h", + "i", + "j", + "k", + "l", + "m", + "n", + "o", + "p", + "q", + "r", + "s", + "t", + "u", + "v", + "w", + "x", + "y", + "z", + "braceleft", + "bar", + "braceright", + "asciitilde", + "Adieresis", + "Aring", + "Ccedilla", + "Eacute", + "Ntilde", + "Odieresis", + "Udieresis", + "aacute", + "agrave", + "acircumflex", + "adieresis", + "atilde", + "aring", + "ccedilla", + "eacute", + "egrave", + "ecircumflex", + "edieresis", + "iacute", + "igrave", + "icircumflex", + "idieresis", + "ntilde", + "oacute", + "ograve", + "ocircumflex", + "odieresis", + "otilde", + "uacute", + "ugrave", + "ucircumflex", + "udieresis", + "dagger", + "degree", + "cent", + "sterling", + "section", + "bullet", + "paragraph", + "germandbls", + "registered", + "copyright", + "trademark", + "acute", + "dieresis", + "notequal", + "AE", + "Oslash", + "infinity", + "plusminus", + "lessequal", + "greaterequal", + "yen", + "mu", + "partialdiff", + "summation", + "product", + "pi", + "integral", + "ordfeminine", + "ordmasculine", + "Omega", + "ae", + "oslash", + "questiondown", + "exclamdown", + "logicalnot", + "radical", + "florin", + "approxequal", + "Delta", + "guillemotleft", + "guillemotright", + "ellipsis", + "nonbreakingspace", + "Agrave", + "Atilde", + "Otilde", + "OE", + "oe", + "endash", + "emdash", + "quotedblleft", + "quotedblright", + "quoteleft", + "quoteright", + "divide", + "lozenge", + "ydieresis", + "Ydieresis", + "fraction", + "currency", + "guilsinglleft", + "guilsinglright", + "fi", + "fl", + "daggerdbl", + "periodcentered", + "quotesinglbase", + "quotedblbase", + "perthousand", + "Acircumflex", + "Ecircumflex", + "Aacute", + "Edieresis", + "Egrave", + "Iacute", + "Icircumflex", + "Idieresis", + "Igrave", + "Oacute", + "Ocircumflex", + "apple", + "Ograve", + "Uacute", + "Ucircumflex", + "Ugrave", + "dotlessi", + "circumflex", + "tilde", + "macron", + "breve", + "dotaccent", + "ring", + "cedilla", + "hungarumlaut", + "ogonek", + "caron", + "Lslash", + "lslash", + "Scaron", + "scaron", + "Zcaron", + "zcaron", + "brokenbar", + "Eth", + "eth", + "Yacute", + "yacute", + "Thorn", + "thorn", + "minus", + "multiply", + "onesuperior", + "twosuperior", + "threesuperior", + "onehalf", + "onequarter", + "threequarters", + "franc", + "Gbreve", + "gbreve", + "Idotaccent", + "Scedilla", + "scedilla", + "Cacute", + "cacute", + "Ccaron", + "ccaron", + "dcroat"] diff --git a/opentype.cabal b/opentype.cabal --- a/opentype.cabal +++ b/opentype.cabal @@ -1,5 +1,5 @@ name: opentype -version: 0.0.1 +version: 0.1.0 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -20,10 +20,22 @@ library build-depends: - base >=3 && <5, binary >=0.8.1.0, - bytestring >0.10.0, containers >=0.5.3, ghc >=7.10.0, time >1.4.0, - vector >=0.10, pretty-hex >=1.0 - exposed-modules: Opentype.Fileformat + base >=3 && <5, + binary >=0.8.1.0, + bytestring >0.10.0, + containers >=0.5.3, + ghc >=7.10.0, + microlens > 0.4.0.0, + microlens-th > 0.4.0.0, + mtl >= 2.2.1, + pretty-hex >=1.0, + time >1.4.0, + unordered-containers >0.2.6.0, + vector >=0.10 + exposed-modules: + Opentype.Fileformat + Opentype.Fileformat.Unicode + Opentype.Fileformat.FontInfo exposed: True buildable: True other-modules: @@ -37,6 +49,7 @@ Opentype.Fileformat.Post Opentype.Fileformat.Kern Opentype.Fileformat.OS2 + Opentype.Fileformat.Unicode.PostNames ghc-options: -Wall test-suite test