module Graphics.Hoodle.Render
(
renderStrk
, renderImg
, renderBkg
, renderItem
, renderPage
, renderBkg_InBBox
, renderRBkg
, renderRItem
, renderRLayer_InBBox
, renderRBkg_InBBox
, renderRBkg_Buf
, renderRLayer_InBBoxBuf
, updateLayerBuf
, updatePageBuf
, updateHoodleBuf
, cnstrctRLayer
, cnstrctRBkg_StateT
, cnstrctRPage_StateT
, cnstrctRHoodle
) where
import Control.Lens (view,set,over)
import Control.Monad.State hiding (mapM,mapM_)
import Data.Foldable
import Data.Traversable (mapM)
import qualified Data.Map as M
import Data.Monoid
import Graphics.Rendering.Cairo
import Data.Hoodle.Generic
import Data.Hoodle.Simple
import Data.Hoodle.BBox
import Data.Hoodle.Predefined
#ifdef POPPLER
import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage
#endif
import Graphics.Hoodle.Render.Background
import Graphics.Hoodle.Render.Item
import Graphics.Hoodle.Render.Primitive
import Graphics.Hoodle.Render.Type
import Graphics.Hoodle.Render.Type.HitTest
import Graphics.Hoodle.Render.Util
import Graphics.Hoodle.Render.Util.HitTest
import Prelude hiding (curry,uncurry,mapM,mapM_,concatMap)
renderStrk :: Stroke -> Render ()
renderStrk s@(Stroke _ _ w d) = do
let opacity = if stroke_tool s == "highlighter"
then predefined_highlighter_opacity
else 1.0
case M.lookup (stroke_color s) predefined_pencolor of
Just (r,g,b,a) -> setSourceRGBA r g b (a*opacity)
Nothing -> setSourceRGBA 0 0 0 1
setLineWidth w
setLineCap LineCapRound
setLineJoin LineJoinRound
drawStrokeCurve d
stroke
renderStrk s@(VWStroke _ _ d) = do
let opacity = if stroke_tool s == "highlighter"
then predefined_highlighter_opacity
else 1.0
case M.lookup (stroke_color s) predefined_pencolor of
Just (r,g,b,a) -> setSourceRGBA r g b (a*opacity)
Nothing -> setSourceRGBA 0 0 0 1
setFillRule FillRuleWinding
drawVWStrokeCurve d
fill
renderImg :: Image -> Render ()
renderImg (Image _ (x,y) (Dim w h)) = do
setSourceRGBA 0 0 0 1
setLineWidth 10
rectangle x y w h
stroke
renderItem :: Item -> Render ()
renderItem (ItemStroke strk) = renderStrk strk
renderItem (ItemImage img) = renderImg img
renderBkg :: (Background,Dimension) -> Render ()
renderBkg (Background _typ col sty,Dim w h) = do
let c = M.lookup col predefined_bkgcolor
case c of
Just (r,g,b,_a) -> setSourceRGB r g b
Nothing -> setSourceRGB 1 1 1
rectangle 0 0 w h
fill
drawRuling w h sty
renderBkg (BackgroundPdf _ _ _ _,Dim w h) = do
setSourceRGBA 1 1 1 1
rectangle 0 0 w h
fill
renderPage :: Page -> Render ()
renderPage page = do
renderBkg (view background page,view dimension page)
setLineCap LineCapRound
setLineJoin LineJoinRound
mapM_ (mapM renderItem . view items) . view layers $ page
stroke
renderBkg_InBBox :: Maybe BBox -> Dimension -> Background -> Render ()
renderBkg_InBBox mbbox dim@(Dim w h) (Background typ col sty) = do
let mbbox2 = toMaybe $ fromMaybe mbbox `mappend` (Intersect (Middle (dimToBBox dim)))
case mbbox2 of
Nothing -> renderBkg (Background typ col sty,Dim w h)
Just bbox@(BBox (x1,y1) (x2,y2)) -> do
let c = M.lookup col predefined_bkgcolor
case c of
Just (r,g,b,_a) -> setSourceRGB r g b
Nothing -> setSourceRGB 1 1 1
rectangle x1 y1 (x2x1) (y2y1)
fill
drawRuling_InBBox bbox w h sty
renderBkg_InBBox _ _ (BackgroundPdf _ _ _ _) =
error "BackgroundPdf in renderBkg_InBBox"
renderRBkg :: (RBackground,Dimension) -> Render (RBackground,Dimension)
renderRBkg (r@(RBkgSmpl _ _ _),dim) = renderBkg (rbkg2Bkg r,dim) >> return (r,dim)
renderRBkg (r@(RBkgPDF _ _ _ p _),dim) = do
case p of
Nothing -> return ()
Just pg -> do
let Dim w h = dim
setSourceRGBA 1 1 1 1
rectangle 0 0 w h
fill
#ifdef POPPLER
PopplerPage.pageRender pg
#endif
return (r,dim)
renderRItem :: RItem -> Render RItem
renderRItem itm@(RItemStroke strk) = renderStrk (strkbbx_strk strk) >> return itm
renderRItem itm@(RItemImage img msfc) = do
case msfc of
Nothing -> renderImg (imgbbx_img img)
Just sfc -> do
let (x,y) = (img_pos . imgbbx_img) img
BBox (x1,y1) (x2,y2) = getBBox img
ix <- liftM fromIntegral (imageSurfaceGetWidth sfc)
iy <- liftM fromIntegral (imageSurfaceGetHeight sfc)
clipBBox (Just (getBBox img))
save
translate x y
scale ((x2x1)/ix) ((y2y1)/iy)
setSourceSurface sfc 0 0
paint
restore
resetClip
return itm
renderRBkg_InBBox :: Maybe BBox
-> (RBackground,Dimension)
-> Render (RBackground,Dimension)
renderRBkg_InBBox mbbox (b,dim) = do
case b of
RBkgSmpl _ _ _ -> do
clipBBox mbbox
renderRBkg_Buf (b,dim)
resetClip
RBkgPDF _ _ _ _ _ -> do
clipBBox mbbox
renderRBkg_Buf (b,dim)
resetClip
return (b,dim)
renderRLayer_InBBox :: Maybe BBox -> RLayer -> Render RLayer
renderRLayer_InBBox mbbox layer = do
clipBBox mbbox
let hittestbbox = case mbbox of
Nothing -> NotHitted []
:- Hitted (view gitems layer)
:- Empty
Just bbox -> (hltHittedByBBox bbox . view gitems) layer
(mapM_ renderRItem . concatMap unHitted . getB) hittestbbox
resetClip
return layer
renderRBkg_Buf :: (RBackground,Dimension)
-> Render (RBackground,Dimension)
renderRBkg_Buf (b,dim) = do
case b of
RBkgSmpl _ _ msfc -> do
case msfc of
Nothing -> renderRBkg (b,dim) >> return ()
Just sfc -> do
setSourceSurface sfc 0 0
paint
RBkgPDF _ _ _ _ msfc -> do
case msfc of
Nothing -> renderRBkg (b,dim) >> return ()
Just sfc -> do
setSourceSurface sfc 0 0
paint
return (b,dim)
renderRLayer_InBBoxBuf :: Maybe BBox -> RLayer -> Render RLayer
renderRLayer_InBBoxBuf mbbox lyr = do
case view gbuffer lyr of
LyBuf (Just sfc) -> do clipBBox mbbox
setSourceSurface sfc 0 0
paint
resetClip
_ -> renderRLayer_InBBox mbbox lyr >> return ()
return lyr
updateLayerBuf :: Maybe BBox -> RLayer -> IO RLayer
updateLayerBuf mbbox lyr = do
case view gbuffer lyr of
LyBuf (Just sfc) -> do
renderWith sfc $ do
clearBBox mbbox
renderRLayer_InBBox mbbox lyr
return lyr
_ -> return lyr
updatePageBuf :: RPage -> IO RPage
updatePageBuf pg = do
let dim = view gdimension pg
mbbox = Just . dimToBBox $ dim
nlyrs <- mapM (updateLayerBuf mbbox) . view glayers $ pg
return (set glayers nlyrs pg)
updateHoodleBuf :: RHoodle -> IO RHoodle
updateHoodleBuf hdl = do
let pgs = view gpages hdl
npgs <- mapM updatePageBuf pgs
return . set gpages npgs $ hdl
cnstrctRHoodle :: Hoodle -> IO RHoodle
cnstrctRHoodle hdl = do
let ttl = view title hdl
pgs = view pages hdl
npgs <- evalStateT (mapM cnstrctRPage_StateT pgs) Nothing
return . set gtitle ttl . set gpages (fromList npgs) $ emptyGHoodle
cnstrctRPage_StateT :: Page -> StateT (Maybe Context) IO RPage
cnstrctRPage_StateT pg = do
let bkg = view background pg
dim = view dimension pg
lyrs = view layers pg
nlyrs <- liftIO $ (liftM fromList . mapM cnstrctRLayer) lyrs
nbkg <- cnstrctRBkg_StateT dim bkg
return . set glayers nlyrs $ emptyGPage dim nbkg
cnstrctRLayer :: Layer -> IO RLayer
cnstrctRLayer lyr = do
nitms <- (mapM cnstrctRItem . view items) lyr
return (set gitems nitms emptyRLayer)
cnstrctRBkg_StateT :: Dimension -> Background
-> StateT (Maybe Context) IO RBackground
cnstrctRBkg_StateT dim@(Dim w h) bkg = do
let rbkg = bkg2RBkg bkg
case rbkg of
RBkgSmpl _c _s msfc -> do
case msfc of
Just _ -> return rbkg
Nothing -> do
sfc <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h)
renderWith sfc $ renderBkg (bkg,dim)
return rbkg { rbkg_cairosurface = Just sfc}
RBkgPDF md mf pn _ _ -> do
#ifdef POPPLER
mctxt <- get
case mctxt of
Nothing -> do
case (md,mf) of
(Just d, Just f) -> do
mdoc <- liftIO $ popplerGetDocFromFile f
put $ Just (Context d f mdoc)
case mdoc of
Just doc -> do
(mpg,msfc) <- liftIO $ popplerGetPageFromDoc doc pn
return (rbkg {rbkg_popplerpage = mpg, rbkg_cairosurface = msfc})
Nothing -> error "no pdf doc? in mkBkgPDF"
_ -> return rbkg
Just (Context _oldd _oldf olddoc) -> do
(mpage,msfc) <- case olddoc of
Just doc -> do
liftIO $ popplerGetPageFromDoc doc pn
Nothing -> return (Nothing,Nothing)
return $ RBkgPDF md mf pn mpage msfc
#else
return rbkg
#endif