{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Hoodle.Render -- Copyright : (c) 2011-2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- -- collection of rendering routine -- ----------------------------------------------------------------------------- module Graphics.Hoodle.Render ( -- * xform Xform4Page(..) -- * simple rendering using non-R-structure , renderStrk , renderImg , renderBkg , renderItem , renderLayer , renderPage -- * simple rendering using R-structure , renderRBkg , renderRItem -- * render in bbox , renderRLayer_InBBox , renderRBkg_InBBox -- * render using buf , renderRBkg_Buf , renderRLayer_InBBoxBuf -- * buffer update , updateLayerBuf , updatePageBuf , updateHoodleBuf -- * construct R-structure from non-R-structure , cnstrctRLayer , cnstrctRBkg_StateT , cnstrctRPage_StateT , cnstrctRHoodle -- * some simple render with state , renderPage_StateT , initRenderContext ) where import Control.Applicative -- import Control.Concurrent (putMVar) import Control.Concurrent.STM import Control.Lens (view,set) import Control.Monad.Identity (runIdentity) import Control.Monad.State hiding (mapM,mapM_) import Control.Monad.Trans.Reader import qualified Data.ByteString.Char8 as C import Data.Foldable import qualified Data.HashMap.Strict as HM -- import qualified Data.Sequence as Seq (null) import Data.Traversable (mapM,sequenceA) -- import Data.UUID.V4 import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Cairo.SVG as RSVG import System.Directory (doesFileExist) import System.FilePath (takeExtension) -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Simple import Data.Hoodle.BBox import Data.Hoodle.Predefined import Data.Hoodle.Zipper -- from this package import Graphics.Hoodle.Render.Background import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Primitive import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Util -- import Prelude hiding (curry,uncurry,mapM,mapM_,concatMap) data Xform4Page = Xform4Page { transx :: Double , transy :: Double , scalex :: Double , scaley :: Double } deriving (Show) ------------ -- simple -- ------------ -- | render stroke renderStrk :: Stroke -> Cairo.Render () renderStrk s@(Stroke _ _ w d) = do let opacity = if stroke_tool s == "highlighter" then predefined_highlighter_opacity else 1.0 case getPenColor (stroke_color s) of Just (r,g,b,a) -> Cairo.setSourceRGBA r g b (a*opacity) Nothing -> Cairo.setSourceRGBA 0.5 0.5 0.5 1 Cairo.setLineWidth w Cairo.setLineCap Cairo.LineCapRound Cairo.setLineJoin Cairo.LineJoinRound drawStrokeCurve d Cairo.stroke renderStrk s@(VWStroke _ _ d) = do let opacity = if stroke_tool s == "highlighter" then predefined_highlighter_opacity else 1.0 case getPenColor (stroke_color s) of Just (r,g,b,a) -> Cairo.setSourceRGBA r g b (a*opacity) Nothing -> Cairo.setSourceRGBA 0.5 0.5 0.5 1 Cairo.setFillRule Cairo.FillRuleWinding drawVWStrokeCurve d Cairo.fill -- | render image : not fully implemented renderImg :: Image -> Cairo.Render () renderImg img@(Image src (x,y) (Dim w h)) = do let (x2,y2) = (x+w,y+h) -- imgbbx = BBox (x,y) (x2,y2) embed = getByteStringIfEmbeddedPNG src msfc <- liftIO $ case embed of Just bstr -> do sfc <- saveTempPNGToCreateSurface bstr return (Just sfc) Nothing -> do let filesrc = C.unpack (img_src img) filesrcext = takeExtension filesrc imgaction | filesrcext == ".PNG" || filesrcext == ".png" = do b <- doesFileExist filesrc if b then Just <$> Cairo.imageSurfaceCreateFromPNG filesrc else return Nothing | filesrcext == ".JPG" || filesrcext == ".jpg" = do b <- doesFileExist filesrc if b then Just <$> getJPGandCreateSurface filesrc else return Nothing | otherwise = return Nothing imgaction case msfc of Nothing -> do -- fall back Cairo.setSourceRGBA 0 0 0 1 Cairo.setLineWidth 10 Cairo.rectangle x y w h Cairo.stroke Just sfc -> do ix <- liftM fromIntegral (Cairo.imageSurfaceGetWidth sfc) iy <- liftM fromIntegral (Cairo.imageSurfaceGetHeight sfc) Cairo.save Cairo.translate x y Cairo.scale ((x2-x)/ix) ((y2-y)/iy) Cairo.setSourceSurface sfc 0 0 Cairo.paint Cairo.restore -- | render svg renderSVG :: SVG -> Cairo.Render () renderSVG svg@(SVG _ _ bstr _ _) = do let str = C.unpack bstr RSVG.withSvgFromString str $ \rsvg -> do let svgbbx = runIdentity (makeBBoxed svg) let (x,y) = (svg_pos . bbxed_content) svgbbx BBox (x1,y1) (x2,y2) = getBBox svgbbx (ix',iy') = RSVG.svgGetSize rsvg ix = fromIntegral ix' iy = fromIntegral iy' Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) RSVG.svgRender rsvg Cairo.restore return () -- | render svg renderLink :: Link -> Cairo.Render () renderLink lnk = let bstr = link_render lnk in if C.null bstr then do let lnkbbx = runIdentity (makeBBoxed lnk) bbox@(BBox (x0,y0) (x1,y1)) = getBBox lnkbbx clipBBox (Just bbox) Cairo.setSourceRGBA 0 1 0 1 Cairo.rectangle x0 y0 (x1-x0) (y1-y0) Cairo.fill Cairo.resetClip return () else do let str = C.unpack bstr RSVG.withSvgFromString str $ \rsvg -> do let lnkbbx = runIdentity (makeBBoxed lnk) let (x,y) = (link_pos . bbxed_content) lnkbbx BBox (x1,y1) (x2,y2) = getBBox lnkbbx (ix',iy') = RSVG.svgGetSize rsvg ix = fromIntegral ix' iy = fromIntegral iy' clipBBox (Just (getBBox lnkbbx)) Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) RSVG.svgRender rsvg Cairo.restore Cairo.resetClip return () -- | renderAnchor :: Anchor -> Cairo.Render () renderAnchor anc = let bstr = anchor_render anc in if C.null bstr then do let ancbbx = runIdentity (makeBBoxed anc) bbox@(BBox (x0,y0) (x1,y1)) = getBBox ancbbx clipBBox (Just bbox) Cairo.setSourceRGBA 1 0 0 1 Cairo.rectangle x0 y0 (x1-x0) (y1-y0) Cairo.fill Cairo.resetClip return () else do let str = C.unpack bstr RSVG.withSvgFromString str $ \rsvg -> do let ancbbx = runIdentity (makeBBoxed anc) let (x,y) = (anchor_pos . bbxed_content) ancbbx BBox (x1,y1) (x2,y2) = getBBox ancbbx (ix',iy') = RSVG.svgGetSize rsvg ix = fromIntegral ix' iy = fromIntegral iy' clipBBox (Just (getBBox ancbbx)) Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) RSVG.svgRender rsvg Cairo.restore Cairo.resetClip return () -- | render item renderItem :: Item -> Cairo.Render () renderItem (ItemStroke strk) = renderStrk strk renderItem (ItemImage img) = renderImg img renderItem (ItemSVG svg) = renderSVG svg renderItem (ItemLink lnk) = renderLink lnk renderItem (ItemAnchor anc) = renderAnchor anc -- | renderLayer renderLayer :: Layer -> Cairo.Render () renderLayer = mapM_ renderItem . view items -- | renderPage :: Page -> Cairo.Render () renderPage page = do renderBkg (view background page,view dimension page) Cairo.setLineCap Cairo.LineCapRound Cairo.setLineJoin Cairo.LineJoinRound mapM_ renderLayer . view layers $ page Cairo.stroke ----- -- R-structure ---- drawFallBackBkg :: Dimension -> Cairo.Render () drawFallBackBkg (Dim w h) = do Cairo.setSourceRGBA 1 1 1 1 Cairo.rectangle 0 0 w h Cairo.fill -- | renderRBkg :: RenderCache -> CanvasId -> (RBackground,Dimension, Maybe Xform4Page) -> Cairo.Render (RBackground,Dimension, Maybe Xform4Page) renderRBkg = renderRBkg_Buf -- | renderRItem :: RenderCache -> CanvasId -> RItem -> Cairo.Render RItem renderRItem _ _ itm@(RItemStroke strk) = renderStrk (bbxed_content strk) >> return itm renderRItem _cache _cid itm@(RItemImage img msfc) = do case msfc of Nothing -> renderImg (bbxed_content img) Just sfc -> do let (x,y) = (img_pos . bbxed_content) img BBox (x1,y1) (x2,y2) = getBBox img ix <- liftM fromIntegral (Cairo.imageSurfaceGetWidth sfc) iy <- liftM fromIntegral (Cairo.imageSurfaceGetHeight sfc) Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) Cairo.setSourceSurface sfc 0 0 Cairo.paint Cairo.restore return itm renderRItem _ _ itm@(RItemSVG svgbbx mrsvg) = do case mrsvg of Nothing -> renderSVG (bbxed_content svgbbx) Just rsvg -> do let (x,y) = (svg_pos . bbxed_content) svgbbx BBox (x1,y1) (x2,y2) = getBBox svgbbx (ix',iy') = RSVG.svgGetSize rsvg ix = fromIntegral ix' iy = fromIntegral iy' Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) RSVG.svgRender rsvg Cairo.restore return () return itm renderRItem _ _ itm@(RItemLink lnkbbx mrsvg) = do case mrsvg of Nothing -> renderLink (bbxed_content lnkbbx) Just rsvg -> do let (x,y) = (link_pos . bbxed_content) lnkbbx BBox (x1,y1) (x2,y2) = getBBox lnkbbx (ix',iy') = RSVG.svgGetSize rsvg ix = fromIntegral ix' iy = fromIntegral iy' Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) RSVG.svgRender rsvg Cairo.restore return () return itm renderRItem _ _ itm@(RItemAnchor ancbbx mrsvg) = do case mrsvg of Nothing -> renderAnchor (bbxed_content ancbbx) Just rsvg -> do let (x,y) = (anchor_pos . bbxed_content) ancbbx BBox (x1,y1) (x2,y2) = getBBox ancbbx (ix',iy') = RSVG.svgGetSize rsvg ix = fromIntegral ix' iy = fromIntegral iy' Cairo.save Cairo.translate x y Cairo.scale ((x2-x1)/ix) ((y2-y1)/iy) RSVG.svgRender rsvg Cairo.restore return () return itm ------------ -- InBBox -- ------------ -- | background drawing in bbox renderRBkg_InBBox :: RenderCache -> CanvasId -> Maybe BBox -> (RBackground,Dimension,Maybe Xform4Page) -> Cairo.Render (RBackground,Dimension, Maybe Xform4Page) renderRBkg_InBBox cache cid mbbox (b,dim,mx) = do clipBBox (fmap (flip inflate 1) mbbox) renderRBkg_Buf cache cid (b,dim,mx) Cairo.resetClip return (b,dim,mx) -- | render RLayer within BBox after hittest items renderRLayer_InBBox :: RenderCache -> CanvasId -> Maybe BBox -> (RLayer,Dimension,Maybe Xform4Page) -> Cairo.Render (RLayer, Dimension, Maybe Xform4Page) renderRLayer_InBBox = renderRLayer_InBBoxBuf ----------------------- -- draw using buffer -- ----------------------- adjustScale :: Double -> Maybe Xform4Page -> Cairo.Render () adjustScale s mx = case mx of Nothing -> Cairo.scale (1/s) (1/s) Just xform -> if (scalex xform /s > 0.999 && scalex xform /s < 1.001) then do Cairo.identityMatrix Cairo.translate (transx xform) (transy xform) else Cairo.scale (1/s) (1/s) -- | Background rendering using buffer renderRBkg_Buf :: RenderCache -> CanvasId -> (RBackground,Dimension,Maybe Xform4Page) -> Cairo.Render (RBackground,Dimension,Maybe Xform4Page) renderRBkg_Buf cache _cid (b,dim,mx) = do case HM.lookup (rbkg_surfaceid b) cache of Nothing -> drawFallBackBkg dim >> return () Just (s,sfc) -> do Cairo.save adjustScale s mx Cairo.setSourceSurface sfc 0 0 Cairo.paint Cairo.restore return (b,dim,mx) -- | renderRLayer_InBBoxBuf :: RenderCache -> CanvasId -> Maybe BBox -> (RLayer,Dimension,Maybe Xform4Page) -> Cairo.Render (RLayer,Dimension,Maybe Xform4Page) renderRLayer_InBBoxBuf cache _cid mbbox (lyr,dim,mx) = do case view gbuffer lyr of LyBuf sfcid -> do case HM.lookup sfcid cache of Nothing -> return (lyr,dim,mx) Just (s,sfc) -> do clipBBox (fmap (flip inflate 2) mbbox) -- clipBBox mbbox Cairo.save adjustScale s mx Cairo.setSourceSurface sfc 0 0 Cairo.paint Cairo.restore Cairo.resetClip return (lyr,dim,mx) ------------------- -- update buffer ------------------- -- | updateLayerBuf :: CanvasId -> RLayer -> Renderer () updateLayerBuf _cid lyr = do qgen <- rendererGenCmdQ <$> ask case view gbuffer lyr of LyBuf sfcid -> do cmdid <- issueGenCommandID (liftIO . atomically) (sendGenCommand qgen cmdid (LayerRedraw sfcid (view gitems lyr))) -- | updatePageBuf :: CanvasId -> RPage -> Renderer () updatePageBuf cid = mapM_ (updateLayerBuf cid) . view glayers -- | updateHoodleBuf :: CanvasId -> RHoodle -> Renderer () updateHoodleBuf cid = mapM_ (updatePageBuf cid) . view gpages ------- -- smart constructor for R hoodle structures ------- -- | cnstrctRHoodle :: Hoodle -> Renderer RHoodle cnstrctRHoodle hdl = do let hid = view hoodleID hdl ttl = view title hdl revs = view revisions hdl pgs = view pages hdl pdf = view embeddedPdf hdl txt = view embeddedText hdl (qpdf,_qgen) <- ((,) <$> rendererPDFCmdQ <*> rendererGenCmdQ)<$> ask mdoc <- maybe (return Nothing) (\src -> liftIO $ do cmdid <- issuePDFCommandID docvar <- atomically newEmptyTMVar atomically $ sendPDFCommand qpdf cmdid (GetDocFromDataURI src docvar) atomically $ takeTMVar docvar ) pdf let getNumPgs doc = liftIO $ do cmdid <- issuePDFCommandID nvar <- atomically newEmptyTMVar atomically $ sendPDFCommand qpdf cmdid (GetNPages doc nvar) atomically $ takeTMVar nvar mnumpdfpgs <- sequenceA (getNumPgs <$> mdoc) -- liftIO $print mnumpdfpgs npgs <- evalStateT (mapM cnstrctRPage_StateT pgs) (Just (Context "" "" Nothing mdoc)) return $ GHoodle hid ttl revs (PDFData <$> pdf <*> mnumpdfpgs) txt (fromList npgs) -- | cnstrctRPage_StateT :: Page -> StateT (Maybe Context) Renderer RPage cnstrctRPage_StateT pg = do let bkg = view background pg dim = view dimension pg lyrs = view layers pg nlyrs_lst <- lift (mapM cnstrctRLayer lyrs) sfcid <- issueSurfaceID let nlyrs_nonemptylst = if null nlyrs_lst then (emptyRLayer sfcid,[]) else (head nlyrs_lst,tail nlyrs_lst) nlyrs = fromNonEmptyList nlyrs_nonemptylst nbkg <- cnstrctRBkg_StateT dim bkg return $ GPage dim nbkg nlyrs -- | cnstrctRLayer :: Layer -> Renderer RLayer cnstrctRLayer lyr = do sfcid <- issueSurfaceID nitms <- (mapM cnstrctRItem . view items) lyr return (set gitems nitms (emptyRLayer sfcid)) ------------------------------------------------------- -- simple rendering with pdf (or global information) -- ------------------------------------------------------- -- | renderPage_StateT :: Page -> StateT Context Cairo.Render () renderPage_StateT pg = do let bkg = view background pg dim = view dimension pg lyrs = view layers pg renderBackground_StateT dim bkg lift (mapM_ renderLayer lyrs) -- | initRenderContext :: Hoodle -> IO Context initRenderContext hdl = do let pdf = view embeddedPdf hdl mdoc <- join <$> mapM popplerGetDocFromDataURI pdf return (Context "" "" Nothing mdoc)