module Hoodle.Coroutine.Pen where
import Control.Applicative ((<$>),(<*>))
import Control.Lens (view,set,at)
import Control.Monad hiding (mapM_,forM_)
import Control.Monad.State hiding (mapM_,forM_)
import Data.Foldable (mapM_,forM_)
import Data.Sequence hiding (filter)
import Data.Maybe
import Data.Time.Clock
import Graphics.Rendering.Cairo
import Data.Hoodle.Predefined
import Data.Hoodle.BBox
import Data.Hoodle.Generic (gpages)
import Data.Hoodle.Simple (Dimension(..))
import Graphics.Hoodle.Render (renderStrk)
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.Alias
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 :: PageNum -> CanvasGeometry -> Page EditMode -> a -> MainCoroutine (TempRender a)
createTempRender _pnum geometry _page 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
penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox
penPageSwitch pgn = do
xstate <- get
let cibox = view currentCanvasInfo xstate
ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum pgn)) cibox
put (set currentCanvasInfo ncibox xstate)
invalidateAllInBBox Nothing Efficient
return ncibox
commonPenStart :: (forall a. ViewMode 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
boxAction f . getCanvasInfo cid $ nxstate
where f :: forall b. (ViewMode 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
return (set currentPageNum (unPageNum pgn) cvsInfo )
else return cvsInfo
action nCvsInfo pgn geometry (x,y)
penStart :: CanvasId -> PointerCoord -> MainCoroutine ()
penStart cid pcoord = commonPenStart penAction cid pcoord
where penAction :: forall b. (ViewMode 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 pnum geometry page (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
then do
liftIO $ putStrLn " horizontal line cured !"
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
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
boxAction (fsingle r xst) . getCanvasInfo cid $ xst
where
pdraw = tempInfo trdr
fsingle :: forall b. (ViewMode 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 canvas = view drawArea cvsInfo
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)
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
processWithTimeInterval :: (Monad m, MonadIO m) =>
NominalDiffTime
-> (UTCTime -> m a)
-> (UTCTime -> m a)
-> UTCTime
-> 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)
-> (UTCTime -> m a)
-> UTCTime
-> m a
processWithDefTimeInterval = processWithTimeInterval dtime_bound