{-# LANGUAGE Rank2Types, GADTs, ScopedTypeVariables, TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Coroutine.Pen -- Copyright : (c) 2011, 2012 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- 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 -- xoj = getXournal xst 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 -- invalidateAll 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