----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Coroutine.Select -- Copyright : (c) 2011, 2012 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Application.HXournal.Coroutine.Select where import Graphics.UI.Gtk hiding (get,set,disconnect) import Application.HXournal.Type.Event import Application.HXournal.Type.Enum import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas import Application.HXournal.Type.Clipboard import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.XournalState import Application.HXournal.Type.Alias import Application.HXournal.Accessor import Application.HXournal.Device import Application.HXournal.View.Draw import Application.HXournal.View.Coordinate import Application.HXournal.Coroutine.EventConnect import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.Pen import Application.HXournal.Coroutine.Mode import Application.HXournal.Coroutine.Commit import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Select import Application.HXournal.ModelAction.Layer import Control.Monad import Control.Monad.Identity import Control.Monad.Trans import Control.Monad.Coroutine.SuspensionFunctors import Control.Category import Data.Label import Prelude hiding ((.), id) import Data.Xournal.Simple (Dimension(..)) import Data.Xournal.Generic import Data.Xournal.BBox import Graphics.Rendering.Cairo import qualified Graphics.Rendering.Cairo.Matrix as Mat import Data.Monoid import qualified Data.IntMap as M import Data.Sequence (Seq,(|>)) import qualified Data.Sequence as Sq (empty) import Data.Time.Clock import Graphics.Xournal.Render.Type import Graphics.Xournal.Render.BBoxMapPDF import Graphics.Xournal.Render.HitTest import Graphics.Xournal.Render.BBox import Graphics.Xournal.Render.Generic -- | createTempSelectRender :: PageNum -> CanvasGeometry -> Page EditMode -> a -> MainCoroutine (TempSelectRender a) createTempSelectRender pnum geometry page x = do let Dim cw ch = unCanvasDimension . canvasDim $ geometry xformfunc = cairoXform4PageCoordinate geometry pnum renderfunc = do xformfunc cairoRenderOption (InBBoxOption Nothing) (InBBox page) return () tempsurface <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch) let tempselection = TempSelectRender tempsurface (cw,ch) x liftIO $ updateTempSelection tempselection renderfunc True return tempselection -- | For Selection mode from pen mode with 2nd pen button dealWithOneTimeSelectMode :: MainCoroutine () -> MainCoroutine () dealWithOneTimeSelectMode action = do xstate <- getSt case get isOneTimeSelectMode xstate of NoOneTimeSelectMode -> action YesBeforeSelect -> action >> updateXState (return . set isOneTimeSelectMode YesAfterSelect) YesAfterSelect -> do updateXState (return . set isOneTimeSelectMode NoOneTimeSelectMode) modeChange ToViewAppendMode -- | main mouse pointer click entrance in rectangular selection mode. -- choose either starting new rectangular selection or move previously -- selected selection. selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine () selectRectStart cid = commonPenStart rectaction cid where rectaction cinfo pnum geometry (cidup,cidmove) (x,y) = do strs <- getAllStrokeBBoxInCurrentLayer ctime <- liftIO $ getCurrentTime let newSelectAction page = dealWithOneTimeSelectMode $ do tsel <- createTempSelectRender pnum geometry page [] newSelectRectangle cid pnum geometry cidmove cidup strs (x,y) ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) let action (Right tpage) | hitInHandle tpage (x,y) = case getULBBoxFromSelected tpage of Middle bbox -> maybe (return ()) (\handle -> startResizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tpage) (checkIfHandleGrasped bbox (x,y)) _ -> return () action (Right tpage) | hitInSelection tpage (x,y) = do startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage action (Right tpage) | otherwise = newSelectAction (gcast tpage :: Page EditMode ) action (Left page) = newSelectAction page xstate <- getSt let xojstate = get xournalstate xstate let epage = getCurrentPageEitherFromXojState cinfo xojstate action epage -- | newSelectRectangle :: CanvasId -> PageNum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> [StrokeBBox] -> (Double,Double) -> ((Double,Double),UTCTime) -> TempSelection -> MainCoroutine () newSelectRectangle cid pnum geometry connidmove connidup strs orig (prev,otime) tempselection = do r <- await xst <- getSt selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) defact = newSelectRectangle cid pnum geometry connidmove connidup strs orig (prev,otime) tempselection moveact _xstate _cinfo (_pcoord,(x,y)) = do let bbox = BBox orig (x,y) hittestbbox = mkHitTestInsideBBox bbox strs hittedstrs = concat . map unHitted . getB $ hittestbbox page <- getCurrentPageCvsId cid let (fstrs,sstrs) = separateFS $ getDiffStrokeBBox (tempSelected tempselection) hittedstrs (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when ((not.null) fstrs || (not.null) sstrs ) $ do let xformfunc = cairoXform4PageCoordinate geometry pnum ulbbox = unUnion . mconcat . fmap (Union .Middle . flip inflate 5 . strokebbox_bbox) $ fstrs renderfunc = do xformfunc case ulbbox of Top -> do cairoRenderOption (InBBoxOption Nothing) (InBBox page) mapM_ renderSelectedStroke hittedstrs Middle sbbox -> do let redrawee = filter (hitTestBBoxBBox sbbox.strokebbox_bbox) hittedstrs cairoRenderOption (InBBoxOption (Just sbbox)) (InBBox page) clipBBox (Just sbbox) mapM_ renderSelectedStroke redrawee Bottom -> return () mapM_ renderSelectedStroke sstrs liftIO $ updateTempSelection tempselection renderfunc False when willUpdate $ invalidateTemp cid (tempSurface tempselection) (renderBoxSelection bbox) newSelectRectangle cid pnum geometry connidmove connidup strs orig (ncoord,ntime) tempselection { tempSelectInfo = hittedstrs } upact xstate cinfo pcoord = do let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return epage = getCurrentPageEitherFromXojState cinfo (get xournalstate xstate) cpn = get currentPageNum cinfo bbox = BBox orig (x,y) hittestbbox = mkHitTestInsideBBox bbox strs selectstrs = fmapAL unNotHitted id hittestbbox SelectState txoj = get xournalstate xstate newpage = case epage of Left pagebbox -> makePageSelectMode pagebbox selectstrs Right tpage -> let ls = glayers tpage currlayer = gselectedlayerbuf ls newlayer = GLayerBuf (get g_buffer currlayer) (TEitherAlterHitted (Right selectstrs)) npage = tpage { glayers = ls { gselectedlayerbuf = newlayer } } in npage newtxoj = txoj { gselectSelected = Just (cpn,newpage) } ui = get gtkUIManager xstate liftIO $ toggleCutCopyDelete ui (isAnyHitted selectstrs) putSt . set xournalstate (SelectState newtxoj) =<< (liftIO (updatePageAll (SelectState newtxoj) xstate)) disconnect connidmove disconnect connidup invalidateAll -- | prepare for moving selection startMoveSelect :: CanvasId -> PageNum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> ((Double,Double),UTCTime) -> Page SelectMode -> MainCoroutine () startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage = do strimage <- liftIO $ mkStrokesNImage geometry tpage tsel <- createTempSelectRender pnum geometry (gcast tpage :: Page EditMode) strimage moveSelect cid pnum geometry cidmove cidup (x,y) ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) surfaceFinish (imageSurface strimage) -- | moveSelect :: CanvasId -> PageNum -- ^ starting pagenum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> (Double,Double) -> ((Double,Double),UTCTime) -> TempSelectRender StrokesNImage -> MainCoroutine () moveSelect cid pnum geometry connidmove connidup orig@(x0,y0) (prev,otime) tempselection = do xst <- getSt r <- await selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpInterPage r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) defact = moveSelect cid pnum geometry connidmove connidup orig (prev,otime) tempselection moveact _xstate _cinfo oldpgn pcpair@(newpgn,PageCoord (px,py)) = do let (x,y) | oldpgn == newpgn = (px,py) | otherwise = let DeskCoord (xo,yo) = page2Desktop geometry (oldpgn,PageCoord (0,0)) DeskCoord (xn,yn) = page2Desktop geometry pcpair in (xn-xo,yn-yo) (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do let sfunc = offsetFunc (x-x0,y-y0) xform = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry . (,) pnum . PageCoord (c1,c2) = xform (sfunc (0,0)) (a1',a2') = xform (sfunc (1,0)) (a1,a2) = (a1'-c1,a2'-c2) (b1',b2') = xform (sfunc (0,1)) (b1,b2) = (b1'-c1,b2'-c2) xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 invalidateTempBasePage cid (tempSurface tempselection) pnum (drawTempSelectImage geometry tempselection xformmat) moveSelect cid pnum geometry connidmove connidup orig (ncoord,ntime) tempselection upact :: (ViewMode a) => HXournalState -> CanvasInfo a -> PointerCoord -> MainCoroutine () upact xst cinfo pcoord = switchActionEnteringDiffPage pnum geometry pcoord (return ()) (chgaction xst cinfo) (ordaction xst cinfo) chgaction :: (ViewMode a) => HXournalState -> CanvasInfo a -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () chgaction xstate cinfo oldpgn (newpgn,PageCoord (x,y)) = do let xojstate@(SelectState txoj) = get xournalstate xstate epage = getCurrentPageEitherFromXojState cinfo xojstate (xstate1,ntxoj1,selectedstrs) <- case epage of Right oldtpage -> do let strs = getSelectedStrokes oldtpage let oldtpage' = deleteSelected oldtpage ntxoj <- liftIO $ updateTempXournalSelectIO txoj oldtpage' (unPageNum oldpgn) xst <- return . set xournalstate (SelectState ntxoj) =<< (liftIO (updatePageAll (SelectState ntxoj) xstate)) return (xst,ntxoj,strs) Left _ -> error "this is impossible, in moveSelect" let maction = do page <- M.lookup (unPageNum newpgn) (get g_selectAll ntxoj1) let (mcurrlayer,npage) = getCurrentLayerOrSet page currlayer <- mcurrlayer let oldstrs = get g_bstrokes currlayer let newstrs = map (changeStrokeBy (offsetFunc (x-x0,y-y0))) selectedstrs alist = oldstrs :- Hitted newstrs :- Empty ntpage = makePageSelectMode npage alist coroutineaction = do ntxoj2 <- liftIO $ updateTempXournalSelectIO ntxoj1 ntpage (unPageNum newpgn) let ncinfo = set currentPageNum (unPageNum newpgn) $ cinfo cmap = getCanvasInfoMap xstate1 cmap' = M.adjust (const (CanvasInfoBox ncinfo)) cid cmap xst = maybe xstate1 id $ setCanvasInfoMap cmap' xstate1 return . set xournalstate (SelectState ntxoj2) =<< (liftIO (updatePageAll (SelectState ntxoj2) xst)) return coroutineaction xstate2 <- maybe (return xstate1) id maction commit xstate2 disconnect connidmove disconnect connidup invalidateAll ordaction xstate cinfo _pgn (_cpn,PageCoord (x,y)) = do let offset = (x-x0,y-y0) xojstate@(SelectState txoj) = get xournalstate xstate epage = getCurrentPageEitherFromXojState cinfo xojstate pagenum = get currentPageNum cinfo case epage of Right tpage -> do let newtpage = changeSelectionByOffset offset tpage newtxoj <- liftIO $ updateTempXournalSelectIO txoj newtpage pagenum commit . set xournalstate (SelectState newtxoj) =<< (liftIO (updatePageAll (SelectState newtxoj) xstate)) Left _ -> error "this is impossible, in moveSelect" disconnect connidmove disconnect connidup invalidateAll -- | prepare for resizing selection startResizeSelect :: Handle -> CanvasId -> PageNum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> BBox -> ((Double,Double),UTCTime) -> Page SelectMode -> MainCoroutine () startResizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tpage = do strimage <- liftIO $ mkStrokesNImage geometry tpage tsel <- createTempSelectRender pnum geometry (gcast tpage :: Page EditMode) strimage resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) surfaceFinish (imageSurface strimage) -- | resizeSelect :: Handle -> CanvasId -> PageNum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> BBox -> ((Double,Double),UTCTime) -> TempSelectRender StrokesNImage -> MainCoroutine () resizeSelect handle cid pnum geometry connidmove connidup origbbox (prev,otime) tempselection = do xst <- getSt r <- await selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) defact = resizeSelect handle cid pnum geometry connidmove connidup origbbox (prev,otime) tempselection moveact _xstate _cinfo (_pcoord,(x,y)) = do (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do let newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) sfunc = scaleFromToBBox origbbox newbbox xform = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry . (,) pnum . PageCoord (c1,c2) = xform (sfunc (0,0)) (a1',a2') = xform (sfunc (1,0)) (a1,a2) = (a1'-c1,a2'-c2) (b1',b2') = xform (sfunc (0,1)) (b1,b2) = (b1'-c1,b2'-c2) xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 invalidateTemp cid (tempSurface tempselection) (drawTempSelectImage geometry tempselection xformmat) resizeSelect handle cid pnum geometry connidmove connidup origbbox (ncoord,ntime) tempselection upact xstate cinfo pcoord = do let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) xojstate@(SelectState txoj) = get xournalstate xstate epage = getCurrentPageEitherFromXojState cinfo xojstate pagenum = get currentPageNum cinfo case epage of Right tpage -> do let sfunc = scaleFromToBBox origbbox newbbox let newtpage = changeSelectionBy sfunc tpage newtxoj <- liftIO $ updateTempXournalSelectIO txoj newtpage pagenum commit . set xournalstate (SelectState newtxoj) =<< (liftIO (updatePageAll (SelectState newtxoj) xstate)) Left _ -> error "this is impossible, in resizeSelect" disconnect connidmove disconnect connidup invalidateAll return () -- | deleteSelection :: MainCoroutine () deleteSelection = do liftIO $ putStrLn "delete selection is called" xstate <- getSt let SelectState txoj = get xournalstate xstate Just (n,tpage) = gselectSelected txoj slayer = gselectedlayerbuf . glayers $ tpage case unTEitherAlterHitted . get g_bstrokes $ slayer of Left _ -> liftIO $ putStrLn "no stroke selection 2 " Right alist -> do let newlayer = Left . concat . getA $ alist oldlayers = glayers tpage newpage = tpage { glayers = oldlayers { gselectedlayerbuf = GLayerBuf (get g_buffer slayer) (TEitherAlterHitted newlayer) } } newtxoj <- liftIO $ updateTempXournalSelectIO txoj newpage n newxstate <- liftIO $ updatePageAll (SelectState newtxoj) . set xournalstate (SelectState newtxoj) $ xstate commit newxstate let ui = get gtkUIManager newxstate liftIO $ toggleCutCopyDelete ui False invalidateAll -- | cutSelection :: MainCoroutine () cutSelection = do liftIO $ putStrLn "cutSelection called" copySelection deleteSelection -- | copySelection :: MainCoroutine () copySelection = updateXState copySelectionAction >> invalidateAll where copySelectionAction xst = selectBoxAction (fsingle xst) (fsingle xst) . get currentCanvasInfo $ xst fsingle xstate cinfo = maybe (return xstate) id $ do let xojstate = get xournalstate xstate let epage = getCurrentPageEitherFromXojState cinfo xojstate eitherMaybe epage `pipe` getActiveLayer `pipe` (Right . xstateadj . takeHittedStrokes) where eitherMaybe (Left _) = Nothing eitherMaybe (Right a) = Just a x `pipe` a = x >>= eitherMaybe . a infixl 6 `pipe` xstateadj strs | null strs = return xstate | otherwise = do let newclip = Clipboard strs xstate' = set clipboard newclip xstate ui = get gtkUIManager xstate' liftIO $ togglePaste ui True return xstate' -- | pasteToSelection :: MainCoroutine () pasteToSelection = modeChange ToSelectMode >> updateXState pasteAction >> invalidateAll where pasteAction xst = boxAction (fsimple xst) . get currentCanvasInfo $ xst fsimple xstate cinfo = do geometry <- liftIO (getGeometry4CurrCvs xstate) let pagenum = get currentPageNum cinfo xojstate@(SelectState txoj) = get xournalstate xstate clipstrs' = getClipContents . get clipboard $ xstate nclipstrs = adjustStrokePosition4Paste geometry (PageNum pagenum) clipstrs' epage = getCurrentPageEitherFromXojState cinfo xojstate tpage = either gcast id epage layerselect = gselectedlayerbuf . glayers $ tpage ls = glayers tpage gbuf = get g_buffer layerselect newlayerselect = case getActiveLayer tpage of Left strs -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (strs :- Hitted nclipstrs :- Empty) Right alist -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (concat (interleave id unHitted alist) :- Hitted nclipstrs :- Empty ) tpage' = tpage { glayers = ls { gselectedlayerbuf = newlayerselect } } txoj' <- liftIO $ updateTempXournalSelectIO txoj tpage' pagenum xstate' <- liftIO $ updatePageAll (SelectState txoj') . set xournalstate (SelectState txoj') $ xstate commit xstate' let ui = get gtkUIManager xstate' liftIO $ toggleCutCopyDelete ui True return xstate' -- | selectPenColorChanged :: PenColor -> MainCoroutine () selectPenColorChanged pcolor = do liftIO $ putStrLn "selectPenColorChanged called" xstate <- getSt let SelectState txoj = get xournalstate xstate Just (n,tpage) = gselectSelected txoj slayer = gselectedlayerbuf . glayers $ tpage case unTEitherAlterHitted . get g_bstrokes $ slayer of Left _ -> liftIO $ putStrLn "no stroke selection 2 " Right alist -> do let alist' = fmapAL id (Hitted . map (changeStrokeColor pcolor) . unHitted) alist newlayer = Right alist' ls = glayers tpage newpage = tpage { glayers = ls { gselectedlayerbuf = GLayerBuf (get g_buffer slayer) (TEitherAlterHitted newlayer) }} newtxoj <- liftIO $ updateTempXournalSelectIO txoj newpage n commit =<< liftIO (updatePageAll (SelectState newtxoj) . set xournalstate (SelectState newtxoj) $ xstate ) invalidateAll -- | selectPenWidthChanged :: Double -> MainCoroutine () selectPenWidthChanged pwidth = do liftIO $ putStrLn "selectPenWidthChanged called" xstate <- getSt let SelectState txoj = get xournalstate xstate Just (n,tpage) = gselectSelected txoj slayer = gselectedlayerbuf . get g_layers $ tpage case unTEitherAlterHitted . get g_bstrokes $ slayer of Left _ -> liftIO $ putStrLn "no stroke selection 2 " Right alist -> do let alist' = fmapAL id (Hitted . map (changeStrokeWidth pwidth) . unHitted) alist newlayer = Right alist' ls = get g_layers tpage newpage = tpage { glayers = ls { gselectedlayerbuf = GLayerBuf (get g_buffer slayer) (TEitherAlterHitted newlayer) }} newtxoj <- liftIO $ updateTempXournalSelectIO txoj newpage n commit =<< liftIO (updatePageAll (SelectState newtxoj) . set xournalstate (SelectState newtxoj) $ xstate ) invalidateAll -- | main mouse pointer click entrance in lasso selection mode. -- choose either starting new rectangular selection or move previously -- selected selection. selectLassoStart :: CanvasId -> PointerCoord -> MainCoroutine () selectLassoStart cid = commonPenStart lassoAction cid where lassoAction cinfo pnum geometry (cidup,cidmove) (x,y) = do strs <- getAllStrokeBBoxInCurrentLayer ctime <- liftIO $ getCurrentTime let newSelectAction page = dealWithOneTimeSelectMode $ do tsel <- createTempSelectRender pnum geometry page [] newSelectLasso cinfo pnum geometry cidmove cidup strs (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel surfaceFinish (tempSurface tsel) let action (Right tpage) | hitInSelection tpage (x,y) = startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage action (Right tpage) | hitInHandle tpage (x,y) = case getULBBoxFromSelected tpage of Middle bbox -> maybe (return ()) (\handle -> startResizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tpage) (checkIfHandleGrasped bbox (x,y)) _ -> return () action (Right tpage) | otherwise = newSelectAction (gcast tpage :: Page EditMode ) action (Left page) = newSelectAction page xstate <- getSt let xojstate = get xournalstate xstate let epage = getCurrentPageEitherFromXojState cinfo xojstate action epage -- | newSelectLasso :: (ViewMode a) => CanvasInfo a -> PageNum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> [StrokeBBox] -> (Double,Double) -> ((Double,Double),UTCTime) -> Seq (Double,Double) -> TempSelection -> MainCoroutine () newSelectLasso cvsInfo pnum geometry cidmove cidup strs orig (prev,otime) lasso tsel = do r <- await fsingle r cvsInfo where fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact (moveact cinfo) (upact cinfo) defact = newSelectLasso cvsInfo pnum geometry cidmove cidup strs orig (prev,otime) lasso tsel moveact cinfo (_pcoord,(x,y)) = do let nlasso = lasso |> (x,y) (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do invalidateTemp (get canvasId cinfo) (tempSurface tsel) (renderLasso nlasso) newSelectLasso cinfo pnum geometry cidmove cidup strs orig (ncoord,ntime) nlasso tsel upact cinfo pcoord = do xstate <- getSt let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return nlasso = lasso |> (x,y) xojstate = get xournalstate xstate epage = getCurrentPageEitherFromXojState cinfo xojstate cpn = get currentPageNum cinfo hittestlasso = mkHitTestAL (hitLassoStroke (nlasso |> orig)) strs selectstrs = fmapAL unNotHitted id hittestlasso SelectState txoj = get xournalstate xstate newpage = case epage of Left pagebbox -> let (mcurrlayer,npagebbox) = getCurrentLayerOrSet pagebbox currlayer = maybe (error "newSelectLasso") id mcurrlayer newlayer = GLayerBuf (get g_buffer currlayer) (TEitherAlterHitted (Right selectstrs)) tpg = gcast npagebbox ls = get g_layers tpg npg = tpg { glayers = ls { gselectedlayerbuf = newlayer} } in npg Right tpage -> let ls = glayers tpage currlayer = gselectedlayerbuf ls newlayer = GLayerBuf (get g_buffer currlayer) (TEitherAlterHitted (Right selectstrs)) npage = tpage { glayers = ls { gselectedlayerbuf = newlayer } } in npage newtxoj = txoj { gselectSelected = Just (cpn,newpage) } let ui = get gtkUIManager xstate liftIO $ toggleCutCopyDelete ui (isAnyHitted selectstrs) putSt . set xournalstate (SelectState newtxoj) =<< (liftIO (updatePageAll (SelectState newtxoj) xstate)) disconnect cidmove disconnect cidup invalidateAll