carettah 0.0.7 → 0.1.0
raw patch · 5 files changed
+155/−126 lines, 5 filesdep +highlighting-kate
Dependencies added: highlighting-kate
Files
- Carettah.hs +40/−38
- Config.hs +9/−8
- FormatPangoMarkup.hs +27/−0
- Render.hs +74/−76
- carettah.cabal +5/−4
Carettah.hs view
@@ -9,6 +9,7 @@ import Data.Version (showVersion) import System.FilePath ((</>),(<.>)) import System.Directory (copyFile)+import Control.Monad import Control.Monad.Reader import qualified Graphics.UI.Gtk as G import qualified Graphics.Rendering.Cairo as C@@ -24,11 +25,12 @@ splitBlocks :: P.Pandoc -> [[P.Block]] splitBlocks (P.Pandoc _ blocks) = go blocks- where go (P.Header 1 h:xs) = let (b1, b2) = break (\a -> case a of- (P.Header 1 _) -> True- _ -> False) xs- in (P.Header 1 h:b1):go b2+ where go (P.Header 1 h:xs) =+ let (b1, b2) = break check xs+ in (P.Header 1 h:b1):go b2 go _ = []+ check (P.Header 1 _) = True+ check _ = False backgroundTop :: [P.Block] -> [P.Block] backgroundTop blocks = filter go blocks ++ filter (not . go) blocks@@ -43,7 +45,7 @@ -- 二枚目以降のスライドをRender blockToSlide :: [P.Block] -> [Double -> C.Render Double]-blockToSlide blockss = map go blockss+blockToSlide = map go where ag = alphaBackG gCfg tty = textTitleY gCfg@@ -56,24 +58,24 @@ go (P.Para [P.Image [P.Str "background"] (pngfile, _)]) = \y -> renderPngFit ag pngfile >> return y go (P.Para [P.Image [P.Str "inline"] (pngfile, _)]) =- \y -> renderPngInline CairoCenter (CairoPosition y) CairoFit- CairoFit 1 pngfile+ \y -> renderPngInline (CCenter, CPosition y) (CFit, CFit) + 1 pngfile go (P.Header 1 strs) =- \y -> renderTextM CairoCenter (CairoPosition tty) tts (inlinesToString strs) >> return y+ \y -> renderLayoutM (CCenter, CPosition tty) tts (inlinesToString strs) >> return y go (P.BulletList plains) = \y -> yposSequence y $ map go' plains where go' [P.Plain strs] =- \ypos -> renderTextM (CairoPosition tcx) (CairoPosition ypos) tcs ("☆ " ++ inlinesToString strs)+ \ypos -> renderLayoutM (CPosition tcx, CPosition ypos) tcs ("☆ " ++ inlinesToString strs) go' x = error $ show x -- 一部のみをサポート- go (P.CodeBlock (_, _, _) ss) = \y ->- renderLayoutG (CairoPosition $ tcx + tcbo) (CairoPosition y) tcbs ss+ go (P.CodeBlock attr ss) = \y ->+ renderLayoutG attr (CPosition $ tcx + tcbo, CPosition y) tcbs ss go (P.Para strs) =- \y -> renderTextM (CairoPosition tcx) (CairoPosition y) tcs (inlinesToString strs)+ \y -> renderLayoutM (CPosition tcx, CPosition y) tcs (inlinesToString strs) go x = error $ show x -- 一部のみをサポート -- スライド表紙をRender coverSlide :: [P.Block] -> [Double -> C.Render Double]-coverSlide blocks = map go blocks+coverSlide = map go where ag = alphaBackG gCfg ttcy = textTitleCoverY gCfg@@ -84,9 +86,9 @@ go (P.Para [P.Image [P.Str "background"] (pngfile, _)]) = \y -> renderPngFit ag pngfile >> return y go (P.Header 1 strs) =- \y -> renderTextM CairoCenter (CairoPosition ttcy) ttcs (inlinesToString strs) >> return y+ \y -> renderLayoutM (CCenter, CPosition ttcy) ttcs (inlinesToString strs) >> return y go (P.Para strs) =- \y -> renderTextM CairoCenter (CairoPosition tccy) tccs (inlinesToString strs) >> return y+ \y -> renderLayoutM (CCenter, CPosition tccy) tccs (inlinesToString strs) >> return y go x = error $ show x -- 一部のみをサポート updateCanvas :: G.DrawingArea -> IO ()@@ -146,12 +148,12 @@ setWiiHandle wiiOn updateSpeechMinutes $ const presenTime -- start GUI- _ <- G.initGUI+ void G.initGUI window <- G.windowNew canvas <- G.drawingAreaNew G.widgetSetSizeRequest window (canvasW gCfg) (canvasH gCfg) -- key event- _ <- window `G.on` G.keyPressEvent $ G.tryEvent $ do+ void $ window `G.on` G.keyPressEvent $ G.tryEvent $ do keyName <- G.eventKeyName liftIO $ case keyName of@@ -166,27 +168,27 @@ loadMarkdown md curPage >> G.widgetQueueDraw canvas _ -> return ()- _ <- G.onDestroy window G.mainQuit- _ <- G.onExpose canvas $ const (updateCanvas canvas >> return True)- _ <- G.timeoutAdd (do rtime <- queryCarettahState renderdTime- ntime <- getCurrentTime- let dtime :: Double- dtime = (fromRational . toRational) $- diffUTCTime ntime rtime- if dtime > 5 then G.widgetQueueDraw canvas >>- return True else do- bf <- queryCarettahState wiiBtnFlag- af <- updateWiiBtnFlag- let bs = af `diffCwiidBtnFlag` bf- go b | b == cwiidBtnA = nextPage >> G.widgetQueueDraw canvas- | b == cwiidBtnB = prevPage >> G.widgetQueueDraw canvas- | b == cwiidBtnUp = topPage >> G.widgetQueueDraw canvas- | b == cwiidBtnDown = endPage >> G.widgetQueueDraw canvas- | b == cwiidBtnPlus = G.windowFullscreen window- | b == cwiidBtnMinus = G.windowUnfullscreen window- | otherwise = return ()- go bs- return True) 50+ void $ G.onDestroy window G.mainQuit+ void $ G.onExpose canvas $ const (updateCanvas canvas >> return True)+ void $ G.timeoutAdd (do rtime <- queryCarettahState renderdTime+ ntime <- getCurrentTime+ let dtime :: Double+ dtime = (fromRational . toRational) $+ diffUTCTime ntime rtime+ if dtime > 5 then G.widgetQueueDraw canvas >>+ return True else do+ bf <- queryCarettahState wiiBtnFlag+ af <- updateWiiBtnFlag+ let bs = af `diffCwiidBtnFlag` bf+ go b | b == cwiidBtnA = nextPage >> G.widgetQueueDraw canvas+ | b == cwiidBtnB = prevPage >> G.widgetQueueDraw canvas+ | b == cwiidBtnUp = topPage >> G.widgetQueueDraw canvas+ | b == cwiidBtnDown = endPage >> G.widgetQueueDraw canvas+ | b == cwiidBtnPlus = G.windowFullscreen window+ | b == cwiidBtnMinus = G.windowUnfullscreen window+ | otherwise = return ()+ go bs+ return True) 50 G.set window [G.containerChild G.:= canvas] G.widgetShowAll window updateStartTime
Config.hs view
@@ -9,6 +9,7 @@ import Data.IORef import Data.Time import System.IO.Unsafe (unsafePerformIO)+import Control.Monad import Control.Monad.Reader import qualified Graphics.Rendering.Cairo as C import System.CWiid@@ -93,8 +94,8 @@ Nothing -> putStrLn "not found..." Just wmj -> do putStrLn "found!"- _ <- cwiidSetRptMode wmj- _ <- cwiidSetLed wmj+ void $ cwiidSetRptMode wmj+ void $ cwiidSetLed wmj updateCarettahState (\s -> s { wiiHandle = WiiHandle wmj }) | otherwise = return () @@ -143,15 +144,15 @@ canvasH = 480, alphaBackG = 0.4, textTitleCoverY = 170,- textTitleCoverSize = 40,+ textTitleCoverSize = 30, textContextCoverY = 300,- textContextCoverSize = 30,- textTitleY = 6,- textTitleSize = 40,+ textContextCoverSize = 28,+ textTitleY = 35,+ textTitleSize = 30, textContextX = 40, textContextY = 90,- textContextSize = 30,- textCodeBlockSize = 14,+ textContextSize = 22,+ textCodeBlockSize = 12, textCodeBlockOfs = 10, turtleSize = 40, waveSize = 20,
+ FormatPangoMarkup.hs view
@@ -0,0 +1,27 @@+module FormatPangoMarkup (formatPangoMarkup) where+import Text.Highlighting.Kate+import Graphics.Rendering.Pango++-- TODO: should use blaze-builder++tagTok :: Token -> String+tagTok (KeywordTok, s) = "<span foreground=\"#007020\" font_weight=\"bold\">" ++ escapeMarkup s ++ "</span>"+tagTok (DataTypeTok, s) = "<span foreground=\"#902000\">" ++ escapeMarkup s ++ "</span>"+tagTok (DecValTok, s) = "<span foreground=\"#40a070\">" ++ escapeMarkup s ++ "</span>"+tagTok (BaseNTok, s) = "<span foreground=\"#40a070\">" ++ escapeMarkup s ++ "</span>"+tagTok (FloatTok, s) = "<span foreground=\"#40a070\">" ++ escapeMarkup s ++ "</span>"+tagTok (CharTok, s) = "<span foreground=\"#4070a0\">" ++ escapeMarkup s ++ "</span>"+tagTok (StringTok, s) = "<span foreground=\"#4070a0\">" ++ escapeMarkup s ++ "</span>"+tagTok (CommentTok, s) = "<span foreground=\"#60a0b0\" background=\"lightgray\" font_style=\"italic\">" ++ escapeMarkup s ++ "</span>"+tagTok (OtherTok, s) = "<span foreground=\"#007020\">" ++ escapeMarkup s ++ "</span>"+tagTok (AlertTok, s) = "<span foreground=\"red\" font_weight=\"bold\">" ++ escapeMarkup s ++ "</span>"+tagTok (FunctionTok, s) = "<span foreground=\"#06287e\">" ++ escapeMarkup s ++ "</span>"+tagTok (RegionMarkerTok, s) = escapeMarkup s+tagTok (ErrorTok, s) = "<span foreground=\"red\" font_weight=\"bold\">" ++ escapeMarkup s ++ "</span>"+tagTok (NormalTok, s) = escapeMarkup s++tagLine :: SourceLine -> [String]+tagLine = fmap tagTok++formatPangoMarkup :: String -> String -> String+formatPangoMarkup lang = unlines . fmap (concat . tagLine) . highlightAs lang
Render.hs view
@@ -1,88 +1,83 @@-module Render (clearCanvas, CairoPosition(..), CairoSize(..), toDouble,+module Render (clearCanvas, CPosition(..), CSize(..), toDouble, renderWave, renderTurtle, renderPngFit, renderPngInline,- renderTextM, renderTextG, renderLayoutG, yposSequence,- renderSlide) where-import Data.Char-import Data.Bits+ renderLayoutG, renderLayoutM,+ yposSequence, renderSlide) where import System.FilePath ((</>),(<.>))+import Control.Monad import Control.Monad.Reader+import Text.Pandoc (Attr) import qualified Graphics.UI.Gtk as G import qualified Graphics.Rendering.Cairo as C --+import FormatPangoMarkup import Config import WrapPaths (wrapGetDataFileName) -data CairoPosition = CairoPosition Double | CairoCenter- deriving (Show, Eq, Ord)-data CairoSize = CairoSize Double | CairoFit- deriving (Show, Eq, Ord)---- copy from System.Glib.UTFString (gtk2hs/glib/System/Glib/UTFString.hs)--- 本来はCStringを使うとこに埋め込んどくべき。gtk2hsを参考に-toUTF :: String -> String-toUTF [] = []-toUTF (x:xs) | ord x<=0x007F = x:toUTF xs- | ord x<=0x07FF = chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):- chr (0x80 .|. (ord x .&. 0x3F)):- toUTF xs- | otherwise = chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):- chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):- chr (0x80 .|. (ord x .&. 0x3F)):- toUTF xs+data CPosition = CPosition Double | CCenter+ deriving (Show, Eq, Ord)+data CSize = CSize Double | CFit+ deriving (Show, Eq, Ord)+type CXy = (CPosition, CPosition)+type CWl = (CSize, CSize) toDouble :: Integral a => a -> Double toDouble = fromIntegral -mySetFontSize :: String -> Double -> C.Render ()-mySetFontSize fname fsize = do- C.selectFontFace (toUTF fname) C.FontSlantNormal C.FontWeightNormal- C.setFontSize fsize+type LayoutFunc = G.PangoLayout -> G.Markup -> IO () -renderText' :: String -> CairoPosition -> CairoPosition -> Double -> String -> C.Render Double-renderText' fname x y fsize text = do- C.save- mySetFontSize fname fsize- (C.TextExtents _ yb w h _ _) <- C.textExtents (toUTF text)- C.restore- let truePosition (CairoPosition x') (CairoPosition y') = return (x', y')- truePosition CairoCenter (CairoPosition y') =- return (toDouble (canvasW gCfg) / 2 - w / 2, y')- truePosition x' y' =- error $ "called with x=" ++ show x' ++ " y=" ++ show y'- (xt, yt) <- truePosition x y- let nypos = yt + h - yb- C.save- mySetFontSize fname fsize- C.moveTo xt nypos- C.textPath $ toUTF text- C.fill >> C.stroke >> C.restore- return nypos+stringToLayout :: String -> LayoutFunc -> CXy -> Double -> String -> IO (G.PangoLayout, Double, Double)+stringToLayout fname lFun (x, _) fsize text = do+ lay <- G.cairoCreateContext Nothing >>= G.layoutEmpty+ void $ lFun lay text+ G.layoutSetWrap lay G.WrapPartialWords+ setAW lay x+ fd <- liftIO G.fontDescriptionNew+ G.fontDescriptionSetSize fd fsize+ G.fontDescriptionSetFamily fd fname+ G.layoutSetFontDescription lay (Just fd)+ (_, G.PangoRectangle _ _ lw lh) <- G.layoutGetExtents lay+ -- xxx inkとlogicalの違いは？+ return (lay, lw, lh)+ where+ screenW = toDouble (canvasW gCfg)+ setAW lay CCenter = do+ G.layoutSetWidth lay (Just screenW)+ G.layoutSetAlignment lay G.AlignCenter+ setAW lay (CPosition x') = do+ G.layoutSetWidth lay (Just $ screenW - x' * 2)+ G.layoutSetAlignment lay G.AlignLeft -renderTextG :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double-renderTextG = renderText' "TakaoExゴシック"-renderTextM :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double-renderTextM = renderText' "Takao P明朝"+truePosition :: Double -> Double -> (CPosition, CPosition) -> (Double, Double)+truePosition fsize _ (CPosition x', CPosition y') = (x', y' + fsize)+truePosition _ _ (CCenter, CPosition y') = (0, y')+truePosition _ _ (x', y') =+ error $ "called with x=" ++ show x' ++ " y=" ++ show y' -renderLayoutG :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double-renderLayoutG x y fsize text = do+renderLayout' :: String -> LayoutFunc -> CXy -> Double -> String -> C.Render Double+renderLayout' fname lFun (x, y) fsize text = do C.save- ctxt <- liftIO $ G.cairoCreateContext Nothing- txt <- liftIO $ G.layoutEmpty ctxt- liftIO $ G.layoutSetText txt text- let truePosition (CairoPosition x') (CairoPosition y') = return (x', y' + 20)- truePosition x' y' =- error $ "called with x=" ++ show x' ++ " y=" ++ show y'- (xt, yt) <- truePosition x y+ (lay, lw, lh) <- liftIO $ stringToLayout fname lFun (x, y) fsize text+ let (xt, yt) = truePosition fsize lw (x, y) C.moveTo xt yt- fd <- liftIO G.fontDescriptionNew- liftIO $ G.fontDescriptionSetSize fd fsize- liftIO $ G.layoutSetFontDescription txt (Just fd)- (_, G.PangoRectangle _ _ _ lh) <-- liftIO $ G.layoutGetExtents txt -- xxx inkとlogicalの違いは？- G.showLayout txt+ G.showLayout lay C.restore return $ yt + lh +renderLayoutM :: CXy -> Double -> String -> C.Render Double+renderLayoutM = renderLayout' "IPA P明朝" G.layoutSetText++renderLayoutG' :: LayoutFunc -> CXy -> Double -> String -> C.Render Double+renderLayoutG' = renderLayout' "IPA X0208 ゴシック"++renderLayoutG :: Attr -> CXy -> Double -> String -> C.Render Double+renderLayoutG (_, [], _) xy fs txt = + renderLayoutG' G.layoutSetText xy fs txt+renderLayoutG (_, classs, _) xy fs txt =+ renderLayoutG' f xy fs txt'+ where+ txt' = formatPangoMarkup (head classs) txt+ f l t = void $ G.layoutSetMarkup l t+ renderSurface :: Double -> Double -> Double -> C.Surface -> C.Render () renderSurface x y alpha surface = do C.save@@ -95,13 +90,16 @@ surface <- liftIO $ C.imageSurfaceCreateFromPNG file w <- C.imageSurfaceGetWidth surface h <- C.imageSurfaceGetHeight surface- if (w, h) == (0, 0)- then do fn <- liftIO . wrapGetDataFileName $ "data" </> "notfound" <.> "png"- surface' <- liftIO $ C.imageSurfaceCreateFromPNG fn- w' <- C.imageSurfaceGetWidth surface'- h' <- C.imageSurfaceGetHeight surface'- return (surface', w', h')- else return (surface, w, h)+ ret surface w h+ where+ ret _ 0 0 = do + surface' <- liftIO $ + wrapGetDataFileName ("data" </> "notfound" <.> "png") >>= + C.imageSurfaceCreateFromPNG+ w' <- C.imageSurfaceGetWidth surface'+ h' <- C.imageSurfaceGetHeight surface'+ return (surface', w', h')+ ret s w h = return (s, w, h) renderPngSize :: Double -> Double -> Double -> Double -> Double -> FilePath -> C.Render Double renderPngSize = f@@ -116,9 +114,9 @@ C.restore return $ y + h -renderPngInline :: CairoPosition -> CairoPosition -> CairoSize -> CairoSize -> Double -> FilePath -> C.Render Double+renderPngInline :: CXy -> CWl -> Double -> FilePath -> C.Render Double renderPngInline = f- where f CairoCenter (CairoPosition y) CairoFit CairoFit alpha file = do+ where f (CCenter, CPosition y) (CFit, CFit) alpha file = do C.save (surface, iw, ih) <- pngSurfaceSize file let diw = toDouble iw@@ -136,7 +134,7 @@ C.surfaceFinish surface C.restore return $ y' + tih- f _ _ _ _ _ _ = return 0 -- xxx renerPngFit統合して一関数にすべき+ f _ _ _ _ = return 0 -- xxx renerPngFit統合して一関数にすべき renderPngFit :: Double -> FilePath -> C.Render () renderPngFit = f@@ -167,7 +165,7 @@ speechSec = 60 * smin charMax = waveCharMax gCfg numChar = round $ charMax * sec / speechSec- _ <- renderTextM (CairoPosition 0) (CairoPosition $ ch - ws) ws $ replicate numChar '>'+ void $ renderLayoutM (CPosition 0, CPosition $ ch - ws * 2) ws $ replicate numChar '>' return () renderTurtle :: Double -> C.Render ()@@ -189,7 +187,7 @@ ch = toDouble $ canvasH gCfg tcy = textContextY gCfg C.scale (toDouble w / cw) (toDouble h / ch)- _ <- yposSequence tcy s+ void $ yposSequence tcy s renderWave renderSlide :: [[Double -> C.Render Double]] -> Int -> Int -> Int -> C.Render ()
carettah.cabal view
@@ -1,5 +1,5 @@ Name: carettah-Version: 0.0.7+Version: 0.1.0 Author: Kiwamu Okabe <kiwamu@debian.or.jp> Maintainer: Kiwamu Okabe <kiwamu@debian.or.jp> License: GPL-2@@ -11,7 +11,7 @@ Cabal-Version: >= 1.6 Build-Type: Simple Homepage: http://carettah.masterq.net/-Tested-with: GHC == 7.0.4+Tested-with: GHC == 7.4.1 data-files: data/turtle.png, data/debian.png, data/notfound.png @@ -27,8 +27,9 @@ gtk, cairo, pango,- hcwiid- other-modules: Paths_carettah Config Render WrapPaths+ hcwiid,+ highlighting-kate+ other-modules: Paths_carettah Config Render WrapPaths FormatPangoMarkup ghc-options: -Wall ghc-prof-options: -auto-all -caf-all