hoodle-core-0.13: src/Hoodle/Coroutine/Pen.hs
{-# LANGUAGE Rank2Types, GADTs, ScopedTypeVariables, TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Pen
-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Hoodle.Coroutine.Pen where
-- from other packages
import Control.Applicative ((<$>),(<*>))
import Control.Lens (view,set,at)
import Control.Monad hiding (mapM_,forM_)
import Control.Monad.State hiding (mapM_,forM_)
-- import Control.Monad.Trans
import Data.Functor.Identity (Identity(..))
import Data.Foldable (forM_)
import Data.Sequence hiding (filter)
import Data.Maybe
import Data.Time.Clock
import Graphics.Rendering.Cairo
-- from hoodle-platform
import Data.Hoodle.BBox
import Data.Hoodle.Generic (gpages)
import Data.Hoodle.Simple (Dimension(..))
import Graphics.Hoodle.Render (renderStrk)
-- from this package
import Hoodle.Accessor
import Hoodle.Device
import Hoodle.Coroutine.Commit
import Hoodle.Coroutine.Draw
import Hoodle.ModelAction.Page
import Hoodle.ModelAction.Pen
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
import Hoodle.Type.Enum
import Hoodle.Type.Event
import Hoodle.Type.PageArrangement
import Hoodle.Type.Predefined
import Hoodle.Type.HoodleState
import Hoodle.Util
import Hoodle.View.Coordinate
import Hoodle.View.Draw
--
import Prelude hiding (mapM_)
-- |
createTempRender :: CanvasGeometry -> a -> MainCoroutine (TempRender a)
createTempRender geometry x = do
xst <- get
let cinfobox = view currentCanvasInfo xst
mcvssfc = view (unboxLens mDrawSurface) cinfobox
let hdl = getHoodle xst
let Dim cw ch = unCanvasDimension . canvasDim $ geometry
srcsfc <- liftIO $ maybe (fst <$> canvasImageSurface Nothing geometry hdl)
(\cvssfc -> do
sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch)
renderWith sfc $ do
setSourceSurface cvssfc 0 0
setOperator OperatorSource
paint
return sfc)
mcvssfc
liftIO $ renderWith srcsfc $ do
emphasisCanvasRender ColorRed geometry
tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch)
let trdr = TempRender srcsfc tgtsfc (cw,ch) x
return trdr
-- | page switch if pen click a page different than the current page
penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox
penPageSwitch pgn = do
xstate <- get
let cibox = view currentCanvasInfo xstate
ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum pgn))) cibox
put (set currentCanvasInfo ncibox xstate)
invalidateAllInBBox Nothing Efficient
return ncibox
-- | Common Pen Work starting point
commonPenStart :: (forall a. CanvasInfo a -> PageNum -> CanvasGeometry
-> (Double,Double) -> MainCoroutine () )
-> CanvasId -> PointerCoord
-> MainCoroutine ()
commonPenStart action cid pcoord = do
oxstate <- get
let currcid = getCurrentCanvasId oxstate
when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll)
nxstate <- get
forBoth' unboxBiAct f . getCanvasInfo cid $ nxstate
where f :: forall b. CanvasInfo b -> MainCoroutine ()
f cvsInfo = do
let cpn = PageNum . view currentPageNum $ cvsInfo
arr = view (viewInfo.pageArrangement) cvsInfo
canvas = view drawArea cvsInfo
geometry <- liftIO $ makeCanvasGeometry cpn arr canvas
let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord
maybeFlip pagecoord (return ())
$ \(pgn,PageCoord (x,y)) -> do
nCvsInfo <- if (cpn /= pgn)
then do penPageSwitch pgn
-- temporary dirty fix
return (set currentPageNum (unPageNum pgn) cvsInfo )
else return cvsInfo
action nCvsInfo pgn geometry (x,y)
-- | enter pen drawing mode
penStart :: CanvasId -> PointerCoord -> MainCoroutine ()
penStart cid pcoord = commonPenStart penAction cid pcoord
where penAction :: forall b. CanvasInfo b -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine ()
penAction _cinfo pnum geometry (x,y) = do
xstate <- get
let PointerCoord _ _ _ z = pcoord
let currhdl = getHoodle xstate
pinfo = view penInfo xstate
mpage = view (gpages . at (unPageNum pnum)) currhdl
forM_ mpage $ \_page -> do
trdr <- createTempRender geometry (empty |> (x,y,z))
pdraw <-penProcess cid pnum geometry trdr ((x,y),z)
surfaceFinish (tempSurfaceSrc trdr)
surfaceFinish (tempSurfaceTgt trdr)
--
case viewl pdraw of
EmptyL -> return ()
(x1,_y1,_z1) :< _rest -> do
if x1 <= 1e-3 -- this is ad hoc but..
then invalidateAll
else do
(newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw
commit . set hoodleModeState (ViewAppendState newhdl)
=<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate))
let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord
nbbox = xformBBox f bbox
invalidateAllInBBox (Just nbbox) BkgEfficient
-- | main pen coordinate adding process
-- | now being changed
penProcess :: CanvasId -> PageNum
-> CanvasGeometry
-> TempRender (Seq (Double,Double,Double))
-> ((Double,Double),Double)
-> MainCoroutine (Seq (Double,Double,Double))
penProcess cid pnum geometry trdr ((x0,y0),z0) = do
r <- nextevent
xst <- get
forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst
where
pdraw = tempInfo trdr
fsingle :: forall b.
UserEvent -> HoodleState -> CanvasInfo b
-> MainCoroutine (Seq (Double,Double,Double))
fsingle r xstate cvsInfo =
penMoveAndUpOnly r pnum geometry
(penProcess cid pnum geometry trdr ((x0,y0),z0))
(\(pcoord,(x,y)) -> do
let PointerCoord _ _ _ z = pcoord
let pinfo = view penInfo xstate
let xformfunc = cairoXform4PageCoordinate geometry pnum
tmpstrk = createNewStroke pinfo pdraw
renderfunc = do
xformfunc
renderStrk tmpstrk
let (srcsfc,tgtsfc) = (,) <$> tempSurfaceSrc <*> tempSurfaceTgt $ trdr
virtualDoubleBufferDraw srcsfc tgtsfc (return ()) renderfunc
liftIO $ doubleBufferFlush tgtsfc cvsInfo
---
let ntrdr = trdr { tempInfo = pdraw |> (x,y,z) }
penProcess cid pnum geometry ntrdr ((x,y),z) )
(\_ -> return pdraw )
-- |
skipIfNotInSamePage :: Monad m =>
PageNum -> CanvasGeometry -> PointerCoord
-> m a
-> ((PointerCoord,(Double,Double)) -> m a)
-> m a
skipIfNotInSamePage pgn geometry pcoord skipaction ordaction =
switchActionEnteringDiffPage pgn geometry pcoord
skipaction (\_ _ -> skipaction ) (\_ (_,PageCoord xy)->ordaction (pcoord,xy))
-- |
switchActionEnteringDiffPage :: Monad m =>
PageNum -> CanvasGeometry -> PointerCoord
-> m a
-> (PageNum -> (PageNum,PageCoordinate) -> m a)
-> (PageNum -> (PageNum,PageCoordinate) -> m a)
-> m a
switchActionEnteringDiffPage pgn geometry pcoord skipaction chgaction ordaction = do
let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord
maybeFlip pagecoord skipaction
$ \(cpn, pxy) -> if pgn == cpn
then ordaction pgn (cpn,pxy)
else chgaction pgn (cpn,pxy)
-- | in page action
penMoveAndUpOnly :: Monad m => UserEvent
-> PageNum
-> CanvasGeometry
-> m a
-> ((PointerCoord,(Double,Double)) -> m a)
-> (PointerCoord -> m a)
-> m a
penMoveAndUpOnly r pgn geometry defact moveaction upaction =
case r of
PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction
PenUp _ pcoord -> upaction pcoord
_ -> defact
-- |
penMoveAndUpInterPage :: Monad m => UserEvent
-> PageNum
-> CanvasGeometry
-> m a
-> (PageNum -> (PageNum,PageCoordinate) -> m a)
-> (PointerCoord -> m a)
-> m a
penMoveAndUpInterPage r pgn geometry defact moveaction upaction =
case r of
PenMove _ pcoord ->
switchActionEnteringDiffPage pgn geometry pcoord defact moveaction moveaction
PenUp _ pcoord -> upaction pcoord
_ -> defact
-- | process action when last time was before time diff limit, otherwise
-- just do default action.
processWithTimeInterval :: (Monad m, MonadIO m) =>
NominalDiffTime -- ^ time diff
-> (UTCTime -> m a) -- ^ not larger than time diff bound
-> (UTCTime -> m a) -- ^ larger than time diff bound
-> UTCTime -- ^ last updated time
-> m a
processWithTimeInterval tdiffbound defact updateact otime = do
ctime <- liftIO getCurrentTime
let dtime = diffUTCTime ctime otime
if dtime > tdiffbound then updateact ctime else defact otime
-- |
processWithDefTimeInterval :: (Monad m, MonadIO m) =>
(UTCTime -> m a) -- ^ not larger than time diff bound
-> (UTCTime -> m a) -- ^ larger than time diff bound
-> UTCTime -- ^ last updated time
-> m a
processWithDefTimeInterval = processWithTimeInterval dtime_bound