HPDF-1.0: Test/AFMParser.hs
module Main where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Prim
import Text.ParserCombinators.Parsec.Char
import Data.Char(toUpper)
import System.Environment
import Data.Maybe(isJust,fromJust,mapMaybe)
import qualified Data.IntMap as IM
import Data.List(intersperse)
import qualified Data.Map as M
capitalize :: String -> String
capitalize [] = []
capitalize (h:t) = toUpper h : t
line :: Parser ()
line = do string "\r\n"
return ()
toEndOfLine :: Parser ()
toEndOfLine = do many (noneOf "\r\n")
line
return ()
getString :: String -> Parser String
getString s = do
string s
spaces
c <- many1 (alphaNum <|> oneOf "-+")
line
return c
getName :: String -> Parser String
getName s = do
string s
spaces
c <- alphaNum >> many (alphaNum <|> oneOf " -+")
line
return c
getInt :: String -> Parser Int
getInt s = do c <- getString s
return $ read c
getFloat :: String -> Parser Double
getFloat s = do string s
spaces
c <- many1 (alphaNum <|> oneOf ".-+")
line
return $ read c
getBool :: String -> Parser Bool
getBool s = do c <- getString s
return $ read (capitalize c)
data CharacterSet = ExtendedRoman
| Special
deriving(Eq,Read,Show)
data Weight = Medium
| Bold
| Roman
deriving(Eq,Read,Show)
getCharacterSet :: String -> Parser CharacterSet
getCharacterSet s = do c <- getString s
return $ read c
getWeigth :: String -> Parser Weight
getWeigth s = do c <- getString s
return $ read c
array :: Parser [String]
array = sepEndBy (many1 (oneOf "-+0123456789")) (many1 (oneOf " "))
getArray :: String -> Parser [Double]
getArray s = do string s
spaces
c <- array
line
return . map read $ c
comment :: String -> Parser ()
comment s = do string s
toEndOfLine
comments :: Parser ()
comments = do many1 (comment "Comment")
return ()
data EncodingScheme = AdobeStandardEncoding
| FontSpecific
deriving(Eq,Read,Show)
getEncoding :: String -> Parser EncodingScheme
getEncoding s = do c <- getString s
return $ read c
number :: Parser Int
number = do c <- many1 (oneOf "-+0123456789")
return $ read c
data Elem = C Int
| WX Int
| N String
| B [Double]
| L
deriving(Eq,Read,Show)
metricElem :: Parser Elem
metricElem = do char 'C'
spaces
c <- number
return $ C c
<|>
do string "WX"
spaces
c <- number
return $ WX c
<|>
do char 'N'
spaces
c <- many1 alphaNum
return $ N c
<|>
do char 'B'
spaces
c <- array
return . B . map read $ c
<|>
do char 'L'
spaces
many1 letter
spaces
many1 letter
return L
data Metric = Metric { charCode :: Int
, width :: Int
, name :: String
, bounds :: [Double]
}
deriving(Eq,Show)
data Font = Font { metrics :: [Metric]
, underlinePosition :: Int
, underlineThickness :: Int
, ascent :: Int
, descent :: Int
, kernData :: Maybe [KX]
}
deriving(Eq,Show)
isEncoded :: Metric -> Bool
isEncoded (Metric c _ _ _) = c /= (-1)
mkMetric :: [Elem] -> Metric
mkMetric l = foldr addElem (Metric (-1) 0 "" []) l
where
addElem (C c) m = m {charCode=c}
addElem (WX c) m = m {width=c}
addElem (N s) m = m {name=s}
addElem (B l) m = m {bounds=l}
addElem _ m = m
charMetric :: Parser Metric
charMetric = do
l <- sepEndBy metricElem (many1 (oneOf "; "))
line
return . mkMetric $ l
data KX = KX String String Int
deriving(Eq,Ord,Show)
kernPair :: Parser KX
kernPair = do string "KPX"
spaces
namea <- many1 letter
spaces
nameb <- many1 letter
spaces
nb <- many1 (oneOf "-+0123456789")
line
return $ KX namea nameb (read nb)
getKernData :: Parser (Maybe [KX])
getKernData = do
{ comment "StartKernData"
; nbKerns <- getInt "StartKernPairs"
; k <- many1 kernPair
; comment "EndKernPairs"
; comment "EndKernData"
; return $ Just k
}
afm :: Parser Font
afm = do { comment "StartFontMetrics"
; comments
; fontName <- getString "FontName"
; fullName <- getName "FullName"
; familyName <- getString "FamilyName"
; weight <- getWeigth "Weight"
; italicAngle <- getFloat "ItalicAngle"
; isFixedPitch <- getBool "IsFixedPitch"
; characterSet <- getCharacterSet "CharacterSet"
; bbox <- getArray "FontBBox"
; underlinePosition <- getInt "UnderlinePosition"
; underlineThickness <- getInt "UnderlineThickness"
; comment "Version"
; comment "Notice"
; encodingScheme <- getEncoding "EncodingScheme"
; capHeight <- option 0 $ getInt "CapHeight"
; xHeight <- option 0 $ getInt "XHeight"
; ascender <- option 0 $ getInt "Ascender"
; descender <- option 0 $ getInt "Descender"
; stdHW <- getInt "StdHW"
; stdVW <- getInt "StdVW"
; startCharMetrics <- getInt "StartCharMetrics"
; charMetrics <- many1 charMetric
; comment "EndCharMetrics"
; kerns <- option Nothing getKernData
; comment "EndFontMetrics"
; return $ Font (filter isEncoded charMetrics) underlinePosition underlineThickness ascender descender kerns
}
allFonts :: [String]
allFonts = [ "Helvetica.afm"
, "Helvetica-Bold.afm"
, "Helvetica-Oblique.afm"
, "Helvetica-BoldOblique.afm"
, "Times-Roman.afm"
, "Times-Bold.afm"
, "Times-Italic.afm"
, "Times-BoldItalic.afm"
, "Courier.afm"
, "Courier-Bold.afm"
, "Courier-Oblique.afm"
, "Courier-BoldOblique.afm"
, "Symbol.afm"
, "ZapfDingbats.afm"
]
createFontList :: Font -> [(Int,Int)]
createFontList (Font m up ut asc desc k) = zip codes (map getWidth [32..255])
where
codes = [32..255]
getWidth c = IM.findWithDefault spaceWidth c chars
spaceWidth = IM.findWithDefault 0 32 chars
chars = IM.fromList . map zipMetric $ m
zipMetric m@(Metric c w _ _) = (c,w)
parseFont :: String -> IO (Maybe Font)
parseFont s = do
r <- parseFromFile afm $ "../Core14_AFMs/" ++ s
case r of
Left e -> error (show e)
Right r -> return $ Just r
fontData :: Font -> [String]
fontData (Font _ up ut asc desc k) = [show up,show ut,show asc,show desc,maybe "0" (const "1") k]
kernForFont :: (Int,Font) -> M.Map (Int,Int,Int) Int
kernForFont (i,(Font m _ _ _ _ Nothing)) = M.empty
kernForFont (i,(Font m _ _ _ _ (Just k))) = do
let names = M.fromList . map (\x -> (name x, charCode x)) $ m
k' = mapMaybe kernToList k
kernToList (KX na nb v) =
let ca = M.lookup na names
cb = M.lookup nb names in
case (ca,cb) of
(Just a,Just b) -> Just $ ((i,a,b),v)
(_,_) -> Nothing
M.fromList k'
createKern :: [Font] -> IO ()
createKern f = do
let allmaps = map kernForFont $ (zip [0..] f)
endkern = M.fromList $ [((i,j,0),0) | i <- [0..13],j <- [32..255]]
result = M.unions $ allmaps
putStrLn $ "-- #hide"
putStrLn $ "module Graphics.PDF.LowLevel.Kern(kerns) where"
putStrLn ""
putStrLn $ "import qualified Data.Map as M"
putStrLn $ "import Data.Word"
putStrLn $ "kerns :: M.Map (Int,Word8,Word8) Int"
putStrLn $ "kerns = M." ++ (show result)
main :: IO ()
main = do
r <- getArgs
maybeFonts <- mapM parseFont allFonts
let fonts = map fromJust . filter isJust $ maybeFonts
if null r
then do
let carray = map createFontList fonts
putStrLn "#ifndef _METRICS_H_"
putStrLn "#define _METRICS_H_"
putStrLn "static const unsigned long gmetric[]={"
mapM_ putStr . intersperse "\n," . map (\(c,w) -> show w) . concat $ carray
putStrLn "};"
putStrLn "static const long fmetric[]={"
mapM_ putStr . intersperse "\n," . concatMap fontData $ fonts
putStrLn "};"
putStrLn "#endif"
else do
createKern fonts