hoodle-core-0.15: src/Hoodle/View/Draw.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.View.Draw
-- Copyright : (c) 2011-2015 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.View.Draw where
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Lens (view,set,at)
import Control.Monad (when)
import Data.Foldable hiding (elem)
import qualified Data.IntMap as M
import Data.Maybe hiding (fromMaybe)
import Data.Monoid
import Data.Sequence
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.UI.Gtk as Gtk
-- from hoodle-platform
import Data.Hoodle.BBox
import Data.Hoodle.Generic
import Data.Hoodle.Predefined
import Data.Hoodle.Select
import Data.Hoodle.Simple (Dimension(..),Stroke(..))
import Data.Hoodle.Zipper (currIndex)
import Graphics.Hoodle.Render
import Graphics.Hoodle.Render.Generic
import Graphics.Hoodle.Render.Highlight
import Graphics.Hoodle.Render.Type
import Graphics.Hoodle.Render.Type.HitTest
import Graphics.Hoodle.Render.Util
-- from this package
import Hoodle.Type.Alias
import Hoodle.Type.Canvas
import Hoodle.Type.PageArrangement
import Hoodle.Type.Enum
import Hoodle.Type.Predefined
import Hoodle.Type.Widget
import Hoodle.Util
import Hoodle.View.Coordinate
--
import Prelude hiding (mapM_,concatMap,foldr)
-- |
type family DrawingFunction (v :: ViewMode) :: * -> *
-- |
newtype SinglePageDraw a =
SinglePageDraw
{ unSinglePageDraw :: RenderCache
-> CanvasId
-> Bool -- ^ isCurrentCanvas
-> (Gtk.DrawingArea, Maybe Cairo.Surface)
-> (PageNum, Page a)
-> ViewInfo SinglePage
-> Maybe BBox
-> DrawFlag
-> IO (Page a) }
-- |
newtype ContPageDraw a =
ContPageDraw
{ unContPageDraw :: RenderCache
-> Bool -- ^ isCurrentCanvas
-> CanvasInfo ContinuousPage
-> Maybe BBox
-> Hoodle a
-> DrawFlag
-> IO (Hoodle a) }
-- |
type instance DrawingFunction SinglePage = SinglePageDraw
-- |
type instance DrawingFunction ContinuousPage = ContPageDraw
-- |
getCanvasViewPort :: CanvasGeometry -> ViewPortBBox
getCanvasViewPort geometry =
let DeskCoord (x0,y0) = canvas2Desktop geometry (CvsCoord (0,0))
CanvasDimension (Dim w h) = canvasDim geometry
DeskCoord (x1,y1) = canvas2Desktop geometry (CvsCoord (w,h))
in ViewPortBBox (BBox (x0,y0) (x1,y1))
-- |
getBBoxInPageCoord :: CanvasGeometry -> PageNum -> BBox -> BBox
getBBoxInPageCoord geometry pnum bbox =
let DeskCoord (x0,y0) = page2Desktop geometry (pnum,PageCoord (0,0))
in moveBBoxByOffset (-x0,-y0) bbox
-- |
getViewableBBox :: CanvasGeometry
-> Maybe BBox -- ^ in desktop coordinate
-> IntersectBBox
getViewableBBox geometry mbbox =
let ViewPortBBox vportbbox = getCanvasViewPort geometry
in (fromMaybe mbbox :: IntersectBBox) `mappend` (Intersect (Middle vportbbox))
-- | double buffering within two image surfaces
virtualDoubleBufferDraw :: (MonadIO m) =>
Cairo.Surface -- source surface
-> Cairo.Surface -- target surface
-> Cairo.Render () -- pre-render before source paint
-> Cairo.Render () -- post-render after source paint
-> m ()
virtualDoubleBufferDraw srcsfc tgtsfc pre post =
Cairo.renderWith tgtsfc $ do
pre
Cairo.setSourceSurface srcsfc 0 0
Cairo.setOperator Cairo.OperatorSource
Cairo.paint
Cairo.setOperator Cairo.OperatorOver
post
-- |
doubleBufferFlush :: Cairo.Surface -> CanvasInfo a -> IO ()
doubleBufferFlush sfc cinfo = do
let canvas = view drawArea cinfo
#ifdef GTK3
Just win <- Gtk.widgetGetWindow canvas
#else
win <- Gtk.widgetGetDrawWindow canvas
#endif
#ifdef GTK3
Gtk.renderWithDrawWindow win $ do
#else
Gtk.renderWithDrawable win $ do
#endif
Cairo.setSourceSurface sfc 0 0
Cairo.setOperator Cairo.OperatorSource
Cairo.paint
-- | common routine for double buffering
doubleBufferDraw :: (Gtk.DrawWindow, Maybe Cairo.Surface)
-> CanvasGeometry
-> Cairo.Render a
-> IntersectBBox
-> IO (Maybe a)
doubleBufferDraw (win,msfc) geometry rndr (Intersect ibbox) = do
let Dim cw ch = unCanvasDimension . canvasDim $ geometry
mbbox' = case ibbox of
Top -> Just (BBox (0,0) (cw,ch))
Middle bbox -> Just (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord) bbox)
Bottom -> Nothing
let action = do
case msfc of
Nothing -> do
#ifdef GTK3
Gtk.renderWithDrawWindow win $ do
#else
Gtk.renderWithDrawable win $ do
#endif
clipBBox mbbox'
Cairo.setSourceRGBA 0.5 0.5 0.5 1
Cairo.rectangle 0 0 cw ch
Cairo.fill
rndr
Just sfc -> do
r <- Cairo.renderWith sfc $ do
clipBBox mbbox'
Cairo.setSourceRGBA 0.5 0.5 0.5 1
Cairo.rectangle 0 0 cw ch
Cairo.fill
clipBBox mbbox'
rndr
#ifdef GTK3
Gtk.renderWithDrawWindow win $ do
#else
Gtk.renderWithDrawable win $ do
#endif
Cairo.setSourceSurface sfc 0 0
Cairo.setOperator Cairo.OperatorSource
Cairo.paint
return r
case ibbox of
Top -> Just <$> action
Middle _ -> Just <$> action
Bottom -> return Nothing
-- |
mkXform4Page :: CanvasGeometry -> PageNum -> Xform4Page
mkXform4Page geometry pnum =
let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0))
CvsCoord (x1,y1) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (1,1))
sx = x1-x0
sy = y1-y0
in Xform4Page x0 y0 sx sy
-- |
cairoXform4PageCoordinate :: Xform4Page -> Cairo.Render ()
cairoXform4PageCoordinate xform = do
Cairo.translate (transx xform) (transy xform)
Cairo.scale (scalex xform) (scaley xform)
-- |
data PressureMode = NoPressure | Pressure
-- |
drawCurvebitGen :: PressureMode
-> Gtk.DrawingArea
-> CanvasGeometry
-> Double
-> (Double,Double,Double,Double)
-> PageNum
-> Seq (Double,Double,Double)
-> ((Double,Double),Double)
-> ((Double,Double),Double)
-> IO ()
drawCurvebitGen pmode canvas geometry wdth (r,g,b,a) pnum pdraw ((x0,y0),z0) ((x,y),z) = do
#ifdef GTK3
Just win <- Gtk.widgetGetWindow canvas
#else
win <- Gtk.widgetGetDrawWindow canvas
#endif
#ifdef GTK3
Gtk.renderWithDrawWindow win $ do
#else
Gtk.renderWithDrawable win $ do
#endif
cairoXform4PageCoordinate (mkXform4Page geometry pnum)
Cairo.setSourceRGBA r g b a
case pmode of
NoPressure -> do
Cairo.setLineWidth wdth
case viewl pdraw of
EmptyL -> return ()
(xo,yo,_) :< rest -> do
Cairo.moveTo xo yo
mapM_ (\(x',y',_)-> Cairo.lineTo x' y') rest
Cairo.lineTo x y
Cairo.stroke
Pressure -> do
let wx0 = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z0
wy0 = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z0
wx = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z
wy = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z
Cairo.moveTo (x0-wx0) (y0-wy0)
Cairo.lineTo (x0+wx0) (y0+wy0)
Cairo.lineTo (x+wx) (y+wy)
Cairo.lineTo (x-wx) (y-wy)
Cairo.fill
-- |
drawFuncGen :: em
-> (RenderCache -> CanvasId -> (PageNum,Page em) -> Maybe BBox
-> DrawFlag -> Cairo.Render (Page em))
-> DrawingFunction SinglePage em
drawFuncGen _typ render = SinglePageDraw func
where func cache cid isCurrentCvs (canvas,msfc) (pnum,page) vinfo mbbox flag = do
let arr = view pageArrangement vinfo
geometry <- makeCanvasGeometry pnum arr canvas
#ifdef GTK3
Just win <- Gtk.widgetGetWindow canvas
#else
win <- Gtk.widgetGetDrawWindow canvas
#endif
let ibboxnew = getViewableBBox geometry mbbox
let mbboxnew = toMaybe ibboxnew
xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)
renderfunc = do
xformfunc
pg <- render cache cid (pnum,page) mbboxnew flag
-- Start Widget
when isCurrentCvs (emphasisCanvasRender ColorBlue geometry)
-- End Widget
Cairo.resetClip
return pg
doubleBufferDraw (win,msfc) geometry renderfunc ibboxnew
>>= maybe (return page) return
-- |
drawFuncSelGen :: (RenderCache -> CanvasId -> (PageNum,Page SelectMode) -> Maybe BBox
-> DrawFlag -> Cairo.Render ())
-> (RenderCache -> CanvasId -> (PageNum,Page SelectMode) -> Maybe BBox
-> DrawFlag -> Cairo.Render ())
-> DrawingFunction SinglePage SelectMode
drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\c i x y f -> rencont c i x y f >> rensel c i x y f >> return (snd x))
-- |
emphasisCanvasRender :: PenColor -> CanvasGeometry -> Cairo.Render ()
emphasisCanvasRender pcolor geometry = do
Cairo.identityMatrix
let CanvasDimension (Dim cw ch) = canvasDim geometry
let (r,g,b,a) = convertPenColorToRGBA pcolor
Cairo.setSourceRGBA r g b a
Cairo.setLineWidth 2
Cairo.rectangle 0 0 cw ch
Cairo.stroke
-- | highlight current page
emphasisPageRender :: CanvasGeometry -> (PageNum,Page EditMode) -> Cairo.Render ()
emphasisPageRender geometry (pn,pg) = do
Cairo.save
Cairo.identityMatrix
cairoXform4PageCoordinate (mkXform4Page geometry pn)
let Dim w h = view gdimension pg
Cairo.setSourceRGBA 0 0 1.0 1
Cairo.setLineWidth 2
Cairo.rectangle 0 0 w h
Cairo.stroke
Cairo.restore
-- | highlight notified item (like link)
emphasisNotifiedRender :: CanvasGeometry -> (PageNum,BBox,RItem) -> Cairo.Render ()
emphasisNotifiedRender geometry (pn,BBox (x1,y1) (x2,y2),_) = do
Cairo.save
Cairo.identityMatrix
cairoXform4PageCoordinate (mkXform4Page geometry pn)
Cairo.setSourceRGBA 1.0 1.0 0 0.1
Cairo.rectangle x1 y1 (x2-x1) (y2-y1)
Cairo.fill
Cairo.restore
-- |
drawContPageGen :: (RenderCache -> CanvasId -> (PageNum,Page EditMode) -> Maybe BBox
-> DrawFlag -> Cairo.Render (Int,Page EditMode))
-> DrawingFunction ContinuousPage EditMode
drawContPageGen render = ContPageDraw func
where func :: RenderCache -> Bool -> CanvasInfo ContinuousPage
-> Maybe BBox -> Hoodle EditMode -> DrawFlag -> IO (Hoodle EditMode)
func cache isCurrentCvs cinfo mbbox hdl flag = do
let cid = view canvasId cinfo
arr = view (viewInfo.pageArrangement) cinfo
pnum = PageNum . view currentPageNum $ cinfo
canvas = view drawArea cinfo
msfc = view mDrawSurface cinfo
geometry <- makeCanvasGeometry pnum arr canvas
let pgs = view gpages hdl
mcpg = view (at (unPageNum pnum)) pgs
let drawpgs = catMaybes . map f
$ (getPagesInViewPortRange geometry hdl)
where f k = maybe Nothing (\a->Just (k,a))
. M.lookup (unPageNum k) $ pgs
#ifdef GTK3
Just win <- Gtk.widgetGetWindow canvas
#else
win <- Gtk.widgetGetDrawWindow canvas
#endif
let ibboxnew = getViewableBBox geometry mbbox
let mbboxnew = toMaybe ibboxnew
xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)
onepagerender (pn,pg) = do
Cairo.identityMatrix
cairoXform4PageCoordinate (mkXform4Page geometry pn)
let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew
render cache cid (pn,pg) pgmbbox flag
renderfunc = do
xformfunc
ndrawpgs <- mapM onepagerender drawpgs
let npgs = foldr rfunc pgs ndrawpgs
where rfunc (k,pg) m = M.adjust (const pg) k m
let nhdl = set gpages npgs hdl
mapM_ (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg
mapM_ (emphasisNotifiedRender geometry) (view notifiedItem cinfo)
when isCurrentCvs (emphasisCanvasRender ColorRed geometry)
let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew
drawWidgets allWidgets hdl cinfo mbbox_canvas
Cairo.resetClip
return nhdl
doubleBufferDraw (win,msfc) geometry renderfunc ibboxnew
>>= maybe (return hdl) return
-- |
drawContPageSelGen :: (RenderCache -> CanvasId -> (PageNum,Page EditMode) -> Maybe BBox
-> DrawFlag -> Cairo.Render (Int,Page EditMode))
-> (RenderCache -> CanvasId -> (PageNum, Page SelectMode) -> Maybe BBox
-> DrawFlag -> Cairo.Render (Int,Page SelectMode))
-> DrawingFunction ContinuousPage SelectMode
drawContPageSelGen rendergen rendersel = ContPageDraw func
where func :: RenderCache -> Bool -> CanvasInfo ContinuousPage
-> Maybe BBox -> Hoodle SelectMode ->DrawFlag -> IO (Hoodle SelectMode)
func cache isCurrentCvs cinfo mbbox thdl flag = do
let cid = view canvasId cinfo
arr = view (viewInfo.pageArrangement) cinfo
pnum = PageNum . view currentPageNum $ cinfo
mtpage = view gselSelected thdl
canvas = view drawArea cinfo
msfc = view mDrawSurface cinfo
pgs = view gselAll thdl
mcpg = view (at (unPageNum pnum)) pgs
hdl = gSelect2GHoodle thdl
geometry <- makeCanvasGeometry pnum arr canvas
let drawpgs = catMaybes . map f
$ (getPagesInViewPortRange geometry hdl)
where f k = maybe Nothing (\a->Just (k,a))
. M.lookup (unPageNum k) $ pgs
#ifdef GTK3
Just win <- Gtk.widgetGetWindow canvas
#else
win <- Gtk.widgetGetDrawWindow canvas
#endif
let ibboxnew = getViewableBBox geometry mbbox
mbboxnew = toMaybe ibboxnew
onepagerender (pn,pg) = do
Cairo.identityMatrix
let xform = mkXform4Page geometry pn
cairoXform4PageCoordinate xform
rendergen cache cid (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag
selpagerender :: (PageNum, Page SelectMode)
-> Cairo.Render (Int, Page SelectMode)
selpagerender (pn,pg) = do
Cairo.identityMatrix
let xform = mkXform4Page geometry pn
cairoXform4PageCoordinate xform
rendersel cache cid (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag
renderfunc :: Cairo.Render (Hoodle SelectMode)
renderfunc = do
let xform = mkXform4Page geometry pnum
cairoXform4PageCoordinate xform
ndrawpgs <- mapM onepagerender drawpgs
let npgs = foldr rfunc pgs ndrawpgs
where rfunc (k,pg) m = M.adjust (const pg) k m
let nthdl :: Hoodle SelectMode
nthdl = set gselAll npgs thdl
r <- runMaybeT $ do (n,tpage) <- MaybeT (return mtpage)
lift (selpagerender (PageNum n,tpage))
let nthdl2 = set gselSelected r nthdl
maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg
mapM_ (emphasisNotifiedRender geometry) (view notifiedItem cinfo)
when isCurrentCvs (emphasisCanvasRender ColorGreen geometry)
let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew
drawWidgets allWidgets hdl cinfo mbbox_canvas
Cairo.resetClip
return nthdl2
doubleBufferDraw (win,msfc) geometry renderfunc ibboxnew
>>= maybe (return thdl) return
-- |
drawSinglePage :: CanvasGeometry -> DrawingFunction SinglePage EditMode
drawSinglePage geometry = drawFuncGen EditMode f
where
f cache cid (pnum,page) mbbox flag = do
let xform = mkXform4Page geometry pnum
case flag of
Clear -> do (pg',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (page,Just xform)
return pg'
BkgEfficient -> do (InBBoxBkgBuf pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf page, Just xform)
return pg'
Efficient -> do (InBBox pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox page, Just xform)
return pg'
-- |
drawSinglePageSel :: CanvasGeometry -> DrawingFunction SinglePage SelectMode
drawSinglePageSel geometry = drawFuncSelGen rendercontent renderselect
where rendercontent cache cid (pnum,tpg) mbbox flag = do
let pg' = hPage2RPage tpg
xform = mkXform4Page geometry pnum
case flag of
Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (pg',Just xform) >> return ()
BkgEfficient -> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf pg',Just xform) >> return ()
Efficient -> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox pg',Just xform) >> return ()
return ()
renderselect _cache _cid (_pnum,tpg) mbbox _flag = do
cairoHittedBoxDraw geometry tpg mbbox
return ()
-- |
drawContHoodle :: CanvasGeometry -> DrawingFunction ContinuousPage EditMode
drawContHoodle geometry = drawContPageGen f
where
f cache cid (pnum@(PageNum n),page) mbbox flag = do
let xform = mkXform4Page geometry pnum
case flag of
Clear -> do (p',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (page, Just xform)
return (n, p')
BkgEfficient -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf page, Just xform)
return (n, unInBBoxBkgBuf p')
Efficient -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox page, Just xform)
return (n, unInBBox p')
-- |
drawContHoodleSel :: CanvasGeometry
-> DrawingFunction ContinuousPage SelectMode
drawContHoodleSel geometry = drawContPageSelGen renderother renderselect
where renderother cache cid (pnum@(PageNum n),page) mbbox flag = do
let xform = mkXform4Page geometry pnum
case flag of
Clear -> (,) n . fst <$> cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (page,Just xform)
BkgEfficient -> (,) n . unInBBoxBkgBuf . fst <$> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf page,Just xform)
Efficient -> (,) n . unInBBox . fst <$> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox page,Just xform)
renderselect _cache _cid (PageNum n,tpg) mbbox _flag = do
cairoHittedBoxDraw geometry tpg mbbox
return (n,tpg)
-- |
cairoHittedBoxDraw :: CanvasGeometry
-> Page SelectMode
-> Maybe BBox
-> Cairo.Render ()
cairoHittedBoxDraw geometry tpg mbbox = do
let layers = view glayers tpg
slayer = view selectedLayer layers
case unTEitherAlterHitted . view gitems $ slayer of
Right alist -> do
clipBBox mbbox
Cairo.setSourceRGBA 0.0 0.0 1.0 1.0
let hititms = concatMap unHitted (getB alist)
mapM_ renderSelectedItem hititms
let ulbbox = unUnion . mconcat . fmap (Union .Middle . getBBox)
$ hititms
case ulbbox of
Middle bbox -> renderSelectHandle geometry bbox
_ -> return ()
Cairo.resetClip
Left _ -> return ()
-- |
renderLasso :: CanvasGeometry -> Seq (Double,Double) -> Cairo.Render ()
renderLasso geometry lst = do
let z = canvas2DesktopRatio geometry
Cairo.setLineWidth (predefinedLassoWidth*z)
uncurry4 Cairo.setSourceRGBA predefinedLassoColor
let (dasha,dashb) = predefinedLassoDash
adjusteddash = (fmap (*z) dasha,dashb*z)
uncurry Cairo.setDash adjusteddash
case viewl lst of
EmptyL -> return ()
x :< xs -> do uncurry Cairo.moveTo x
mapM_ (uncurry Cairo.lineTo) xs
Cairo.stroke
-- |
renderBoxSelection :: BBox -> Cairo.Render ()
renderBoxSelection bbox = do
Cairo.setLineWidth predefinedLassoWidth
uncurry4 Cairo.setSourceRGBA predefinedLassoColor
uncurry Cairo.setDash predefinedLassoDash
let (x1,y1) = bbox_upperleft bbox
(x2,y2) = bbox_lowerright bbox
Cairo.rectangle x1 y1 (x2-x1) (y2-y1)
Cairo.stroke
-- |
renderSelectedStroke :: BBoxed Stroke -> Cairo.Render ()
renderSelectedStroke str = do
Cairo.setLineWidth 1.5
Cairo.setSourceRGBA 0 0 1 1
renderStrkHltd str
-- |
renderSelectedItem :: RItem -> Cairo.Render ()
renderSelectedItem itm = do
Cairo.setLineWidth 1.5
Cairo.setSourceRGBA 0 0 1 1
renderRItemHltd itm
-- |
canvas2DesktopRatio :: CanvasGeometry -> Double
canvas2DesktopRatio geometry =
let DeskCoord (tx1,_) = canvas2Desktop geometry (CvsCoord (0,0))
DeskCoord (tx2,_) = canvas2Desktop geometry (CvsCoord (1,0))
in tx2-tx1
-- |
renderSelectHandle :: CanvasGeometry -> BBox -> Cairo.Render ()
renderSelectHandle geometry bbox = do
let z = canvas2DesktopRatio geometry
Cairo.setLineWidth (predefinedLassoWidth*z)
uncurry4 Cairo.setSourceRGBA predefinedLassoColor
let (dasha,dashb) = predefinedLassoDash
adjusteddash = (fmap (*z) dasha,dashb*z)
uncurry Cairo.setDash adjusteddash
let (x1,y1) = bbox_upperleft bbox
(x2,y2) = bbox_lowerright bbox
hsize = predefinedLassoHandleSize*z
Cairo.rectangle x1 y1 (x2-x1) (y2-y1)
Cairo.stroke
Cairo.setSourceRGBA 1 0 0 0.8
Cairo.rectangle (x1-hsize) (y1-hsize) (2*hsize) (2*hsize)
Cairo.fill
Cairo.setSourceRGBA 1 0 0 0.8
Cairo.rectangle (x1-hsize) (y2-hsize) (2*hsize) (2*hsize)
Cairo.fill
Cairo.setSourceRGBA 1 0 0 0.8
Cairo.rectangle (x2-hsize) (y1-hsize) (2*hsize) (2*hsize)
Cairo.fill
Cairo.setSourceRGBA 1 0 0 0.8
Cairo.rectangle (x2-hsize) (y2-hsize) (2*hsize) (2*hsize)
Cairo.fill
Cairo.setSourceRGBA 0.5 0 0.2 0.8
Cairo.rectangle (x1-hsize*0.6) (0.5*(y1+y2)-hsize*0.6) (1.2*hsize) (1.2*hsize)
Cairo.fill
Cairo.setSourceRGBA 0.5 0 0.2 0.8
Cairo.rectangle (x2-hsize*0.6) (0.5*(y1+y2)-hsize*0.6) (1.2*hsize) (1.2*hsize)
Cairo.fill
Cairo.setSourceRGBA 0.5 0 0.2 0.8
Cairo.rectangle (0.5*(x1+x2)-hsize*0.6) (y1-hsize*0.6) (1.2*hsize) (1.2*hsize)
Cairo.fill
Cairo.setSourceRGBA 0.5 0 0.2 0.8
Cairo.rectangle (0.5*(x1+x2)-hsize*0.6) (y2-hsize*0.6) (1.2*hsize) (1.2*hsize)
Cairo.fill
-- |
canvasImageSurface :: RenderCache
-> CanvasId
-> Maybe Double -- ^ multiply
-> CanvasGeometry
-> Hoodle EditMode
-> IO (Cairo.Surface,Dimension)
canvasImageSurface cache cid mmulti geometry hdl = do
let ViewPortBBox bbx_desk = getCanvasViewPort geometry
nbbx_desk = case mmulti of
Nothing -> bbx_desk
Just z -> let (x0,y0) = bbox_upperleft bbx_desk
(x1,y1) = bbox_lowerright bbx_desk
Dim ws_desk hs_desk = bboxToDim bbx_desk
in BBox (x0-z*ws_desk,y0-z*hs_desk) (x1+z*ws_desk,y1+z*hs_desk)
nbbx_cvs =
xformBBox ( unCvsCoord . desktop2Canvas geometry . DeskCoord ) nbbx_desk
nvport = ViewPortBBox nbbx_desk
Dim w_cvs h_cvs = bboxToDim nbbx_cvs
let pgs = view gpages hdl
drawpgs = (catMaybes . map f . getPagesInRange geometry nvport) hdl
where f k = maybe Nothing (\a -> Just (k,a)) . M.lookup (unPageNum k) $ pgs
onepagerender (pn,pg) = do
Cairo.identityMatrix
case mmulti of
Nothing -> return ()
Just z -> do
let (ws_cvs,hs_cvs) = (w_cvs/(2*z+1),h_cvs/(2*z+1))
Cairo.translate (z*ws_cvs) (z*hs_cvs)
let xform = mkXform4Page geometry pn
cairoXform4PageCoordinate xform
cairoRenderOption (InBBoxOption Nothing) cache cid (InBBox pg, Nothing :: Maybe Xform4Page)
renderfunc = do
Cairo.setSourceRGBA 0.5 0.5 0.5 1
Cairo.rectangle 0 0 w_cvs h_cvs
Cairo.fill
mapM_ onepagerender drawpgs
print (Prelude.length drawpgs)
sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor w_cvs) (floor h_cvs)
Cairo.renderWith sfc renderfunc
return (sfc, Dim w_cvs h_cvs)
---------------------------------------------------
-- Widgets --
---------------------------------------------------
-- |
drawWidgets :: [WidgetItem]
-> Hoodle EditMode
-> CanvasInfo a
-> Maybe BBox
-> Cairo.Render ()
drawWidgets witms hdl cinfo mbbox = do
when (PanZoomWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUsePanZoomWidget) cinfo) $
renderPanZoomWidget (view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) cinfo)
mbbox (view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo)
when (LayerWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseLayerWidget) cinfo)
(drawLayerWidget hdl cinfo mbbox (view (canvasWidgets.layerWidgetConfig.layerWidgetPosition) cinfo))
when (ClockWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseClockWidget) cinfo) $
renderClockWidget mbbox (view (canvasWidgets.clockWidgetConfig) cinfo)
when (ScrollWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseScrollWidget) cinfo) $
renderScrollWidget mbbox (view (canvasWidgets.scrollWidgetConfig) cinfo)
---------------------
-- Pan Zoom Widget --
---------------------
-- |
renderPanZoomWidget :: Bool -> Maybe BBox -> CanvasCoordinate -> Cairo.Render ()
renderPanZoomWidget b mbbox (CvsCoord (x,y)) = do
Cairo.identityMatrix
clipBBox mbbox
Cairo.setSourceRGBA 0.5 0.5 0.2 0.3
Cairo.rectangle x y 100 100
Cairo.fill
Cairo.setSourceRGBA 0.2 0.2 0.7 0.5
Cairo.rectangle (x+10) (y+10) 40 80
Cairo.fill
Cairo.setSourceRGBA 0.2 0.7 0.2 0.5
Cairo.rectangle (x+50) (y+10) 40 80
Cairo.fill
Cairo.setSourceRGBA 0.7 0.2 0.2 (if b then 1.0 else 0.5)
Cairo.rectangle (x+30) (y+30) 40 40
Cairo.fill
Cairo.setSourceRGBA 0.5 0.5 0.5 0.5
Cairo.rectangle x y 10 10
Cairo.fill
Cairo.setSourceRGBA 0 0 0 0.7
Cairo.setLineWidth 1
Cairo.moveTo x y
Cairo.lineTo (x+10) (y+10)
Cairo.stroke
Cairo.moveTo x (y+10)
Cairo.lineTo (x+10) y
Cairo.stroke
Cairo.resetClip
------------------
-- Layer Widget --
------------------
drawLayerWidget :: Hoodle EditMode
-> CanvasInfo a
-> Maybe BBox
-> CanvasCoordinate
-> Cairo.Render ()
drawLayerWidget hdl cinfo mbbox cvscoord = do
let cpn = view currentPageNum cinfo
lc = view (canvasWidgets.layerWidgetConfig) cinfo
runMaybeT $ do
pg <- MaybeT . return $ view (gpages.at cpn) hdl
let lyrs = view glayers pg
n = currIndex lyrs
-- l = current lyrs
lift $ renderLayerWidget (show n) mbbox cvscoord
when (view layerWidgetShowContent lc) $ do
liftIO $ putStrLn "drawLayerWidget: not implemented"
-- sfc <- MaybeT . return $ msfc
-- lift $ renderLayerContent mbbox (view gdimension pg) sfc cvscoord
return ()
renderLayerContent :: Maybe BBox
-> Dimension
-> Cairo.Surface
-> CanvasCoordinate
-> Cairo.Render ()
renderLayerContent mbbox (Dim w h) sfc (CvsCoord (x,y)) = do
Cairo.identityMatrix
clipBBox mbbox
let sx = 200 / w
Cairo.rectangle (x+100) y 200 (h*200/w)
Cairo.setLineWidth 0.5
Cairo.setSourceRGBA 0 0 0 1
Cairo.stroke
Cairo.translate (x+100) (y)
Cairo.scale sx sx
Cairo.setSourceSurface sfc 0 0
Cairo.paint
-- |
renderLayerWidget :: String -> Maybe BBox -> CanvasCoordinate -> Cairo.Render ()
renderLayerWidget str mbbox (CvsCoord (x,y)) = do
Cairo.identityMatrix
clipBBox mbbox
Cairo.setSourceRGBA 0.5 0.5 0.2 0.3
Cairo.rectangle x y 100 100
Cairo.fill
Cairo.rectangle x y 10 10
Cairo.fill
Cairo.setSourceRGBA 0 0 0 0.7
Cairo.setLineWidth 1
Cairo.moveTo x y
Cairo.lineTo (x+10) (y+10)
Cairo.stroke
Cairo.moveTo x (y+10)
Cairo.lineTo (x+10) y
Cairo.stroke
-- upper right
Cairo.setSourceRGBA 0 0 0 0.4
Cairo.moveTo (x+80) y
Cairo.lineTo (x+100) y
Cairo.lineTo (x+100) (y+20)
Cairo.fill
-- lower left
Cairo.setSourceRGBA 0 0 0 0.1
Cairo.moveTo x (y+80)
Cairo.lineTo x (y+100)
Cairo.lineTo (x+20) (y+100)
Cairo.fill
-- middle right
Cairo.setSourceRGBA 0 0 0 0.3
Cairo.moveTo (x+90) (y+40)
Cairo.lineTo (x+100) (y+50)
Cairo.lineTo (x+90) (y+60)
Cairo.fill
--
Cairo.identityMatrix
l1 <- Gtk.createLayout "layer"
Gtk.updateLayout l1
(_,reclog) <- liftIO $ Gtk.layoutGetExtents l1
let Gtk.PangoRectangle _ _ w1 h1 = reclog
Cairo.moveTo (x+15) y
let sx1 = 50 / w1
sy1 = 20 / h1
Cairo.scale sx1 sy1
Gtk.layoutPath l1
Cairo.setSourceRGBA 0 0 0 0.4
Cairo.fill
--
Cairo.identityMatrix
l <- Gtk.createLayout str
Gtk.updateLayout l
(_,reclog2) <- liftIO $ Gtk.layoutGetExtents l
let Gtk.PangoRectangle _ _ w h = reclog2
Cairo.moveTo (x+30) (y+20)
let sx = 40 / w
sy = 60 / h
Cairo.scale sx sy
Gtk.layoutPath l
Cairo.setSourceRGBA 0 0 0 0.4
Cairo.fill
------------------
-- Clock Widget --
------------------
renderClockWidget :: Maybe BBox -> ClockWidgetConfig -> Cairo.Render ()
renderClockWidget mbbox cfg = do
let CvsCoord (x,y) = view clockWidgetPosition cfg
(h,m,s) = view clockWidgetTime cfg
div2rad :: Int -> Int -> Double
div2rad n theta = fromIntegral theta/fromIntegral n * 2.0*pi
Cairo.identityMatrix
clipBBox mbbox
Cairo.setSourceRGBA 0.5 0.5 0.2 0.3
Cairo.arc x y 50 0.0 (2.0*pi)
Cairo.fill
--
Cairo.setSourceRGBA 1 0 0 0.7
Cairo.setLineWidth 0.5
Cairo.moveTo x y
Cairo.lineTo (x+45*sin (div2rad 60 s)) (y-45*cos (div2rad 60 s))
Cairo.stroke
--
Cairo.setSourceRGBA 0 0 0 1
Cairo.setLineWidth 1.0
Cairo.moveTo x y
Cairo.lineTo (x+50*sin (div2rad 60 m)) (y-50*cos (div2rad 60 m))
Cairo.stroke
--
Cairo.setSourceRGBA 0 0 0 1
Cairo.setLineWidth 2.0
Cairo.moveTo x y
Cairo.lineTo (x+30*sin (div2rad 12 h + div2rad 720 m))
(y-30*cos (div2rad 12 h + div2rad 720 m))
Cairo.stroke
--
Cairo.resetClip
------------------
-- Clock Widget --
------------------
renderScrollWidget :: Maybe BBox -> ScrollWidgetConfig -> Cairo.Render ()
renderScrollWidget mbbox _cfg = do
Cairo.identityMatrix
clipBBox mbbox
Cairo.setSourceRGBA 0.5 0.5 0.2 0.3
Cairo.moveTo 100 0
Cairo.lineTo 0 50
Cairo.lineTo 200 50
Cairo.fill
--
Cairo.resetClip