diff --git a/line2pdf.cabal b/line2pdf.cabal --- a/line2pdf.cabal +++ b/line2pdf.cabal @@ -1,5 +1,5 @@ name: line2pdf -version: 0.0.3 +version: 0.0.4 copyright: 2008 Audrey Tang license: BSD3 license-file: LICENSE @@ -16,10 +16,20 @@ flag small_base description: Choose the new smaller, split-up base package. +library + exposed-modules: Text.LineToPDF + extensions: ImplicitParams, ExistentialQuantification + if flag(small_base) + build-depends: base >= 3, containers, bytestring + else + build-depends: base < 3 + hs-source-dirs: src + executable line2pdf main-is: line2pdf.hs - extensions: ImplicitParams + extensions: ImplicitParams, ExistentialQuantification if flag(small_base) build-depends: base >= 3, containers, bytestring else build-depends: base < 3 + hs-source-dirs: . src diff --git a/line2pdf.hs b/line2pdf.hs --- a/line2pdf.hs +++ b/line2pdf.hs @@ -1,329 +1,23 @@ -{-# LANGUAGE ImplicitParams #-} - -module Main (main) where -import Data.IORef -import System.IO -import System.IO.Unsafe +module Main where import System.Exit import System.Environment -import Control.Applicative +import Text.LineToPDF import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.IntMap as IM -{-# 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 []) - -type M = IO -type Obj = Int - main :: IO () main = do args <- getArgs - input <- case args of + (lang, input) <- case args of [] -> do - putStrLn "Usage: line2pdf input.txt > output.pdf" + putStrLn "Usage: line2pdf [-big5|-gbk|-euc-jp|-euc-kr] input.txt > output.pdf" putStrLn " (Form feed (^L) in input denotes a pagebreak.)" exitWith ExitSuccess - (i:_) -> return i - - hSetBinaryMode stdout True - - pr$ "%PDF-1.2\n" ++ "%\xE2\xE3\xCF\xD3\n" - - (info, root, tPages, resources) <- writeHeader - - pageObjs <- let ?tPages = tPages - ?resources = resources in writePages =<< (L.lines <$> L.readFile input) - - 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 ++ " " ++ show pageHeight - 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 :: M (Obj, Obj, Obj, Obj) -writeHeader = do - info <- printObj $ "/CreationDate(D:20080707163949+08'00')" - ++ "/Producer(line2pdf.hs)" - ++ "/Title(Untitled)" - encoding <- printObj strDefaultEncoding - everyFont <- (`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" - tradFont <- writeTradChineseFonts - root <- incrObj - tPages <- incrObj - markObj $ \resources -> do - pr$ "/Font<<" ++ concat everyFont ++ concat tradFont ++ ">>" - ++ "/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) - -startPage :: (?tPages :: Obj, ?resources :: Obj) => M Int -startPage = 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 fontN = 30 :: Int - ptSize = 12 :: Int - pr$ "/F" ++ show fontN ++ " " ++ show ptSize ++ " Tf\n" - pr$ "1 0 0 1 50 " ++ show (pageHeight - 40) ++ " Tm\n" - pr$ "12 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) => [L.ByteString] -> M [Obj] -writePages lns = do - pos <- newRef =<< startPage - - (`mapM_` lns) $ \ln -> do - case fromEnum (L.length ln) of - 1 | L.head ln == '\f' -> do - endPage =<< readRef pos - writeRef pos =<< startPage - len -> do - pr$ "T*(" - L.putStr 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]" - -pageWidth :: Int -pageWidth = 792 - -pageHeight :: Int -pageHeight = 612 - -writeTradChineseFonts :: M [String] -writeTradChineseFonts = do - tradFont <- newRef [] - let addFont o fn = modifyRef tradFont - (("/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/ETen-B5-H" - pr$ "/DescendantFonts[" ++ show (succ obj) ++ " 0 R]" - markObj $ \obj -> do - pr$ "/Type/Font" - ++ "/Subtype/CIDFontType2" - ++ "/BaseFont/" - pr$ name ++ "/FontDescriptor " ++ show (succ obj) ++ " 0 R" - ++ "/CIDSystemInfo<<" - ++ "/Registry(Adobe)" - ++ "/Ordering(CNS1)" - ++ "/Supplement 0" - ++ ">>" - ++ "/DW 1000" - ++ "/W[13500 14000 500]" - printObj $ "/Type/FontDescriptor" - ++ "/FontName/" - ++ takeWhile (/= ',') name - ++ "/FontBBox[0 -199 1000 801]" - ++ "/Flags 7" - ++ "/CapHeight 0" - ++ "/Ascent 800" - ++ "/Descent -199" - ++ "/StemV 0" - ++ "/ItalicAngle 0" - mapM_ (uncurry markFont) tradChineseFonts - readRef tradFont + ("-big5":i:_) -> return (TraditionalChinese, i) + ("-gbk":i:_) -> return (SimplifiedChinese, i) + ("-euc-jp":i:_) -> return (Japanese, i) + ("-euc-kr":i:_) -> return (Korean, i) + (i:_) -> return (Latin, i) -tradChineseFonts :: [(Int, String)] -tradChineseFonts = - [ (30, "MingLiU") - , (31, "MingLiU,Italic") - , (32, "MingLiU,Bold") - , (33, "MingLiU,BoldItalic") - ] + src <- L.readFile input + lineToPDF $ defaultConfig lang src diff --git a/src/Text/LineToPDF.hs b/src/Text/LineToPDF.hs new file mode 100644 --- /dev/null +++ b/src/Text/LineToPDF.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE ImplicitParams, ExistentialQuantification #-} + +module Text.LineToPDF (lineToPDF, defaultConfig, AppConfig(..), Language(..)) where +import Data.IORef +import System.IO +import System.IO.Unsafe +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.IntMap as IM + +{-# 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 :: Int + , language :: 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 + , language = 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 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 :: AppConfig -> M (Obj, Obj, Obj, Obj) +writeHeader appConfig = do + info <- printObj $ "/CreationDate(D:20080707163949+08'00')" + ++ "/Producer(line2pdf.hs)" + ++ "/Title(Untitled)" + encoding <- printObj strDefaultEncoding + everyFont <- (`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" + tradFont <- case language appConfig of + Latin -> return [] + TraditionalChinese -> writeTradChineseFonts + SimplifiedChinese -> writeSimpChineseFonts + Japanese -> writeJapaneseFonts + Korean -> writeKoreanFonts + root <- incrObj + tPages <- incrObj + markObj $ \resources -> do + pr$ "/Font<<" ++ concat everyFont ++ concat tradFont ++ ">>" + ++ "/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, language = lang } = 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"; + pr$ "/F" ++ fontOf lang ++ " " ++ show pt ++ " Tf\n" + pr$ "1 0 0 1 50 " ++ show (height - 40) ++ " Tm\n" + pr$ "12 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" + , 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<>>>>" + } + +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<>>" + } + +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") +-- , (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