diff --git a/OpenAFP-Utils.cabal b/OpenAFP-Utils.cabal --- a/OpenAFP-Utils.cabal +++ b/OpenAFP-Utils.cabal @@ -1,5 +1,5 @@ Name: OpenAFP-Utils -Version: 1.1 +Version: 1.2 License: BSD3 License-file: LICENSE Author: Audrey Tang @@ -8,53 +8,64 @@ Description: Assorted utilities to work with AFP data streams Category: Data Build-type: Simple +Cabal-Version : >= 1.2 -Executable: afp-dump -Main-is: afp-dump.hs -Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml -Extensions: DeriveDataTypeable, PatternGuards +Executable afp2line2pdf + Main-is: afp2line2pdf.hs + Build-depends: OpenAFP, haskell98, base + Extensions: StandaloneDeriving, GeneralizedNewtypeDeriving, ImplicitParams, + ExistentialQuantification, PatternGuards -Executable: afp-page -Main-is: afp-page.hs -Build-depends: OpenAFP, haskell98, base +Executable afp-olndump + Main-is: afp-olndump.hs + Build-depends: OpenAFP, haskell98, base, bytestring, containers, binary -Executable: afp-replace -Main-is: afp-replace.hs -Build-depends: OpenAFP, haskell98, base -Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards +Executable afp-dump + Main-is: afp-dump.hs + Build-depends: OpenAFP, haskell98, base, bytestring, containers, uconv, xhtml + Extensions: DeriveDataTypeable, PatternGuards -Executable: afp-scanudc -Main-is: afp-scanudc.hs -Build-depends: OpenAFP, haskell98, base, directory -Extensions: BangPatterns +Executable afp-page + Main-is: afp-page.hs + Build-depends: OpenAFP, haskell98, base -Executable: afp-split -Main-is: afp-split.hs -Build-depends: OpenAFP, haskell98, base +Executable afp-replace + Main-is: afp-replace.hs + Build-depends: OpenAFP, haskell98, base + Extensions: DeriveDataTypeable, FlexibleContexts, PatternGuards -Executable: afp-split-scb -Main-is: afp-split-scb.hs -Build-depends: OpenAFP, haskell98, base +Executable afp-scanudc + Main-is: afp-scanudc.hs + Build-depends: OpenAFP, haskell98, base, directory + Extensions: BangPatterns, PatternGuards -Executable: afp-split-tcb -Main-is: afp-split-tcb.hs -Build-depends: OpenAFP, haskell98, base, filepath -Extensions: ImplicitParams +Executable afp-split + Main-is: afp-split.hs + Build-depends: OpenAFP, haskell98, base -Executable: afp-type -Main-is: afp-type.hs -Build-depends: OpenAFP, haskell98, base +Executable afp-split-scb + Main-is: afp-split-scb.hs + Build-depends: OpenAFP, haskell98, base -Executable: afp-udcfix -Main-is: afp-udcfix.hs -Build-depends: OpenAFP, haskell98, base, regex-base, regex-posix -Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts +Executable afp-split-tcb + Main-is: afp-split-tcb.hs + Build-depends: OpenAFP, haskell98, base, filepath + Extensions: ImplicitParams -Executable: afp-validate -Main-is: afp-validate.hs -Build-depends: OpenAFP, haskell98, base +Executable afp-type + Main-is: afp-type.hs + Build-depends: OpenAFP, haskell98, base -Executable: afp2line -Main-is: afp2line.hs -Build-depends: OpenAFP, haskell98, base -Extensions: GeneralizedNewtypeDeriving +Executable afp-udcfix + Main-is: afp-udcfix.hs + Build-depends: OpenAFP, haskell98, base, regex-base, regex-posix + Extensions: DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, PatternGuards + +Executable afp-validate + Main-is: afp-validate.hs + Build-depends: OpenAFP, haskell98, base + +Executable afp2line + Main-is: afp2line.hs + Build-depends: OpenAFP, haskell98, base + Extensions: GeneralizedNewtypeDeriving diff --git a/afp-olndump.hs b/afp-olndump.hs new file mode 100644 --- /dev/null +++ b/afp-olndump.hs @@ -0,0 +1,101 @@ +import OpenAFP +import Control.Applicative +import Data.Binary.Get +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L + +data F = MkF + { _OFLLen :: N4 + , _Checksum :: N4 + , _OIDLen :: N2 + , _OIDName :: ByteString + , _ODescLen :: N2 + , _ObjDesc :: Desc + , _ObjData :: ByteString + } + deriving Show + +data Desc + = CMap + { _ObjType :: N1 + , _Precedence :: N1 + , _Linkage :: N1 + , _WritingDirection :: N1 + , _GCSGID :: N2 + , _CPGID :: N2 + } + | CID + { _ObjType :: N1 + , _Precedence :: N1 + , _MaximumV :: N2 + , _MaximumW :: N2 + } + | NA { _ObjType :: N1 } + | PFB { _ObjType :: N1 } + | AFM { _ObjType :: N1 } + | FMap { _ObjType :: N1 } + | Reserved { _ObjType :: N1 } + deriving Show + +descExt :: Desc -> String +descExt CMap{} = "CMP" +descExt CID{} = "CID" +descExt NA{} = "NA" +descExt PFB{} = "PFB" +descExt AFM{} = "AFM" +descExt FMap{} = "DAT" +descExt Reserved{} = "RES" + +instance Binary Desc where + put = undefined + get = do + objType <- get + case objType of + 0 -> return $ NA objType + 1 -> liftM5 (CMap objType) get get get get get + 5 -> liftM3 (CID objType) get get get + 6 -> return $ PFB objType + 7 -> return $ AFM objType + 8 -> return $ FMap objType + _ -> return $ Reserved objType + +instance Binary F where + put = undefined + get = do + oflLen <- get + checksum <- get + oidLen <- get + let szOID = fromEnum oidLen - 2 + oidName <- getByteString szOID + oDescLen <- get + let szDesc = fromEnum oDescLen - 2 + objDesc <- decodeBuf <$> getByteString szDesc + objData <- getByteString (fromEnum oflLen - 12 - szOID - szDesc) + return $ MkF oflLen checksum oidLen oidName oDescLen objDesc objData + where + decodeBuf :: Binary a => ByteString -> a + decodeBuf = decode . L.fromChunks . (:[]) + +main :: IO () +main = do + args <- getArgs + if null args then error "Usage: afp-olndump input.oln [outputDirectory]" else do + let inputFile = head args + outDir = case args of + (_:d:_) -> d + _ -> let d = takeWhile (/= '.') inputFile in + if d == inputFile then d ++ ".out" else d + cs <- filter (~~ _FNG) <$> readAFP (head args) + let fs = decodeList $ L.fromChunks (map (packBuf . fng . decodeChunk) cs) + createDirectoryIfMissing True outDir + mapM_ (dump outDir) fs + +dump :: FilePath -> F -> IO () +dump d f = do + putStrLn $ unwords [ file, ":", show len, "bytes" ] + C.writeFile file dat + where + ext = descExt $ _ObjDesc f + file = d ++ "/" ++ C.unpack (_OIDName f) ++ ('.':ext) + len = C.length dat + dat = _ObjData f diff --git a/afp2line.hs b/afp2line.hs --- a/afp2line.hs +++ b/afp2line.hs @@ -154,22 +154,27 @@ ptxGroupDump :: [PTX_] -> IO () ptxGroupDump (scfl:cs) = do let scflId = ptx_scfl (decodeChunk scfl) + curEncoding <- lookupFontEncoding scflId cs ..> - [ _PTX_TRN ... \trn -> case curEncoding of - Just CP37 -> let bstr = packAStr' (ptx_trn trn) in do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - Just CP835 -> pack835 (ptx_trn trn) >>= \bstr -> do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - Just CP939 -> pack939 (ptx_trn trn) >>= \bstr -> do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - Just CP950 -> let bstr = packBuf (ptx_trn trn) in do - insertText bstr - modifyIORef _CurrentColumn (+ S.length bstr) - _ -> fail "TRN without SCFL?" + [ _PTX_TRN ... \trn -> do + when (ptx_scfl (decodeChunk scfl) == 2) $ do + hPrint stderr (ptx_trn trn) + case curEncoding of + Just CP37 -> let bstr = packAStr' (ptx_trn trn) in do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP835 -> pack835 (ptx_trn trn) >>= \bstr -> do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP939 -> pack939 (ptx_trn trn) >>= \bstr -> do + C.hPut stderr bstr + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + Just CP950 -> let bstr = packBuf (ptx_trn trn) in do + insertText bstr + modifyIORef _CurrentColumn (+ S.length bstr) + _ -> fail "TRN without SCFL?" , _PTX_BLN ... \_ -> do writeIORef _CurrentColumn 0 modifyIORef _CurrentLine (+1) diff --git a/afp2line2pdf.hs b/afp2line2pdf.hs new file mode 100644 --- /dev/null +++ b/afp2line2pdf.hs @@ -0,0 +1,803 @@ +{-# 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<>>>>" + } + +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") + [ (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