diff --git a/hxournal.cabal b/hxournal.cabal --- a/hxournal.cabal +++ b/hxournal.cabal @@ -1,5 +1,5 @@ Name: hxournal -Version: 0.6.4.2 +Version: 0.6.4.3 Synopsis: A pen notetaking program written in haskell Description: notetaking program written in haskell and gtk2hs Homepage: http://ianwookim.org/hxournal diff --git a/lib/Application/HXournal/Accessor.hs b/lib/Application/HXournal/Accessor.hs --- a/lib/Application/HXournal/Accessor.hs +++ b/lib/Application/HXournal/Accessor.hs @@ -36,6 +36,7 @@ import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.Coroutine import Application.HXournal.View.Coordinate +import Application.HXournal.Type.XournalState import Control.Monad.Coroutine import Control.Monad.Coroutine.SuspensionFunctors @@ -57,29 +58,65 @@ -- | -getPenType :: Iteratee MyEvent XournalStateIO PenType +getPenType :: MainCoroutine PenType -- Iteratee MyEvent XournalStateIO PenType getPenType = get (penType.penInfo) <$> lift (St.get) -- | +getCurrentPageCurr :: MainCoroutine (Page EditMode) +getCurrentPageCurr = do + xstate <- getSt + let xojstate = get xournalstate xstate + cinfobox = get currentCanvasInfo xstate + case cinfobox of + CanvasInfoBox cinfo -> return (getCurrentPageFromXojState cinfo xojstate) + +-- | + +getCurrentPageCvsId :: CanvasId -> MainCoroutine (Page EditMode) +getCurrentPageCvsId cid = do + xstate <- getSt + let xojstate = get xournalstate xstate + cinfobox = getCanvasInfo cid xstate + case cinfobox of + CanvasInfoBox cinfo -> return (getCurrentPageFromXojState cinfo xojstate) + + + +-- | + +getCurrentPageEitherFromXojState :: (ViewMode a) => + CanvasInfo a -> XournalState + -> Either (Page EditMode) (Page SelectMode) +getCurrentPageEitherFromXojState cinfo xojstate = + let cpn = get currentPageNum cinfo + page = getCurrentPageFromXojState cinfo xojstate + in case xojstate of + ViewAppendState xoj -> Left page + SelectState txoj -> + case get g_selectSelected txoj of + Nothing -> Left page + Just (n,tpage) -> if cpn == n + then Right tpage + else Left page + + + +-- | + getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox] getAllStrokeBBoxInCurrentPage = do - xstate <- getSt - case get currentCanvasInfo xstate of - CanvasInfoBox currCvsInfo -> - let pagebbox = getPage currCvsInfo - in return [s| l <- gToList (get g_layers pagebbox), s <- get g_bstrokes l ] + page <- getCurrentPageCurr + return [s| l <- gToList (get g_layers page), s <- get g_bstrokes l ] +-- | getAllStrokeBBoxInCurrentLayer :: MainCoroutine [StrokeBBox] getAllStrokeBBoxInCurrentLayer = do - xstate <- getSt - case get currentCanvasInfo xstate of - CanvasInfoBox currCvsInfo -> do - let pagebbox = getPage currCvsInfo - (mcurrlayer, _currpage) = getCurrentLayerOrSet pagebbox - currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer - return (get g_bstrokes currlayer) + page <- getCurrentPageCurr + let (mcurrlayer, _currpage) = getCurrentLayerOrSet page + currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer + return (get g_bstrokes currlayer) otherCanvas :: HXournalState -> [Int] otherCanvas = M.keys . getCanvasInfoMap @@ -190,21 +227,21 @@ -- | - +{- unboxGetPage :: CanvasInfoBox -> (Page EditMode) unboxGetPage = either id (gcast :: Page SelectMode -> Page EditMode) . unboxGet currentPage +-} -- | getCanvasGeometryCvsId :: CanvasId -> HXournalState -> IO CanvasGeometry getCanvasGeometryCvsId cid xstate = do let cinfobox = getCanvasInfo cid xstate - page = unboxGetPage cinfobox cpn = PageNum . unboxGet currentPageNum $ cinfobox canvas = unboxGet drawArea cinfobox xojstate = get xournalstate xstate fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry - fsingle = flip (makeCanvasGeometry EditMode (cpn,page)) canvas + fsingle = flip (makeCanvasGeometry cpn) canvas . get (pageArrangement.viewInfo) boxAction fsingle cinfobox @@ -213,12 +250,11 @@ getCanvasGeometry :: HXournalState -> IO CanvasGeometry getCanvasGeometry xstate = do let cinfobox = get currentCanvasInfo xstate - page = unboxGetPage cinfobox cpn = PageNum . unboxGet currentPageNum $ cinfobox canvas = unboxGet drawArea cinfobox xojstate = get xournalstate xstate fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry - fsingle = flip (makeCanvasGeometry EditMode (cpn,page)) canvas + fsingle = flip (makeCanvasGeometry cpn) canvas . get (pageArrangement.viewInfo) boxAction fsingle cinfobox diff --git a/lib/Application/HXournal/Coroutine/Commit.hs b/lib/Application/HXournal/Coroutine/Commit.hs --- a/lib/Application/HXournal/Coroutine/Commit.hs +++ b/lib/Application/HXournal/Coroutine/Commit.hs @@ -16,16 +16,14 @@ import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Event import Application.HXournal.Type.Undo - import Application.HXournal.Coroutine.Draw import Application.HXournal.ModelAction.File import Application.HXournal.ModelAction.Page - import Data.Label import Control.Monad.Trans import Application.HXournal.Accessor - +-- | save state and add the current status in undo history commit :: HXournalState -> MainCoroutine () commit xstate = do @@ -39,9 +37,10 @@ $ xstate putSt xstate' +-- | + undo :: MainCoroutine () undo = do - liftIO $ putStrLn "undo is called" xstate <- getSt let utable = get undoTable xstate case getPrevUndo utable of @@ -53,10 +52,10 @@ =<< (liftIO (updatePageAll xojstate xstate)) invalidateAll +-- | redo :: MainCoroutine () redo = do - liftIO $ putStrLn "redo is called" xstate <- getSt let utable = get undoTable xstate case getNextUndo utable of @@ -68,9 +67,10 @@ =<< (liftIO (updatePageAll xojstate xstate)) invalidateAll +-- | + clearUndoHistory :: MainCoroutine () clearUndoHistory = do - liftIO $ putStrLn "clearUndoHistory is called" xstate <- getSt putSt . set undoTable (emptyUndo 1) $ xstate diff --git a/lib/Application/HXournal/Coroutine/Draw.hs b/lib/Application/HXournal/Coroutine/Draw.hs --- a/lib/Application/HXournal/Coroutine/Draw.hs +++ b/lib/Application/HXournal/Coroutine/Draw.hs @@ -58,7 +58,8 @@ fsingle xstate cvsInfo = do let cpn = PageNum . get currentPageNum $ cvsInfo isCurrentCvs = cid == getCurrentCanvasId xstate - case get currentPage cvsInfo of + epage = getCurrentPageEitherFromXojState cvsInfo (get xournalstate xstate) + case epage of Left page -> do liftIO (unSinglePageDraw drawf isCurrentCvs <$> get drawArea <*> pure (cpn,page) @@ -133,8 +134,8 @@ xst <- getSt selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst where fsingle xstate cvsInfo = do - let page = either id gcast $ get currentPage cvsInfo - canvas = get drawArea cvsInfo + page <- getCurrentPageCvsId cid + let canvas = get drawArea cvsInfo vinfo = get viewInfo cvsInfo pnum = PageNum . get currentPageNum $ cvsInfo geometry <- liftIO $ getCanvasGeometry xstate @@ -156,8 +157,8 @@ xst <- getSt selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst where fsingle xstate cvsInfo = do - let page = either id gcast $ get currentPage cvsInfo - canvas = get drawArea cvsInfo + page <- getCurrentPageCvsId cid + let canvas = get drawArea cvsInfo vinfo = get viewInfo cvsInfo geometry <- liftIO $ getCanvasGeometry xstate win <- liftIO $ widgetGetDrawWindow canvas diff --git a/lib/Application/HXournal/Coroutine/Eraser.hs b/lib/Application/HXournal/Coroutine/Eraser.hs --- a/lib/Application/HXournal/Coroutine/Eraser.hs +++ b/lib/Application/HXournal/Coroutine/Eraser.hs @@ -76,9 +76,10 @@ St.runState (hitTestStrokes line hittestbbox) False if hitState then do + page <- getCurrentPageCvsId cid let currxoj = unView . get xournalstate $ xstate pgnum = get currentPageNum cvsInfo - (mcurrlayer, currpage) = getCurrentLayerOrSet . getPage $ cvsInfo + (mcurrlayer, currpage) = getCurrentLayerOrSet page currlayer = maybe (error "eraserProcess") id mcurrlayer let (newstrokes,maybebbox1) = St.runState (eraseHitted hitteststroke) Nothing maybebbox = fmap (flip inflate 2.0) maybebbox1 diff --git a/lib/Application/HXournal/Coroutine/Layer.hs b/lib/Application/HXournal/Coroutine/Layer.hs --- a/lib/Application/HXournal/Coroutine/Layer.hs +++ b/lib/Application/HXournal/Coroutine/Layer.hs @@ -33,11 +33,7 @@ import Control.Category import Data.Label import Prelude hiding ((.),id) - - - import Data.IORef - import qualified Data.Sequence as Seq import Graphics.UI.Gtk hiding (get,set) @@ -48,7 +44,8 @@ selectBoxAction (fsingle xst) (fsingle xst) . get currentCanvasInfo $ xst where fsingle xstate cvsInfo = do - let epage = get currentPage cvsInfo + let xojstate = get xournalstate xstate + let epage = getCurrentPageEitherFromXojState cvsInfo xojstate cpn = get currentPageNum cvsInfo xojstate = get xournalstate xstate newxojstate <- either (action xojstate cpn) (action xojstate cpn . gcast) epage @@ -125,10 +122,11 @@ startGotoLayerAt :: MainCoroutine () startGotoLayerAt = selectBoxAction fsingle fsingle . get currentCanvasInfo =<< getSt - {- (error "startGotoLayerAt") -} where fsingle cvsInfo = do - let epage = get currentPage cvsInfo + xstate <- getSt + let xojstate = get xournalstate xstate + let epage = getCurrentPageEitherFromXojState cvsInfo xojstate page = either id gcast epage (_,currpage) = getCurrentLayerOrSet page Select (O (Just lyrzipper)) = get g_layers currpage diff --git a/lib/Application/HXournal/Coroutine/Mode.hs b/lib/Application/HXournal/Coroutine/Mode.hs --- a/lib/Application/HXournal/Coroutine/Mode.hs +++ b/lib/Application/HXournal/Coroutine/Mode.hs @@ -25,7 +25,6 @@ import Application.HXournal.ModelAction.Page import Application.HXournal.Coroutine.Scroll import Application.HXournal.Coroutine.Draw ---import Data.Foldable import Data.Traversable import Control.Applicative import Control.Monad.Trans @@ -77,10 +76,11 @@ whencont xstate cinfo = do geometry <- liftIO $ getCanvasGeometry xstate cdim <- liftIO $ return . canvasDim =<< getCanvasGeometry xstate + page <- getCurrentPageCurr let zmode = get (zoomMode.viewInfo) cinfo canvas = get drawArea cinfo cpn = PageNum . get currentPageNum $ cinfo - page = getPage cinfo + pdim = PageDimension (get g_dimension page ) ViewPortBBox bbox = get (viewPortBBox.pageArrangement.viewInfo) cinfo (x0,y0) = bbox_upperleft bbox @@ -92,7 +92,6 @@ (get scrolledWindow cinfo) nvinfo (unPageNum cpn) - (Left page) (get horizAdjustment cinfo) (get vertAdjustment cinfo) (get horizAdjConnId cinfo) @@ -103,17 +102,17 @@ whensing xstate cinfo = do cdim <- liftIO $ return . canvasDim =<< getCanvasGeometry xstate + page <- getCurrentPageCurr let zmode = get (zoomMode.viewInfo) cinfo canvas = get drawArea cinfo cpn = PageNum . get currentPageNum $ cinfo - page = getPage cinfo (hadj,vadj) = get adjustments cinfo (xpos,ypos) <- liftIO $ (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj let arr = makeContinuousSingleArrangement zmode cdim (getXournal xstate) (cpn, PageCoord (xpos,ypos)) ContinuousSingleArrangement _ (DesktopDimension (Dim w h)) _ _ = arr - geometry <- liftIO $ makeCanvasGeometry EditMode (cpn,page) arr canvas + geometry <- liftIO $ makeCanvasGeometry cpn arr canvas let DeskCoord (nxpos,nypos) = page2Desktop geometry (cpn,PageCoord (xpos,ypos)) let vinfo = get viewInfo cinfo nvinfo = ViewInfo (get zoomMode vinfo) arr @@ -122,7 +121,6 @@ (get scrolledWindow cinfo) nvinfo (get currentPageNum cinfo) - (get currentPage cinfo) hadj vadj (get horizAdjConnId cinfo) diff --git a/lib/Application/HXournal/Coroutine/Page.hs b/lib/Application/HXournal/Coroutine/Page.hs --- a/lib/Application/HXournal/Coroutine/Page.hs +++ b/lib/Application/HXournal/Coroutine/Page.hs @@ -102,8 +102,8 @@ fsingle xstate cinfo = do geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo + page <- getCurrentPageCvsId cid let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode - page = getPage cinfo pdim = PageDimension $ get g_dimension page cdim = canvasDim geometry narr = makeSingleArrangement zmode pdim cdim (0,0) @@ -114,9 +114,9 @@ fcont xstate cinfo = do geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo + page <- getCurrentPageCvsId cid let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode cpn = PageNum $ get currentPageNum cinfo - page = getPage cinfo pdim = PageDimension $ get g_dimension page cdim = canvasDim geometry xoj = getXournal xstate @@ -141,39 +141,6 @@ cid <- (liftM (getCurrentCanvasId) getSt) canvasZoomUpdateCvsId cid mzmode -{- - updateXState zoomUpdateAction - >> adjustScrollbarWithGeometryCurrent - >> invalidateAll - where zoomUpdateAction xst = - selectBoxAction (fsingle xst) (fcont xst) . get currentCanvasInfo $ xst - - fsingle xstate cinfo = do - geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo - let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode - page = getPage cinfo - pdim = PageDimension $ get g_dimension page - cdim = canvasDim geometry - narr = makeSingleArrangement zmode pdim cdim (0,0) - ncinfobox = CanvasInfoBox - . set (pageArrangement.viewInfo) narr - . set (zoomMode.viewInfo) zmode $ cinfo - return . modifyCurrentCanvasInfo (const ncinfobox) $ xstate - - fcont xstate cinfo = do - geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo - let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode - cpn = PageNum $ get currentPageNum cinfo - page = getPage cinfo - pdim = PageDimension $ get g_dimension page - cdim = canvasDim geometry - xoj = getXournal xstate - narr = makeContinuousSingleArrangement zmode cdim xoj (cpn,PageCoord (0,0)) - ncinfobox = CanvasInfoBox - . set (pageArrangement.viewInfo) narr - . set (zoomMode.viewInfo) zmode $ cinfo - return . modifyCurrentCanvasInfo (const ncinfobox) $ xstate --} -- | diff --git a/lib/Application/HXournal/Coroutine/Pen.hs b/lib/Application/HXournal/Coroutine/Pen.hs --- a/lib/Application/HXournal/Coroutine/Pen.hs +++ b/lib/Application/HXournal/Coroutine/Pen.hs @@ -57,11 +57,7 @@ return cinfo' where switchact xst = do let xoj = getXournal xst - let page = maybeError "no such page in penPageSwitch" - $ IM.lookup (unPageNum pgn) (get g_pages xoj) - ncinfo = set currentPageNum (unPageNum pgn) - . set currentPage (Left page) - $ cinfo + ncinfo = set currentPageNum (unPageNum pgn) cinfo mfunc = const (return . CanvasInfoBox $ ncinfo) return . (,ncinfo) =<< modifyCurrCvsInfoM mfunc xst @@ -81,11 +77,10 @@ boxAction f . getCanvasInfo cid $ nxstate where f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine () f cvsInfo = do - let page = getPage cvsInfo - cpn = PageNum . get currentPageNum $ cvsInfo + let cpn = PageNum . get currentPageNum $ cvsInfo arr = get (pageArrangement.viewInfo) cvsInfo canvas = get drawArea cvsInfo - geometry <- liftIO $ makeCanvasGeometry EditMode (cpn,page) arr canvas + geometry <- liftIO $ makeCanvasGeometry cpn arr canvas let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord maybeFlip pagecoord (return ()) $ \(pgn,PageCoord (x,y)) -> do diff --git a/lib/Application/HXournal/Coroutine/Select.hs b/lib/Application/HXournal/Coroutine/Select.hs --- a/lib/Application/HXournal/Coroutine/Select.hs +++ b/lib/Application/HXournal/Coroutine/Select.hs @@ -46,6 +46,7 @@ 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,(|>)) @@ -94,19 +95,22 @@ action (Right tpage) | hitInHandle tpage (x,y) = case getULBBoxFromSelected tpage of Middle bbox -> - maybe (return ()) (\handle -> do { tsel <- createTempSelectRender pnum geometry (gcast tpage :: Page EditMode) (getSelectedStrokes tpage); resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel ; surfaceFinish (tempSurface tsel) }) (checkIfHandleGrasped bbox (x,y)) + 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 - tsel <- createTempSelectRender pnum geometry - (gcast tpage :: Page EditMode) (getSelectedStrokes tpage) - moveSelect cid pnum geometry cidmove cidup - (x,y) ((x,y),ctime) tsel - surfaceFinish (tempSurface tsel) - + startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage action (Right tpage) | otherwise = newSelectAction (gcast tpage :: Page EditMode ) action (Left page) = newSelectAction page - action (get currentPage cinfo) + xstate <- getSt + let xojstate = get xournalstate xstate + let epage = getCurrentPageEitherFromXojState cinfo xojstate + action epage +-- | newSelectRectangle :: CanvasId -> PageNum @@ -131,8 +135,8 @@ let bbox = BBox orig (x,y) hittestbbox = mkHitTestInsideBBox bbox strs hittedstrs = concat . map unHitted . getB $ hittestbbox - let page = either id gcast $ get currentPage cinfo - (fstrs,sstrs) = separateFS $ getDiffStrokeBBox (tempSelected tempselection) hittedstrs + 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 @@ -160,7 +164,7 @@ upact xstate cinfo pcoord = do let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord (x,y) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return - let epage = get currentPage cinfo + let epage = getCurrentPageEitherFromXojState cinfo (get xournalstate xstate) cpn = get currentPageNum cinfo let bbox = BBox orig (x,y) hittestbbox = mkHitTestInsideBBox bbox strs @@ -184,19 +188,25 @@ disconnect connidup invalidateAll -{- let (mcurrlayer,npagebbox) = getCurrentLayerOrSet pagebbox - currlayer = maybe (error "newSelectRectangle") 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 -} - - - - - +-- | 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) -- | @@ -207,7 +217,7 @@ -> ConnectId DrawingArea -> (Double,Double) -> ((Double,Double),UTCTime) - -> TempSelection + -> TempSelectRender StrokesNImage -> MainCoroutine () moveSelect cid pnum geometry connidmove connidup orig@(x0,y0) (prev,otime) tempselection = do @@ -229,11 +239,22 @@ (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do - let strs = tempSelectInfo tempselection - newstrs = map (changeStrokeBy (offsetFunc (x-x0,y-y0))) strs - drawselection = do - mapM_ (drawOneStroke . gToStroke) newstrs - invalidateTempBasePage cid (tempSurface tempselection) pnum drawselection + 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 +{- (c1,c2) = (x-x0,y-y0) + (a1,a2) = (1,0) + (b1,b2) = (0,1) + xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 -} + invalidateTempBasePage cid (tempSurface tempselection) pnum + (drawTempSelectImage geometry tempselection xformmat) + -- (translate (x-x0) (y-y0))) moveSelect cid pnum geometry connidmove connidup orig (ncoord,ntime) tempselection upact :: (ViewMode a) => HXournalState -> CanvasInfo a -> PointerCoord -> MainCoroutine () @@ -243,8 +264,8 @@ (ordaction xst cinfo) chgaction :: (ViewMode a) => HXournalState -> CanvasInfo a -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () chgaction xstate cinfo oldpgn (newpgn,PageCoord (x,y)) = do - let SelectState txoj = get xournalstate xstate - epage = get currentPage cinfo + let xojstate@(SelectState txoj) = get xournalstate xstate + epage = getCurrentPageEitherFromXojState cinfo xojstate (xstate1,ntxoj1,selectedstrs) <- case epage of Right oldtpage -> do @@ -265,8 +286,7 @@ ntpage = makePageSelectMode npage alist coroutineaction = do ntxoj2 <- liftIO $ updateTempXournalSelectIO ntxoj1 ntpage (unPageNum newpgn) - let ncinfo = set currentPage (Right ntpage) - . set currentPageNum (unPageNum newpgn) $ cinfo + 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 @@ -279,12 +299,10 @@ disconnect connidup invalidateAll - - ordaction xstate cinfo _pgn (_cpn,PageCoord (x,y)) = do let offset = (x-x0,y-y0) - SelectState txoj = get xournalstate xstate - epage = get currentPage cinfo + xojstate@(SelectState txoj) = get xournalstate xstate + epage = getCurrentPageEitherFromXojState cinfo xojstate pagenum = get currentPageNum cinfo case epage of Right tpage -> do @@ -297,12 +315,31 @@ disconnect connidup invalidateAll + +-- | prepare for resizing selection - -- return () - -- runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return - -- penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) +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 @@ -312,7 +349,7 @@ -> ConnectId DrawingArea -> BBox -> ((Double,Double),UTCTime) - -> TempSelection + -> TempSelectRender StrokesNImage -> MainCoroutine () resizeSelect handle cid pnum geometry connidmove connidup origbbox (prev,otime) tempselection = do @@ -326,21 +363,27 @@ moveact xstate cinfo (x,y) = do (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do - let strs = tempSelectInfo tempselection + let newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) sfunc = scaleFromToBBox origbbox newbbox - newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) - newstrs = map (changeStrokeBy sfunc) strs - drawselection = do - mapM_ (drawOneStroke . gToStroke) newstrs - invalidateTemp cid (tempSurface tempselection) drawselection + 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 pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord (x,y) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) - SelectState txoj = get xournalstate xstate - epage = get currentPage cinfo + xojstate@(SelectState txoj) = get xournalstate xstate + epage = getCurrentPageEitherFromXojState cinfo xojstate pagenum = get currentPageNum cinfo case epage of Right tpage -> do @@ -389,9 +432,11 @@ copySelection = updateXState copySelectionAction >> invalidateAll where copySelectionAction xst = selectBoxAction (fsingle xst) (fsingle xst) . get currentCanvasInfo $ xst - fsingle xstate cinfo = maybe (return xstate) id $ - eitherMaybe (get currentPage cinfo) `pipe` getActiveLayer - `pipe` (Right . xstateadj . takeHittedStrokes) + 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 @@ -408,10 +453,11 @@ where pasteAction xst = boxAction (fsimple xst) . get currentCanvasInfo $ xst fsimple xstate cinfo = do - let SelectState txoj = get xournalstate xstate + let xojstate@(SelectState txoj) = get xournalstate xstate clipstrs = getClipContents . get clipboard $ xstate pagenum = get currentPageNum cinfo - tpage = either gcast id (get currentPage cinfo) + epage = getCurrentPageEitherFromXojState cinfo xojstate + tpage = either gcast id epage layerselect = gselectedlayerbuf . glayers $ tpage ls = glayers tpage gbuf = get g_buffer layerselect @@ -487,22 +533,28 @@ 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) = do - tsel <- createTempSelectRender - pnum geometry (gcast tpage :: Page EditMode) - (getSelectedStrokes tpage) - moveSelect (get canvasId cinfo) pnum geometry cidmove cidup - (x,y) ((x,y),ctime) 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 -> do { tsel <- createTempSelectRender pnum geometry (gcast tpage :: Page EditMode) (getSelectedStrokes tpage); resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel ; surfaceFinish (tempSurface tsel) }) (checkIfHandleGrasped bbox (x,y)) + 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 - action (get currentPage cinfo) + xstate <- getSt + let xojstate = get xournalstate xstate + let epage = getCurrentPageEitherFromXojState cinfo xojstate + action epage + + +-- | + newSelectLasso :: (ViewMode a) => CanvasInfo a -> PageNum -> CanvasGeometry @@ -529,10 +581,12 @@ newSelectLasso cinfo pnum geometry cidmove cidup strs orig (ncoord,ntime) nlasso tsel upact cinfo pcoord = do + xstate <- getSt let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord (x,y) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return nlasso = lasso |> (x,y) - let epage = get currentPage cinfo + xojstate = get xournalstate xstate + let epage = getCurrentPageEitherFromXojState cinfo xojstate cpn = get currentPageNum cinfo let hittestlasso = mkHitTestAL (hitLassoStroke (nlasso |> orig)) strs selectstrs = fmapAL unNotHitted id hittestlasso @@ -561,9 +615,5 @@ disconnect cidmove disconnect cidup invalidateAll - - - - diff --git a/lib/Application/HXournal/Coroutine/Window.hs b/lib/Application/HXournal/Coroutine/Window.hs --- a/lib/Application/HXournal/Coroutine/Window.hs +++ b/lib/Application/HXournal/Coroutine/Window.hs @@ -33,6 +33,7 @@ import qualified Data.IntMap as M import Data.Maybe import Data.Xournal.Simple (Dimension(..)) +import Data.Xournal.Generic import Prelude hiding ((.),id) -- | @@ -50,7 +51,9 @@ let cinfo' = updateCanvasDimForSingle cdim cinfo return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate fcont xstate cinfo = do - let cinfo' = updateCanvasDimForContSingle cdim cinfo + page <- getCurrentPageCvsId cid + let pdim = PageDimension (get g_dimension page) + let cinfo' = updateCanvasDimForContSingle pdim cdim cinfo return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate diff --git a/lib/Application/HXournal/ModelAction/Page.hs b/lib/Application/HXournal/ModelAction/Page.hs --- a/lib/Application/HXournal/ModelAction/Page.hs +++ b/lib/Application/HXournal/ModelAction/Page.hs @@ -53,13 +53,17 @@ . xojstateEither +{- updatePageFromCanvasToXournal :: (ViewMode a) => CanvasInfo a -> XournalState -> XournalState updatePageFromCanvasToXournal cinfo xojstate = - let cpn = get currentPageNum cinfo - epg = get currentPage cinfo - page = either id gcast epg + let cpn = get curentPageNum + page = getCurrentPageFromXojState cinfo xojstate + -- either id gcast epg in setPageMap (M.adjust (const page) cpn . getPageMap $ xojstate) xojstate + -- epg = get currentPage cinfo +-} + -- | updatePageAll :: XournalState -> HXournalState -> IO HXournalState @@ -69,13 +73,9 @@ return $ maybe xstate id . setCanvasInfoMap cmap' . set xournalstate xojst $ xstate - --- return newxstate --- let cid = getCurrentCanvasId xstate --- cinfobox = maybeError "updatePageAll" (M.lookup cid cmap') - -- set currentCanvasInfo cinfobox - -- set currentCanvas (cid,cinfobox) +-- | + adjustPage :: XournalState -> CanvasInfoBox -> CanvasInfoBox adjustPage xojstate = selectBox fsingle fsingle where fsingle :: CanvasInfo a -> CanvasInfo a @@ -104,12 +104,10 @@ updateCvsInfoFrmXoj xoj cinfobox = selectBoxAction fsingle fcont cinfobox where fsingle cinfo = do let pagenum = get currentPageNum cinfo - page = getPage cinfo let oarr = get (pageArrangement.viewInfo) cinfo canvas = get drawArea cinfo zmode = get (zoomMode.viewInfo) cinfo - geometry <- makeCanvasGeometry EditMode (PageNum pagenum,page) - oarr canvas + geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas let cdim = canvasDim geometry pg = getPageFromGXournalMap pagenum xoj pdim@(PageDimension (Dim w h)) = PageDimension $ get g_dimension pg @@ -120,19 +118,16 @@ adjustmentSetUpper vadj h return . CanvasInfoBox . set currentPageNum pagenum - . set (pageArrangement.viewInfo) arr - . set currentPage (Left pg) $ cinfo + . set (pageArrangement.viewInfo) arr $ cinfo fcont cinfo = do let pagenum = get currentPageNum cinfo - page = getPage cinfo let oarr = get (pageArrangement.viewInfo) cinfo canvas = get drawArea cinfo zmode = get (zoomMode.viewInfo) cinfo (hadj,vadj) = get adjustments cinfo (xdesk,ydesk) <- (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj - geometry <- makeCanvasGeometry EditMode (PageNum pagenum,page) - oarr canvas + geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas let ulcoord = maybeError "updateCvsFromXoj" $ desktop2Page geometry (DeskCoord (xdesk,ydesk)) let cdim = canvasDim geometry @@ -144,8 +139,7 @@ adjustmentSetUpper vadj h return . CanvasInfoBox . set currentPageNum pagenum - . set (pageArrangement.viewInfo) arr - . set currentPage (Left pg) $ cinfo + . set (pageArrangement.viewInfo) arr $ cinfo @@ -171,13 +165,11 @@ in spg fsingle cinfo = do let xoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj) - CanvasInfoBox cinfo' <- updateCvsInfoFrmXoj xoj cinfobox - return . CanvasInfoBox . set currentPage (getselectedpage cinfo) $ cinfo' - + updateCvsInfoFrmXoj xoj cinfobox fcont cinfo = do let xoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj) - CanvasInfoBox cinfo' <- updateCvsInfoFrmXoj xoj cinfobox - return . CanvasInfoBox . set currentPage (getselectedpage cinfo) $ cinfo' + updateCvsInfoFrmXoj xoj cinfobox + {- @@ -225,9 +217,7 @@ zmode = get (zoomMode.viewInfo) cinfo arr = makeSingleArrangement zmode pdim cdim (0,0) return $ set currentPageNum (unPageNum pnum) - . set (pageArrangement.viewInfo) arr - . set currentPage (Left pg) - $ cinfo + . set (pageArrangement.viewInfo) arr $ cinfo -- | setPageCont : in ContinuousSingle Page mode @@ -243,9 +233,8 @@ zmode = get (zoomMode.viewInfo) cinfo arr = makeContinuousSingleArrangement zmode cdim xoj (pnum,PageCoord (0,0)) return $ set currentPageNum (unPageNum pnum) - . set (pageArrangement.viewInfo) arr - . set currentPage (Left pg) - $ cinfo + . set (pageArrangement.viewInfo) arr $ cinfo + -- | diff --git a/lib/Application/HXournal/ModelAction/Select.hs b/lib/Application/HXournal/ModelAction/Select.hs --- a/lib/Application/HXournal/ModelAction/Select.hs +++ b/lib/Application/HXournal/ModelAction/Select.hs @@ -25,11 +25,14 @@ import Data.Monoid import Data.Xournal.Generic import Data.Xournal.BBox +import Data.Xournal.Simple (Dimension(..)) import Graphics.Xournal.Render.Type +import Graphics.Xournal.Render.BBox import Graphics.Xournal.Render.BBoxMapPDF import Graphics.Xournal.Render.HitTest - +import Graphics.Xournal.Render.Simple import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Matrix (Matrix, invert, transformPoint ) import Graphics.UI.Gtk hiding (get,set) import Data.Time.Clock import Control.Monad @@ -88,18 +91,11 @@ getActiveLayer :: Page SelectMode -> Either [StrokeBBox] (TAlterHitted StrokeBBox) getActiveLayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . get g_layers -{- let ls = glayers tpage - slayer = gselectedlayerbuf ls - in et $ slayer -} getSelectedStrokes :: Page SelectMode -> [StrokeBBox] getSelectedStrokes = either (const []) (concatMap unHitted . getB) . getActiveLayer - {- let activelayer = getActiveLayer tpage - in case activelayer of - Left _ -> [] - Right alist -> concatMap unHitted . getB $ alist -} -- | start a select mode with alter list selection @@ -198,7 +194,6 @@ Middle bbox -> hitTestBBoxPoint bbox point _ -> False - -- any (flip hitTestBBoxPoint point) bboxes getULBBoxFromSelected :: Page SelectMode -> ULMaybe BBox getULBBoxFromSelected tpage = @@ -343,6 +338,56 @@ } type TempSelection = TempSelectRender [StrokeBBox] + +data StrokesNImage = StrokesNImage { strokes :: [StrokeBBox] + , strbbox :: Maybe BBox + , imageSurface :: Surface } + + +-- | + +mkStrokesNImage :: CanvasGeometry -> Page SelectMode -> IO StrokesNImage +mkStrokesNImage geometry tpage = do + let strs = getSelectedStrokes tpage + drawselection = mapM_ (drawOneStroke.gToStroke) strs + Dim cw ch = get g_dimension tpage -- unCanvasDimension . canvasDim $ geometry + mbbox = case getULBBoxFromSelected tpage of + Middle bbox -> Just bbox + _ -> Nothing + sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch) + renderWith sfc $ do + setSourceRGBA 1 1 1 0 + rectangle 0 0 cw ch + fill + setSourceRGBA 0 0 0 1 + drawselection + return $ StrokesNImage strs mbbox sfc + +-- | + +drawTempSelectImage :: CanvasGeometry + -> TempSelectRender StrokesNImage + -> Matrix -- ^ transformation matrix + -> Render () +drawTempSelectImage geometry tempselection xformmat = do + let sfc = imageSurface (tempSelectInfo tempselection) + CanvasDimension (Dim cw ch) = canvasDim geometry + invxformmat = invert xformmat + newvbbox = BBox (transformPoint invxformmat (0,0)) + (transformPoint invxformmat (cw,ch)) + mbbox = strbbox (tempSelectInfo tempselection) + newmbbox = case unIntersect (Intersect (Middle newvbbox) `mappend` fromMaybe mbbox) of + Middle bbox -> Just bbox + _ -> Just newvbbox + setMatrix xformmat + clipBBox newmbbox + setSourceSurface sfc 0 0 + setOperator OperatorOver + paint + + + +-- | tempSelected :: TempSelection -> [StrokeBBox] tempSelected = tempSelectInfo diff --git a/lib/Application/HXournal/ModelAction/Window.hs b/lib/Application/HXournal/ModelAction/Window.hs --- a/lib/Application/HXournal/ModelAction/Window.hs +++ b/lib/Application/HXournal/ModelAction/Window.hs @@ -66,7 +66,7 @@ scrolledWindowSetHAdjustment scrwin hadj scrolledWindowSetVAdjustment scrwin vadj -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic - return $ CanvasInfo cid canvas scrwin (error "no viewInfo" :: ViewInfo a) 0 (error "No page") hadj vadj Nothing Nothing + return $ CanvasInfo cid canvas scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing -- | only connect events @@ -150,7 +150,7 @@ newcinfo <- minimalCanvasInfo xstate cid return $ newcinfo { _viewInfo = _viewInfo oldcinfo , _currentPageNum = _currentPageNum oldcinfo - , _currentPage = _currentPage oldcinfo } + } -- | event connect diff --git a/lib/Application/HXournal/Type/Canvas.hs b/lib/Application/HXournal/Type/Canvas.hs --- a/lib/Application/HXournal/Type/Canvas.hs +++ b/lib/Application/HXournal/Type/Canvas.hs @@ -13,7 +13,65 @@ -- ----------------------------------------------------------------------------- -module Application.HXournal.Type.Canvas where +module Application.HXournal.Type.Canvas +( +-- * data types + CanvasId +, PenDraw (..) +, emptyPenDraw +, ViewInfo (..) +, CanvasInfo (..) +, CanvasInfoBox (..) +, CanvasInfoMap +, PenType (..) +, WidthColorStyle +, PenHighlighterEraserSet +, PenInfo +-- * default constructor +, defaultViewInfoSinglePage +, defaultCvsInfoSinglePage +, defaultPenWCS +, defaultEraserWCS +, defaultTextWCS +, defaultHighligherWCS +, defaultPenInfo +-- * lenses +, zoomMode +, pageArrangement +, canvasId +, drawArea +, scrolledWindow +, viewInfo +, currentPageNum +-- , currentPage +, horizAdjustment +, vertAdjustment +, horizAdjConnId +, vertAdjConnId +, adjustments +, currentTool +, penWidth +, penColor +, currPen +, currHighlighter +, currEraser +, currText +, penType +, penSet +-- * for box +, getDrawAreaFromBox +, unboxGet +, fmapBox +, boxAction +, selectBoxAction +, selectBox +, pageArrEitherFromCanvasInfoBox +, viewModeBranch +-- * others +-- , getPage +, updateCanvasDimForSingle +, updateCanvasDimForContSingle +) where import Application.HXournal.Type.Enum import Application.HXournal.Type.Alias @@ -47,6 +105,8 @@ , _pageArrangement :: PageArrangement a } +-- | default view info with single page mode + defaultViewInfoSinglePage :: ViewInfo SinglePage defaultViewInfoSinglePage = ViewInfo { _zoomMode = Original @@ -55,6 +115,7 @@ (PageDimension (Dim 100 100)) (ViewPortBBox (BBox (0,0) (100,100))) } +-- | lens for zoomMode zoomMode :: ViewInfo a :-> ZoomMode zoomMode = lens _zoomMode (\a f -> f { _zoomMode = a } ) @@ -69,7 +130,7 @@ , _scrolledWindow :: ScrolledWindow , _viewInfo :: ViewInfo a , _currentPageNum :: Int - , _currentPage :: Either (Page EditMode) (Page SelectMode) + -- , _currentPage :: Either (Page EditMode) (Page SelectMode) , _horizAdjustment :: Adjustment , _vertAdjustment :: Adjustment , _horizAdjConnId :: Maybe (ConnectId Adjustment) @@ -83,7 +144,7 @@ , _scrolledWindow = error "ScrolledWindow" , _viewInfo = defaultViewInfoSinglePage , _currentPageNum = 0 - , _currentPage = error "currentPage" + -- , _currentPage = error "currentPage" , _horizAdjustment = error "adjustment" , _vertAdjustment = error "vadjust" , _horizAdjConnId = Nothing @@ -105,24 +166,31 @@ currentPageNum :: CanvasInfo a :-> Int currentPageNum = lens _currentPageNum (\a f -> f { _currentPageNum = a }) +{- currentPage :: CanvasInfo a :-> Either (Page EditMode) (Page SelectMode) currentPage = lens _currentPage (\a f -> f { _currentPage = a }) +-} +-- | + horizAdjustment :: CanvasInfo a :-> Adjustment horizAdjustment = lens _horizAdjustment (\a f -> f { _horizAdjustment = a }) +-- | + vertAdjustment :: CanvasInfo a :-> Adjustment vertAdjustment = lens _vertAdjustment (\a f -> f { _vertAdjustment = a }) +-- | ConnectId for horizontal scrollbar value change event + horizAdjConnId :: CanvasInfo a :-> Maybe (ConnectId Adjustment ) horizAdjConnId = lens _horizAdjConnId (\a f -> f { _horizAdjConnId = a }) +-- | ConnectId for vertical scrollbar value change event + vertAdjConnId :: CanvasInfo a :-> Maybe (ConnectId Adjustment) vertAdjConnId = lens _vertAdjConnId (\a f -> f { _vertAdjConnId = a }) - - - -- | adjustments :: CanvasInfo a :-> (Adjustment,Adjustment) @@ -133,20 +201,26 @@ data CanvasInfoBox = forall a. (ViewMode a) => CanvasInfoBox (CanvasInfo a) getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea -getDrawAreaFromBox = unboxGet drawArea -- (CanvasInfoBox x) = get drawArea x +getDrawAreaFromBox = unboxGet drawArea +-- | + unboxGet :: (forall a. (ViewMode a) => CanvasInfo a :-> b) -> CanvasInfoBox -> b unboxGet f (CanvasInfoBox x) = get f x +-- | fmap-like operation for box + fmapBox :: (forall a. (ViewMode a) => CanvasInfo a -> CanvasInfo a) -> CanvasInfoBox -> CanvasInfoBox fmapBox f (CanvasInfoBox cinfo) = CanvasInfoBox (f cinfo) +-- | boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b) -> CanvasInfoBox -> m b boxAction f (CanvasInfoBox cinfo) = f cinfo +-- | either-like operation selectBoxAction :: (Monad m) => (CanvasInfo SinglePage -> m a) @@ -156,6 +230,8 @@ SingleArrangement _ _ _ -> fsingle cinfo ContinuousSingleArrangement _ _ _ _ -> fcont cinfo +-- | + selectBox :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) -> (CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage) -> CanvasInfoBox -> CanvasInfoBox @@ -164,11 +240,14 @@ idaction = selectBoxAction (return . CanvasInfoBox . fsingle) (return . CanvasInfoBox . fcont) in runIdentity . idaction +-- | + pageArrEitherFromCanvasInfoBox :: CanvasInfoBox -> Either (PageArrangement SinglePage) (PageArrangement ContinuousSinglePage) pageArrEitherFromCanvasInfoBox (CanvasInfoBox cinfo) = pageArrEither . get (pageArrangement.viewInfo) $ cinfo +-- | viewModeBranch :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) -> (CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage) @@ -186,10 +265,15 @@ | TextWork deriving (Show,Eq) + +-- | + data WidthColorStyle = WidthColorStyle { _penWidth :: Double , _penColor :: PenColor } deriving (Show) +-- | + data PenHighlighterEraserSet = PenHighlighterEraserSet { _currPen :: WidthColorStyle , _currHighlighter :: WidthColorStyle @@ -197,10 +281,13 @@ , _currText :: WidthColorStyle} deriving (Show) +-- | + data PenInfo = PenInfo { _penType :: PenType , _penSet :: PenHighlighterEraserSet } deriving (Show) +-- | currentTool :: PenInfo :-> WidthColorStyle currentTool = lens chooser setter where chooser pinfo = case _penType pinfo of @@ -217,18 +304,27 @@ TextWork -> pset { _currText = wcs } in pinfo { _penSet = psetnew } +-- | + defaultPenWCS :: WidthColorStyle defaultPenWCS = WidthColorStyle predefined_medium ColorBlack +-- | + defaultEraserWCS :: WidthColorStyle defaultEraserWCS = WidthColorStyle predefined_eraser_medium ColorWhite +-- | + defaultTextWCS :: WidthColorStyle defaultTextWCS = defaultPenWCS +-- | + defaultHighligherWCS :: WidthColorStyle defaultHighligherWCS = WidthColorStyle predefined_highlighter_medium ColorYellow +-- | defaultPenInfo :: PenInfo defaultPenInfo = @@ -243,9 +339,10 @@ -- | +{- getPage :: (ViewMode a) => CanvasInfo a -> (Page EditMode) getPage = either id (gcast :: Page SelectMode -> Page EditMode) . get currentPage - +-} -- | @@ -264,16 +361,17 @@ -- | -updateCanvasDimForContSingle :: CanvasDimension +updateCanvasDimForContSingle :: PageDimension + -> CanvasDimension -> CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage -updateCanvasDimForContSingle cdim@(CanvasDimension (Dim w' h')) cinfo = +updateCanvasDimForContSingle pdim cdim@(CanvasDimension (Dim w' h')) cinfo = let zmode = get (zoomMode.viewInfo) cinfo arr@(ContinuousSingleArrangement _ ddim func vbbox@(ViewPortBBox bbox)) = get (pageArrangement.viewInfo) cinfo (x,y) = bbox_upperleft bbox - dim = get g_dimension . getPage $ cinfo - (sinvx,sinvy) = getRatioPageCanvas zmode (PageDimension dim) cdim + -- dim = get g_dimension . getPage $ cinfo + (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy) arr' = ContinuousSingleArrangement cdim ddim func (ViewPortBBox nbbox) in set (pageArrangement.viewInfo) arr' cinfo diff --git a/lib/Application/HXournal/Type/XournalState.hs b/lib/Application/HXournal/Type/XournalState.hs --- a/lib/Application/HXournal/Type/XournalState.hs +++ b/lib/Application/HXournal/Type/XournalState.hs @@ -54,6 +54,7 @@ , modifyCurrentCanvasInfo , modifyCurrCvsInfoM , xojstateEither +, getCurrentPageFromXojState -- | for debug , showCanvasInfoMapViewPortBBox ) where @@ -157,7 +158,6 @@ setCurrentCanvasId a f = do cinfobox <- M.lookup a (_cvsInfoMap f) return (f { _currentCanvas = (a,cinfobox) }) - -- modify currentCanvas (\(_,x)->(a,x)) -- | @@ -187,8 +187,6 @@ cmap' = M.adjust (const a) cid (_cvsInfoMap f) in f { _currentCanvas = (cid,a), _cvsInfoMap = cmap' } --- modify currentCanvas (\(x,_)->(x,a)) - resetXournalStateBuffers :: XournalState -> IO XournalState resetXournalStateBuffers xojstate1 = case xojstate1 of @@ -240,11 +238,7 @@ . M.adjust f cid . getCanvasInfoMap $ xstate --- modify currentCanvasInfo f --- . modify canvasInfoMap (M.adjust f cid) - - -- | should be deprecated modifyCurrentCanvasInfo :: (CanvasInfoBox -> CanvasInfoBox) @@ -252,8 +246,6 @@ -> HXournalState modifyCurrentCanvasInfo f = modify currentCanvasInfo f - -- modify currentCanvasInfo f . modify canvasInfoMap (M.adjust f cid) $ st - -- where cid = getCurrentCanvasId st -- | should be deprecated @@ -268,8 +260,6 @@ ncinfomap = M.adjust (const ncinfobox) cid cinfomap maybe (return st) return (setCanvasInfoMap ncinfomap st) --- return nst --- set currentCanvasInfo ncinfobox -- | @@ -279,16 +269,25 @@ SelectState txoj -> Right txoj -- | + +getCurrentPageFromXojState :: (ViewMode a) => CanvasInfo a -> XournalState -> Page EditMode +getCurrentPageFromXojState cinfo xojstate = + let cpn = get currentPageNum cinfo + pagemap = getPageMapFromXojState xojstate + in maybeError "updatePageFromCanvasToXournal" $ M.lookup cpn pagemap +-- | + +getPageMapFromXojState :: XournalState -> M.IntMap (Page EditMode) +getPageMapFromXojState = either (get g_pages) (get g_selectAll) . xojstateEither + + +-- | + showCanvasInfoMapViewPortBBox :: HXournalState -> IO () showCanvasInfoMapViewPortBBox xstate = do let cmap = getCanvasInfoMap xstate putStrLn . show . map (unboxGet (viewPortBBox.pageArrangement.viewInfo)) . M.elems $ cmap - - - - - diff --git a/lib/Application/HXournal/View/Coordinate.hs b/lib/Application/HXournal/View/Coordinate.hs --- a/lib/Application/HXournal/View/Coordinate.hs +++ b/lib/Application/HXournal/View/Coordinate.hs @@ -53,20 +53,21 @@ -- | make a canvas geometry data structure from current status -makeCanvasGeometry :: (GPageable em) => - em - -> (PageNum, Page em) +makeCanvasGeometry :: -- (GPageable em) => + -- em + PageNum -- , Page em) -> PageDimension -> PageArrangement vm -> DrawingArea -> IO CanvasGeometry -makeCanvasGeometry typ (cpn,page) arr canvas = do +-- makeCanvasGeometry typ (cpn,page) arr canvas = do +makeCanvasGeometry cpn arr canvas = do win <- widgetGetDrawWindow canvas let cdim@(CanvasDimension (Dim w' h')) = get canvasDimension arr screen <- widgetGetScreen canvas (ws,hs) <- (,) <$> (fromIntegral <$> screenGetWidth screen) <*> (fromIntegral <$> screenGetHeight screen) (x0,y0) <- return . ((,) <$> fromIntegral.fst <*> fromIntegral.snd ) =<< drawWindowGetOrigin win - let (Dim w h) = get g_dimension page + let -- (Dim w h) = get g_dimension page corig = CanvasOrigin (x0,y0) let (deskdim, cvsvbbox, p2d, d2p) = case arr of @@ -187,13 +188,15 @@ -- | -getCvsGeomFrmCvsInfo :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry +getCvsGeomFrmCvsInfo :: (ViewMode a) => + -- Page EditMode -> + CanvasInfo a -> IO CanvasGeometry getCvsGeomFrmCvsInfo cinfo = do - let page = getPage cinfo + let -- page = getPage cinfo cpn = PageNum . get currentPageNum $ cinfo canvas = get drawArea cinfo arr = get (pageArrangement.viewInfo) cinfo - makeCanvasGeometry EditMode (cpn,page) arr canvas + makeCanvasGeometry cpn arr canvas -- EditMode (cpn,page) arr canvas diff --git a/lib/Application/HXournal/View/Draw.hs b/lib/Application/HXournal/View/Draw.hs --- a/lib/Application/HXournal/View/Draw.hs +++ b/lib/Application/HXournal/View/Draw.hs @@ -168,7 +168,7 @@ drawFuncGen typ render = SinglePageDraw func where func isCurrentCvs canvas (pnum,page) vinfo mbbox = do let arr = get pageArrangement vinfo - geometry <- makeCanvasGeometry typ (pnum,page) arr canvas + geometry <- makeCanvasGeometry pnum arr canvas win <- widgetGetDrawWindow canvas let ibboxnew = getViewableBBox geometry mbbox let mbboxnew = toMaybe ibboxnew @@ -207,9 +207,8 @@ where func isCurrentCvs cinfo mbbox xoj = do let arr = get (pageArrangement.viewInfo) cinfo pnum = PageNum . get currentPageNum $ cinfo - page = getPage cinfo canvas = get drawArea cinfo - geometry <- makeCanvasGeometry EditMode (pnum,page) arr canvas + geometry <- makeCanvasGeometry pnum arr canvas let pgs = get g_pages xoj let drawpgs = catMaybes . map f $ (getPagesInViewPortRange geometry xoj) @@ -256,10 +255,9 @@ where func isCurrentCvs cinfo mbbox txoj = do let arr = get (pageArrangement.viewInfo) cinfo pnum = PageNum . get currentPageNum $ cinfo - page = getPage cinfo - tpage = get currentPage cinfo + mtpage = get g_selectSelected txoj canvas = get drawArea cinfo - geometry <- makeCanvasGeometry EditMode (pnum,page) arr canvas + geometry <- makeCanvasGeometry pnum arr canvas let pgs = get g_selectAll txoj xoj = GXournal (get g_selectTitle txoj) pgs let drawpgs = catMaybes . map f @@ -290,9 +288,7 @@ -- clipBBox mbboxnew mapM_ onepagerender drawpgs -- emphasispagerender (pnum,page) - case tpage of - Left page' -> return () - Right tpage' -> selpagerender (pnum,tpage') + maybe (return ()) (\(n,tpage)-> selpagerender (PageNum n,tpage)) mtpage when isCurrentCvs (emphasisCanvasRender ColorGreen geometry) resetClip