hxournal-0.6.6: lib/Application/HXournal/Coroutine/Pen.hs
{-# LANGUAGE Rank2Types, GADTs, ScopedTypeVariables, TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : Application.HXournal.Coroutine.Pen
-- Copyright : (c) 2011, 2012 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module Application.HXournal.Coroutine.Pen where
import Graphics.UI.Gtk hiding (get,set,disconnect)
import Application.HXournal.Device
import Application.HXournal.Type.Event
import Application.HXournal.Type.Enum
import Application.HXournal.Type.Coroutine
import Application.HXournal.Type.Canvas
import Application.HXournal.Type.PageArrangement
import Application.HXournal.Type.XournalState
import Application.HXournal.Coroutine.Draw
import Application.HXournal.Coroutine.EventConnect
import Application.HXournal.Coroutine.Commit
import Application.HXournal.Accessor
import Application.HXournal.ModelAction.Pen
import Application.HXournal.ModelAction.Page
import Application.HXournal.View.Coordinate
import Application.HXournal.View.Draw
import Application.HXournal.Util
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Coroutine.SuspensionFunctors
import Data.Xournal.Predefined
import Data.Xournal.BBox
import Data.Sequence hiding (filter)
import qualified Data.Map as M
import Data.Maybe
import Control.Category
import Data.Label
import Prelude hiding ((.), id)
-- | page switch if pen click a page different than the current page
penPageSwitch :: (ViewMode a) =>
CanvasInfo a -> PageNum -> MainCoroutine (CanvasInfo a)
penPageSwitch cinfo pgn = do (xst,cinfo') <- getSt >>= switchact
putSt xst
return cinfo'
where switchact xst = do
let ncinfo = set currentPageNum (unPageNum pgn) cinfo
mfunc = const (return . CanvasInfoBox $ ncinfo)
return . (,ncinfo) =<< modifyCurrCvsInfoM mfunc xst
-- | Common Pen Work starting point
commonPenStart :: (forall a. ViewMode a => CanvasInfo a -> PageNum -> CanvasGeometry
-> (ConnectId DrawingArea, ConnectId DrawingArea)
-> (Double,Double) -> MainCoroutine () )
-> CanvasId -> PointerCoord
-> MainCoroutine ()
commonPenStart action cid pcoord = do
oxstate <- getSt
let currcid = getCurrentCanvasId oxstate
when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll)
nxstate <- getSt
boxAction f . getCanvasInfo cid $ nxstate
where f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine ()
f cvsInfo = do
let cpn = PageNum . get currentPageNum $ cvsInfo
arr = get (pageArrangement.viewInfo) cvsInfo
canvas = get 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 penPageSwitch cvsInfo pgn
else return cvsInfo
connidup <- connectPenUp nCvsInfo
connidmove <- connectPenMove nCvsInfo
action nCvsInfo pgn geometry (connidup,connidmove) (x,y)
-- | enter pen drawing mode
penStart :: CanvasId -> PointerCoord -> MainCoroutine ()
penStart cid pcoord = commonPenStart penAction cid pcoord
where penAction :: forall b. (ViewMode b) => CanvasInfo b -> PageNum -> CanvasGeometry -> (ConnectId DrawingArea, ConnectId DrawingArea) -> (Double,Double) -> MainCoroutine ()
penAction _cinfo pnum geometry (cidmove,cidup) (x,y) = do
xstate <- getSt
let PointerCoord _ _ _ z = pcoord
let currxoj = unView . get xournalstate $ xstate
pinfo = get penInfo xstate
pdraw <-penProcess cid pnum geometry cidmove cidup (empty |> (x,y,z)) ((x,y),z)
(newxoj,bbox) <- liftIO $ addPDraw pinfo currxoj pnum pdraw
commit . set xournalstate (ViewAppendState newxoj)
=<< (liftIO (updatePageAll (ViewAppendState newxoj) xstate))
let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord
nbbox = xformBBox f bbox
invalidateAllInBBox (Just (inflate nbbox 2.0))
-- | main pen coordinate adding process
-- | now being changed
penProcess :: CanvasId -> PageNum
-> CanvasGeometry
-> ConnectId DrawingArea -> ConnectId DrawingArea
-> Seq (Double,Double,Double) -> ((Double,Double),Double)
-> MainCoroutine (Seq (Double,Double,Double))
penProcess cid pnum geometry connidmove connidup pdraw ((x0,y0),z0) = do
r <- await
xst <- getSt
boxAction (fsingle r xst) . getCanvasInfo cid $ xst
where
fsingle :: forall b. (ViewMode b) =>
MyEvent -> HXournalState -> CanvasInfo b
-> MainCoroutine (Seq (Double,Double,Double))
fsingle r xstate cvsInfo =
penMoveAndUpOnly r pnum geometry
(penProcess cid pnum geometry connidmove connidup pdraw ((x0,y0),z0))
(\(pcoord,(x,y)) -> do
let PointerCoord _ _ _ z = pcoord
let canvas = get drawArea cvsInfo
ptype = get (penType.penInfo) xstate
pcolor = get (penColor.currentTool.penInfo) xstate
pwidth = get (penWidth.currentTool.penInfo) xstate
(pcr,pcg,pcb,pca)= fromJust (M.lookup pcolor penColorRGBAmap)
opacity = case ptype of
HighlighterWork -> predefined_highlighter_opacity
_ -> 1.0
pcolRGBA = (pcr,pcg,pcb,pca*opacity)
let pressureType = case get (variableWidthPen.penInfo) xstate of
True -> Pressure
False -> NoPressure
liftIO $ drawCurvebitGen pressureType canvas geometry
pwidth pcolRGBA pnum ((x0,y0),z0) ((x,y),z)
penProcess cid pnum geometry connidmove connidup (pdraw |> (x,y,z)) ((x,y),z) )
(\_ -> disconnect connidmove >> disconnect connidup >> 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 => 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