carettah 0.0.5 → 0.0.6
raw patch · 5 files changed
+55/−45 lines, 5 filesdep +pangodep −uglymemo
Dependencies added: pango
Dependencies removed: uglymemo
Files
- Carettah.hs +7/−8
- Config.hs +4/−4
- Render.hs +42/−31
- carettah.cabal +2/−2
- data/turtle.png binary
Carettah.hs view
@@ -59,17 +59,16 @@ \y -> renderPngInline CairoCenter (CairoPosition y) CairoFit CairoFit 1 pngfile go (P.Header 1 strs) =- \y -> renderText CairoCenter (CairoPosition tty) tts (inlinesToString strs) >> return y+ \y -> renderTextM CairoCenter (CairoPosition tty) tts (inlinesToString strs) >> return y go (P.BulletList plains) = \y -> yposSequence y $ map go' plains where go' [P.Plain strs] =- \ypos -> renderText (CairoPosition tcx) (CairoPosition ypos) tcs ("☆ " ++ inlinesToString strs)+ \ypos -> renderTextM (CairoPosition tcx) (CairoPosition ypos) tcs ("☆ " ++ inlinesToString strs) go' x = error $ show x -- 一部のみをサポート- go (P.CodeBlock (_, _, _) ss) = \y -> yposSequence y $ map go' (lines ss)- where- go' s ypos = renderText (CairoPosition $ tcx + tcbo) (CairoPosition ypos) tcbs s+ go (P.CodeBlock (_, _, _) ss) = \y ->+ renderLayoutG (CairoPosition $ tcx + tcbo) (CairoPosition y) tcbs ss go (P.Para strs) =- \y -> renderText (CairoPosition tcx) (CairoPosition y) tcs (inlinesToString strs)+ \y -> renderTextM (CairoPosition tcx) (CairoPosition y) tcs (inlinesToString strs) go x = error $ show x -- 一部のみをサポート -- スライド表紙をRender@@ -85,9 +84,9 @@ go (P.Para [P.Image [P.Str "background"] (pngfile, _)]) = \y -> renderPngFit ag pngfile >> return y go (P.Header 1 strs) =- \y -> renderText CairoCenter (CairoPosition ttcy) ttcs (inlinesToString strs) >> return y+ \y -> renderTextM CairoCenter (CairoPosition ttcy) ttcs (inlinesToString strs) >> return y go (P.Para strs) =- \y -> renderText CairoCenter (CairoPosition tccy) tccs (inlinesToString strs) >> return y+ \y -> renderTextM CairoCenter (CairoPosition tccy) tccs (inlinesToString strs) >> return y go x = error $ show x -- 一部のみをサポート updateCanvas :: G.DrawingArea -> IO ()
Config.hs view
@@ -139,7 +139,7 @@ gCfg = Config { canvasW = 640, canvasH = 480,- alphaBackG = 0.5,+ alphaBackG = 0.4, textTitleCoverY = 170, textTitleCoverSize = 40, textContextCoverY = 300,@@ -147,10 +147,10 @@ textTitleY = 6, textTitleSize = 40, textContextX = 40,- textContextY = 96,+ textContextY = 90, textContextSize = 30,- textCodeBlockSize = 20,- textCodeBlockOfs = 20,+ textCodeBlockSize = 14,+ textCodeBlockOfs = 10, turtleSize = 40, waveSize = 20, waveCharMax = 53 -- xxxxxx 本来はwaveSizeから検出すべき手で数えんなよwwww
Render.hs view
@@ -1,11 +1,12 @@ module Render (clearCanvas, CairoPosition(..), CairoSize(..), toDouble, renderWave, renderTurtle, renderPngFit, renderPngInline,- renderText, yposSequence, renderSlide) where+ renderTextM, renderTextG, renderLayoutG, yposSequence,+ renderSlide) where import Data.Char import Data.Bits-import qualified Data.MemoUgly as M import System.FilePath ((</>),(<.>)) import Control.Monad.Reader+import qualified Graphics.UI.Gtk as G import qualified Graphics.Rendering.Cairo as C -- import Config@@ -16,21 +17,6 @@ data CairoSize = CairoSize Double | CairoFit 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@@ -47,15 +33,15 @@ toDouble :: Integral a => a -> Double toDouble = fromIntegral -mySetFontSize :: Double -> C.Render ()-mySetFontSize fsize = do- C.selectFontFace (toUTF "Takao P明朝") C.FontSlantNormal C.FontWeightNormal+mySetFontSize :: String -> Double -> C.Render ()+mySetFontSize fname fsize = do+ C.selectFontFace (toUTF fname) C.FontSlantNormal C.FontWeightNormal C.setFontSize fsize -renderText :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double-renderText x y fsize text = do+renderText' :: String -> CairoPosition -> CairoPosition -> Double -> String -> C.Render Double+renderText' fname x y fsize text = do C.save- mySetFontSize fsize+ mySetFontSize fname fsize (C.TextExtents _ yb w h _ _) <- C.textExtents (toUTF text) C.restore let truePosition (CairoPosition x') (CairoPosition y') = return (x', y')@@ -66,12 +52,37 @@ (xt, yt) <- truePosition x y let nypos = yt + h - yb C.save- mySetFontSize fsize+ mySetFontSize fname fsize C.moveTo xt nypos C.textPath $ toUTF text C.fill >> C.stroke >> C.restore return nypos +renderTextG :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double+renderTextG = renderText' "TakaoExゴシック"+renderTextM :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double+renderTextM = renderText' "Takao P明朝"++renderLayoutG :: CairoPosition -> CairoPosition -> Double -> String -> C.Render Double+renderLayoutG 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+ 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+ C.restore+ return $ yt + lh+ renderSurface :: Double -> Double -> Double -> C.Surface -> C.Render () renderSurface x y alpha surface = do C.save@@ -87,8 +98,7 @@ return (surface, w, h) renderPngSize :: Double -> Double -> Double -> Double -> Double -> FilePath -> C.Render Double---renderPngSize x y w h alpha file = memo6 f-renderPngSize = memo6 f+renderPngSize = f where f x y w h alpha file = do C.save (surface, iw, ih) <- pngSurfaceSize file@@ -101,7 +111,7 @@ return $ y + h renderPngInline :: CairoPosition -> CairoPosition -> CairoSize -> CairoSize -> Double -> FilePath -> C.Render Double-renderPngInline = memo6 f+renderPngInline = f where f CairoCenter (CairoPosition y) CairoFit CairoFit alpha file = do C.save (surface, iw, ih) <- pngSurfaceSize file@@ -114,15 +124,16 @@ scale = if wratio > hratio then hratio * 0.95 else wratio * 0.95 tiw = diw * scale tih = dih * scale+ y' = y + 10 C.scale scale scale- renderSurface ((cw / 2 - tiw / 2) / scale) (y / scale) alpha surface+ renderSurface ((cw / 2 - tiw / 2) / scale) (y' / scale) alpha surface C.surfaceFinish surface C.restore- return $ y + tih+ return $ y' + tih f _ _ _ _ _ _ = return 0 -- xxx renerPngFit統合して一関数にすべき renderPngFit :: Double -> FilePath -> C.Render ()-renderPngFit = memo2 f+renderPngFit = f where f alpha file = do C.save (surface, iw, ih) <- pngSurfaceSize file@@ -150,7 +161,7 @@ speechSec = 60 * smin charMax = waveCharMax gCfg numChar = round $ charMax * sec / speechSec- _ <- renderText (CairoPosition 0) (CairoPosition $ ch - ws) ws $ replicate numChar '>'+ _ <- renderTextM (CairoPosition 0) (CairoPosition $ ch - ws) ws $ replicate numChar '>' return () renderTurtle :: Double -> C.Render ()
carettah.cabal view
@@ -1,5 +1,5 @@ Name: carettah-Version: 0.0.5+Version: 0.0.6 Author: Kiwamu Okabe <kiwamu@debian.or.jp> Maintainer: Kiwamu Okabe <kiwamu@debian.or.jp> License: GPL-2@@ -25,7 +25,7 @@ pandoc, gtk, cairo,- uglymemo,+ pango, hcwiid other-modules: Paths_carettah Config Render WrapPaths ghc-options: -Wall
data/turtle.png view
binary file changed (54453 → 18251 bytes)