module Hoodle.Coroutine.Pen where
import Control.Category
import Control.Lens (view,set)
import Control.Monad
import Control.Monad.State
import Data.Sequence hiding (filter)
import Data.Maybe
import Data.Time.Clock
import Data.Hoodle.Predefined
import Data.Hoodle.BBox
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 ((.), id)
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)
invalidateAll
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 = unView . view hoodleModeState $ xstate
pinfo = view penInfo xstate
pdraw <-penProcess cid pnum geometry (empty |> (x,y,z)) ((x,y),z)
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
-> Seq (Double,Double,Double) -> ((Double,Double),Double)
-> MainCoroutine (Seq (Double,Double,Double))
penProcess cid pnum geometry pdraw ((x0,y0),z0) = do
r <- nextevent
xst <- get
boxAction (fsingle r xst) . getCanvasInfo cid $ xst
where
fsingle :: forall b. (ViewMode b) =>
MyEvent -> HoodleState -> CanvasInfo b
-> MainCoroutine (Seq (Double,Double,Double))
fsingle r xstate cvsInfo =
penMoveAndUpOnly r pnum geometry
(penProcess cid pnum geometry pdraw ((x0,y0),z0))
(\(pcoord,(x,y)) -> do
let PointerCoord _ _ _ z = pcoord
let canvas = view drawArea cvsInfo
msfc = view mDrawSurface cvsInfo
ptype = view (penInfo.penType) xstate
pcolor = view (penInfo.currentTool.penColor) xstate
pwidth = view (penInfo.currentTool.penWidth) xstate
(pcr,pcg,pcb,pca) = convertPenColorToRGBA pcolor
opacity = case ptype of
HighlighterWork -> predefined_highlighter_opacity
_ -> 1.0
pcolRGBA = (pcr,pcg,pcb,pca*opacity)
let pressureType = case view (penInfo.variableWidthPen) xstate of
True -> Pressure
False -> NoPressure
liftIO $ drawCurvebitGen pressureType (canvas,msfc) geometry
pwidth pcolRGBA pnum ((x0,y0),z0) ((x,y),z)
penProcess cid pnum geometry (pdraw |> (x,y,z)) ((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 => MyEvent
-> 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 => MyEvent
-> 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