hxournal 0.6.5 → 0.6.5.0
raw patch · 14 files changed
+97/−138 lines, 14 files
Files
- CHANGES +3/−0
- hxournal.cabal +1/−1
- lib/Application/HXournal/Accessor.hs +10/−26
- lib/Application/HXournal/Coroutine/Draw.hs +2/−6
- lib/Application/HXournal/Coroutine/Mode.hs +4/−4
- lib/Application/HXournal/Coroutine/Page.hs +8/−41
- lib/Application/HXournal/Coroutine/Scroll.hs +3/−4
- lib/Application/HXournal/Coroutine/Select.hs +22/−15
- lib/Application/HXournal/Coroutine/Window.hs +6/−14
- lib/Application/HXournal/ModelAction/Select.hs +16/−2
- lib/Application/HXournal/Type/Canvas.hs +0/−8
- lib/Application/HXournal/Type/Clipboard.hs +1/−0
- lib/Application/HXournal/Type/PageArrangement.hs +7/−2
- lib/Application/HXournal/View/Coordinate.hs +14/−15
CHANGES view
@@ -22,3 +22,6 @@ 0.6.4: 6 Feb 2012 * lasso selection, continuous page view. ++0.6.5: 12 Feb 2012+ * pen button support, pen pressure support, using faster xoj parser
hxournal.cabal view
@@ -1,5 +1,5 @@ Name: hxournal-Version: 0.6.5+Version: 0.6.5.0 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
@@ -16,22 +16,23 @@ import Application.HXournal.Type import Control.Applicative-import Control.Monad-import qualified Control.Monad.State as St+import Control.Monad hiding (mapM_)+import qualified Control.Monad.State as St hiding (mapM_) import Control.Monad.Trans import Control.Category import qualified Data.IntMap as M import Data.Label-import Prelude hiding ((.),id) import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set)+import Data.Foldable+import Data.Monoid import Data.Xournal.BBox import Data.Xournal.Generic import Application.HXournal.ModelAction.Layer import Application.HXournal.Type.Alias import Application.HXournal.Type.PageArrangement import Application.HXournal.View.Coordinate-+import Prelude hiding ((.),id,mapM_) -- | get HXournalState @@ -140,7 +141,6 @@ liftIO $ maybe (return ()) signalBlock mconnid agr <- liftIO $ uiManagerGetActionGroups ui Just ra1 <- liftIO $ actionGroupGetAction (head agr) "ONEPAGEA"- -- let wra1 = castToRadioAction ra1 selectBoxAction (fsingle ra1) (fcont ra1) cinfobox liftIO $ maybe (return ()) signalUnblock mconnid return ()@@ -148,8 +148,6 @@ let wra1 = castToRadioAction ra1 liftIO $ Gtk.set wra1 [radioActionCurrentValue := 1 ] fcont ra1 _cinfo = do- -- let wra1 = castToRadioAction ra1 - -- liftIO $ wra1 `on` radioActionChanged $ const (putStrLn "hellowworld2" >> return ()) liftIO $ Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 0 ] -- | @@ -232,7 +230,6 @@ let cinfobox = getCanvasInfo cid xstate cpn = PageNum . unboxGet currentPageNum $ cinfobox canvas = unboxGet drawArea cinfobox- -- xojstate = get xournalstate xstate fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry fsingle = flip (makeCanvasGeometry cpn) canvas . get (pageArrangement.viewInfo) @@ -240,32 +237,19 @@ -- | -getCanvasGeometry :: HXournalState -> IO CanvasGeometry -getCanvasGeometry xstate = do +getGeometry4CurrCvs :: HXournalState -> IO CanvasGeometry +getGeometry4CurrCvs xstate = do let cinfobox = get currentCanvasInfo xstate cpn = PageNum . unboxGet currentPageNum $ cinfobox canvas = unboxGet drawArea cinfobox- -- xojstate = get xournalstate xstate fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry fsingle = flip (makeCanvasGeometry cpn) canvas . get (pageArrangement.viewInfo) - boxAction fsingle cinfobox --{--getCanvasGeometry :: CanvasInfo SinglePage -> MainCoroutine CanvasPageGeometry -getCanvasGeometry cinfo = do - let canvas = get drawArea cinfo- page = getPage cinfo- (x0,y0) = bbox_upperleft . unViewPortBBox . get (viewPortBBox.pageArrangement.viewInfo) $ cinfo- liftIO (getCanvasPageGeometry canvas page (x0,y0))--}-----+-- | +bbox4AllStrokes :: (Foldable t, Functor t) => t StrokeBBox -> ULMaybe BBox +bbox4AllStrokes = unUnion . fold . fmap (Union . Middle . strokebbox_bbox)
lib/Application/HXournal/Coroutine/Draw.hs view
@@ -131,11 +131,9 @@ xst <- getSt selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst where fsingle xstate cvsInfo = do - -- page <- getCurrentPageCvsId cid let canvas = get drawArea cvsInfo- -- vinfo = get viewInfo cvsInfo pnum = PageNum . get currentPageNum $ cvsInfo - geometry <- liftIO $ getCanvasGeometry xstate+ geometry <- liftIO $ getCanvasGeometryCvsId cid xstate win <- liftIO $ widgetGetDrawWindow canvas let xformfunc = cairoXform4PageCoordinate geometry pnum liftIO $ renderWithDrawable win $ do @@ -154,10 +152,8 @@ xst <- getSt selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst where fsingle xstate cvsInfo = do - -- page <- getCurrentPageCvsId cid let canvas = get drawArea cvsInfo- -- vinfo = get viewInfo cvsInfo - geometry <- liftIO $ getCanvasGeometry xstate+ geometry <- liftIO $ getCanvasGeometryCvsId cid xstate win <- liftIO $ widgetGetDrawWindow canvas let xformfunc = cairoXform4PageCoordinate geometry pnum liftIO $ renderWithDrawable win $ do
lib/Application/HXournal/Coroutine/Mode.hs view
@@ -82,8 +82,9 @@ noaction xstate = const (return xstate) whencont xstate cinfo = do - geometry <- liftIO $ getCanvasGeometry xstate - cdim <- liftIO $ return . canvasDim =<< getCanvasGeometry xstate + geometry <- liftIO $ getGeometry4CurrCvs xstate + cdim <- liftIO $ return . canvasDim $ geometry + -- =<< getCanvasGeometry xstate page <- getCurrentPageCurr let zmode = get (zoomMode.viewInfo) cinfo canvas = get drawArea cinfo @@ -109,8 +110,7 @@ return $ set currentCanvasInfo (CanvasInfoBox ncinfo) xstate whensing xstate cinfo = do - cdim <- liftIO $ return . canvasDim =<< getCanvasGeometry xstate - -- page <- getCurrentPageCurr + cdim <- liftIO $ return . canvasDim =<< getGeometry4CurrCvs xstate let zmode = get (zoomMode.viewInfo) cinfo canvas = get drawArea cinfo cpn = PageNum . get currentPageNum $ cinfo
lib/Application/HXournal/Coroutine/Page.hs view
@@ -46,7 +46,6 @@ npgnum = modifyfn (get currentPageNum cvsInfo) cid = get canvasId cvsInfo (b,npgnum',_selectedpage,xojst') = changePageInXournalState npgnum xojst- -- Dim w h = get g_dimension selectedpage xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid xstatefinal <- return . modifyCurrentCanvasInfo (const ncvsInfo) $ xstate'@@ -58,7 +57,6 @@ npgnum = modifyfn (get currentPageNum cvsInfo) cid = get canvasId cvsInfo (b,npgnum',_selectedpage,xojst') = changePageInXournalState npgnum xojst- -- Dim w h = get g_dimension selectedpage xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid xstatefinal <- return . modifyCurrentCanvasInfo (const ncvsInfo) $ xstate'@@ -102,21 +100,23 @@ page <- getCurrentPageCvsId cid let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode pdim = PageDimension $ get g_dimension page+ xy = either (const (0,0)) (unPageCoord.snd) + (getCvsOriginInPage geometry) cdim = canvasDim geometry - narr = makeSingleArrangement zmode pdim cdim (0,0)+ narr = makeSingleArrangement zmode pdim cdim xy ncinfobox = CanvasInfoBox . set (pageArrangement.viewInfo) narr . set (zoomMode.viewInfo) zmode $ cinfo return . modifyCanvasInfo cid (const ncinfobox) $ xstate 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 - -- pdim = PageDimension $ get g_dimension page cdim = canvasDim geometry xoj = getXournal xstate - narr = makeContinuousSingleArrangement zmode cdim xoj (cpn,PageCoord (0,0))+ origcoord = either (const (cpn,PageCoord (0,0))) id + (getCvsOriginInPage geometry)+ narr = makeContinuousSingleArrangement zmode cdim xoj origcoord ncinfobox = CanvasInfoBox . set (pageArrangement.viewInfo) narr . set (zoomMode.viewInfo) zmode $ cinfo@@ -130,40 +130,6 @@ -> MainCoroutine () canvasZoomUpdateCvsId = canvasZoomUpdateGenRenderCvsId invalidateAll -{- - cid mzmode = updateXState zoomUpdateAction - >> adjustScrollbarWithGeometryCvsId cid- >> invalidateAll- where zoomUpdateAction xst = - selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst - - fsingle xstate cinfo = do - geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo - page <- getCurrentPageCvsId cid- let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode - 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 . modifyCanvasInfo cid (const ncinfobox) $ xstate- - 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 - 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 . modifyCanvasInfo cid (const ncinfobox) $ xstate--}- -- | canvasZoomUpdateBufAll :: MainCoroutine () @@ -182,12 +148,13 @@ -- | - + canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine () canvasZoomUpdate mzmode = do cid <- (liftM (getCurrentCanvasId) getSt) canvasZoomUpdateCvsId cid mzmode + -- |
lib/Application/HXournal/Coroutine/Scroll.hs view
@@ -36,8 +36,7 @@ adjustScrollbarWithGeometryCvsId cid = do xstate <- getSt let cinfobox = getCanvasInfo cid xstate- - geometry <- liftIO . getCanvasGeometry $ xstate+ geometry <- liftIO (getCanvasGeometryCvsId cid xstate) let (hadj,vadj) = unboxGet adjustments cinfobox connidh = unboxGet horizAdjConnId cinfobox connidv = unboxGet vertAdjConnId cinfobox@@ -49,7 +48,7 @@ adjustScrollbarWithGeometryCurrent :: MainCoroutine () adjustScrollbarWithGeometryCurrent = do xstate <- getSt- geometry <- liftIO . getCanvasGeometry $ xstate+ geometry <- liftIO . getGeometry4CurrCvs $ xstate let cinfobox = get currentCanvasInfo xstate let (hadj,vadj) = unboxGet adjustments cinfobox connidh = unboxGet horizAdjConnId cinfobox @@ -96,7 +95,7 @@ vscrollMove cid = do ev <- await xst <- getSt - geometry <- liftIO (getCanvasGeometry xst)+ geometry <- liftIO (getCanvasGeometryCvsId cid xst) case ev of VScrollBarMoved _cid' v -> do updateXState $ return.modifyCurrentCanvasInfo
lib/Application/HXournal/Coroutine/Select.hs view
@@ -173,16 +173,15 @@ (ncoord,ntime) tempselection { tempSelectInfo = hittedstrs } upact xstate cinfo pcoord = do - let -- pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord - (_,(x,y)) = runIdentity $ + let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return- let epage = getCurrentPageEitherFromXojState cinfo (get xournalstate xstate)+ epage = getCurrentPageEitherFromXojState cinfo (get xournalstate xstate) cpn = get currentPageNum cinfo - let bbox = BBox orig (x,y)+ bbox = BBox orig (x,y) hittestbbox = mkHitTestInsideBBox bbox strs selectstrs = fmapAL unNotHitted id hittestbbox- let SelectState txoj = get xournalstate xstate+ SelectState txoj = get xournalstate xstate newpage = case epage of Left pagebbox -> makePageSelectMode pagebbox selectstrs Right tpage -> @@ -192,7 +191,7 @@ npage = tpage { glayers = ls { gselectedlayerbuf = newlayer } } in npage newtxoj = txoj { gselectSelected = Just (cpn,newpage) } - let ui = get gtkUIManager xstate+ ui = get gtkUIManager xstate liftIO $ toggleCutCopyDelete ui (isAnyHitted selectstrs) putSt . set xournalstate (SelectState newtxoj) =<< (liftIO (updatePageAll (SelectState newtxoj) xstate))@@ -386,8 +385,7 @@ 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 $ + let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return newbbox = getNewBBoxFromHandlePos handle origbbox (x,y)@@ -431,12 +429,16 @@ liftIO $ toggleCutCopyDelete ui False invalidateAll +-- | + cutSelection :: MainCoroutine () cutSelection = do liftIO $ putStrLn "cutSelection called" copySelection deleteSelection +-- | + copySelection :: MainCoroutine () copySelection = updateXState copySelectionAction >> invalidateAll where copySelectionAction xst = @@ -457,24 +459,28 @@ liftIO $ togglePaste ui True return xstate' +-- | + pasteToSelection :: MainCoroutine () pasteToSelection = modeChange ToSelectMode >> updateXState pasteAction >> invalidateAll where pasteAction xst = boxAction (fsimple xst) . get currentCanvasInfo $ xst fsimple xstate cinfo = do - let xojstate@(SelectState txoj) = get xournalstate xstate- clipstrs = getClipContents . get clipboard $ xstate- pagenum = get currentPageNum cinfo + geometry <- liftIO (getGeometry4CurrCvs xstate)+ let pagenum = get currentPageNum cinfo + xojstate@(SelectState txoj) = get xournalstate xstate+ clipstrs' = getClipContents . get clipboard $ xstate+ nclipstrs = adjustStrokePosition4Paste geometry (PageNum pagenum) clipstrs' epage = getCurrentPageEitherFromXojState cinfo xojstate tpage = either gcast id epage layerselect = gselectedlayerbuf . glayers $ tpage ls = glayers tpage gbuf = get g_buffer layerselect newlayerselect = case getActiveLayer tpage of - Left strs -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (strs :- Hitted clipstrs :- Empty)+ Left strs -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (strs :- Hitted nclipstrs :- Empty) Right alist -> (GLayerBuf gbuf . TEitherAlterHitted . Right) (concat (interleave id unHitted alist) - :- Hitted clipstrs + :- Hitted nclipstrs :- Empty ) tpage' = tpage { glayers = ls { gselectedlayerbuf = newlayerselect } } txoj' <- liftIO $ updateTempXournalSelectIO txoj tpage' pagenum @@ -508,6 +514,8 @@ . set xournalstate (SelectState newtxoj) $ xstate ) invalidateAll +-- | + selectPenWidthChanged :: Double -> MainCoroutine () selectPenWidthChanged pwidth = do liftIO $ putStrLn "selectPenWidthChanged called"@@ -590,8 +598,7 @@ (ncoord,ntime) nlasso tsel upact cinfo pcoord = do xstate <- getSt - let -- pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord - (_,(x,y)) = runIdentity $ + let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return nlasso = lasso |> (x,y)
lib/Application/HXournal/Coroutine/Window.hs view
@@ -48,9 +48,7 @@ canvasConfigureGenUpdate updatefunc cid cdim = (updateXState $ selectBoxAction fsingle fcont . getCanvasInfo cid ) >> updatefunc - -- canvasZoomUpdateAll - where -- cdim = CanvasDimension (Dim w' h')- fsingle cinfo = do + where fsingle cinfo = do xstate <- getSt let cinfo' = updateCanvasDimForSingle cdim cinfo return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate@@ -68,18 +66,10 @@ -> MainCoroutine () doCanvasConfigure = canvasConfigureGenUpdate canvasZoomUpdateAll -- -- fsingle :: CanvasInfo SinglePage -> MainCoroutine HXournalState- {- xstate <- getSt - let cinfobox = getCanvasInfo cid xstate -}- {- xstate' <- -} - -- putSt xstate' - - -- | canvasConfigure' :: CanvasId -> CanvasDimension -> MainCoroutine () -canvasConfigure' cid cdim = do -- @(CanvasDimension (Dim w' h')) = do +canvasConfigure' cid cdim = do xstate <- getSt ctime <- liftIO getCurrentTime maybe defaction (chkaction ctime) (get lastTimeCanvasConfigure xstate) @@ -171,8 +161,10 @@ ev <- await case ev of UpdateCanvas cid -> invalidateWithBuf cid >> paneMoveStart - PaneMoveEnd -> return () - CanvasConfigure cid w' h'-> + PaneMoveEnd -> do + -- canvasZoomUpdateAll + return () + CanvasConfigure cid w' h'-> do canvasConfigureGenUpdate canvasZoomUpdateBufAll cid (CanvasDimension (Dim w' h')) >> paneMoveStart _ -> paneMoveStart
lib/Application/HXournal/ModelAction/Select.hs view
@@ -12,6 +12,7 @@ module Application.HXournal.ModelAction.Select where +import Application.HXournal.Accessor (bbox4AllStrokes) import Application.HXournal.Type.Enum import Application.HXournal.Type.Alias import Application.HXournal.Type.Predefined @@ -209,8 +210,8 @@ 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 + Right alist -> bbox4AllStrokes . takeHittedStrokes $ alist +-- unUnion . mconcat . fmap (Union . Middle . strokebbox_bbox) . takeHittedStrokes $ alist hitInHandle :: Page SelectMode -> (Double,Double) -> Bool hitInHandle tpage point = @@ -435,4 +436,17 @@ then ((x,y),ntime) else (prev,otime) return (willUpdate,(nprev,nntime))++-- | ++adjustStrokePosition4Paste :: CanvasGeometry -> PageNum -> [StrokeBBox] -> [StrokeBBox]+adjustStrokePosition4Paste geometry pgn strs = + case bboxStrs of + Middle (BBox (xs0,ys0) _) -> fmap (changeStrokeBy (offsetFunc (x0-xs0,y0-ys0))) strs + _ -> strs + where bboxStrs = bbox4AllStrokes strs+ ViewPortBBox (BBox (xv0,yv0) _) = canvasViewPort geometry + (x0,y0) = maybe (0,0) + (\(pgn',norigin) -> if pgn == pgn' then unPageCoord norigin else (0,0))+ $ desktop2Page geometry (DeskCoord (xv0,yv0))
lib/Application/HXournal/Type/Canvas.hs view
@@ -345,13 +345,6 @@ -- | -{- -getPage :: (ViewMode a) => CanvasInfo a -> (Page EditMode)-getPage = either id (gcast :: Page SelectMode -> Page EditMode) . get currentPage--}---- | - updateCanvasDimForSingle :: CanvasDimension -> CanvasInfo SinglePage -> CanvasInfo SinglePage @@ -376,7 +369,6 @@ ContinuousSingleArrangement _ ddim func (ViewPortBBox bbox) = get (pageArrangement.viewInfo) cinfo (x,y) = bbox_upperleft bbox - -- 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)
lib/Application/HXournal/Type/Clipboard.hs view
@@ -10,6 +10,7 @@ -- Stability : experimental -- Portability : GHC --+----------------------------------------------------------------------------- module Application.HXournal.Type.Clipboard where
lib/Application/HXournal/Type/PageArrangement.hs view
@@ -127,8 +127,13 @@ let PageOrigin (_,y0) = maybeError "makeContSingleArr" $ pageArrFuncContSingle xoj pnum dim = get g_dimension . head . gToList . get g_pages $ xoj (sinvx,sinvy) = getRatioPageCanvas zmode (PageDimension dim) cdim - vport = ViewPortBBox (BBox (xpos,ypos+y0) (xpos+cw/sinvx,ypos+y0+ch/sinvy))- in ContinuousSingleArrangement cdim (deskDimContSingle xoj) (pageArrFuncContSingle xoj) vport + (x1,y1) = (xpos,ypos+y0)+ (x2,y2) = (xpos+cw/sinvx,ypos+y0+ch/sinvy)+ ddim@(DesktopDimension (Dim w h)) = deskDimContSingle xoj + (x1',x2') = if x2 > w && w-(x2-x1) > 0 then (w-(x2-x1),w) else (x1,x2)+ (y1',y2') = if y2 > h && h-(y2-y1) > 0 then (h-(y2-y1),h) else (y1,y2)+ vport = ViewPortBBox (BBox (x1',y1') (x2',y2') )+ in ContinuousSingleArrangement cdim ddim (pageArrFuncContSingle xoj) vport -- |
lib/Application/HXournal/View/Coordinate.hs view
@@ -37,7 +37,6 @@ CanvasGeometry { screenDim :: ScreenDimension , canvasDim :: CanvasDimension- -- , canvasOrigin :: CanvasOrigin , desktopDim :: DesktopDimension , canvasViewPort :: ViewPortBBox -- ^ in desktop coordinate , screen2Canvas :: ScreenCoordinate -> CanvasCoordinate@@ -50,13 +49,10 @@ -- | make a canvas geometry data structure from current status -makeCanvasGeometry :: -- (GPageable em) => - -- em - PageNum -- , Page em) -> PageDimension +makeCanvasGeometry :: PageNum -> PageArrangement vm -> DrawingArea -> IO CanvasGeometry --- makeCanvasGeometry typ (cpn,page) arr canvas = do makeCanvasGeometry cpn arr canvas = do win <- widgetGetDrawWindow canvas let cdim@(CanvasDimension (Dim w' h')) = get canvasDimension arr@@ -64,9 +60,8 @@ (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- corig = CanvasOrigin (x0,y0)- let (deskdim, cvsvbbox, p2d, d2p) = + let corig = CanvasOrigin (x0,y0)+ (deskdim, cvsvbbox, p2d, d2p) = case arr of SingleArrangement _ pdim vbbox -> ( DesktopDimension . unPageDimension $ pdim , vbbox@@ -82,10 +77,6 @@ deskdim cvsvbbox s2c c2s c2d d2c d2p p2d ---- -- | makePage2Desktop :: (PageNum -> Maybe PageOrigin) @@ -174,7 +165,6 @@ pgcheck n pg = let Dim w h = get g_dimension pg DeskCoord ul = page2Desktop geometry (PageNum n,PageCoord (0,0)) DeskCoord lr = page2Desktop geometry (PageNum n,PageCoord (w,h))- -- nbbox = BBox ul lr inbbox = Intersect (Middle (BBox ul lr)) result = ivbbox `mappend` inbbox in case result of @@ -193,7 +183,16 @@ arr = get (pageArrangement.viewInfo) cinfo makeCanvasGeometry cpn arr canvas --+-- | Get Canvas Origin in Page Coordinate : Right is successful case, +-- Left is unsuccessful case, then return in DesktopCoordinate+ +getCvsOriginInPage :: CanvasGeometry + -> Either DesktopCoordinate (PageNum, PageCoordinate) +getCvsOriginInPage geometry = + let ViewPortBBox (BBox (x0,y0) (_,_)) = canvasViewPort geometry + in case desktop2Page geometry (DeskCoord (x0,y0)) of+ Nothing -> Left (DeskCoord (x0,y0))+ Just (pgn,pxy) -> Right (pgn,pxy)+