hxournal 0.6.2.1 → 0.6.3
raw patch · 17 files changed
+799/−234 lines, 17 filesdep +Diffdep ~xournal-builderdep ~xournal-parserdep ~xournal-render
Dependencies added: Diff
Dependency ranges changed: xournal-builder, xournal-parser, xournal-render, xournal-types
Files
- hxournal.cabal +13/−11
- lib/Application/HXournal/Coroutine/Commit.hs +6/−1
- lib/Application/HXournal/Coroutine/Default.hs +1/−1
- lib/Application/HXournal/Coroutine/Draw.hs +41/−10
- lib/Application/HXournal/Coroutine/Eraser.hs +6/−10
- lib/Application/HXournal/Coroutine/File.hs +6/−1
- lib/Application/HXournal/Coroutine/Highlighter.hs +7/−3
- lib/Application/HXournal/Coroutine/Pen.hs +16/−17
- lib/Application/HXournal/Coroutine/Scroll.hs +0/−1
- lib/Application/HXournal/Coroutine/Select.hs +207/−53
- lib/Application/HXournal/Draw.hs +265/−93
- lib/Application/HXournal/GUI/Menu.hs +26/−10
- lib/Application/HXournal/ModelAction/Pen.hs +7/−3
- lib/Application/HXournal/ModelAction/Select.hs +143/−15
- lib/Application/HXournal/Type/Canvas.hs +49/−4
- lib/Application/HXournal/Type/XournalState.hs +1/−1
- lib/Application/HXournal/Util.hs +5/−0
hxournal.cabal view
@@ -1,5 +1,5 @@ Name: hxournal-Version: 0.6.2.1+Version: 0.6.3 Synopsis: A pen notetaking program written in haskell Description: notetaking program written in haskell and gtk2hs Homepage: http://ianwookim.org/hxournal@@ -48,10 +48,10 @@ cairo == 0.12.*, monad-coroutine == 0.7.*, transformers == 0.2.*,- xournal-types == 0.3.*,- xournal-parser >= 0.3.0.1 && < 0.4,- xournal-render == 0.5.*,- xournal-builder >= 0.1.0.1 && < 0.2,+ xournal-types >= 0.3.1 && < 0.4,+ xournal-parser >= 0.3.0.2 && < 0.4,+ xournal-render >= 0.5.1 && < 0.6,+ xournal-builder >= 0.1.0.2 && < 0.2, containers == 0.4.*, template-haskell == 2.*, bytestring == 0.9.*, @@ -61,7 +61,8 @@ configurator == 0.2.*, poppler == 0.12.*, time == 1.2.*, - TypeCompose == 0.9.*+ TypeCompose == 0.9.*, + Diff == 0.1.* else Build-Depends: base == 4.*, @@ -73,10 +74,10 @@ cairo == 0.12.*, monad-coroutine == 0.7.*, transformers == 0.2.*,- xournal-types == 0.3.*,- xournal-parser >= 0.3.0.1 && < 0.4,- xournal-render == 0.5.*,- xournal-builder >= 0.1.0.1 && < 0.2,+ xournal-types >= 0.3.1 && < 0.4,+ xournal-parser >= 0.3.0.2 && < 0.4,+ xournal-render >= 0.5.1 && < 0.6,+ xournal-builder >= 0.1.0.2 && < 0.2, containers == 0.4.*, template-haskell == 2.*, bytestring == 0.9.*, @@ -85,7 +86,8 @@ cmdargs >= 0.7 && <= 0.10, configurator == 0.2.*, time == 1.2.*, - TypeCompose == 0.9.*+ TypeCompose == 0.9.*, + Diff == 0.1.* Exposed-Modules:
lib/Application/HXournal/Coroutine/Commit.hs view
@@ -72,7 +72,12 @@ putSt xstate' invalidateAll -+clearUndoHistory :: MainCoroutine () +clearUndoHistory = do + liftIO $ putStrLn "clearUndoHistory is called"+ xstate <- getSt+ putSt . set undoTable (emptyUndo 1) $ xstate+
lib/Application/HXournal/Coroutine/Default.hs view
@@ -123,7 +123,7 @@ case ptype of PenWork -> penStart cid pcoord EraserWork -> eraserStart cid pcoord - HighlighterWork -> highlighterStart pcoord+ HighlighterWork -> highlighterStart cid pcoord _ -> return () _ -> defaultEventProcess r1
lib/Application/HXournal/Coroutine/Draw.hs view
@@ -26,13 +26,20 @@ import Control.Monad.Trans import qualified Control.Monad.State as St import qualified Data.IntMap as M+import Control.Category import Data.Label import Prelude hiding ((.),id) +import Data.Xournal.Generic+import Graphics.Xournal.Render.Generic+import Graphics.Xournal.Render.BBoxMapPDF+import Graphics.Rendering.Cairo+import Graphics.UI.Gtk hiding (get,set)+ invalidateSelSingle :: CanvasId -> Maybe BBox -> PageDrawF -> PageDrawFSel - -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+ -> MainCoroutine () invalidateSelSingle cid mbbox drawf drawfsel = do xstate <- lift St.get let maybeCvs = M.lookup cid (get canvasInfoMap xstate)@@ -52,7 +59,7 @@ $ cvsInfo ) invalidateGenSingle :: CanvasId -> Maybe BBox -> PageDrawF- -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+ -> MainCoroutine () invalidateGenSingle cid mbbox drawf = do xstate <- lift St.get let maybeCvs = M.lookup cid (get canvasInfoMap xstate)@@ -69,14 +76,14 @@ $ cvsInfo ) -invalidateAll :: MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+invalidateAll :: MainCoroutine () invalidateAll = do xstate <- getSt let cinfoMap = get canvasInfoMap xstate keys = M.keys cinfoMap forM_ keys invalidate -invalidateOther :: MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+invalidateOther :: MainCoroutine () invalidateOther = do xstate <- getSt let currCvsId = get currentCanvas xstate@@ -87,30 +94,54 @@ -- | invalidate clear -invalidate :: CanvasId -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () +invalidate :: CanvasId -> MainCoroutine () invalidate cid = invalidateSelSingle cid Nothing drawPageClearly drawPageSelClearly -- | Drawing objects only in BBox -invalidateInBBox :: CanvasId -> BBox -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+invalidateInBBox :: CanvasId -> BBox -> MainCoroutine () invalidateInBBox cid bbox = invalidateSelSingle cid (Just bbox) drawPageInBBox drawSelectionInBBox -- | Drawing BBox -invalidateDrawBBox :: CanvasId -> BBox -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () +invalidateDrawBBox :: CanvasId -> BBox -> MainCoroutine () invalidateDrawBBox cid bbox = invalidateSelSingle cid (Just bbox) drawBBox drawBBoxSel ++ -- | Drawing using layer buffer -invalidateWithBuf :: CanvasId -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () +invalidateWithBuf :: CanvasId -> MainCoroutine () invalidateWithBuf = invalidateWithBufInBBox Nothing -- | Drawing using layer buffer in BBox -invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () +invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () invalidateWithBufInBBox mbbox cid = invalidateSelSingle cid mbbox drawBuf drawSelectionInBBox -+-- | Drawing temporary gadgets +invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine ()+invalidateTemp cid tempsurface rndr = do + xstate <- lift St.get + let cvsInfo = getCanvasInfo cid xstate + page = either id gcast $ get currentPage cvsInfo + canvas = get drawArea cvsInfo+ vinfo = get viewInfo cvsInfo + let zmode = get zoomMode vinfo+ origin = get viewPortOrigin vinfo+ geometry <- liftIO $ getCanvasPageGeometry canvas page origin+ let (cw, ch) = (,) <$> floor . fst <*> floor . snd + $ canvas_size geometry + let mbboxnew = adjustBBoxWithView geometry zmode Nothing+ win <- liftIO $ widgetGetDrawWindow canvas+ let xformfunc = transformForPageCoord geometry zmode+ liftIO $ renderWithDrawable win $ do + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint + xformfunc + rndr +
lib/Application/HXournal/Coroutine/Eraser.hs view
@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Coroutine.Eraser @@ -9,6 +8,7 @@ -- Stability : experimental -- Portability : GHC --+ module Application.HXournal.Coroutine.Eraser where import Graphics.UI.Gtk hiding (get,set,disconnect)@@ -47,7 +47,7 @@ eraserStart :: CanvasId -> PointerCoord - -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+ -> MainCoroutine () eraserStart cid pcoord = do xstate <- changeCurrentCanvasId cid let cvsInfo = getCanvasInfo cid xstate@@ -64,7 +64,7 @@ -> ConnectId DrawingArea -> ConnectId DrawingArea -> [StrokeBBox] -> (Double,Double)- -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+ -> MainCoroutine () eraserProcess cid cpg connidmove connidup strs (x0,y0) = do r <- await xstate <- getSt@@ -83,12 +83,6 @@ pgnum = get currentPageNum cvsInfo (mcurrlayer, currpage) = getCurrentLayerOrSet . getPage $ cvsInfo currlayer = maybe (error "eraserProcess") id mcurrlayer-- -- for test- -- let Select (O (Just ll)) = get g_layers currpage- -- SZ (_,(x1,x2)) = ll - -- liftIO$ print (Seq.length x1, Seq.length x2)- let (newstrokes,maybebbox1) = St.runState (eraseHitted hitteststroke) Nothing maybebbox = fmap (flip inflate 2.0) maybebbox1 newlayerbbox <- liftIO . updateLayerBuf maybebbox . set g_bstrokes newstrokes $ currlayer @@ -97,7 +91,8 @@ newxojstate = ViewAppendState newxojbbox commit . set xournalstate newxojstate . updatePageAll newxojstate $ xstate - invalidateWithBufInBBox maybebbox cid + -- invalidateWithBufInBBox maybebbox cid + invalidateWithBuf cid newstrs <- getAllStrokeBBoxInCurrentLayer eraserProcess cid cpg connidup connidmove newstrs (x,y) else eraserProcess cid cpg connidmove connidup strs (x,y) @@ -107,3 +102,4 @@ invalidateAll _ -> return () +
lib/Application/HXournal/Coroutine/File.hs view
@@ -75,6 +75,8 @@ let ui = get gtkUIManager xstate liftIO $ toggleSave ui False +-- | main coroutine for open a file + fileOpen :: MainCoroutine () fileOpen = do liftIO $ putStrLn "file open clicked"@@ -97,12 +99,15 @@ xstateNew <- liftIO $ getFileContent (Just filename) xstate putSt . set isSaved True $ xstateNew - liftIO $ setTitleFromFileName xstateNew + liftIO $ setTitleFromFileName xstateNew + clearUndoHistory invalidateAll liftIO $ widgetDestroy dialog ResponseCancel -> liftIO $ widgetDestroy dialog _ -> error "??? in fileOpen " return ()++-- | main coroutine for save as fileSaveAs :: MainCoroutine () fileSaveAs = do
lib/Application/HXournal/Coroutine/Highlighter.hs view
@@ -9,15 +9,19 @@ -- Stability : experimental -- Portability : GHC --+ module Application.HXournal.Coroutine.Highlighter where import Application.HXournal.Device import Application.HXournal.Type.Event import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Canvas import Application.HXournal.Type.XournalState+import Application.HXournal.Coroutine.Pen + import Control.Monad.Trans -highlighterStart :: PointerCoord -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()-highlighterStart _pcoord = do +highlighterStart :: CanvasId -> PointerCoord -> MainCoroutine () +highlighterStart cid pcoord = do liftIO $ putStrLn "highlighter started"-+ penStart cid pcoord
lib/Application/HXournal/Coroutine/Pen.hs view
@@ -28,6 +28,7 @@ import Application.HXournal.Draw import Control.Monad.Trans +import Data.Xournal.Predefined import Data.Xournal.Generic import Control.Monad.Coroutine.SuspensionFunctors import Data.Sequence hiding (filter)@@ -38,8 +39,9 @@ import Prelude hiding ((.), id) import Graphics.Xournal.Render.BBox +-- | enter pen drawing mode -penStart :: CanvasId -> PointerCoord -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+penStart :: CanvasId -> PointerCoord -> MainCoroutine () penStart cid pcoord = do xstate <- changeCurrentCanvasId cid let cvsInfo = getCanvasInfo cid xstate @@ -51,33 +53,25 @@ let (x,y) = device2pageCoord geometry zmode pcoord connidup <- connectPenUp cvsInfo connidmove <- connectPenMove cvsInfo - - {-- -- just for test- xstate2 <- getSt- let epg2 = get currentPage . getCurrentCanvasInfo $ xstate2 - liftIO $ putStrLn "before pen start"- liftIO $ either testPage (testPage . gcast) epg2 - liftIO $ putStrLn "from currxoj" - liftIO $ testPage (getPageFromGXournalMap pagenum currxoj) -}- pdraw <-penProcess cid geometry connidmove connidup (empty |> (x,y)) (x,y) (newxoj,bbox) <- liftIO $ addPDraw pinfo currxoj pagenum pdraw- let bbox' = inflate bbox (get (penWidth.penInfo) xstate) + let bbox' = inflate bbox (get (penWidth.currentTool.penInfo) xstate) xstate' = set xournalstate (ViewAppendState newxoj) . updatePageAll (ViewAppendState newxoj) $ xstate commit xstate'- mapM_ (flip invalidateInBBox bbox') . filter (/=cid) $ otherCanvas xstate' + invalidateAll + -- mapM_ (flip invalidateInBBox bbox') . filter (/=cid) $ otherCanvas xstate' +-- | main pen coordinate adding process+ penProcess :: CanvasId -> CanvasPageGeometry -> ConnectId DrawingArea -> ConnectId DrawingArea -> Seq (Double,Double) -> (Double,Double) -> MainCoroutine (Seq (Double,Double))- -- Iteratee MyEvent XournalStateIO (Seq (Double,Double)) penProcess cid cpg connidmove connidup pdraw (x0,y0) = do r <- await xstate <- getSt@@ -86,10 +80,15 @@ PenMove _cid' pcoord -> do let canvas = get drawArea cvsInfo zmode = get (zoomMode.viewInfo) cvsInfo- pcolor = get (penColor.penInfo) xstate - pwidth = get (penWidth.penInfo) xstate + ptype = get (penType.penInfo) xstate+ pcolor = get (penColor.currentTool.penInfo) xstate + pwidth = get (penWidth.currentTool.penInfo) xstate (x,y) = device2pageCoord cpg zmode pcoord - pcolRGBA = fromJust (M.lookup pcolor penColorRGBAmap) + (pcr,pcg,pcb,pca)= fromJust (M.lookup pcolor penColorRGBAmap) + opacity = case ptype of + HighlighterWork -> predefined_highlighter_opacity + _ -> 1.0+ pcolRGBA = (pcr,pcg,pcb,pca*opacity) liftIO $ drawSegment canvas cpg zmode pwidth pcolRGBA (x0,y0) (x,y) penProcess cid cpg connidmove connidup (pdraw |> (x,y)) (x,y) PenUp _cid' pcoord -> do
lib/Application/HXournal/Coroutine/Scroll.hs view
@@ -46,7 +46,6 @@ . set currentCanvas cid $ xstate lift . St.put $ xstate'- -- invalidateBBoxOnly cid invalidateWithBuf cid vscrollMove cid VScrollBarEnd cid' _v -> do
lib/Application/HXournal/Coroutine/Select.hs view
@@ -29,13 +29,14 @@ import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Select import Application.HXournal.ModelAction.Layer +import Control.Monad import Control.Monad.Trans import Control.Monad.Coroutine.SuspensionFunctors import Control.Compose import Control.Category+import Control.Applicative import Data.Label import Prelude hiding ((.), id)- import Data.Xournal.Generic import Data.Xournal.BBox import Data.Xournal.Select@@ -43,17 +44,86 @@ import Graphics.Xournal.Render.BBoxMapPDF import Graphics.Xournal.Render.HitTest import Graphics.Xournal.Render.BBox-+import Graphics.Rendering.Cairo import System.IO.Unsafe- import qualified Data.IntMap as IM import Data.Maybe+import Data.Monoid +import Data.Time.Clock+import Data.Xournal.Generic+-- import Graphics.Xournal.Render.BBox+import Graphics.Xournal.Render.Simple+import Graphics.Xournal.Render.Generic+import Graphics.Xournal.Render.PDFBackground+import Graphics.Xournal.Render.BBoxMapPDF+import Graphics.Rendering.Cairo+import Graphics.UI.Gtk hiding (get,set,disconnect) +data TempSelectRender a = TempSelectRender { tempSurface :: Surface + , widthHeight :: (Double,Double)+ , tempSelectInfo :: a + } ++type TempSelection = TempSelectRender [StrokeBBox]++tempSelected :: TempSelection -> [StrokeBBox]+tempSelected = tempSelectInfo ++mkTempSelection :: Surface -> (Double,Double) -> [StrokeBBox] -> TempSelection+mkTempSelection sfc (w,h) strs = TempSelectRender sfc (w,h) strs ++-- | update the content of temp selection. should not be often updated+ +updateTempSelection :: TempSelectRender a -> Render () -> Bool -> IO ()+updateTempSelection tempselection renderfunc isFullErase = + renderWith (tempSurface tempselection) $ do + when isFullErase $ do + let (cw,ch) = widthHeight tempselection+ setSourceRGBA 0.5 0.5 0.5 1+ rectangle 0 0 cw ch + fill + renderfunc + +dtime_bound :: NominalDiffTime +dtime_bound = realToFrac (picosecondsToDiffTime 100000000000)++getNewCoordTime :: ((Double,Double),UTCTime) + -> (Double,Double)+ -> IO (Bool,((Double,Double),UTCTime))+getNewCoordTime (prev,otime) (x,y) = do + ntime <- getCurrentTime + let dtime = diffUTCTime ntime otime + willUpdate = dtime > dtime_bound+ (nprev,nntime) = if dtime > dtime_bound + then ((x,y),ntime)+ else (prev,otime)+ return (willUpdate,(nprev,nntime))+++createTempSelectRender :: CanvasPageGeometry -> ZoomMode + -> TPageBBoxMapPDFBuf+ -> a + -> MainCoroutine (TempSelectRender a) +createTempSelectRender geometry zmode page x = do + let (cw, ch) = (,) <$> floor . fst <*> floor . snd + $ canvas_size geometry + cwch = (fromIntegral cw, fromIntegral ch)+ xformfunc = transformForPageCoord geometry zmode+ renderfunc = do + xformfunc + cairoRenderOption (InBBoxOption Nothing) (InBBox page) + return ()+ tempsurface <- liftIO $ createImageSurface FormatARGB32 cw ch + let tempselection = TempSelectRender tempsurface cwch x+ liftIO $ updateTempSelection tempselection renderfunc True+ return tempselection ++ -- | main mouse pointer click entrance in rectangular selection mode. -- choose either starting new rectangular selection or move previously -- selected selection. -selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () +selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine () selectRectStart cid pcoord = do xstate <- changeCurrentCanvasId cid let cvsInfo = getCanvasInfo cid xstate@@ -63,44 +133,42 @@ connidup <- connectPenUp cvsInfo connidmove <- connectPenMove cvsInfo strs <- getAllStrokeBBoxInCurrentLayer- case get currentPage cvsInfo of - Right tpage -> if hitInSelection tpage (x,y)- then do - moveSelectRectangle cvsInfo - geometry - zmode - connidup - connidmove - (x,y) - (x,y)- else - newSelectRectangle cvsInfo - geometry - zmode - connidup - connidmove - strs - (x,y) - (x,y)- Left _ -> newSelectRectangle cvsInfo - geometry - zmode - connidup - connidmove - strs - (x,y) - (x,y)+ ctime <- liftIO $ getCurrentTime+ let action (Right tpage) | hitInSelection tpage (x,y) = do+ tempselection <- createTempSelectRender + geometry zmode + (gcast tpage :: TPageBBoxMapPDFBuf)+ (getSelectedStrokes tpage)+ moveSelectRectangle cvsInfo geometry zmode connidup connidmove (x,y) ((x,y),ctime) tempselection + surfaceFinish (tempSurface tempselection)+ action (Right tpage) | hitInHandle tpage (x,y) = + case getULBBoxFromSelected tpage of + Middle bbox -> + maybe (return ()) (\handle -> do { tempselection <- createTempSelectRender geometry zmode (gcast tpage :: TPageBBoxMapPDFBuf) (getSelectedStrokes tpage); resizeSelectRectangle handle cvsInfo geometry zmode connidup connidmove bbox ((x,y),ctime) tempselection ; surfaceFinish (tempSurface tempselection) }) (checkIfHandleGrasped bbox (x,y))+ _ -> return () + action (Right tpage) | otherwise = newSelectAction (gcast tpage :: TPageBBoxMapPDFBuf )+ action (Left page) = newSelectAction page+ newSelectAction page = do + tempselection <- createTempSelectRender geometry zmode page [] + newSelectRectangle cvsInfo geometry zmode connidup connidmove strs + (x,y) ((x,y),ctime) tempselection+ surfaceFinish (tempSurface tempselection)+ action (get currentPage cvsInfo) + - + newSelectRectangle :: CanvasInfo -> CanvasPageGeometry -> ZoomMode -> ConnectId DrawingArea -> ConnectId DrawingArea -> [StrokeBBox] -> (Double,Double)- -> (Double,Double)+ -> ((Double,Double),UTCTime)+ -> TempSelection -> MainCoroutine () -newSelectRectangle cinfo geometry zmode connidmove connidup strs orig prev = do +newSelectRectangle cinfo geometry zmode connidmove connidup strs orig + (prev,otime) + tempselection = do let cid = get canvasId cinfo r <- await case r of @@ -110,17 +178,40 @@ prevbbox = BBox orig prev hittestbbox = mkHitTestInsideBBox bbox strs hittedstrs = concat . map unHitted . getB $ hittestbbox- if not (isBBoxDeltaSmallerThan 1.0 geometry zmode bbox prevbbox) - then do flip invalidateWithBufInBBox cid . Just $- (inflate (fromJust (Just bbox `merge` Just prevbbox)) 5.0)- invalidateDrawBBox cid bbox- else return ()- newSelectRectangle cinfo geometry zmode connidmove connidup strs orig (x,y) + let newbbox = inflate (fromJust (Just bbox `merge` Just prevbbox)) 5.0+ xstate <- getSt+ let cvsInfo = getCanvasInfo cid xstate + page = either id gcast $ get currentPage cvsInfo + numselstrs = length hittedstrs + (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 = transformForPageCoord geometry zmode+ 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 bbox -> do + let redrawee = filter (\x -> hitTestBBoxBBox bbox (strokebbox_bbox x) ) hittedstrs + cairoRenderOption (InBBoxOption (Just bbox)) (InBBox page)+ clipBBox (Just bbox)+ mapM_ renderSelectedStroke redrawee + Bottom -> return ()+ mapM_ renderSelectedStroke sstrs + liftIO $ updateTempSelection tempselection renderfunc False+ when willUpdate $ + invalidateTemp cid (tempSurface tempselection) + (renderBoxSelection bbox) + newSelectRectangle cinfo geometry zmode connidmove connidup strs orig + (ncoord,ntime)+ tempselection { tempSelectInfo = hittedstrs } PenUp _cid' pcoord -> do let (x,y) = device2pageCoord geometry zmode pcoord let epage = get currentPage cinfo cpn = get currentPageNum cinfo - let bbox = BBox orig (x,y) hittestbbox = mkHitTestInsideBBox bbox strs selectstrs = fmapAL unNotHitted id hittestbbox@@ -158,15 +249,24 @@ -> ConnectId DrawingArea -> ConnectId DrawingArea -> (Double,Double)- -> (Double,Double)+ -> ((Double,Double),UTCTime)+ -> TempSelection -> MainCoroutine ()-moveSelectRectangle cinfo geometry zmode connidmove connidup orig@(x0,y0) _prev = do+moveSelectRectangle cinfo geometry zmode connidmove connidup orig@(x0,y0) + (prev,otime) tempselection = do xstate <- getSt r <- await case r of - PenMove _cid' pcoord -> do + PenMove cid pcoord -> do let (x,y) = device2pageCoord geometry zmode pcoord - moveSelectRectangle cinfo geometry zmode connidmove connidup orig (x,y) + (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+ moveSelectRectangle cinfo geometry zmode connidmove connidup orig (ncoord,ntime) tempselection PenUp _cid' pcoord -> do let (x,y) = device2pageCoord geometry zmode pcoord let offset = (x-x0,y-y0)@@ -175,7 +275,7 @@ pagenum = get currentPageNum cinfo case epage of Right tpage -> do - let newtpage = changeSelectionByOffset tpage offset+ let newtpage = changeSelectionByOffset offset tpage newtxoj <- liftIO $ updateTempXournalSelectIO txoj newtpage pagenum commit . set xournalstate (SelectState newtxoj) . updatePageAll (SelectState newtxoj) @@ -186,6 +286,55 @@ invalidateAll _ -> return () +resizeSelectRectangle :: Handle + -> CanvasInfo+ -> CanvasPageGeometry+ -> ZoomMode+ -> ConnectId DrawingArea + -> ConnectId DrawingArea+ -> BBox+ -> ((Double,Double),UTCTime)+ -> TempSelection+ -> MainCoroutine ()+resizeSelectRectangle handle cinfo geometry zmode connidmove connidup origbbox + (prev,otime) tempselection = do+ xstate <- getSt+ r <- await + case r of + PenMove cid pcoord -> do + let (x,y) = device2pageCoord geometry zmode pcoord + (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) + when willUpdate $ do + let strs = tempSelectInfo tempselection+ 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+ resizeSelectRectangle handle cinfo geometry zmode connidmove connidup + origbbox (ncoord,ntime) tempselection+ PenUp _cid pcoord -> do + let (x,y) = device2pageCoord geometry zmode pcoord + newbbox = getNewBBoxFromHandlePos handle origbbox (x,y)+ SelectState txoj = get xournalstate xstate+ epage = get currentPage cinfo + 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)+ . updatePageAll (SelectState newtxoj) + $ xstate + Left _ -> error "this is impossible, in resizeSelectRectangle" + disconnect connidmove+ disconnect connidup + invalidateAll+ return () + _ -> return () + deleteSelection :: MainCoroutine () deleteSelection = do liftIO $ putStrLn "delete selection is called"@@ -223,8 +372,7 @@ case etpage of Left _ -> return () Right tpage -> do - let slayer = gselectedlayerbuf . glayers $ tpage- case unTEitherAlterHitted . get g_bstrokes $ slayer of + case getActiveLayer tpage of Left _ -> return () Right alist -> do let strs = takeHittedStrokes alist @@ -247,14 +395,15 @@ clipstrs = getClipContents . get clipboard $ xstate cinfo = getCurrentCanvasInfo xstate pagenum = get currentPageNum cinfo - tpage = case get currentPage cinfo of - Left pbbox -> (gcast pbbox :: TTempPageSelectPDFBuf)- Right tp -> tp + tpage = either gcast id (get currentPage cinfo)+ -- case get currentPage cinfo of + -- Left pbbox -> (gcast pbbox :: TTempPageSelectPDFBuf)+ -- Right tp -> tp layerselect = gselectedlayerbuf . glayers $ tpage ls = glayers tpage gbuf = get g_buffer layerselect- newlayerselect = - case unTEitherAlterHitted . get g_bstrokes $ layerselect of + newlayerselect = case getActiveLayer tpage of + -- case unTEitherAlterHitted . get g_bstrokes $ layerselect of Left strs -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (strs :- Hitted clipstrs :- Empty) Right alist -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (concat (interleave id unHitted alist) @@ -311,6 +460,11 @@ . set xournalstate (SelectState newtxoj) $ xstate invalidateAll +++++
lib/Application/HXournal/Draw.hs view
@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Draw @@ -9,6 +8,7 @@ -- Stability : experimental -- Portability : GHC --+ module Application.HXournal.Draw where import Graphics.UI.Gtk hiding (get)@@ -33,7 +33,7 @@ import Graphics.Xournal.Render.HitTest import Application.HXournal.Type import Application.HXournal.Device-+import Application.HXournal.Util data CanvasPageGeometry = @@ -51,7 +51,15 @@ type PageDrawFSel = DrawingArea -> TTempPageSelectPDFBuf -> ViewInfo -> Maybe BBox -> IO () +predefinedLassoColor :: (Double,Double,Double,Double)+predefinedLassoColor = (1.0,116.0/255.0,0,0.8) +predefinedLassoWidth :: Double +predefinedLassoWidth = 4.0++predefinedLassoDash :: ([Double],Double)+predefinedLassoDash = ([10,5],10) + getCanvasPageGeometry :: DrawingArea -> GPage b s a -> (Double,Double) @@ -137,37 +145,37 @@ drawFuncGen :: (TPageBBoxMapPDFBuf -> Maybe BBox -> Render ()) -> PageDrawF drawFuncGen render canvas page vinfo mbbox = do - let zmode = get zoomMode vinfo- origin = get viewPortOrigin vinfo- geometry <- getCanvasPageGeometry canvas page origin- win <- widgetGetDrawWindow canvas- let mbboxnew = adjustBBoxWithView geometry zmode mbbox- renderWithDrawable win $ do- transformForPageCoord geometry zmode- clipBBox mbboxnew- render page mbboxnew - resetClip - return ()- return ()+ let zmode = get zoomMode vinfo+ origin = get viewPortOrigin vinfo+ geometry <- getCanvasPageGeometry canvas page origin+ win <- widgetGetDrawWindow canvas+ let mbboxnew = adjustBBoxWithView geometry zmode mbbox+ xformfunc = transformForPageCoord geometry zmode+ renderfunc = do+ xformfunc + clipBBox mbboxnew+ render page mbboxnew + resetClip + doubleBuffering win geometry xformfunc renderfunc + drawFuncSelGen :: (TTempPageSelectPDFBuf -> Maybe BBox -> Render ()) -> (TTempPageSelectPDFBuf -> Maybe BBox -> Render ()) -> PageDrawFSel drawFuncSelGen rencont rensel canvas page vinfo mbbox = do - let zmode = get zoomMode vinfo- origin = get viewPortOrigin vinfo- geometry <- getCanvasPageGeometry canvas page origin- win <- widgetGetDrawWindow canvas- let mbboxnew = adjustBBoxWithView geometry zmode mbbox- renderWithDrawable win $ do- transformForPageCoord geometry zmode- clipBBox mbboxnew- rencont page mbboxnew - rensel page mbboxnew - resetClip - return ()- -+ let zmode = get zoomMode vinfo+ origin = get viewPortOrigin vinfo+ geometry <- getCanvasPageGeometry canvas page origin+ win <- widgetGetDrawWindow canvas+ let mbboxnew = adjustBBoxWithView geometry zmode mbbox+ xformfunc = transformForPageCoord geometry zmode+ renderfunc = do+ xformfunc + clipBBox mbboxnew+ rencont page mbboxnew + rensel page mbboxnew + resetClip + doubleBuffering win geometry xformfunc renderfunc drawPageClearly :: PageDrawF drawPageClearly = drawFuncGen $ \page _mbbox -> @@ -178,24 +186,22 @@ where rendercontent tpg _mbbox = do let pg = (gcast tpg :: TPageBBoxMapPDFBuf) cairoRenderOption (DrawBkgPDF,DrawFull) (gcast pg :: TPageBBoxMapPDF)- renderselect tpg mbbox = + renderselect tpg mbbox = cairoHittedBoxDraw tpg mbbox -- drawBBoxOnly :: PageDrawF drawBBoxOnly canvas page vinfo _mbbox = do let zmode = get zoomMode vinfo origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- transformForPageCoord geometry zmode- cairoRenderOption (DrawWhite,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)- -- tpageBBoxMapPDFFromTPageBBoxMapPDFBuf page )- return ()+ let xformfunc = transformForPageCoord geometry zmode+ renderfunc = do + cairoRenderOption (DrawWhite,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)+ doubleBuffering win geometry xformfunc renderfunc + adjustBBoxWithView :: CanvasPageGeometry -> ZoomMode -> Maybe BBox -> Maybe BBox adjustBBoxWithView geometry zmode mbbox = @@ -212,12 +218,16 @@ geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas let mbboxnew = adjustBBoxWithView geometry zmode mbbox- renderWithDrawable win $ do- transformForPageCoord geometry zmode- cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) -- (InBBox (gcast page :: TPageBBoxMapPDF))- return ()- return ()+ -- renderWithDrawable win $ do+ let xformfunc = transformForPageCoord geometry zmode+ renderfunc = do + cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) -- (InBBox (gcast page :: TPageBBoxMapPDF))+ return ()+ doubleBuffering win geometry xformfunc renderfunc ++-- | deprecated+ drawBBox :: PageDrawF drawBBox _ _ _ Nothing = return () drawBBox canvas page vinfo (Just bbox) = do @@ -225,16 +235,23 @@ origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- setLineWidth 0.5 - setSourceRGBA 1.0 0.0 0.0 1.0- transformForPageCoord geometry zmode- let (x1,y1) = bbox_upperleft bbox- (x2,y2) = bbox_lowerright bbox- rectangle x1 y1 (x2-x1) (y2-y1)- stroke- return ()+ -- renderWithDrawable win $ + let xformfunc = transformForPageCoord geometry zmode+ renderfunc = do+ setLineWidth 0.5 + setSourceRGBA 1.0 0.0 0.0 1.0+ xformfunc + let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ return ()+ doubleBuffering win geometry xformfunc renderfunc +++-- | deprecated + drawBBoxSel :: PageDrawFSel drawBBoxSel _ _ _ Nothing = return () drawBBoxSel canvas tpg vinfo (Just bbox) = do @@ -243,17 +260,72 @@ origin = get viewPortOrigin vinfo geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- setLineWidth 0.5 - setSourceRGBA 1.0 0.0 0.0 1.0- transformForPageCoord geometry zmode- let (x1,y1) = bbox_upperleft bbox- (x2,y2) = bbox_lowerright bbox- rectangle x1 y1 (x2-x1) (y2-y1)- stroke- return ()+ let xformfunc = transformForPageCoord geometry zmode+ renderfunc = do+ setLineWidth 0.5 + setSourceRGBA 1.0 0.0 0.0 1.0+ let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ return ()+ doubleBuffering win geometry xformfunc renderfunc +-- | ++drawTempBBox :: BBox -> PageDrawF +drawTempBBox bbox _ _ _ Nothing = return ()+drawTempBBox bbox canvas page vinfo mbbox@(Just _) = do + let zmode = get zoomMode vinfo+ origin = get viewPortOrigin vinfo+ geometry <- getCanvasPageGeometry canvas page origin+ win <- widgetGetDrawWindow canvas+ let xformfunc = transformForPageCoord geometry zmode+ renderbelow = do+ transformForPageCoord geometry zmode+ cairoRenderOption (InBBoxOption Nothing) (InBBox page)+ {- (InBBoxOption mbbox) -}+ renderabove = do+ setLineWidth 0.5 + setSourceRGBA 1.0 0.0 0.0 1.0+ let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ return ()+ doubleBuffering win geometry xformfunc (xformfunc >> renderbelow >> renderabove)+ + -- (xformfunc >> renderabove) ++++-- |++drawSelTempBBox :: BBox -> PageDrawFSel +drawSelTempBBox bbox _ _ _ Nothing = return ()+drawSelTempBBox bbox canvas tpg vinfo mbbox@(Just _) = do + let page = (gcast tpg :: TPageBBoxMapPDFBuf)+ let zmode = get zoomMode vinfo+ origin = get viewPortOrigin vinfo+ geometry <- getCanvasPageGeometry canvas page origin+ win <- widgetGetDrawWindow canvas+ let xformfunc = transformForPageCoord geometry zmode+ renderbelow = do+ cairoRenderOption (InBBoxOption Nothing) (InBBox page)+ -- (InBBox (gcast page :: TPageBBoxMapPDF))+ cairoHittedBoxDraw tpg mbbox + renderabove = do+ setLineWidth 0.5 + setSourceRGBA 1.0 0.0 0.0 1.0+ let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ return ()+ doubleBuffering win geometry xformfunc (xformfunc >> renderbelow >> renderabove)+ -- (xformfunc >> renderabove)+ getRatioFromPageToCanvas :: CanvasPageGeometry -> ZoomMode -> Double getRatioFromPageToCanvas _cpg Original = 1.0 getRatioFromPageToCanvas cpg FitWidth = @@ -310,28 +382,13 @@ geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas let mbboxnew = adjustBBoxWithView geometry zmode mbbox- renderWithDrawable win $ do- transformForPageCoord geometry zmode- cairoRenderOption (InBBoxOption mbboxnew) (InBBox page)- -- (InBBox (gcast page :: TPageBBoxMapPDF))- cairoHittedBoxDraw tpg mbboxnew - -{--drawSelectionInBBoxOnly :: PageDrawFSel -drawSelectionInBBoxOnly canvas tpg vinfo mbbox = do - let zmode = get zoomMode vinfo- origin = get viewPortOrigin vinfo- page = (gcast tpg :: TPageBBoxMapPDFBuf)- geometry <- getCanvasPageGeometry canvas page origin- win <- widgetGetDrawWindow canvas - let mbboxnew = adjustBBoxWithView geometry zmode mbbox- renderWithDrawable win $ do- transformForPageCoord geometry zmode- cairoRenderOption (InBBoxOption mbboxnew) (InBBox page)- -- (DrawWhite,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)- -- (DrawBuffer,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)- cairoHittedBoxDraw tpg mbbox --}+ let xformfunc = transformForPageCoord geometry zmode+ renderfunc = do+ xformfunc + cairoRenderOption (InBBoxOption mbboxnew) (InBBox page)+ cairoHittedBoxDraw tpg mbboxnew + doubleBuffering win geometry xformfunc renderfunc + cairoHittedBoxDraw :: TTempPageSelectPDFBuf -> Maybe BBox -> Render () cairoHittedBoxDraw tpg mbbox = do @@ -347,15 +404,71 @@ drawbox = do { rectangle x1 y1 (x2-x1) (y2-y1); stroke } case mbbox of Just bboxarg -> if hitTestBBoxBBox bbox bboxarg - then drawbox+ then do -- drawbox+ drawbox else return () Nothing -> drawbox - mapM_ oneboxdraw hitstrs + mapM_ renderSelectedStroke hitstrs + let ulbbox = unUnion . mconcat . fmap (Union .Middle . strokebbox_bbox) + $ hitstrs + + case ulbbox of + Middle bbox -> renderSelectHandle bbox + _ -> return () + -- (\x-> renderSelectedStroke x >> oneboxdraw x) hitstrs resetClip Left _ -> return () + ---- +-- | common routine for double buffering ++doubleBuffering :: DrawWindow -> CanvasPageGeometry + -> Render ()+ -> Render () + -> IO ()+doubleBuffering win geometry xform rndr = do + let (cw, ch) = (,) <$> floor . fst <*> floor . snd + $ canvas_size geometry + withImageSurface FormatARGB32 cw ch $ \tempsurface -> do + renderWith tempsurface $ do + setSourceRGBA 0.5 0.5 0.5 1+ rectangle 0 0 (fromIntegral cw) (fromIntegral ch) + fill + rndr + renderWithDrawable win $ do + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + -- setAntialias AntialiasNone+ xform+ paint + + +-- | +{- +doubleBufferingPersist :: DrawWindow + -> Surface+ -> Render () + -> IO ()+doubleBufferingPersist win sfc xform rndr = do + let (cw, ch) = (,) <$> floor . fst <*> floor . snd + $ canvas_size geometry + renderWith tempsurface $ do + setSourceRGBA 0.5 0.5 0.5 1+ rectangle 0 0 (fromIntegral cw) (fromIntegral ch) + fill + rndr + renderWithDrawable win $ do + setSourceSurface sfc 0 0 + setOperator OperatorSource + -- setAntialias AntialiasNone+ -- xform+ paint +-}+++ drawBuf :: PageDrawF drawBuf canvas page vinfo mbbox = do let zmode = get zoomMode vinfo@@ -363,12 +476,12 @@ geometry <- getCanvasPageGeometry canvas page origin let mbboxnew = adjustBBoxWithView geometry zmode mbbox win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- transformForPageCoord geometry zmode- cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) - return ()- return ()-+ let xformfunc = transformForPageCoord geometry zmode+ let renderfunc = do + xformfunc + cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) + return ()+ doubleBuffering win geometry xformfunc renderfunc drawSelBuf :: PageDrawFSel drawSelBuf canvas tpg vinfo mbbox = do @@ -377,7 +490,66 @@ page = (gcast tpg :: TPageBBoxMapPDFBuf) geometry <- getCanvasPageGeometry canvas page origin win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- transformForPageCoord geometry zmode- cairoRenderOption (InBBoxOption mbbox) (InBBox (gcast page :: TPageBBoxMapPDF))- cairoHittedBoxDraw tpg mbbox + let xformfunc = transformForPageCoord geometry zmode + let renderfunc = do+ transformForPageCoord geometry zmode+ cairoRenderOption (InBBoxOption mbbox) (InBBox (gcast page :: TPageBBoxMapPDF))+ cairoHittedBoxDraw tpg mbbox + doubleBuffering win geometry xformfunc renderfunc +++renderBoxSelection :: BBox -> Render () +renderBoxSelection bbox = do+ setLineWidth predefinedLassoWidth+ uncurry4 setSourceRGBA predefinedLassoColor+ uncurry setDash predefinedLassoDash + let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke++renderSelectedStroke :: StrokeBBox -> Render () +renderSelectedStroke str = do + let bbox = strokebbox_bbox str + setLineWidth 1.5+ setSourceRGBA 0 0 1 1+ cairoOneStrokeSelected str+ {- let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke -}++renderSelectHandle :: BBox -> Render () +renderSelectHandle bbox = do + setLineWidth predefinedLassoWidth+ uncurry4 setSourceRGBA predefinedLassoColor+ uncurry setDash predefinedLassoDash + let (x1,y1) = bbox_upperleft bbox+ (x2,y2) = bbox_lowerright bbox+ rectangle x1 y1 (x2-x1) (y2-y1)+ stroke+ setSourceRGBA 1 0 0 0.8+ rectangle (x1-5) (y1-5) 10 10 + fill+ setSourceRGBA 1 0 0 0.8+ rectangle (x1-5) (y2-5) 10 10 + fill+ setSourceRGBA 1 0 0 0.8+ rectangle (x2-5) (y1-5) 10 10 + fill+ setSourceRGBA 1 0 0 0.8+ rectangle (x2-5) (y2-5) 10 10 + fill+ + setSourceRGBA 0.5 0 0.2 0.8+ rectangle (x1-3) (0.5*(y1+y2)-3) 6 6 + fill+ setSourceRGBA 0.5 0 0.2 0.8+ rectangle (x2-3) (0.5*(y1+y2)-3) 6 6 + fill+ setSourceRGBA 0.5 0 0.2 0.8+ rectangle (0.5*(x1+x2)-3) (y1-3) 6 6 + fill+ setSourceRGBA 0.5 0 0.2 0.8+ rectangle (0.5*(x1+x2)-3) (y2-3) 6 6 + fill
lib/Application/HXournal/GUI/Menu.hs view
@@ -578,16 +578,17 @@ let c = int2Color v st <- readIORef sref let callback = get callBack st- let stNew = set (penColor.penInfo) c st + let stNew = set (penColor.currentTool.penInfo) c st writeIORef sref stNew callback (PenColorChanged c) assignPoint :: IORef HXournalState -> RadioAction -> IO () assignPoint sref a = do v <- radioActionGetCurrentValue a- let w = int2Point v st <- readIORef sref - let stNew = set (penWidth.penInfo) w st + let ptype = get (penType.penInfo) st+ let w = int2Point ptype v+ let stNew = set (penWidth.currentTool.penInfo) w st let callback = get callBack st writeIORef sref stNew callback (PenWidthChanged w)@@ -603,13 +604,28 @@ int2PenType 7 = Right SelectHandToolWork int2PenType _ = error "No such pentype" -int2Point :: Int -> Double -int2Point 0 = predefined_veryfine -int2Point 1 = predefined_fine-int2Point 2 = predefined_medium-int2Point 3 = predefined_thick-int2Point 4 = predefined_verythick-int2Point _ = error "No such point"+int2Point :: PenType -> Int -> Double +int2Point PenWork 0 = predefined_veryfine +int2Point PenWork 1 = predefined_fine+int2Point PenWork 2 = predefined_medium+int2Point PenWork 3 = predefined_thick+int2Point PenWork 4 = predefined_verythick+int2Point HighlighterWork 0 = predefined_highlighter_veryfine+int2Point HighlighterWork 1 = predefined_highlighter_fine+int2Point HighlighterWork 2 = predefined_highlighter_medium+int2Point HighlighterWork 3 = predefined_highlighter_thick+int2Point HighlighterWork 4 = predefined_highlighter_verythick+int2Point EraserWork 0 = predefined_eraser_veryfine+int2Point EraserWork 1 = predefined_eraser_fine+int2Point EraserWork 2 = predefined_eraser_medium+int2Point EraserWork 3 = predefined_eraser_thick+int2Point EraserWork 4 = predefined_eraser_verythick+int2Point TextWork 0 = predefined_veryfine+int2Point TextWork 1 = predefined_fine+int2Point TextWork 2 = predefined_medium+int2Point TextWork 3 = predefined_thick+int2Point TextWork 4 = predefined_verythick+int2Point _ _ = error "No such point" int2Color :: Int -> PenColor int2Color 0 = ColorBlack
lib/Application/HXournal/ModelAction/Pen.hs view
@@ -41,13 +41,17 @@ addPDraw :: PenInfo -> TXournalBBoxMapPDFBuf -> Int -> Seq (Double,Double) -> IO (TXournalBBoxMapPDFBuf,BBox) addPDraw pinfo xoj pgnum pdraw = do - let pcolor = get penColor pinfo+ let ptype = get penType pinfo+ pcolor = get (penColor.currentTool) pinfo pcolname = fromJust (M.lookup pcolor penColorNameMap)- pwidth = get penWidth pinfo+ pwidth = get (penWidth.currentTool) pinfo (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGXournalMap pgnum xoj) currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer - newstroke = Stroke { stroke_tool = "pen" + newstroke = Stroke { stroke_tool = case ptype of + PenWork -> "pen" + HighlighterWork -> "highlighter"+ _ -> error "error in addPDraw" , stroke_color = pcolname , stroke_width = pwidth , stroke_data = map (uncurry (:!:)) . toList $ pdraw
lib/Application/HXournal/ModelAction/Select.hs view
@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.ModelAction.Select @@ -15,7 +14,7 @@ import Application.HXournal.Type.Canvas import Application.HXournal.Draw -+import Data.Monoid import Data.Xournal.Generic import Data.Xournal.BBox import Graphics.Xournal.Render.Type@@ -27,12 +26,30 @@ import Data.Strict.Tuple import qualified Data.IntMap as M import qualified Data.Map as Map - import Control.Category import Data.Label import Prelude hiding ((.),id)+import Data.Algorithm.Diff - +data Handle = HandleTL+ | HandleTR + | HandleBL+ | HandleBR+ | HandleTM+ | HandleBM+ | HandleML+ | HandleMR+ deriving (Show)+ ++scaleFromToBBox :: BBox -> BBox -> (Double,Double) -> (Double,Double)+scaleFromToBBox (BBox (ox1,oy1) (ox2,oy2)) (BBox (nx1,ny1) (nx2,ny2)) (x,y) = + let scalex = (nx2-nx1) / (ox2-ox1)+ scaley = (ny2-ny1) / (oy2-oy1) + nx = (x-ox1)*scalex+nx1+ ny = (y-oy1)*scaley+ny1+ in (nx,ny)+ isBBoxDeltaSmallerThan :: Double ->CanvasPageGeometry -> ZoomMode -> BBox -> BBox -> Bool isBBoxDeltaSmallerThan delta cpg zmode @@ -46,30 +63,65 @@ && (x12'-x22' > (-delta) && x12'-x22' < delta) && (y11'-y21' > (-delta) && y12'-y22' < delta) -changeStrokeByOffset :: (Double,Double) -> StrokeBBox -> StrokeBBox -changeStrokeByOffset (offx,offy) (StrokeBBox t c w ds bbox) = - let offset ( x :!: y ) = (x+offx) :!: (y+offy)- newds = map offset ds - BBox (x1,y1) (x2,y2) = bbox - newbbox = BBox (x1+offx,y1+offy) (x2+offx,y2+offy)+-- | modify stroke using a function++changeStrokeBy :: ((Double,Double)->(Double,Double)) -> StrokeBBox -> StrokeBBox+changeStrokeBy func (StrokeBBox t c w ds bbox) = + let change ( x :!: y ) = let (nx,ny) = func (x,y) + in nx :!: ny+ newds = map change ds + newbbox = mkbbox newds in StrokeBBox t c w newds newbbox -changeSelectionByOffset :: TTempPageSelectPDFBuf -> (Double,Double) - -> TTempPageSelectPDFBuf-changeSelectionByOffset tpage off = +getActiveLayer :: TTempPageSelectPDFBuf -> Either [StrokeBBox] (TAlterHitted StrokeBBox)+getActiveLayer tpage = let ls = glayers tpage slayer = gselectedlayerbuf ls buf = get g_buffer slayer - activelayer = unTEitherAlterHitted . get g_bstrokes $ slayer + in unTEitherAlterHitted . get g_bstrokes $ slayer +++getSelectedStrokes :: TTempPageSelectPDFBuf -> [StrokeBBox]+getSelectedStrokes tpage = + let activelayer = getActiveLayer tpage in case activelayer of + Left _ -> [] + Right alist -> concatMap unHitted . getB $ alist +++-- | modify the whole selection using a function++changeSelectionBy :: ((Double,Double) -> (Double,Double))+ -> TTempPageSelectPDFBuf -> TTempPageSelectPDFBuf+changeSelectionBy func tpage = + let activelayer = getActiveLayer tpage+ ls = glayers tpage+ buf = get g_buffer . gselectedlayerbuf $ ls + in case activelayer of Left _ -> tpage Right alist -> let alist' =fmapAL id - (Hitted . map (changeStrokeByOffset off) . unHitted) + (Hitted . map (changeStrokeBy func) . unHitted) alist layer' = GLayerBuf buf . TEitherAlterHitted . Right $ alist' in tpage { glayers = ls { gselectedlayerbuf = layer' }}+ +{- let ls = glayers tpage+ slayer = gselectedlayerbuf ls+ buf = get g_buffer slayer + activelayer = unTEitherAlterHitted . get g_bstrokes $ slayer +-} +-- | special case of offset modification++changeSelectionByOffset :: (Double,Double) -> TTempPageSelectPDFBuf -> TTempPageSelectPDFBuf+changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy))++offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) +offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy)+++ updateTempXournalSelect :: TTempXournalSelectPDFBuf -> TTempPageSelectPDFBuf -> Int @@ -103,6 +155,34 @@ let bboxes = map strokebbox_bbox . takeHittedStrokes $ alist in any (flip hitTestBBoxPoint point) bboxes +getULBBoxFromSelected :: TTempPageSelectPDFBuf -> ULMaybe BBox +getULBBoxFromSelected tpage = + let activelayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . glayers $ tpage+ in case activelayer of + Left _ -> Bottom+ Right alist -> + unUnion . mconcat . fmap (Union . Middle . strokebbox_bbox) . takeHittedStrokes $ alist + +hitInHandle :: TTempPageSelectPDFBuf -> (Double,Double) -> Bool +hitInHandle tpage point = + case getULBBoxFromSelected tpage of + Middle bbox -> maybe False (const True) (checkIfHandleGrasped bbox point)+ _ -> False+ +{- let activelayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . glayers $ tpage+ in case activelayer of + Left _ -> False + Right alist -> + let ulbbox = unUnion . mconcat . fmap (Union . Middle . strokebbox_bbox) . takeHittledStroke $ alist + in case ulbbox of + Middle bbox -> maybe False (const True) (checkIfHandleGrasped bbox)+ _ -> False+ -- let bboxes = map strokebbox_bbox . takeHittedStrokes $ alist+ -- in any (flip hitTestBBoxPoint point) bboxes +-}+++ takeHittedStrokes :: AlterList [StrokeBBox] (Hitted StrokeBBox) -> [StrokeBBox] takeHittedStrokes = concatMap unHitted . getB @@ -140,3 +220,51 @@ changeStrokeWidth :: Double -> StrokeBBox -> StrokeBBox changeStrokeWidth pwidth str = str { strokebbox_width = pwidth } +newtype CmpStrokeBBox = CmpStrokeBBox { unCmpStrokeBBox :: StrokeBBox }+ deriving Show+instance Eq CmpStrokeBBox where+ CmpStrokeBBox str1 == CmpStrokeBBox str2 = strokebbox_bbox str1 == strokebbox_bbox str2 + +isSame :: DI -> Bool +isSame B = True +isSame _ = False ++separateFS :: [(DI,a)] -> ([a],[a])+separateFS = foldr f ([],[]) + where f (F,x) (fs,ss) = (x:fs,ss)+ f (S,x) (fs,ss) = (fs,x:ss)+ f (B,x) (fs,ss) = (fs,ss)+ +getDiffStrokeBBox :: [StrokeBBox] -> [StrokeBBox] -> [(DI, StrokeBBox)]+getDiffStrokeBBox lst1 lst2 = + let nlst1 = fmap CmpStrokeBBox lst1 + nlst2 = fmap CmpStrokeBBox lst2 + diffresult = getDiff nlst1 nlst2 + in map (\(x,y)->(x,unCmpStrokeBBox y)) diffresult++ +checkIfHandleGrasped :: BBox -> (Double,Double) -> Maybe Handle+checkIfHandleGrasped bbox@(BBox (ulx,uly) (lrx,lry)) (x,y) + | hitTestBBoxPoint (BBox (ulx-5,uly-5) (ulx+5,uly+5)) (x,y) = Just HandleTL+ | hitTestBBoxPoint (BBox (lrx-5,uly-5) (lrx+5,uly+5)) (x,y) = Just HandleTR+ | hitTestBBoxPoint (BBox (ulx-5,lry-5) (ulx+5,lry+5)) (x,y) = Just HandleBL+ | hitTestBBoxPoint (BBox (lrx-5,lry-5) (lrx+5,lry+5)) (x,y) = Just HandleBR+ | hitTestBBoxPoint (BBox (0.5*(ulx+lrx)-5,uly-5) (0.5*(ulx+lrx)+5,uly+5)) (x,y) = Just HandleTM + | hitTestBBoxPoint (BBox (0.5*(ulx+lrx)-5,lry-5) (0.5*(ulx+lrx)+5,lry+5)) (x,y) = Just HandleBM+ | hitTestBBoxPoint (BBox (ulx-5,0.5*(uly+lry)-5) (ulx+5,0.5*(uly+lry)+5)) (x,y) = Just HandleML+ | hitTestBBoxPoint (BBox (lrx-5,0.5*(uly+lry)-5) (lrx+5,0.5*(uly+lry)+5)) (x,y) = Just HandleMR+ | otherwise = Nothing + +getNewBBoxFromHandlePos :: Handle -> BBox -> (Double,Double) -> BBox+getNewBBoxFromHandlePos handle (BBox (ox1,oy1) (ox2,oy2)) (x,y) = + case handle of+ HandleTL -> BBox (x,y) (ox2,oy2)+ HandleTR -> BBox (ox1,y) (x,oy2)+ HandleBL -> BBox (x,oy1) (ox2,y)+ HandleBR -> BBox (ox1,oy1) (x,y)+ HandleTM -> BBox (ox1,y) (ox2,oy2)+ HandleBM -> BBox (ox1,oy1) (ox2,y)+ HandleML -> BBox (x,oy1) (ox2,oy2)+ HandleMR -> BBox (ox1,oy1) (x,oy2)++
lib/Application/HXournal/Type/Canvas.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, TypeOperators #-} ----------------------------------------------------------------------------- -- |@@ -16,12 +16,15 @@ import Application.HXournal.Type.Enum import Data.Sequence import qualified Data.IntMap as M+import Control.Category import Data.Label import Prelude hiding ((.), id) import Graphics.Xournal.Render.BBoxMapPDF import Graphics.UI.Gtk hiding (get,set) +import Data.Xournal.Predefined + type CanvasId = Int data PenDraw = PenDraw { _points :: Seq (Double,Double) } @@ -62,11 +65,53 @@ | TextWork deriving (Show,Eq) +data WidthColorStyle = WidthColorStyle { _penWidth :: Double+ , _penColor :: PenColor } + deriving (Show)+ +data PenHighlighterEraserSet = PenHighlighterEraserSet + { _currPen :: WidthColorStyle + , _currHighlighter :: WidthColorStyle + , _currEraser :: WidthColorStyle + , _currText :: WidthColorStyle}+ deriving (Show) + data PenInfo = PenInfo { _penType :: PenType- , _penWidth :: Double- , _penColor :: PenColor } + -- , _penWidth :: Double+ -- , _penColor :: PenColor + , _penSet :: PenHighlighterEraserSet } deriving (Show) +currentTool :: PenInfo :-> WidthColorStyle +currentTool = lens chooser setter+ where chooser pinfo = case _penType pinfo of+ PenWork -> _currPen . _penSet $ pinfo+ HighlighterWork -> _currHighlighter . _penSet $ pinfo+ EraserWork -> _currEraser . _penSet $ pinfo+ TextWork -> _currText . _penSet $ pinfo + setter wcs pinfo = + let pset = _penSet pinfo+ psetnew = case _penType pinfo of + PenWork -> pset { _currPen = wcs }+ HighlighterWork -> pset { _currHighlighter = wcs }+ EraserWork -> pset { _currEraser = wcs }+ TextWork -> pset { _currText = wcs }+ in pinfo { _penSet = psetnew } + +defaultPenWCS = WidthColorStyle predefined_medium ColorBlack +defaultEraserWCS = WidthColorStyle predefined_eraser_medium ColorWhite+defaultTextWCS = defaultPenWCS+defaultHighligherWCS = WidthColorStyle predefined_highlighter_medium ColorYellow -$(mkLabels [''PenDraw, ''ViewInfo, ''PenInfo, ''CanvasInfo])++defaultPenInfo :: PenInfo +defaultPenInfo = + PenInfo { _penType = PenWork + , _penSet = PenHighlighterEraserSet { _currPen = defaultPenWCS+ , _currHighlighter = defaultHighligherWCS+ , _currEraser = defaultEraserWCS+ , _currText = defaultTextWCS }+ } + +$(mkLabels [''PenDraw, ''ViewInfo, ''PenInfo, ''PenHighlighterEraserSet, ''WidthColorStyle, ''CanvasInfo])
lib/Application/HXournal/Type/XournalState.hs view
@@ -79,7 +79,7 @@ , _clipboard = emptyClipboard , _callBack = error "emtpyHxournalState.callBack" , _deviceList = error "emtpyHxournalState.deviceList"- , _penInfo = PenInfo PenWork predefined_medium ColorBlack+ , _penInfo = defaultPenInfo -- PenInfo PenWork predefined_medium ColorBlack , _selectInfo = SelectInfo SelectRectangleWork , _gtkUIManager = error "emptyHXournalState.gtkUIManager" , _isSaved = False
lib/Application/HXournal/Util.hs view
@@ -43,6 +43,11 @@ L.putStrLn (builder xojsimple) -} ++uncurry4 :: (a->b->c->d->e)->(a,b,c,d)->e +uncurry4 f (x,y,z,w) = f x y z w ++ maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads