diff --git a/hxournal.cabal b/hxournal.cabal --- a/hxournal.cabal +++ b/hxournal.cabal @@ -1,5 +1,5 @@ Name: hxournal -Version: 0.6.4.0 +Version: 0.6.4.1 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 @@ -10,6 +10,7 @@ -- Stability : experimental -- Portability : GHC -- +----------------------------------------------------------------------------- module Application.HXournal.Accessor where 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 @@ -128,7 +128,7 @@ -- | Drawing temporary gadgets -invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine () +invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine () invalidateTemp cid tempsurface rndr = do xst <- getSt selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst @@ -148,6 +148,27 @@ rndr +-- | Drawing temporary gadgets with coordinate based on base page + +invalidateTempBasePage :: CanvasId -> Surface -> PageNum -> Render () + -> MainCoroutine () +invalidateTempBasePage cid tempsurface pnum rndr = do + 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 + vinfo = get viewInfo cvsInfo + geometry <- liftIO $ getCanvasGeometry xstate + win <- liftIO $ widgetGetDrawWindow canvas + let xformfunc = cairoXform4PageCoordinate geometry pnum + liftIO $ renderWithDrawable win $ do + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint + xformfunc + rndr + -- | Drawing using layer buffer invalidateWithBuf :: CanvasId -> MainCoroutine () 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 @@ -150,18 +150,35 @@ penProcess cid pnum geometry connidmove connidup (pdraw |> (x,y)) (x,y) ) (\_ -> disconnect connidmove >> disconnect connidup >> return pdraw ) - +-- | + skipIfNotInSamePage :: Monad m => PageNum -> CanvasGeometry -> PointerCoord - -> m a -> ((Double,Double) -> m a) -> m a -skipIfNotInSamePage pgn geometry pcoord skipaction realaction = do + -> m a + -> ((Double,Double) -> m a) + -> m a +skipIfNotInSamePage pgn geometry pcoord skipaction ordaction = + switchActionEnteringDiffPage pgn geometry pcoord + skipaction (\_ _ -> skipaction ) (\_ (_,PageCoord xy)->ordaction 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, PageCoord (x,y)) -> if pgn == cpn then realaction (x,y) else 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 @@ -172,6 +189,20 @@ 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 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 @@ -33,6 +33,7 @@ import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Select import Application.HXournal.ModelAction.Layer +import Application.HXournal.Util import Control.Monad import Control.Monad.Identity import Control.Monad.Trans @@ -46,6 +47,7 @@ import Data.Xournal.BBox import Graphics.Rendering.Cairo import Data.Monoid +import qualified Data.IntMap as M import Data.Sequence (Seq,(|>)) import qualified Data.Sequence as Sq (empty) import Data.Time.Clock @@ -166,14 +168,7 @@ xstate <- getSt let SelectState txoj = get xournalstate xstate newpage = case epage of - Left pagebbox -> - 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 + Left pagebbox -> makePageSelectMode pagebbox selectstrs Right tpage -> let ls = glayers tpage currlayer = gselectedlayerbuf ls @@ -185,22 +180,28 @@ liftIO $ toggleCutCopyDelete ui (isAnyHitted selectstrs) putSt . set xournalstate (SelectState newtxoj) =<< (liftIO (updatePageAll (SelectState newtxoj) xstate)) - - -- x <- getSt - -- let SelectState txojtest = get xournalstate x - -- y = get g_selectSelected txojtest - -- liftIO $ print y - - disconnect connidmove 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 -} + + + + + + -- | moveSelect :: CanvasId - -> PageNum + -> PageNum -- ^ starting pagenum -> CanvasGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea @@ -214,22 +215,74 @@ 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) + 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 (x,y) = do + moveact xstate cinfo oldpgn pcpair@(newpgn,pgxy@(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 strs = tempSelectInfo tempselection newstrs = map (changeStrokeBy (offsetFunc (x-x0,y-y0))) strs drawselection = do mapM_ (drawOneStroke . gToStroke) newstrs - invalidateTemp cid (tempSurface tempselection) drawselection + invalidateTempBasePage cid (tempSurface tempselection) pnum drawselection moveSelect cid pnum geometry connidmove connidup orig (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 + 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 SelectState txoj = get xournalstate xstate + epage = get currentPage cinfo + (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 currentPage (Right ntpage) + . set currentPageNum (unPageNum newpgn) $ cinfo + cmap = get canvasInfoMap xstate1 + cmap' = M.adjust (const (CanvasInfoBox ncinfo)) cid cmap + xst = set canvasInfoMap 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) SelectState txoj = get xournalstate xstate epage = get currentPage cinfo @@ -244,6 +297,11 @@ disconnect connidmove disconnect connidup invalidateAll + + + -- return () + -- runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return + -- penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) -- | 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 @@ -51,7 +51,6 @@ return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate fcont xstate cinfo = do let cinfo' = updateCanvasDimForContSingle cdim cinfo - liftIO $ print cdim return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate 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 @@ -18,6 +18,8 @@ import Application.HXournal.Type.PageArrangement import Application.HXournal.View.Draw import Application.HXournal.View.Coordinate +import Application.HXournal.Util +import Application.HXournal.ModelAction.Layer import Data.Sequence (ViewL(..),viewl,Seq) import Data.Foldable (foldl') import Data.Monoid @@ -99,7 +101,36 @@ Left _ -> [] Right alist -> concatMap unHitted . getB $ alist -} +-- | start a select mode with alter list selection +makePageSelectMode :: Page EditMode -- ^ base page + -> TAlterHitted StrokeBBox -- ^ current selection layer (active layer will be replaced) + -> Page SelectMode -- ^ resultant select mode page +makePageSelectMode page alist = + let (mcurrlayer,npage) = getCurrentLayerOrSet page + currlayer = maybeError "makePageSelectMode" mcurrlayer + newlayer = GLayerBuf (get g_buffer currlayer) (TEitherAlterHitted (Right alist)) + tpg = gcast npage + ls = get g_layers tpg + npg = tpg { glayers = ls { gselectedlayerbuf = newlayer} } + in npg + + + +-- | get unselected part of page and make an ordinary page + +deleteSelected :: Page SelectMode -> Page SelectMode +deleteSelected tpage = + let activelayer = getActiveLayer tpage + ls = glayers tpage + buf = get g_buffer . gselectedlayerbuf $ ls + in case activelayer of + Left _ -> tpage + Right alist -> + let leftstrs = concat (getA alist) + layer' = GLayerBuf buf . TEitherAlterHitted . Left $ leftstrs + in tpage { glayers = ls { gselectedlayerbuf = layer' }} + -- | modify the whole selection using a function changeSelectionBy :: ((Double,Double) -> (Double,Double)) @@ -147,7 +178,12 @@ . set g_selectSelected (Just (pagenum,tpage)) $ txoj - +-- | + +calculateWholeBBox :: [StrokeBBox] -> Maybe BBox +calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. strokebbox_bbox ) + +-- | hitInSelection :: Page SelectMode -> (Double,Double) -> Bool hitInSelection tpage point = let activelayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . glayers $ tpage