diff --git a/src/Commands.hs b/src/Commands.hs --- a/src/Commands.hs +++ b/src/Commands.hs @@ -3,6 +3,7 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as BC +import System.IO import System.Exit import System.FilePath import qualified Data.Binary.Builder as Br @@ -30,6 +31,7 @@ import PrettyPrint import OidCode import OidTable +import OidTableSVG import Utils import TipToiYaml import Lint @@ -281,42 +283,59 @@ (tty, codeMap) <- readTipToiYaml inf (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap let codes = ("START", fromIntegral (ttProductId tt)) : sort (M.toList totalMap) - let pdfFile = oidTable conf inf codes - B.writeFile out pdfFile + case fromMaybe PDF $ cImageFormat conf of + SVG usePNG -> B.writeFile out $ oidTableSvg conf usePNG inf codes + PDF -> B.writeFile out $ oidTable conf inf codes + _ -> hPutStrLn stderr "tttool oid-table supports only SVG and PDF" >> exitFailure where sort = sortBy (Algorithms.NaturalSort.compare `on` fst) -genPNGsForFile :: Conf -> FilePath -> IO () -genPNGsForFile conf inf = do +isSVG :: FilePath -> Bool +isSVG fn = ".svg" `isSuffixOf` fn + +writeImagesForFile :: Conf -> FilePath -> IO () +writeImagesForFile conf inf = do (tty, codeMap) <- readTipToiYaml inf (tt, totalMap) <- ttYaml2tt (takeDirectory inf) tty codeMap let codes = ("START", fromIntegral (ttProductId tt)) : M.toList totalMap + let format = fromMaybe PNG (cImageFormat conf) forM_ codes $ \(s,c) -> do - genPNG conf c $ printf "oid-%d-%s.png" (ttProductId tt) s + let filename = printf "oid-%d-%s.%s" (ttProductId tt) s (suffixOf format) + let title = printf "%s (product %d code %d)" s (ttProductId tt) c + writeImage format conf title c filename -genPNG :: Conf -> Word16 -> String -> IO () -genPNG conf c filename = +writeImagesForCodes :: Bool -> Conf -> [Word16] -> IO () +writeImagesForCodes False conf codes = + forM_ codes $ \c -> do + let format = fromMaybe PNG (cImageFormat conf) + let filename = printf "oid-%d.%s" c (suffixOf format) + let title = printf "code %d" c + writeImage format conf title c filename +writeImagesForCodes True conf codes = + forM_ codes $ \r -> do + let format = fromMaybe PNG (cImageFormat conf) + let filename = printf "oid-raw-%d.%s" r (suffixOf format) + let title = printf "raw code %d" r + printf "Writing %s... (raw code %d)\n" filename r + writeRawImage format conf title r filename + +writeImage :: ImageFormat -> Conf -> String -> Word16 -> FilePath -> IO () +writeImage format conf title c filename = case code2RawCode c of Nothing -> printf "Skipping %s, code %d not known.\n" filename c Just r -> do printf "Writing %s.. (Code %d, raw code %d)\n" filename c r - genRawPNG' conf r filename - -genPNGsForCodes :: Bool -> Conf -> [Word16] -> IO () -genPNGsForCodes False conf codes = - forM_ codes $ \c -> do - genPNG conf c $ printf "oid-%d.png" c -genPNGsForCodes True conf codes = - forM_ codes $ \r -> do - let filename = printf "oid-raw-%d.png" r - printf "Writing %s... (raw code %d)\n" filename r - genRawPNG' conf r filename + writeRawImage format conf title r filename -genRawPNG' :: Conf -> Word16 -> FilePath -> IO () -genRawPNG' conf = - genRawPNG w h (cDPI conf) (cPixelSize conf) +writeRawImage :: ImageFormat -> Conf -> String -> Word16 -> FilePath -> IO () +writeRawImage PNG conf title raw_code filename = + writeRawPNG w h conf title raw_code filename where (w,h) = cCodeDimPixels conf +writeRawImage (SVG usePNG) conf title raw_code filename = + writeRawSVG conf usePNG title raw_code filename +writeRawImage _ _ _ _ _ = + hPutStrLn stderr "this command only supports PNG and SVG" >> exitFailure cCodeDimPixels :: Conf -> (Int, Int) cCodeDimPixels conf = (w',h') diff --git a/src/OidCode.hs b/src/OidCode.hs --- a/src/OidCode.hs +++ b/src/OidCode.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns, TupleSections, FlexibleContexts #-} -module OidCode (genRawPixels, genRawPNG, DPI(..), PixelSize(..)) where +module OidCode (genRawPixels, oidSVGPattern, writeRawPNG, writeRawSVG, tilePixelSize, DPI(..), PixelSize(..)) where import Data.Word import Data.Bits @@ -14,9 +14,21 @@ import Control.Monad.ST import Control.Applicative import Data.Vector.Storable.ByteString +import qualified Data.ByteString.Base64.Lazy +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Utils +import Types +import qualified Text.Blaze.Svg as S +import qualified Text.Blaze.Svg11 as S +import qualified Text.Blaze.Svg11.Attributes as A +import Text.Blaze.Svg11 ((!)) +import Text.Blaze.Svg.Renderer.Utf8 +import Control.Arrow + + -- Image generation checksum :: Word16 -> Word16 @@ -31,7 +43,74 @@ (^) = xor (&) = (.&.) +oidSVG :: Conf -> Bool -> String -> Word16 -> S.Svg +oidSVG conf usePNG title code = + S.docTypeSvg ! A.version (S.toValue "1.1") + ! A.width (S.toValue "1mm") + ! A.height (S.toValue "1mm") + ! A.viewbox (S.toValue "0 0 48 48") $ do + S.defs (oidSVGPattern conf usePNG title code) + S.rect ! A.width (S.toValue "48") ! A.height (S.toValue "48") + ! A.fill (S.toValue $ "url(#"++title++")") +-- Create an OID pattern with the given id of the given code +-- This assumes 48 dots per mm. +oidSVGPattern :: Conf -> Bool -> String -> Word16 -> S.Svg +oidSVGPattern conf usePNG title code = + S.pattern ! A.width (S.toValue "48") + ! A.height (S.toValue "48") + ! A.id_ (S.toValue title) + ! A.patternunits (S.toValue "userSpaceOnUse") $ + oidSVGPatternContent conf usePNG title code + +oidSVGPatternContent :: Conf -> Bool -> String -> Word16 -> S.Svg +oidSVGPatternContent conf True title code = + S.image ! A.width (S.toValue "48") + ! A.height (S.toValue "48") + ! A.xlinkHref (S.toValue (T.pack "data:image/png;base64," <> pngBase64)) + where + png = genRawPNG 48 48 (conf { cDPI = 1200 }) title code + pngBase64 = T.decodeUtf8 $ B.toStrict $ + Data.ByteString.Base64.Lazy.encode png + +oidSVGPatternContent _conf False _title code = f (0,0) + where + quart 8 = checksum code + quart n = (code `div` 4^n) `mod` 4 + + f :: (Integer, Integer) -> S.Svg + f = mconcat $ map position $ + zip (flip (,) <$> [3,2,1] <*> [3,2,1]) + [ value (quart n) | n <- [0..8] ] ++ + [ (p, plain) | p <- [(0,0), (1,0), (2,0), (3,0), (0,1), (0,3) ] ] ++ + [ ((0,2), special) ] + + -- pixel = S.rect ! A.width (S.toValue "2") ! A.height (S.toValue "2") ! pos (7,7) + pixel (x,y) = S.path ! A.d path + where path = S.mkPath $ do + S.m (x+5) (y+5) + S.hr 2 + S.vr 2 + S.hr (-2) + S.z + + plain = pixel + value 0 = at (2,2) plain + value 1 = at (-2,2) plain + value 2 = at (-2,-2) plain + value 3 = at (2,-2) plain + special = at (3,0) plain + + position ((n,m), p) = at (n*12, m*12) p + + -- Drawing combinators + at (x, y) f = f . ((+x) *** (+y)) + +writeRawSVG :: Conf -> Bool -> String -> Word16 -> FilePath -> IO () +writeRawSVG conf usePNG title code filename = + B.writeFile filename $ + renderSvg (oidSVG conf usePNG title code) + type DPI = Int type PixelSize = Int @@ -45,10 +124,20 @@ black = promotePixel $ PixelYA8 minBound maxBound background = promotePixel $ PixelYA8 maxBound minBound +-- | Size of one tile, in pixels +tilePixelSize :: DPI -> PixelSize -> Int +tilePixelSize dpi _ps = width + where + spacePerPoint = dpi `div2` 100 + width = 4*spacePerPoint + -- | Renders a single OID Image, returns its dimensions and the black pixels therein -singeOidImage :: DPI -> PixelSize -> Word16 -> ((Int, Int), [(Int, Int)]) -singeOidImage dpi ps code = ((width, height), pixels) +singeOidImage :: Conf -> Word16 -> ((Int, Int), [(Int, Int)]) +singeOidImage conf code = ((width, height), pixels) where + dpi = cDPI conf + ps = cPixelSize conf + spacePerPoint = dpi `div2` 100 width = 4*spacePerPoint height = 4*spacePerPoint @@ -87,14 +176,14 @@ -- Drawing combinators at (x, y) = map (\(x', y') -> (x + x', y + y')) - -- integer division rounded up - x `div2` y = ((x-1) `div` y) + 1 +-- integer division rounded up +x `div2` y = ((x-1) `div` y) + 1 -oidImage :: ColorConvertible PixelYA8 p => Int -> Int -> DPI -> PixelSize -> Word16 -> Image p -oidImage w h dpi ps code = +oidImage :: ColorConvertible PixelYA8 p => Int -> Int -> Conf -> Word16 -> Image p +oidImage w h conf code = imageFromBlackPixels w h tiledPixels where - ((cw,ch), pixels) = singeOidImage dpi ps code + ((cw,ch), pixels) = singeOidImage conf code tiledPixels = [ (x',y') @@ -102,26 +191,29 @@ , x' <- [x,x + cw..w-1] , y' <- [y,y + ch..h-1] ] - -- Width and height in pixels -genRawPixels :: Int -> Int -> DPI -> PixelSize -> Word16 -> B.ByteString -genRawPixels w h dpi ps code = +genRawPixels :: Int -> Int -> Conf -> Word16 -> B.ByteString +genRawPixels w h conf code = -- All very shaky here, but it seems to work B.fromStrict $ vectorToByteString $ imageData $ - (oidImage w h dpi ps code :: Image PixelRGB8) + (oidImage w h conf code :: Image PixelRGB8) -genRawPNG :: Int -> Int -> DPI -> PixelSize -> Word16 -> FilePath -> IO () -genRawPNG w h dpi ps code filename = +writeRawPNG :: Int -> Int -> Conf -> String -> Word16 -> FilePath -> IO () +writeRawPNG w h conf title code filename = B.writeFile filename $ + genRawPNG w h conf title code + +genRawPNG :: Int -> Int -> Conf -> String -> Word16 -> B.ByteString +genRawPNG w h conf title code = encodePngWithMetadata metadata $ - (oidImage w h dpi ps code :: Image PixelYA8) + (oidImage w h conf code :: Image PixelYA8) where metadata = mconcat - [ singleton DpiX (fromIntegral dpi) - , singleton DpiY (fromIntegral dpi) - , singleton Title $ "Tiptoi OID Code " ++ show code + [ singleton DpiX (fromIntegral (cDPI conf)) + , singleton DpiY (fromIntegral (cDPI conf)) + , singleton Title title , singleton Software $ "tttool " ++ tttoolVersion ] diff --git a/src/OidTable.hs b/src/OidTable.hs --- a/src/OidTable.hs +++ b/src/OidTable.hs @@ -15,9 +15,6 @@ import Utils import Types - --- IO technically unnecessary: https://github.com/alpheccar/HPDF/issues/7 - oidTable :: Conf -> String -> [(String, Word16)] -> LB.ByteString oidTable conf title entries | entriesPerPage < 1 = error "OID codes too large to fit on a single page" | otherwise = pdfByteString docInfo a4rect $ do @@ -26,11 +23,16 @@ case code2RawCode rc of Nothing -> return (d, Nothing) Just c -> do - image <- createPDFRawImageFromByteString imageWidthPx imageHeightPx False FlateDecode $ + let twp = tilePixelSize (cDPI conf) (cPixelSize conf) + let tw = fromIntegral twp / px + image <- createPDFRawImageFromByteString twp twp False FlateDecode $ compressWith defaultCompressParams { compressLevel = defaultCompression } $ - genRawPixels imageWidthPx imageHeightPx (cDPI conf) (cPixelSize conf) $ + genRawPixels twp twp conf $ c - return (d, Just image) + pat <- createColoredTiling 0 0 tw tw tw tw NoDistortion $ do + applyMatrix $ scale (1/px) (1/px) + drawXObject image + return (d, Just pat) let chunks = chunksOf entriesPerPage entries' let totalPages = length chunks @@ -53,11 +55,10 @@ forM_ (zip thisPage positions) $ \((e,mbi),p) -> do withNewContext $ do - applyMatrix $ translate p + applyMatrix $ translate (align p) forM_ mbi $ \i -> withNewContext $ do - applyMatrix $ translate (0 :+ (-imageHeight)) - applyMatrix $ scale (1/px) (1/px) - drawXObject i + setColoredFillPattern i + fill (Rectangle (0 :+ (- alignToPx imageHeight)) (imageWidth :+ 0)) withNewContext $ do applyMatrix $ translate (0 :+ (-imageHeight - subtitleSep)) let fontRect = Rectangle (0 :+ (-subtitleHeight)) (imageWidth :+ 0) @@ -125,6 +126,15 @@ px :: Double px = fromIntegral (cDPI conf) / 72 + + -- Makes sure the given point is at a coordinate that is a multiple + -- of an pixel + align :: Point -> Point + align pos = alignToPx (realPart pos) :+ (a4h - alignToPx (a4h - imagPart pos)) + + -- Makes sure the given distance is an interal mulitple of a pixel + alignToPx :: Double -> Double + alignToPx x = fromIntegral (floor (x * px)) / px calcPositions :: Double -- ^ total width diff --git a/src/OidTableSVG.hs b/src/OidTableSVG.hs new file mode 100644 --- /dev/null +++ b/src/OidTableSVG.hs @@ -0,0 +1,172 @@ +module OidTableSVG where + +import Data.Word +import qualified Data.ByteString.Lazy as LB +import Control.Monad hiding (forM_) +import Data.Foldable (forM_) +import Text.Printf +import Control.Arrow ((***)) +import Data.String +import Data.Complex + +import qualified Text.Blaze.Svg11 as S +import qualified Text.Blaze.Svg11.Attributes as A +import Text.Blaze.Svg11 ((!)) +import Text.Blaze.Svg.Renderer.Utf8 + +import OidCode +import KnownCodes +import Types +import Utils + +type Point = Complex Double + +oidTableSvg :: Conf -> Bool -> String -> [(String, Word16)] -> LB.ByteString +oidTableSvg conf usePNG title entries + | entriesPerPage < 1 = error "OID codes too large to fit on a single page" + | otherwise = renderSvg $ + S.docTypeSvg ! A.version (S.toValue "1.1") + ! A.width (S.toValue (printf "%fmm" (a4w/mm) :: String)) + ! A.height (S.toValue (printf "%fmm" (a4h/mm) :: String)) + ! A.viewbox (S.toValue (printf "0 0 %f %f" a4w a4h :: String)) + ! A.fontFamily (S.toValue "sans-serif") + $ do + let patid d c | d == show c = d + | otherwise = printf "%s-%d" d c + + -- Create patterns for the codes + S.defs $ forM_ entries $ \(d,c) -> + case code2RawCode c of + Nothing -> return () + Just rc -> oidSVGPattern conf usePNG (patid d c) rc + + -- For SVG, we put all on one page (and exceed the page if it is too big) + let chunks = [entries] + let totalPages = length chunks + + forM_ (zip [1::Int ..] chunks) $ \(pageNum, thisPage) -> do + S.text_ ! A.x (S.toValue (a4w / 2)) + ! A.y (S.toValue (padTop + titleHeight)) + ! A.textAnchor (S.toValue "middle") + ! A.stroke (S.toValue "black") + ! A.fontSize (S.toValue (printf "%f" (12*pt) :: String)) + $ fromString title + + S.text_ ! A.x (S.toValue padLeft) + ! A.y (S.toValue (a4h - padBot)) + ! A.textAnchor (S.toValue "left") + ! A.stroke (S.toValue "black") + ! A.fontSize (S.toValue (printf "%f" (8*pt) :: String)) + $ fromString $ "Created by tttool-" ++ tttoolVersion + + + forM_ (zip thisPage positions) $ \((d,c), x :+ y) -> do + S.rect ! A.width (S.toValue imageWidth) + ! A.height (S.toValue imageHeight) + ! A.x (S.toValue x) + ! A.y (S.toValue y) + ! A.fill (S.toValue $ "url(#"++patid d c++")") + + S.text_ ! A.x (S.toValue x) + ! A.y (S.toValue (y + imageHeight + subtitleSep + subtitleHeight)) + ! A.textAnchor (S.toValue "left") + ! A.stroke (S.toValue "black") + ! A.fontSize (S.toValue (printf "%f" (8*pt) :: String)) + $ fromString d + where + -- Configure-dependent dimensions (all in pt) + (imageWidth,imageHeight) = (*mm) *** (*mm) $ fromIntegral *** fromIntegral $cCodeDim conf + + -- Static dimensions (all in pt) + + -- Page paddings + padTop, padLeft, padBot, padRight :: Double + padTop = 1*cm + padBot = 1*cm + padLeft = 2*cm + padRight = 2*cm + + titleHeight = 1*cm + titleSep = 0.5*cm + footerHeight = 0.5*cm + footerSep = 0.5*cm + + imageSepH = 0.4*cm + imageSepV = 0.2*cm + + subtitleHeight = 0.4*cm + subtitleSep = 0.2*cm + + -- Derived dimensions (all in pt) + {- + titleRect = Rectangle + (padLeft :+ (a4h - padTop - titleHeight)) + ((a4w - padRight) :+ (a4h - padTop)) + titleFont = Font (PDFFont Helvetica 12) black black + + footerRect = Rectangle + (padLeft :+ padBot) + ((a4w - padRight) :+ (padBot + footerHeight)) + footerFont = Font (PDFFont Helvetica 8) black black + + bodyFont = Font (PDFFont Helvetica 8) black black + -} + + bodyWidth = a4w - padLeft - padRight + bodyHeight = a4h - padTop - titleHeight - titleSep - footerSep - footerHeight - padBot + + + positions = map (+(padLeft :+ (padTop + titleHeight + titleSep))) $ + calcPositions bodyWidth bodyHeight + imageWidth (imageHeight + subtitleSep + subtitleHeight) + imageSepH imageSepV + entriesPerPage = length positions + + + -- Derived dimensions (all in pixels) + imageWidthPx = floor (imageWidth * px) + imageHeightPx = floor (imageHeight * px) + + -- config-dependent conversion factors + px :: Double + px = fromIntegral (cDPI conf) / 72 + + + {- + -- Makes sure the given point is at a coordinate that is a multiple + -- of an pixel + align :: Point -> Point + align pos = alignToPx (realPart pos) :+ (a4h - alignToPx (a4h - imagPart pos)) + + -- Makes sure the given distance is an interal mulitple of a pixel + alignToPx :: Double -> Double + alignToPx x = fromIntegral (floor (x * px)) / px + -} + +calcPositions + :: Double -- ^ total width + -> Double -- ^ total height + -> Double -- ^ entry width + -> Double -- ^ entry height + -> Double -- ^ pad width + -> Double -- ^ pad height + -> [Point] +calcPositions tw th ew eh pw ph = [ x :+ ({-(th - -} y) | y <- ys , x <- xs] + where + xs = [0,ew+pw..tw-ew] + ys = [0,eh+ph..th-eh] + +pt :: Double +pt = 48/2.83465 + +-- Conversation factor +cm :: Double +cm = 10 * mm + +mm :: Double +mm = 2.83465 * pt + +-- A4 dimensions +a4w, a4h :: Double +a4w = 595 * pt +a4h = 842 * pt diff --git a/src/TipToiYaml.hs b/src/TipToiYaml.hs --- a/src/TipToiYaml.hs +++ b/src/TipToiYaml.hs @@ -45,6 +45,7 @@ import Data.Traversable (for, traverse) import Control.Arrow import Control.Applicative (Applicative(..), (<*>), (<*)) +import qualified Control.Applicative import TextToSpeech import Language @@ -57,15 +58,15 @@ import TipToiYamlAux data TipToiYAML = TipToiYAML - { ttyScripts :: M.Map String [String] + { ttyScripts :: M.Map String (OptArray String) , ttyComment :: Maybe String , ttyGME_Lang :: Maybe String , ttyMedia_Path :: Maybe String , ttyInit :: Maybe String - , ttyWelcome :: Maybe String + , ttyWelcome :: Maybe PlayListListYaml , ttyProduct_Id :: Word32 , ttyScriptCodes :: Maybe CodeMap - , ttySpeak :: Maybe SpeakSpecs + , ttySpeak :: Maybe (OptArray SpeakSpec) , ttyLanguage :: Maybe Language , ttyGames :: Maybe [GameYaml] } @@ -94,25 +95,26 @@ toSpeakMap :: Language -> Maybe SpeakSpecs -> M.Map String (Language, String) toSpeakMap l Nothing = M.empty -toSpeakMap l (Just (SpeakSpecs specs)) = M.unionsWith e $ map go specs +toSpeakMap l (Just (OptArray specs)) = M.unionsWith e $ map go specs where - go (SpeakSpec ml m) = M.map ((l',)) m + go (SpeakSpec ml m) = M.map (l',) m where l' = fromMaybe l ml e = error "Conflicting definitions in section \"speak\"" -newtype SpeakSpecs = SpeakSpecs [SpeakSpec] +type SpeakSpecs = OptArray SpeakSpec -instance FromJSON SpeakSpecs where - parseJSON (Array a) = SpeakSpecs <$> mapM parseJSON (V.toList a) - parseJSON v = SpeakSpecs . (:[]) <$> parseJSON v +newtype OptArray a = OptArray { unOptArray :: [a] } -instance ToJSON SpeakSpecs where - toJSON (SpeakSpecs [x]) = toJSON x - toJSON (SpeakSpecs l) = Array $ V.fromList $ map toJSON $ l +instance FromJSON a => FromJSON (OptArray a) where + parseJSON v = OptArray <$> ((pure <$> parseJSON v) Control.Applicative.<|> parseJSON v) -type PlayListListYaml = String +instance ToJSON a => ToJSON (OptArray a) where + toJSON (OptArray [x]) = toJSON x + toJSON (OptArray l) = Array $ V.fromList $ map toJSON $ l +type PlayListListYaml = OptArray String + type OIDListYaml = String data GameYaml = CommonGameYaml @@ -299,7 +301,7 @@ , ttyComment = Just $ BC.unpack ttComment , ttyGME_Lang = if BC.null ttLang then Nothing else Just (BC.unpack ttLang) , ttyScripts = M.fromList - [ (show oid, map exportLine ls) | (oid, Just ls) <- ttScripts] + [ (show oid, OptArray $ map exportLine ls) | (oid, Just ls) <- ttScripts] , ttyMedia_Path = Just path , ttyScriptCodes = Nothing , ttySpeak = Nothing @@ -311,8 +313,12 @@ list2Maybe xs = Just xs playListList2Yaml :: PlayListList -> PlayListListYaml -playListList2Yaml = commas . map show . concat +playListList2Yaml = OptArray . map playList2Yaml +playList2Yaml :: PlayList -> String +playList2Yaml = commas . map show + + oidList2Yaml :: [OID] -> OIDListYaml oidList2Yaml = unwords . map show @@ -467,11 +473,11 @@ game2gameYaml Game253 = Game253Yaml playListListFromYaml :: PlayListListYaml -> WithFileNames PlayListList -playListListFromYaml = - fmap listify . - traverse recordFilename . - either error id . - parseOneLinePure parsePlayList "playlist" +playListListFromYaml (OptArray ws) = traverse + ( traverse recordFilename . + either error id . + parseOneLinePure parsePlayList "playlist" + ) ws where listify [] = [] listify x = [x] @@ -759,14 +765,14 @@ first = fst (M.findMin m) last = fst (M.findMax m) - welcome_names <- parseOneLine parsePlayList "welcome" (fromMaybe "" ttyWelcome) + welcome_names <- mapM (parseOneLine parsePlayList "welcome") (maybe [] unOptArray ttyWelcome) let ((prescripts, welcome, games), filenames) = resolveFileNames $ (,,) <$> for [first ..last] (\oid -> (oid ,) <$> - for (M.lookup oid m) (\raw_lines -> + for (M.lookup oid m) (\(OptArray raw_lines) -> forAn raw_lines (\i raw_line -> let d = printf "Line %d of OID %d" i oid (l,s) = either error id $ parseOneLinePure parseLine d raw_line @@ -774,7 +780,7 @@ ) ) ) <*> - traverse recordFilename welcome_names <*> + traverse (traverse recordFilename) welcome_names <*> traverse gameYaml2Game (fromMaybe [] ttyGames) preInitRegs <- M.fromList <$> parseOneLine parseInitRegs "init" (fromMaybe "" ttyInit) @@ -841,7 +847,7 @@ , ttComment = comment , ttDate = BC.pack date , ttLang = maybe BC.empty BC.pack ttyGME_Lang - , ttWelcome = [welcome] + , ttWelcome = welcome , ttInitialRegs = [fromMaybe 0 (M.lookup r initRegs) | r <- [0..maxReg]] , ttScripts = scripts' , ttGames = games @@ -1085,9 +1091,9 @@ , ttySpeak = Nothing , ttyComment = Nothing , ttyGME_Lang = Nothing - , ttyWelcome = Just $ "blob" + , ttyWelcome = Just (OptArray ["blob"]) , ttyScripts = M.fromList [ - (show oid, [line]) + (show oid, OptArray [line]) | oid <- [1..15000] , let chars = [oid `div` 10^p `mod` 10| p <-[4,3,2,1,0]] , let line = ppLine t $ Line 0 [] [Play n | n <- [0..5]] ([10] ++ chars) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -262,11 +262,20 @@ -- Command options +data ImageFormat = SVG { withPNG :: Bool } | PNG | PDF + deriving Show + +suffixOf :: ImageFormat -> String +suffixOf (SVG _) = "svg" +suffixOf PNG = "png" +suffixOf PDF = "pdf" + data Conf = Conf { cTransscriptFile :: Maybe FilePath , cCodeDim :: (Int, Int) , cDPI :: Int , cPixelSize :: Int + , cImageFormat :: Maybe ImageFormat } deriving Show diff --git a/src/tttool.hs b/src/tttool.hs --- a/src/tttool.hs +++ b/src/tttool.hs @@ -5,7 +5,9 @@ import Data.List (intercalate) import Options.Applicative.Help.Chunk import Data.Monoid +import Data.Maybe import Data.Foldable (asum) +import Data.Char (toLower) import Types import RangeParser @@ -31,6 +33,7 @@ <*> codeDim <*> dpi <*> pixelSize + <*> imageFormat transscript = optional $ strOption $ mconcat [ long "transscript" @@ -55,6 +58,29 @@ , help "Use this many pixels (squared) per dot in when creating OID codes." ] + imageFormat = optional $ option parseImageFormat $ mconcat + [ long "image-format" + , short 'f' + , metavar "Format" + , showDefaultWith showImageFormat + , help "image format to write: PNG, PDF, SVG, SVG+PNG (not all commands support all formats)" + ] + + showImageFormat PNG = "png" + showImageFormat PDF = "pdf" + showImageFormat (SVG True) = "svg+png" + showImageFormat (SVG False) = "png" + + parseImageFormat :: ReadM ImageFormat + parseImageFormat = eitherReader (go . map toLower) + where + go "png" = return PNG + go "pdf" = return PDF + go "svg" = return (SVG False) + go "svg+png" = return (SVG True) + go f = Left $ "Unknown image format " ++ f + + codeDim = option parseCodeDim $ mconcat [ long "code-dim" , metavar "W[xH]" @@ -345,30 +371,35 @@ oidTableCmd = command "oid-table" $ info parser $ - progDesc "creates a PDF file with all codes in the yaml file" + progDesc "creates a PDF or SVG file with all codes in the yaml file" where - parser = (\a b conf -> twoFiles "pdf" (genOidTable conf) a b) <$> yamlFileParser <*> outFileParser + parser = (\a b conf -> + let suffix = suffixOf (fromMaybe PDF (cImageFormat conf)) in + twoFiles suffix (genOidTable conf) a b + ) <$> yamlFileParser <*> outFileParser + outFileParser :: Parser (Maybe FilePath) outFileParser = optional $ strArgument $ mconcat [ metavar "OUT" - , help "PDF file to write" + , help "file to write (default: PDF)" ] oidCodesCmd :: Mod CommandFields (Conf -> IO ()) oidCodesCmd = command "oid-codes" $ info parser $ - progDesc "creates PNG files for every OID in the yaml file." <> + progDesc "creates files for every OID in the yaml file (default: PNG)." <> footerDoc foot where foot = unChunk $ vsepChunks - [ paragraph "Uses oid-.png as the file name." - , paragraph "Use the global options to configure size, resolution and blackness of the code (see ./tttool --help)." + [ paragraph "Uses oid-. as the file name." + , paragraph "Use the global options to configure size, file format" + , paragraph "resolution and blackness of the code (see ./tttool --help)." , paragraph $ "Note that it used to work to call \"tttool oid-code foo.yaml\". " ++ "Please use \"tttool oid-codes\" for that now." ] - parser = flip genPNGsForFile <$> yamlFileParser + parser = flip writeImagesForFile <$> yamlFileParser oidCodeCmd :: Mod CommandFields (Conf -> IO ()) oidCodeCmd = @@ -384,7 +415,7 @@ "Please use \"tttool oid-codes\" for that now." ] - parser =(\raw range c -> genPNGsForCodes raw c range) <$> rawCodeSwitchParser <*> codeRangeParser + parser =(\raw range c -> writeImagesForCodes raw c range) <$> rawCodeSwitchParser <*> codeRangeParser codeRangeParser :: Parser [Word16] codeRangeParser = argument (eitherReader parseRange) $ mconcat diff --git a/tttool.cabal b/tttool.cabal --- a/tttool.cabal +++ b/tttool.cabal @@ -1,5 +1,5 @@ name: tttool -version: 1.7.0.3 +version: 1.8 synopsis: Working with files for the Tiptoi® pen description: The Ravensburger Tiptoi® pen is programmed via special files. Their file format has been reverse engineered; this @@ -38,6 +38,7 @@ Language, OidCode, OidTable, + OidTableSVG, OneLineParser, PlaySound, PrettyPrint, @@ -51,13 +52,13 @@ Utils build-depends: - base >= 4.5 && < 4.10, + base >= 4.5 && < 4.11, binary >= 0.5 && < 0.9, containers == 0.4.* || == 0.5.*, directory >= 1.2 && < 1.4, executable-path == 0.0.*, filepath == 1.3.* || == 1.4.*, - template-haskell >= 2.7 && < 2.12, + template-haskell >= 2.7 && < 2.13, JuicyPixels >= 3.2.5 && < 3.3, aeson >= 0.7 && < 1.3, @@ -65,7 +66,7 @@ haskeline == 0.7.*, mtl == 2.1.* || == 2.2.*, parsec == 3.1.*, - process >= 1.1 && < 1.5, + process >= 1.1 && < 1.7, random >= 1.0 && < 1.2, vector >= 0.10 && < 0.13, yaml == 0.8.*, @@ -74,7 +75,10 @@ optparse-applicative >= 0.13 && < 0.15, spool == 0.1.*, zlib >= 0.5 && < 0.7, - natural-sort >= 0.1 && < 0.2 + natural-sort >= 0.1 && < 0.2, + blaze-svg == 0.3.*, + base64-bytestring == 1.0.*, + text == 1.2.* if impl(ghc < 7.5) build-depends: ghc-prim @@ -84,7 +88,7 @@ if flag(old-locale) build-depends: time == 1.4.*, old-locale else - build-depends: time >= 1.5 && < 1.8 + build-depends: time >= 1.5 && < 1.9 if flag(bytestring_has_builder) build-depends: