tttool 1.7.0.3 → 1.8
raw patch · 8 files changed
+432/−89 lines, 8 filesdep +base64-bytestringdep +blaze-svgdep +textdep ~basedep ~processdep ~template-haskell
Dependencies added: base64-bytestring, blaze-svg, text
Dependency ranges changed: base, process, template-haskell, time
Files
- src/Commands.hs +40/−21
- src/OidCode.hs +110/−18
- src/OidTable.hs +20/−10
- src/OidTableSVG.hs +172/−0
- src/TipToiYaml.hs +32/−26
- src/Types.hs +9/−0
- src/tttool.hs +39/−8
- tttool.cabal +10/−6
src/Commands.hs view
@@ -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')
src/OidCode.hs view
@@ -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 ]
src/OidTable.hs view
@@ -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
+ src/OidTableSVG.hs view
@@ -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
src/TipToiYaml.hs view
@@ -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)
src/Types.hs view
@@ -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
src/tttool.hs view
@@ -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-<code>.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-<code>.<format> 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
tttool.cabal view
@@ -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: