module Hoodle.Coroutine.Pen where
import Control.Applicative ((<$>),(<*>))
import Control.Lens (at,over,set,view)
import Control.Monad hiding (mapM_,forM_)
import Control.Monad.State hiding (mapM_,forM_)
import Data.Functor.Identity (Identity(..))
import Data.Foldable (toList)
import Data.Sequence hiding (filter)
import qualified Data.IntMap as IM
import Data.Maybe
import Data.Ratio
import Data.Time.Clock
import qualified Graphics.Rendering.Cairo as Cairo
import Data.Hoodle.BBox
import Data.Hoodle.Generic (gitems,gpages)
import Data.Hoodle.Simple (Dimension(..))
import Graphics.Hoodle.Render (renderStrk,updateLayerBuf)
import Graphics.Hoodle.Render.Type
import Hoodle.Accessor
import Hoodle.Coroutine.Commit
import Hoodle.Coroutine.Draw
import Hoodle.Device
import Hoodle.GUI.Reflect
import Hoodle.ModelAction.Layer
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_)
addPDraw :: CanvasId
-> PenInfo
-> RHoodle
-> PageNum
-> Seq (Double,Double,Double)
-> MainCoroutine (RHoodle,BBox)
addPDraw cid pinfo hdl (PageNum pgnum) pdraw = do
let currpage = getPageFromGHoodleMap pgnum hdl
currlayer = getCurrentLayer currpage
newstroke = createNewStroke pinfo pdraw
newstrokebbox = runIdentity (makeBBoxed newstroke)
bbox = getBBox newstrokebbox
newlayerbbox = over gitems (++[RItemStroke newstrokebbox]) currlayer
callRenderer_ $ updateLayerBuf cid newlayerbbox
let newpagebbox = adjustCurrentLayer newlayerbbox currpage
newhdlbbox = set gpages (IM.adjust (const newpagebbox) pgnum (view gpages hdl) ) hdl
return (newhdlbbox,bbox)
createTempRender :: CanvasGeometry -> a -> MainCoroutine (TempRender a)
createTempRender geometry x = do
xst <- get
cache <- renderCache
let uhdl = view (unitHoodles.currentUnit) xst
cinfobox = view currentCanvasInfo uhdl
mcvssfc = view (unboxLens mDrawSurface) cinfobox
cid = getCurrentCanvasId uhdl
hdl = getHoodle uhdl
Dim cw ch = unCanvasDimension . canvasDim $ geometry
srcsfc <- liftIO $
maybe (fst <$> canvasImageSurface cache cid Nothing geometry hdl)
(\cvssfc -> do
sfc <- Cairo.createImageSurface
Cairo.FormatARGB32 (floor cw) (floor ch)
Cairo.renderWith sfc $ do
Cairo.setSourceSurface cvssfc 0 0
Cairo.setOperator Cairo.OperatorSource
Cairo.paint
return sfc)
mcvssfc
liftIO $ Cairo.renderWith srcsfc $ do
emphasisCanvasRender ColorRed geometry
tgtsfc <- liftIO $ Cairo.createImageSurface
Cairo.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 uhdl = view (unitHoodles.currentUnit) xstate
cibox = view currentCanvasInfo uhdl
ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum pgn))) cibox
uhdl' = set currentCanvasInfo ncibox uhdl
pureUpdateUhdl (const uhdl')
invalidateAllInBBox Nothing Efficient
return ncibox
commonPenStart :: forall b.
(forall a . CanvasInfo a -> PageNum -> CanvasGeometry
-> (Double,Double) -> UTCTime -> MainCoroutine b)
-> CanvasId
-> PointerCoord
-> MainCoroutine (Maybe b)
commonPenStart action cid pcoord = do
oxstate <- get
let currcid = (getCurrentCanvasId . view (unitHoodles.currentUnit)) oxstate
ctime <- liftIO $ getCurrentTime
when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll)
nxstate <- get
forBoth' unboxBiAct (f ctime) . getCanvasInfo cid . view (unitHoodles.currentUnit) $ nxstate
where f :: forall c. UTCTime -> CanvasInfo c -> MainCoroutine (Maybe b)
f ctime 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 Nothing)
$ \(pgn,PageCoord (x,y)) -> do
nCvsInfo <- if (cpn /= pgn)
then do penPageSwitch pgn
return (set currentPageNum (unPageNum pgn) cvsInfo )
else return cvsInfo
Just <$> action nCvsInfo pgn geometry (x,y) ctime
penStart :: CanvasId
-> PointerCoord
-> MainCoroutine (Maybe (Maybe (Maybe ())))
penStart cid pcoord = commonPenStart penAction cid pcoord
where penAction :: forall b. CanvasInfo b -> PageNum -> CanvasGeometry
-> (Double,Double) -> UTCTime
-> MainCoroutine (Maybe (Maybe ()))
penAction _cinfo pnum geometry (x,y) ctime = do
xstate <- get
let uhdl = view (unitHoodles.currentUnit) xstate
let PointerCoord _ _ _ z = pcoord
let currhdl = getHoodle uhdl
pinfo = view penInfo xstate
mpage = view (gpages . at (unPageNum pnum)) currhdl
maybeFlip mpage (return Nothing) $ \_page -> do
trdr <- createTempRender geometry (empty |> (x,y,z))
mpdraw <-penProcess cid pnum geometry trdr ((x,y),z) ctime
Cairo.surfaceFinish (tempSurfaceSrc trdr)
Cairo.surfaceFinish (tempSurfaceTgt trdr)
maybeFlip mpdraw (return (Just Nothing)) $ \pdraw ->
case viewl pdraw of
EmptyL -> return (Just (Just ()))
(x1,_y1,_z1) :< _rest -> do
if x1 <= 1e-3
then invalidateAll
else do
(newhdl,_bbox) <- addPDraw cid pinfo currhdl pnum pdraw
uhdl' <- liftIO (updatePageAll (ViewAppendState newhdl) uhdl)
commit (set (unitHoodles.currentUnit) uhdl' xstate)
return ()
return (Just (Just ()))
penProcess :: CanvasId
-> PageNum
-> CanvasGeometry
-> TempRender (Seq (Double,Double,Double))
-> ((Double,Double),Double)
-> UTCTime
-> MainCoroutine (Maybe (Seq (Double,Double,Double)))
penProcess cid pnum geometry trdr ((x0,y0),z0) ctime = do
r <- nextevent
ntime <- liftIO getCurrentTime
let ispressandhold =
abs (toRational (diffUTCTime ctime ntime)) > 1 % 2
lst = (toList . tempInfo) trdr
deltax = let xlst = map (\(x,_,_)->x) lst
in abs (maximum xlst minimum xlst)
deltay = let ylst = map (\(_,y,_)->y) lst
in abs (maximum ylst minimum ylst)
if (deltax < 20 && deltay < 20 && ispressandhold && Prelude.length lst < 20)
then return Nothing
else do xst <- get
forBoth' unboxBiAct (fsingle r xst) . (getCanvasInfo cid . view (unitHoodles.currentUnit)) $ xst
where
pdraw = tempInfo trdr
fsingle :: forall b.
UserEvent -> HoodleState -> CanvasInfo b
-> MainCoroutine (Maybe (Seq (Double,Double,Double)))
fsingle r xstate cvsInfo =
penMoveAndUpOnly r pnum geometry
(penProcess cid pnum geometry trdr ((x0,y0),z0) ctime)
(\(pcoord,(x,y)) -> do
let PointerCoord _ _ _ z = pcoord
let pinfo = view penInfo xstate
let xformfunc = cairoXform4PageCoordinate (mkXform4Page 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) ctime)
(\_ -> return (Just 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