{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams, ExistentialQuantification #-}
module Main where
import OpenAFP
import Control.Applicative
import System.Exit
import System.Environment
-- import System.Posix.Resource
import qualified Data.ByteString as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Char8 as C
{- LINE2PDF -}
import Data.IORef
import System.IO
import System.IO.Unsafe
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.IntMap as IM
{- END LINE2PDF -}
deriving instance Eq Encoding
deriving instance Ord Encoding
__1GB__ :: Integer
__1GB__ = 1024 * 1024 * 1024
-- mkLimit :: Integer -> ResourceLimits
-- mkLimit x = ResourceLimits (ResourceLimit x) (ResourceLimit x)
main :: IO ()
main = do
-- setResourceLimit ResourceTotalMemory (mkLimit __1GB__)
-- setResourceLimit ResourceCoreFileSize (mkLimit 0)
hSetBinaryMode stdout True
args <- getArgs
when (null args) $ do
putStrLn "Usage: afp2line2pdf input.afp > output.pdf"
forM_ args $ \f -> do
ft <- guessFileType f
processFile ft f
data FileType = F_ASCII | F_EBCDIC | F_AFP | F_PDF | F_Unknown deriving Show
guessFileType :: FilePath -> IO FileType
guessFileType fn = do
fh <- openBinaryFile fn ReadMode
bs <- S.hGet fh 1
hClose fh
return $ if S.null bs then F_Unknown else case C.head bs of
'Z' -> F_AFP
'%' -> F_PDF
'1' -> F_ASCII
'0' -> F_ASCII
' ' -> F_ASCII
'\xF0' -> F_EBCDIC
'\xF1' -> F_EBCDIC
'@' -> F_EBCDIC
_ -> F_Unknown
imageChunkTypes :: [ChunkType]
imageChunkTypes =
[ chunkTypeOf _BII
, chunkTypeOf _BIM
, chunkTypeOf _MIO
, chunkTypeOf _IRD
, chunkTypeOf _IPD
]
_blank1, _blank2 :: C.ByteString
_blank1 = C.pack "BLANK"
_blank2 = C.pack "BLN"
isBlank :: [AFP_] -> Bool
isBlank cs = case find (~~ _BR) cs of
Just c -> let str = S.drop 2 (packAStr $ br (decodeChunk c)) in
(_blank1 `S.isPrefixOf` str) || (_blank2 `S.isPrefixOf` str)
_ -> False
processFile :: FileType -> FilePath -> IO ()
processFile F_ASCII _ = do
-- ...Look at each line's first byte to determine what to output...
return ()
processFile F_AFP f = do
-- Read the first byte to determine its file type:
-- '1' indicates ASCII Plain Text line data
-- '\xF1' indicates EBCDIC line data
-- 'Z' indicates AFP file
-- '%' indicates PDF file
cs <- readAFP f
env <- getEnvironment
case lookup "AFP2PDF2LINE_SKIP_IMAGE" env of
Just "1" -> return ()
_ | not (isBlank cs), any ((`elem` imageChunkTypes) . chunkType) cs -> do
-- We can't process image data, sorry.
exitWith (ExitFailure 1)
_ -> return ()
hSetBinaryMode stdout True
pr$ "%PDF-1.2\n" ++ "%\xE2\xE3\xCF\xD3\n"
(info, root, tPages, resources) <- writeHeader [Latin, TraditionalChinese, Japanese]
forM_ (filter (~~ _PGD) cs) $ \c -> do
let pgd = decodeChunk c
xSize = toPt $ pgd_XPageSize pgd
ySize = toPt $ pgd_YPageSize pgd
modifyIORef __MAX_WIDTH__ (max xSize)
modifyIORef __MAX_HEIGHT__ (max ySize)
modifyIORef __MAX_WIDTH__ (+30)
modifyIORef __MAX_HEIGHT__ (+30)
forM_ (tail $ splitRecords _BPG cs) $ \pageChunks -> do
-- Start page
markObj $ \obj -> do
modifyRef __PAGE__ (obj:)
pr$ "/Type/Page"
pr$ "/Parent " ++ show tPages ++ " 0 R"
pr$ "/Resources " ++ show resources ++ " 0 R"
pr$ "/Contents " ++ show (succ obj) ++ " 0 R"
pr$ "/Rotate 0"
obj <- incrObj
markLocation obj
pr$ show obj ++ " 0 obj" ++ "<<"
pr$ "/Length " ++ show (succ obj) ++ " 0 R"
pr$ ">>" ++ "stream\n"
streamStart <- currentLocation
pr$ "BT\n";
pageChunks ..>
[ _PTX ... ptxDump
, _MCF ... mcfHandler
, _MCF1 ... mcf1Handler
]
-- End Page
pr$ "ET\n"
streamEnd <- currentLocation
pr$ "endstream\n" ++ "endobj\n"
obj' <- incrObj
markLocation obj'
pr$ show obj' ++ " 0 obj\n"
++ show (streamEnd - streamStart) ++ "\n"
++ "endobj\n"
pageObjs <-reverse <$> readRef __PAGE__
markLocation root
writeObj root $ do
pr$ "/Type/Catalog" ++ "/Pages "
pr$ show tPages ++ " 0 R"
maxPageWidth <- readIORef __MAX_WIDTH__
maxPageHeight <- readIORef __MAX_HEIGHT__
markLocation tPages
writeObj tPages $ do
pr$ "/Type/Pages" ++ "/Count "
pr$ show (length pageObjs)
++ "/MediaBox[0 0 "
++ show maxPageWidth ++ " " ++ show maxPageHeight
pr$ "]" ++ "/Kids["
pr$ concatMap ((++ " 0 R ") . show) pageObjs
pr$ "]"
xfer <- currentLocation
objCount <- incrObj
pr$ "xref\n" ++ "0 " ++ show objCount ++ "\n"
++ "0000000000 65535 f \r"
writeLocations
pr$ "trailer\n" ++ "<<" ++ "/Size "
pr$ show objCount
pr$ "/Root " ++ show root ++ " 0 R"
pr$ "/Info " ++ show info ++ " 0 R"
pr$ ">>\n" ++ "startxref\n"
pr$ show xfer ++ "\n" ++ "%%EOF\n"
processFile t f = warn $ "Unknown file type: " ++ show t ++ " (" ++ f ++ ")"
{-# NOINLINE __MAX_WIDTH__ #-}
__MAX_WIDTH__ :: IORef Float
__MAX_WIDTH__ = unsafePerformIO $ newIORef 0
{-# NOINLINE __MAX_HEIGHT__ #-}
__MAX_HEIGHT__ :: IORef Float
__MAX_HEIGHT__ = unsafePerformIO $ newIORef 0
{-# NOINLINE _CurrentLine #-}
_CurrentLine :: IORef Float
_CurrentLine = unsafePerformIO $ newIORef 0
{-# NOINLINE _CurrentColumn #-}
_CurrentColumn :: IORef Float
_CurrentColumn = unsafePerformIO $ newIORef 0
{-# NOINLINE _MaxColumn #-}
_MaxColumn :: IORef Int
_MaxColumn = unsafePerformIO $ newIORef 0
{-# NOINLINE _MaxLine #-}
_MaxLine :: IORef Int
_MaxLine = unsafePerformIO $ newIORef 0
{-# NOINLINE _MaxEncoding #-}
_MaxEncoding :: IORef Encoding
_MaxEncoding = unsafePerformIO $ newIORef CP37
{-# NOINLINE _MinFontSize #-}
_MinFontSize :: IORef Size
_MinFontSize = unsafePerformIO $ newIORef 12
lookupFontEncoding :: N1 -> IO (Maybe Encoding)
lookupFontEncoding = hashLookup _FontToEncoding
insertFonts :: [(N1, ByteString)] -> IO ()
insertFonts = mapM_ $ \(i, f) -> do
let (enc, sz) = fontInfoOf f
modifyIORef _MinFontSize $ \szMin -> case szMin of
0 -> sz
_ -> min szMin sz
modifyIORef _MaxEncoding (max enc)
hashInsert _FontToEncoding i enc
{-# NOINLINE _FontToEncoding #-}
_FontToEncoding :: HashTable N1 Encoding
_FontToEncoding = unsafePerformIO $ hashNew (==) fromIntegral
-- | Record font Id to Name mappings in MCF's RLI and FQN chunks.
mcfHandler :: MCF -> IO ()
mcfHandler r = do
readChunks r ..>
[ _MCF_T ... \mcf -> do
let cs = readChunks mcf
ids = [ t_rli (decodeChunk c) | c <- cs, c ~~ _T_RLI ]
fonts = [ t_fqn (decodeChunk c) | c <- cs, c ~~ _T_FQN ]
insertFonts (ids `zip` map packAStr fonts)
]
-- | Record font Id to Name mappings in MCF1's Data chunks.
mcf1Handler :: MCF1 -> IO ()
mcf1Handler r = do
insertFonts
[ (mcf1_CodedFontLocalId mcf1, packA8 $ mcf1_CodedFontName mcf1)
| Record mcf1 <- readData r
]
encToLang :: Encoding -> Language
encToLang CP37 = Latin
encToLang CP835 = TraditionalChinese
encToLang CP939 = Japanese
encToLang CP950 = TraditionalChinese
ptxDump :: PTX -> IO ()
ptxDump ptx = mapM_ ptxGroupDump . splitRecords _PTX_SCFL $ readChunks ptx
ptxGroupDump :: [PTX_] -> IO ()
ptxGroupDump (scfl:cs) | scfl ~~ _PTX_SCFL = do
let scflId = ptx_scfl (decodeChunk scfl)
rv <- lookupFontEncoding scflId
case rv of
Nothing -> return ()
Just curEncoding -> do
height <- readIORef __MAX_HEIGHT__
curSize <- readIORef _MinFontSize
let display (lang, getBStr) = do
font <- case lang of
Latin -> do
(fontOf . encToLang) <$> readIORef _MaxEncoding
_ -> return (fontOf lang)
pr$ "/F" ++ font ++ " " ++ show curSize ++ " Tf\n"
pr$ show curSize ++ " TL\n"
col <- readIORef _CurrentColumn
ln <- readIORef _CurrentLine
pr$ "1 0 0 1 " ++ show (col + 25) ++ " " ++ show (height - ln - 25) ++ " Tm("
let escape ch = C.intercalate (C.pack ['\\', ch]) . C.split ch
escapeTxt = escape '(' . escape ')' . escape '\\'
bstr <- escapeTxt <$> getBStr
C.putStr bstr
let len = S.length bstr
modifyRef __POS__ (+ len)
pr$ ")Tj\n"
modifyIORef _CurrentColumn (+ (realToFrac (len * curSize) * 0.5))
cs ..>
[ _PTX_TRN ... \trn -> display $ case curEncoding of
CP37 -> (Latin, return $ packAStr' (ptx_trn trn))
CP835 -> (TraditionalChinese, pack835 (ptx_trn trn))
CP939 -> (Japanese, pack939 (ptx_trn trn))
CP950 -> (TraditionalChinese, return $ packBuf (ptx_trn trn))
, _PTX_BLN ... \_ -> do
writeIORef _CurrentColumn 0 -- XXX
modifyIORef _CurrentLine (+ realToFrac curSize)
, _PTX_AMB ... \x -> do
-- hPrint stderr ("AMB", fromEnum $ ptx_amb x)
movePosition Absolute _CurrentLine . ptx_amb $ x
, _PTX_RMB ... \x -> do
-- hPrint stderr ("RMB", fromEnum $ ptx_rmb x)
movePosition Relative _CurrentLine . ptx_rmb $ x
, _PTX_AMI ... movePosition Absolute _CurrentColumn . ptx_ami
, _PTX_RMI ... movePosition Relative _CurrentColumn . ptx_rmi
]
ptxGroupDump _ = return ()
data Position = Absolute | Relative
movePosition :: Position -> IORef Float -> N2 -> IO ()
movePosition p ref n = do
case p of
Absolute -> writeIORef ref (toPt n)
Relative -> modifyIORef ref (+ (toPt n))
toPt :: Enum a => a -> Float
toPt x = realToFrac (fromEnum x) * 0.3
packAStr' :: AStr -> S.ByteString
packAStr' astr = S.map (ebc2ascIsPrintW8 !) (packBuf astr)
{-# INLINE pack835 #-}
{-# INLINE pack939 #-}
pack835, pack939 :: NStr -> IO S.ByteString
pack835 = packWith convert835to950
pack939 = packWith convert939to932
{-# INLINE packWith #-}
packWith :: (Int -> Int) -> NStr -> IO S.ByteString
packWith f nstr = S.unsafeUseAsCStringLen (packBuf nstr) $ \(src, len) -> S.create len $ \target -> do
let s = castPtr src
let t = castPtr target
forM_ [0..(len `div` 2)-1] $ \i -> do
hi <- peekByteOff s (i*2) :: IO Word8
lo <- peekByteOff s (i*2+1) :: IO Word8
let ch = f (fromEnum hi * 256 + fromEnum lo)
(hi', lo') = ch `divMod` 256
pokeByteOff t (i*2) (toEnum hi' :: Word8)
pokeByteOff t (i*2+1) (toEnum lo' :: Word8)
--------------
{-# NOINLINE __POS__ #-}
__POS__ :: IORef Int
__POS__ = unsafePerformIO (newRef 0)
{-# NOINLINE __OBJ__ #-}
__OBJ__ :: IORef Int
__OBJ__ = unsafePerformIO (newRef 0)
{-# NOINLINE __LOC__ #-}
__LOC__ :: IORef (IM.IntMap String)
__LOC__ = unsafePerformIO (newRef IM.empty)
{-# NOINLINE __PAGE__ #-}
__PAGE__ :: IORef [Obj]
__PAGE__ = unsafePerformIO (newRef [])
data Language
= Latin
| TraditionalChinese
| SimplifiedChinese
| Japanese
| Korean
data AppConfig = forall a. MkAppConfig
{ pageWidth :: Int
, pageHeight :: Int
, ptSize :: Float
, languages :: [Language]
, srcLines :: [a]
, srcPut :: a -> IO ()
, srcLength :: a -> Int
, srcHead :: a -> Char
}
defaultConfig :: Language -> L.ByteString -> AppConfig
defaultConfig lang txt = MkAppConfig
{ pageWidth = 842
, pageHeight = 595
, ptSize = 12
, languages = [lang]
, srcLines = L.lines txt
, srcPut = L.putStr
, srcLength = fromEnum . L.length
, srcHead = L.head
}
type M = IO
type Obj = Int
lineToPDF :: AppConfig -> IO ()
lineToPDF appConfig = do
hSetBinaryMode stdout True
pr$ "%PDF-1.2\n" ++ "%\xE2\xE3\xCF\xD3\n"
(info, root, tPages, resources) <- writeHeader $ languages appConfig
pageObjs <- let ?tPages = tPages
?resources = resources in writePages appConfig
markLocation root
writeObj root $ do
pr$ "/Type/Catalog" ++ "/Pages "
pr$ show tPages ++ " 0 R"
markLocation tPages
writeObj tPages $ do
pr$ "/Type/Pages" ++ "/Count "
pr$ show (length pageObjs)
++ "/MediaBox[0 0 "
++ show (pageWidth appConfig) ++ " " ++ show (pageHeight appConfig)
pr$ "]" ++ "/Kids["
pr$ concatMap ((++ " 0 R ") . show) pageObjs
pr$ "]"
xfer <- currentLocation
objCount <- incrObj
pr$ "xref\n" ++ "0 " ++ show objCount ++ "\n"
++ "0000000000 65535 f \r"
writeLocations
pr$ "trailer\n" ++ "<<" ++ "/Size "
pr$ show objCount
pr$ "/Root " ++ show root ++ " 0 R"
pr$ "/Info " ++ show info ++ " 0 R"
pr$ ">>\n" ++ "startxref\n"
pr$ show xfer ++ "\n" ++ "%%EOF\n"
writeObj :: Obj -> M a -> M a
writeObj obj f = do
pr$ show obj ++ " 0 obj" ++ "<<"
rv <- f
pr$ ">>" ++ "endobj\n"
return rv
writeLocations :: M ()
writeLocations = do
locs <- IM.elems <$> readRef __LOC__
pr$ concatMap fmt locs
where
fmt x = pad ++ x ++ " 00000 n \r"
where
pad = replicate (10-l) '0'
l = length x
printObj :: String -> M Obj
printObj str = markObj $ (pr str >>) . return
writeHeader :: [Language] -> M (Obj, Obj, Obj, Obj)
writeHeader langs = do
info <- printObj $ "/CreationDate(D:20080707163949+08'00')"
++ "/Producer(line2pdf.hs)"
++ "/Title(Untitled)"
encoding <- printObj strDefaultEncoding
latinFonts <- (`mapM` ([1..] `zip` baseFonts)) $ \(n, font) -> do
markObj $ \obj -> do
pr$ "/Type/Font" ++ "/Subtype/Type1" ++ "/Name/F"
pr$ show (n :: Int)
pr$ "/Encoding " ++ show encoding ++ " 0 R"
pr$ font
return $ "/F" ++ show n ++ " " ++ show obj ++ " 0 R"
cjkFonts <- (`mapM` langs) $ \lang -> case lang of
Latin -> return []
TraditionalChinese -> writeTradChineseFonts
SimplifiedChinese -> writeSimpChineseFonts
Japanese -> writeJapaneseFonts
Korean -> writeKoreanFonts
root <- incrObj
tPages <- incrObj
markObj $ \resources -> do
pr$ "/Font<<" ++ concat latinFonts ++ concat (concat cjkFonts) ++ ">>"
++ "/ProcSet[/PDF/Text]" ++ "/XObject<<>>"
return (info, root, tPages, resources)
baseFonts :: [String]
baseFonts =
[ "/BaseFont/Courier"
, "/BaseFont/Courier-Oblique"
, "/BaseFont/Courier-Bold"
, "/BaseFont/Courier-BoldOblique"
, "/BaseFont/Helvetica"
, "/BaseFont/Helvetica-Oblique"
, "/BaseFont/Helvetica-Bold"
, "/BaseFont/Helvetica-BoldOblique"
, "/BaseFont/Times-Roman"
, "/BaseFont/Times-Italic"
, "/BaseFont/Times-Bold"
, "/BaseFont/Times-BoldItalic"
, "/BaseFont/Symbol"
, "/BaseFont/ZapfDingbats"
]
pr :: String -> M ()
pr str = do
putStr str
modifyRef __POS__ (+ (length str))
currentLocation :: IO Int
currentLocation = readRef __POS__
newRef :: a -> M (IORef a)
newRef = newIORef
readRef :: IORef a -> M a
readRef = readIORef
writeRef :: IORef a -> a -> M ()
writeRef = writeIORef
modifyRef :: IORef a -> (a -> a) -> M ()
modifyRef = modifyIORef
incrObj :: M Obj
incrObj = do
obj <- succ <$> readRef __OBJ__
writeRef __OBJ__ obj
return obj
markObj :: (Obj -> M a) -> M a
markObj f = do
obj <- incrObj
markLocation obj
writeObj obj (f obj)
markLocation :: Obj -> M ()
markLocation obj = do
loc <- currentLocation
modifyRef __LOC__ $ IM.insert obj (show loc)
fontOf :: Language -> String
fontOf Latin = "1"
fontOf TraditionalChinese = "30"
fontOf SimplifiedChinese = "35"
fontOf Japanese = "20"
fontOf Korean = "40"
startPage :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M Int
startPage MkAppConfig{ pageHeight = height, ptSize = pt, languages = langs } = do
markObj $ \obj -> do
modifyRef __PAGE__ (obj:)
pr$ "/Type/Page"
pr$ "/Parent " ++ show ?tPages ++ " 0 R"
pr$ "/Resources " ++ show ?resources ++ " 0 R"
pr$ "/Contents " ++ show (succ obj) ++ " 0 R"
pr$ "/Rotate 0"
obj <- incrObj
markLocation obj
pr$ show obj ++ " 0 obj" ++ "<<"
pr$ "/Length " ++ show (succ obj) ++ " 0 R"
pr$ ">>" ++ "stream\n"
streamPos <- currentLocation
pr$ "BT\n";
let font = fontOf $ case langs of
(l:_) -> l
_ -> Latin
pr$ "/F" ++ font ++ " " ++ show pt ++ " Tf\n"
pr$ "1 0 0 1 50 " ++ show (height - 40) ++ " Tm\n"
pr$ show pt ++ " TL\n"
return streamPos
endPage :: Int -> M ()
endPage streamStart = do
pr$ "ET\n"
streamEnd <- currentLocation
pr$ "endstream\n"
++ "endobj\n"
obj <- incrObj
markLocation obj
pr$ show obj ++ " 0 obj\n"
++ show (streamEnd - streamStart) ++ "\n"
++ "endobj\n"
writePages :: (?tPages :: Obj, ?resources :: Obj) => AppConfig -> M [Obj]
writePages appConfig@MkAppConfig
{ srcLength = len
, srcPut = put
, srcHead = hd
, srcLines = lns
, pageHeight = height
} = do
pos <- newRef =<< startPage appConfig
(`mapM_` lns) $ \ln -> do
case fromEnum (len ln) of
1 | hd ln == '\f' -> do
endPage =<< readRef pos
writeRef pos =<< startPage appConfig
len -> do
pr$ "T*("
put ln
modifyRef __POS__ (+ len)
pr$ ")Tj\n"
endPage =<< readRef pos
reverse <$> readRef __PAGE__
strDefaultEncoding :: String
strDefaultEncoding = "/Type/Encoding"
++ "/Differences[0 /.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/space/exclam"
++ "/quotedbl/numbersign/dollar/percent/ampersand"
++ "/quoteright/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"
++ "/quoteleft/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/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/.notdef/.notdef/.notdef/.notdef/.notdef/.notdef"
++ "/dotlessi/grave/acute/circumflex/tilde/macron/breve"
++ "/dotaccent/dieresis/.notdef/ring/cedilla/.notdef"
++ "/hungarumlaut/ogonek/caron/space/exclamdown/cent"
++ "/sterling/currency/yen/brokenbar/section/dieresis"
++ "/copyright/ordfeminine/guillemotleft/logicalnot/hyphen"
++ "/registered/macron/degree/plusminus/twosuperior"
++ "/threesuperior/acute/mu/paragraph/periodcentered"
++ "/cedilla/onesuperior/ordmasculine/guillemotright"
++ "/onequarter/onehalf/threequarters/questiondown/Agrave"
++ "/Aacute/Acircumflex/Atilde/Adieresis/Aring/AE"
++ "/Ccedilla/Egrave/Eacute/Ecircumflex/Edieresis/Igrave"
++ "/Iacute/Icircumflex/Idieresis/Eth/Ntilde/Ograve"
++ "/Oacute/Ocircumflex/Otilde/Odieresis/multiply/Oslash"
++ "/Ugrave/Uacute/Ucircumflex/Udieresis/Yacute/Thorn"
++ "/germandbls/agrave/aacute/acircumflex/atilde/adieresis"
++ "/aring/ae/ccedilla/egrave/eacute/ecircumflex"
++ "/edieresis/igrave/iacute/icircumflex/idieresis/eth"
++ "/ntilde/ograve/oacute/ocircumflex/otilde/odieresis"
++ "/divide/oslash/ugrave/uacute/ucircumflex/udieresis"
++ "/yacute/thorn/ydieresis]"
data FontConfig = MkFontConfig
{ encoding :: String
, cidFontType :: String
, ordering :: String
, supplement :: String
, wBox :: String
, descriptor :: String
}
writeJapaneseFonts :: M [String]
writeJapaneseFonts = writeFonts japaneseFonts $ MkFontConfig
-- { encoding = "EUC-H"
{ encoding = "90ms-RKSJ-H"
, cidFontType = "0"
, ordering = "Japan1"
, supplement = "2"
, wBox = "50 500 500"
, descriptor = "/Ascent 723"
++ "/CapHeight 709"
++ "/Descent -241"
++ "/Flags 6"
++ "/FontBBox[-123 -257 1001 910]"
++ "/ItalicAngle 0"
++ "/StemV 69"
++ "/XHeight 450"
++ "/Style<</Panose<010502020400000000000000>>>>>"
}
writeKoreanFonts :: M [String]
writeKoreanFonts = writeFonts koreanFonts $ MkFontConfig
{ encoding = "KSCms-UHC-H/WinCharSet 129"
, cidFontType = "2"
, ordering = "Korea1"
, supplement = "0"
, wBox = "0 1000 500"
, descriptor = "/Flags 7"
++ "/FontBBox[-100 -142 102 1000]"
++ "/MissingWidth 500"
++ "/StemV 91"
++ "/StemH 91"
++ "/ItalicAngle 0"
++ "/CapHeight 858"
++ "/XHeight 429"
++ "/Ascent 858"
++ "/Descent -142"
++ "/Leading 148"
++ "/MaxWidth 2"
++ "/AvgWidth 500"
++ "/Style<</Panose<000000400000000000000000>>>"
}
writeSimpChineseFonts :: M [String]
writeSimpChineseFonts = writeFonts simpChineseFonts $ MkFontConfig
{ encoding = "GB-EUC-H"
, cidFontType = "2"
, ordering = "GB1"
, supplement = "0"
, wBox = "500 1000 500 7716 [500]"
, descriptor = "/FontBBox[0 -199 1000 801]"
++ "/Flags 6"
++ "/CapHeight 658"
++ "/Ascent 801"
++ "/Descent -199"
++ "/StemV 56"
++ "/XHeight 429"
++ "/ItalicAngle 0"
}
writeTradChineseFonts :: M [String]
writeTradChineseFonts = writeFonts tradChineseFonts $ MkFontConfig
{ encoding = "ETen-B5-H"
, cidFontType = "2"
, ordering = "CNS1"
, supplement = "0"
, wBox = "13500 14000 500"
, descriptor = "/FontBBox[0 -199 1000 801]"
++ "/Flags 7"
++ "/CapHeight 0"
++ "/Ascent 800"
++ "/Descent -199"
++ "/StemV 0"
++ "/ItalicAngle 0"
}
writeFonts fonts cfg = do
ref <- newRef []
let addFont o fn = modifyRef ref
(("/F" ++ show fn ++ " " ++ show o ++ " 0 R"):)
markFont fn name = do
markObj $ \obj -> do
addFont obj fn
pr$ "/Type/Font"
++ "/Subtype/Type0"
++ "/Name/F"
pr$ show fn ++ "/BaseFont/"
pr$ name ++ "/Encoding/" ++ encoding cfg
pr$ "/DescendantFonts[" ++ show (succ obj) ++ " 0 R]"
markObj $ \obj -> do
pr$ "/Type/Font"
++ "/Subtype/CIDFontType"
pr$ cidFontType cfg
++ "/BaseFont/"
pr$ name ++ "/FontDescriptor " ++ show (succ obj) ++ " 0 R"
++ "/CIDSystemInfo<<"
++ "/Registry(Adobe)"
++ "/Ordering("
pr$ ordering cfg
++ ")"
++ "/Supplement "
pr$ supplement cfg
++ ">>"
++ "/DW 1000"
++ "/W["
pr$ wBox cfg
++ "]"
printObj $ "/Type/FontDescriptor"
++ "/FontName/"
++ takeWhile (/= ',') name
++ descriptor cfg
mapM_ (uncurry markFont) fonts
readRef ref
fontFamily :: Int -> String -> [(Int, String)]
fontFamily n f =
[ (n, f)
, (n+1, f ++ ",Italic")
, (n+2, f ++ ",Bold")
, (n+3, f ++ ",BoldItalic")
]
japaneseFonts :: [(Int, String)]
japaneseFonts = concatMap (uncurry fontFamily)
-- [ (20, "HeiseiMin-W3-EUC-H")
[ (20, "HeiseiMin-W3-90ms-RKSJ-H")
-- , (24, "HeiseiKakuGo-W5-EUC-H")
]
tradChineseFonts :: [(Int, String)]
tradChineseFonts = fontFamily 30 "MingLiU"
simpChineseFonts :: [(Int, String)]
simpChineseFonts = fontFamily 35 "STSong"
koreanFonts :: [(Int, String)]
koreanFonts = fontFamily 40 "#B5#B8#BF#F2#C3#BC"
-- Target size = AFP size / 3