carettah 0.0.2 → 0.0.3
raw patch · 4 files changed
+120/−65 lines, 4 filesdep +uglymemo
Dependencies added: uglymemo
Files
- Carettah.hs +31/−14
- Config.hs +22/−10
- Render.hs +65/−40
- carettah.cabal +2/−1
Carettah.hs view
@@ -1,8 +1,12 @@ module Main where import System.Environment import System.Mem+import System.IO+import System.Console.GetOpt+import System.Exit import Data.Time import Data.Maybe+import Data.Version (showVersion) import Control.Monad.Reader --import Control.Monad.State --import Control.Monad.Trans@@ -10,10 +14,10 @@ import qualified Graphics.Rendering.Cairo as C import qualified Text.Pandoc as P import System.CWiid-import System.Console.GetOpt -- import Config import Render+import WrapPaths markdown :: String -> P.Pandoc markdown = P.readMarkdown P.defaultParserState{ P.stateStandalone = True }@@ -106,15 +110,20 @@ (OptArg ((\ f opts -> opts { optPdfOutput = Just f }) . fromMaybe "output.pdf") "FILE") "output PDF_FILE"+ , Option "t" ["time"]+ (OptArg ((\ f opts -> opts { optTime = Just $ read f }) . fromMaybe "5")+ "TIME(minute)")+ "set presentation time with minute" ] compilerOpts :: [String] -> IO (Options, [String]) compilerOpts argv =- let header = "Usage: carettah [OPTION...] FILE"+ let header = "\ncarettah version " ++ showVersion wrapVersion ++ "\n" +++ "Usage: carettah [OPTION...] FILE" in case getOpt Permute options argv of- (_,[],[] ) -> error $ usageInfo header options+ (_,[],[] ) -> hPutStrLn stderr (usageInfo header options) >> exitSuccess (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)- (_,_,errs) -> error (concat errs ++ usageInfo header options)+ (_,_,errs) -> hPutStrLn stderr (concat errs ++ usageInfo header options) >> exitFailure outputPDF :: String -> IO () outputPDF pdf = do@@ -126,10 +135,11 @@ C.withPDFSurface pdf dw dh $ flip C.renderWith . sequence_ $ fmap (\a -> renderSlide s a iw ih >> C.showPage) [0..(length s - 1)] -startPresentation :: Bool -> IO ()-startPresentation wiiOn = do- -- setup wiimote+startPresentation :: Bool -> Double -> IO ()+startPresentation wiiOn presenTime = do+ -- setup setWiiHandle wiiOn+ updateSpeechMinutes $ const presenTime -- start GUI _ <- G.initGUI window <- G.windowNew@@ -145,7 +155,9 @@ "q" -> G.widgetDestroy window "j" -> nextPage >> G.widgetQueueDraw canvas "k" -> prevPage >> G.widgetQueueDraw canvas- "r" -> print "TODO: reload slides" -- xxxxxxxxxxxxxxxxxxxxxxxxxxxxx+ "r" -> do md <- queryCarettahState markdownFname+ loadMarkdown md+ nextPage >> prevPage >> G.widgetQueueDraw canvas _ -> return () _ <- G.onDestroy window G.mainQuit _ <- G.onExpose canvas $ const (updateCanvas canvas >> return True)@@ -154,7 +166,7 @@ let dtime :: Double dtime = (fromRational . toRational) $ diffUTCTime ntime rtime- if dtime > 2 then G.widgetQueueDraw canvas >>+ if dtime > 5 then G.widgetQueueDraw canvas >> return True else do bf <- queryCarettahState wiiBtnFlag af <- updateWiiBtnFlag@@ -174,18 +186,23 @@ updateRenderdTime G.mainGUI +loadMarkdown :: String -> IO ()+loadMarkdown fn = do+ s <- readFile fn+ let z = zip (coverSlide:repeat blockToSlide) (splitBlocks $ markdown s)+ updateSlides $ const $ map (\p -> fst p . backgroundTop $ snd p) z+ main :: IO () main = do -- init updateStartTime updateRenderdTime -- opts- (Options {optWiimote = wiiOn, optPdfOutput = pdfFilen}, filen:_) <-+ (Options {optWiimote = wiiOn, optPdfOutput = pdfFilen, optTime = Just presenTime}, filen:_) <- compilerOpts =<< getArgs+ updateMarkdownFname $ const filen -- parse markdown- s <- readFile filen- let z = zip (coverSlide:repeat blockToSlide) (splitBlocks $ markdown s)- in updateSlides $ const $ map (\p -> fst p . backgroundTop $ snd p) z+ loadMarkdown filen case pdfFilen of Just pdf -> outputPDF pdf- Nothing -> startPresentation wiiOn+ Nothing -> startPresentation wiiOn presenTime
Config.hs view
@@ -1,8 +1,10 @@-module Config (gCfg, defaultOptions, Config(..), Options(..), CarettahState(..),+module Config (Config(..), Options(..), CarettahState(..),+ gCfg, defaultOptions, nextPage, prevPage, topPage, endPage, setWiiHandle, updateWiiBtnFlag, updateSlides, queryCarettahState,- updateStartTime, updateRenderdTime, elapsedSecFromStart) where+ updateStartTime, updateRenderdTime, elapsedSecFromStart,+ updateSpeechMinutes, updateMarkdownFname) where import Data.IORef import Data.Time@@ -13,11 +15,13 @@ data Options = Options { optWiimote :: Bool , optPdfOutput :: Maybe FilePath+ , optTime :: Maybe Double } deriving Show defaultOptions :: Options defaultOptions = Options { optWiimote = False , optPdfOutput = Nothing+ , optTime = Just 5 } data WiiHandle = NoWiiHandle | WiiHandle CWiidWiimote@@ -27,11 +31,13 @@ startTime :: UTCTime, renderdTime :: UTCTime, wiiHandle :: WiiHandle,- wiiBtnFlag :: CWiidBtnFlag+ wiiBtnFlag :: CWiidBtnFlag,+ speechMinutes :: Double,+ markdownFname :: String } carettahState :: IORef CarettahState-carettahState = unsafePerformIO $ newIORef CarettahState { page = 0, slides = undefined, startTime = undefined, renderdTime = undefined, wiiHandle = NoWiiHandle, wiiBtnFlag = CWiidBtnFlag 0 }+carettahState = unsafePerformIO $ newIORef CarettahState { page = 0, slides = undefined, startTime = undefined, renderdTime = undefined, wiiHandle = NoWiiHandle, wiiBtnFlag = CWiidBtnFlag 0 , speechMinutes = 5, markdownFname = "notfound.md"} updateCarettahState :: MonadIO m => (CarettahState -> CarettahState) -> m () updateCarettahState fn = liftIO $! atomicModifyIORef carettahState $ \st -> (fn st, ())@@ -95,6 +101,14 @@ return bs go wh +updateSpeechMinutes :: MonadIO m => (Double -> Double) -> m ()+updateSpeechMinutes fn =+ updateCarettahState (\s -> s { speechMinutes = fn $ speechMinutes s })++updateMarkdownFname :: MonadIO m => (String -> String) -> m ()+updateMarkdownFname fn =+ updateCarettahState (\s -> s { markdownFname = fn $ markdownFname s })+ -- constant value data Config = Config { --- posX,posY,fsizeの値は640x480の画面サイズが基準@@ -114,8 +128,7 @@ textCodeBlockOfs :: Double, turtleSize :: Double, waveSize :: Double,- waveCharMax :: Double,- speechMinutes :: Double+ waveCharMax :: Double } gCfg :: Config gCfg = Config {@@ -126,15 +139,14 @@ textTitleCoverSize = 40, textContextCoverY = 300, textContextCoverSize = 30,- textTitleY = 30,+ textTitleY = 6, textTitleSize = 40, textContextX = 40,- textContextY = 120,+ textContextY = 96, textContextSize = 30, textCodeBlockSize = 20, textCodeBlockOfs = 20, turtleSize = 40, waveSize = 20,- waveCharMax = 53, -- xxxxxx 本来はwaveSizeから検出すべき手で数えんなよwwww- speechMinutes = 14 -- xxxxx for 第0回 スタートHaskell+ waveCharMax = 53 -- xxxxxx 本来はwaveSizeから検出すべき手で数えんなよwwww }
Render.hs view
@@ -3,17 +3,34 @@ renderText, yposSequence, renderSlide) where import Data.Char import Data.Bits+import qualified Data.MemoUgly as M import System.FilePath ((</>),(<.>))-import Paths_carettah (getDataFileName) import Control.Monad.Reader import qualified Graphics.Rendering.Cairo as C-import Config(Config(..), gCfg, elapsedSecFromStart)+--+import Config+import WrapPaths (wrapGetDataFileName) data CairoPosition = CairoPosition Double | CairoCenter- deriving Show+ deriving (Show, Eq, Ord) data CairoSize = CairoSize Double | CairoFit- deriving Show+ deriving (Show, Eq, Ord) +-- memoize+memo2 :: (Ord a, Ord b) => (a -> b -> v) -> a -> b -> v+memo2 v = M.memo (M.memo . v)+memo3 :: (Ord a, Ord b, Ord c) => (a -> b -> c -> v) -> a -> b -> c -> v+memo3 v = M.memo (memo2 . v)+memo4 :: (Ord a, Ord b, Ord c, Ord d) =>+ (a -> b -> c -> d -> v) -> a -> b -> c -> d -> v+memo4 v = M.memo (memo3 . v)+memo5 :: (Ord a, Ord b, Ord c, Ord d, Ord e) =>+ (a -> b -> c -> d -> e -> v) -> a -> b -> c -> d -> e -> v+memo5 v = M.memo (memo4 . v)+memo6 :: (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f) =>+ (a -> b -> c -> d -> e -> f -> v) -> a -> b -> c -> d -> e -> f -> v+memo6 v = M.memo (memo5 . v)+ -- copy from System.Glib.UTFString (gtk2hs/glib/System/Glib/UTFString.hs) -- 本来はCStringを使うとこに埋め込んどくべき。gtk2hsを参考に toUTF :: String -> String@@ -70,44 +87,51 @@ return (surface, w, h) renderPngSize :: Double -> Double -> Double -> Double -> Double -> FilePath -> C.Render Double-renderPngSize x y w h alpha file = do- C.save- (surface, iw, ih) <- pngSurfaceSize file- let xscale = w / toDouble iw- let yscale = h / toDouble ih- C.scale xscale yscale- renderSurface (x / xscale) (y / yscale) alpha surface- C.restore- return $ y + h+--renderPngSize x y w h alpha file = memo6 f+renderPngSize = memo6 f+ where f x y w h alpha file = do+ C.save+ (surface, iw, ih) <- pngSurfaceSize file+ let xscale = w / toDouble iw+ let yscale = h / toDouble ih+ C.scale xscale yscale+ renderSurface (x / xscale) (y / yscale) alpha surface+ C.surfaceFinish surface+ C.restore+ return $ y + h renderPngInline :: CairoPosition -> CairoPosition -> CairoSize -> CairoSize -> Double -> FilePath -> C.Render Double-renderPngInline CairoCenter (CairoPosition y) CairoFit CairoFit alpha file = do- C.save- (surface, iw, ih) <- pngSurfaceSize file- let diw = toDouble iw- dih = toDouble ih- cw = toDouble (canvasW gCfg)- ch = toDouble (canvasH gCfg)- iratio = diw / dih- sratio = cw / ch- scale = if iratio > sratio then dih / ch * 0.9 else diw / cw * 0.9- tiw = diw * scale- tih = tih * scale- C.scale scale scale- renderSurface ((cw / 2 - tiw / 2) / scale) (y / scale) alpha surface- C.restore- return $ y + tih-renderPngInline _ _ _ _ _ _ = return 0 -- xxx renerPngFit統合して一関数にすべき+renderPngInline = memo6 f+ where f CairoCenter (CairoPosition y) CairoFit CairoFit alpha file = do+ C.save+ (surface, iw, ih) <- pngSurfaceSize file+ let diw = toDouble iw+ dih = toDouble ih+ cw = toDouble (canvasW gCfg)+ ch = toDouble (canvasH gCfg)+ wratio = cw / diw+ hratio = (ch - y) / dih+ scale = if wratio > hratio then hratio * 0.95 else wratio * 0.95+ tiw = diw * scale+ tih = dih * scale+ C.scale scale scale+ renderSurface ((cw / 2 - tiw / 2) / scale) (y / scale) alpha surface+ C.surfaceFinish surface+ C.restore+ return $ y + tih+ f _ _ _ _ _ _ = return 0 -- xxx renerPngFit統合して一関数にすべき renderPngFit :: Double -> FilePath -> C.Render ()-renderPngFit alpha file = do- C.save- (surface, iw, ih) <- pngSurfaceSize file- let cw = toDouble $ canvasW gCfg- ch = toDouble $ canvasH gCfg- C.scale (cw / toDouble iw) (ch / toDouble ih)- renderSurface 0 0 alpha surface- C.restore+renderPngFit = memo2 f+ where f alpha file = do+ C.save+ (surface, iw, ih) <- pngSurfaceSize file+ let cw = toDouble $ canvasW gCfg+ ch = toDouble $ canvasH gCfg+ C.scale (cw / toDouble iw) (ch / toDouble ih)+ renderSurface 0 0 alpha surface+ C.surfaceFinish surface+ C.restore clearCanvas :: Int -> Int -> C.Render () clearCanvas w h = do@@ -120,9 +144,10 @@ renderWave :: C.Render () renderWave = do sec <- liftIO elapsedSecFromStart+ smin <- queryCarettahState speechMinutes let ws = waveSize gCfg ch = toDouble $ canvasH gCfg- speechSec = 60 * speechMinutes gCfg+ speechSec = 60 * smin charMax = waveCharMax gCfg numChar = round $ charMax * sec / speechSec _ <- renderText (CairoPosition 0) (CairoPosition $ ch - ws) ws $ replicate numChar '>'@@ -130,7 +155,7 @@ renderTurtle :: Double -> C.Render () renderTurtle progress = do- fn <- liftIO . getDataFileName $ "data" </> "turtle" <.> "png"+ fn <- liftIO . wrapGetDataFileName $ "data" </> "turtle" <.> "png" renderPngSize (ts / 2 + (cw - ts * 2) * progress) (ch - ts) ts ts 1 fn >> return () where ts = turtleSize gCfg cw = toDouble $ canvasW gCfg
carettah.cabal view
@@ -1,5 +1,5 @@ Name: carettah-Version: 0.0.2+Version: 0.0.3 Author: Kiwamu Okabe <kiwamu@debian.or.jp> Maintainer: Kiwamu Okabe <kiwamu@debian.or.jp> License: GPL-2@@ -25,6 +25,7 @@ pandoc, gtk, cairo,+ uglymemo, hcwiid other-modules: Paths_carettah Config Render ghc-options: -Wall