hxournal 0.6.4.0 → 0.6.4.1
raw patch · 7 files changed
+178/−32 lines, 7 files
Files
- hxournal.cabal +1/−1
- lib/Application/HXournal/Accessor.hs +1/−0
- lib/Application/HXournal/Coroutine/Draw.hs +22/−1
- lib/Application/HXournal/Coroutine/Pen.hs +37/−6
- lib/Application/HXournal/Coroutine/Select.hs +80/−22
- lib/Application/HXournal/Coroutine/Window.hs +0/−1
- lib/Application/HXournal/ModelAction/Select.hs +37/−1
hxournal.cabal view
@@ -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
lib/Application/HXournal/Accessor.hs view
@@ -10,6 +10,7 @@ -- Stability : experimental -- Portability : GHC --+----------------------------------------------------------------------------- module Application.HXournal.Accessor where
lib/Application/HXournal/Coroutine/Draw.hs view
@@ -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 ()
lib/Application/HXournal/Coroutine/Pen.hs view
@@ -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
lib/Application/HXournal/Coroutine/Select.hs view
@@ -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) -- |
lib/Application/HXournal/Coroutine/Window.hs view
@@ -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
lib/Application/HXournal/ModelAction/Select.hs view
@@ -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