hxournal 0.6.3 → 0.6.4

raw patch · 42 files changed

+3639/−1811 lines, 42 filesdep ~xournal-types

Dependency ranges changed: xournal-types

Files

CHANGES +6/−0
hxournal.cabal +12/−8
lib/Application/HXournal/Accessor.hs +114/−54
lib/Application/HXournal/Config.hs +0/−2
lib/Application/HXournal/Coroutine/Commit.hs +8/−12
lib/Application/HXournal/Coroutine/Default.hs +63/−61
lib/Application/HXournal/Coroutine/Draw.hs +112/−87
lib/Application/HXournal/Coroutine/Eraser.hs +35/−39
lib/Application/HXournal/Coroutine/EventConnect.hs +11/−18
lib/Application/HXournal/Coroutine/File.hs +10/−4
lib/Application/HXournal/Coroutine/Highlighter.hs +1/−3
lib/Application/HXournal/Coroutine/Layer.hs +35/−38
lib/Application/HXournal/Coroutine/Mode.hs +85/−31
lib/Application/HXournal/Coroutine/Page.hs +161/−116
lib/Application/HXournal/Coroutine/Pen.hs +132/−53
lib/Application/HXournal/Coroutine/Scroll.hs +107/−32
lib/Application/HXournal/Coroutine/Select.hs +278/−238
lib/Application/HXournal/Coroutine/Window.hs +86/−58
lib/Application/HXournal/Device.hsc +1/−2
lib/Application/HXournal/Draw.hs +0/−555
lib/Application/HXournal/GUI.hs +13/−16
lib/Application/HXournal/GUI/Menu.hs +15/−3
lib/Application/HXournal/ModelAction/Adjustment.hs +29/−1
lib/Application/HXournal/ModelAction/File.hs +28/−27
lib/Application/HXournal/ModelAction/Layer.hs +7/−14
lib/Application/HXournal/ModelAction/Page.hs +203/−90
lib/Application/HXournal/ModelAction/Pen.hs +13/−15
lib/Application/HXournal/ModelAction/Select.hs +135/−62
lib/Application/HXournal/ModelAction/Window.hs +221/−58
lib/Application/HXournal/Type.hs +1/−0
lib/Application/HXournal/Type/Alias.hs +59/−0
lib/Application/HXournal/Type/Canvas.hs +190/−27
lib/Application/HXournal/Type/Enum.hs +1/−0
lib/Application/HXournal/Type/Event.hs +2/−0
lib/Application/HXournal/Type/PageArrangement.hs +195/−0
lib/Application/HXournal/Type/Predefined.hs +25/−0
lib/Application/HXournal/Type/Undo.hs +0/−43
lib/Application/HXournal/Type/Window.hs +23/−21
lib/Application/HXournal/Type/XournalState.hs +120/−12
lib/Application/HXournal/Util.hs +5/−11
lib/Application/HXournal/View/Coordinate.hs +215/−0
lib/Application/HXournal/View/Draw.hs +882/−0

CHANGES view

@@ -16,3 +16,9 @@  0.6.2: 15 Jan 2012    * layer support++0.6.3: 24 Jan 2012 +   * refine rendering while selection and scrolling. highlighter is implemented. Resizing selected strokes implemented++0.6.4: 6 Feb 2012+   * lasso selection, continuous page view.

hxournal.cabal view

@@ -1,5 +1,5 @@ Name:		hxournal-Version:	0.6.3+Version:	0.6.4 Synopsis:	A pen notetaking program written in haskell  Description: 	notetaking program written in haskell and gtk2hs Homepage:       http://ianwookim.org/hxournal@@ -8,7 +8,7 @@ Author:		Ian-Woo Kim Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com> Category:       Application-Tested-with:    GHC == 7.0.4+Tested-with:    GHC == 7.0 Build-Type: 	Custom Cabal-Version:  >= 1.8 data-files:     template/*.html.st@@ -48,7 +48,7 @@                      cairo == 0.12.*,                      monad-coroutine == 0.7.*,                       transformers == 0.2.*,-                     xournal-types >= 0.3.1 && < 0.4,+                     xournal-types >= 0.3.2 && < 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,@@ -74,7 +74,7 @@                      cairo == 0.12.*,                      monad-coroutine == 0.7.*,                       transformers == 0.2.*,-                     xournal-types >= 0.3.1 && < 0.4,+                     xournal-types >= 0.3.1.999 && < 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,@@ -95,14 +95,21 @@                    Application.HXournal.Job                    Application.HXournal.Command                     Application.HXournal.Type+                   Application.HXournal.Type.Alias                     Application.HXournal.Type.Event                     Application.HXournal.Type.Enum                    Application.HXournal.Type.Clipboard                    Application.HXournal.Type.Canvas                    Application.HXournal.Type.Coroutine+                   Application.HXournal.Type.PageArrangement                     Application.HXournal.Type.XournalState                    Application.HXournal.Type.Window                    Application.HXournal.Type.Undo +                   Application.HXournal.Type.Predefined +                   Application.HXournal.View.Draw+                   Application.HXournal.View.Coordinate+                   Application.HXournal.GUI+                   Application.HXournal.GUI.Menu                    Application.HXournal.ModelAction.Adjustment                    Application.HXournal.ModelAction.Pen                     Application.HXournal.ModelAction.Page@@ -112,10 +119,8 @@                    Application.HXournal.ModelAction.Window                    -- Application.HXournal.ModelAction.Network                    Application.HXournal.ModelAction.Layer-                   Application.HXournal.Coroutine.Callback-                   Application.HXournal.GUI-                   Application.HXournal.GUI.Menu                    Application.HXournal.Coroutine+                   Application.HXournal.Coroutine.Callback                    Application.HXournal.Coroutine.Draw                    Application.HXournal.Coroutine.EventConnect                    Application.HXournal.Coroutine.Default@@ -133,7 +138,6 @@                    Application.HXournal.Coroutine.Layer                    Application.HXournal.Util                    Application.HXournal.Util.Verbatim -                   Application.HXournal.Draw                    Application.HXournal.Device                    Application.HXournal.Accessor                    Application.HXournal.Config

lib/Application/HXournal/Accessor.hs view

@@ -14,10 +14,8 @@ module Application.HXournal.Accessor where  import Application.HXournal.Type-import Application.HXournal.Draw +import Application.HXournal.View.Draw  import Application.HXournal.ModelAction.Page-- import Control.Applicative import Control.Monad import qualified Control.Monad.State as St@@ -27,88 +25,150 @@ import Data.Label import Prelude hiding ((.),id) import Graphics.UI.Gtk hiding (get,set)--import Control.Compose-import Graphics.Xournal.Render.BBoxMapPDF+import qualified Graphics.UI.Gtk as Gtk (get,set) import Data.Xournal.BBox import Data.Xournal.Generic-import Data.Xournal.Buffer-import Data.Xournal.Select- import Application.HXournal.Util import Application.HXournal.ModelAction.Layer +import Application.HXournal.Type.Alias+import Application.HXournal.Type.PageArrangement+import Application.HXournal.View.Coordinate  -getSt :: MainCoroutine HXournalState -- Iteratee MyEvent XournalStateIO HXournalState+-- | get HXournalState ++getSt :: MainCoroutine HXournalState  getSt = lift St.get -putSt :: HXournalState -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+-- | put HXournalState++putSt :: HXournalState -> MainCoroutine ()  putSt = lift . St.put +-- | update state -adjustments :: CanvasInfo :-> (Adjustment,Adjustment) -adjustments = Lens $ (,) <$> (fst `for` horizAdjustment)-                         <*> (snd `for` vertAdjustment)+updateXState :: (HXournalState -> MainCoroutine HXournalState) -> MainCoroutine ()+updateXState action = putSt =<< action =<< getSt  ++-- | + getPenType :: Iteratee MyEvent XournalStateIO PenType getPenType = get (penType.penInfo) <$> lift (St.get)       +-- | + getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox]  getAllStrokeBBoxInCurrentPage = do    xstate <- getSt -  let currCvsInfo  = getCurrentCanvasInfo xstate -  let pagebbox = getPage currCvsInfo-      strs = do -        l <- gToList (get g_layers pagebbox)-        s <- get g_bstrokes l-        return s -  return strs +  case get currentCanvas xstate of+    (_,CanvasInfoBox currCvsInfo) -> +      let pagebbox = getPage currCvsInfo+      in  return [s| l <- gToList (get g_layers pagebbox), s <- get g_bstrokes l ]+    getAllStrokeBBoxInCurrentLayer :: MainCoroutine [StrokeBBox]  getAllStrokeBBoxInCurrentLayer = do    xstate <- getSt -  let currCvsInfo  = getCurrentCanvasInfo xstate -  let pagebbox = getPage currCvsInfo-      (mcurrlayer, currpage) = getCurrentLayerOrSet pagebbox-      currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer-  return (get g_bstrokes currlayer)-      +  case get currentCanvas xstate of +    (_,CanvasInfoBox currCvsInfo) -> do +      let pagebbox = getPage currCvsInfo+          (mcurrlayer, _currpage) = getCurrentLayerOrSet pagebbox+          currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer+      return (get g_bstrokes currlayer)       -updateCanvasInfo :: CanvasInfo -> HXournalState -> HXournalState-updateCanvasInfo cinfo xstate = -  let cid = get canvasId cinfo-      cmap = get canvasInfoMap xstate-      cmap' = M.adjust (const cinfo) cid cmap -      xstate' = set canvasInfoMap cmap' xstate-  in xstate' -  otherCanvas :: HXournalState -> [Int]  otherCanvas = M.keys . get canvasInfoMap  -changeCurrentCanvasId :: CanvasId -> MainCoroutine HXournalState -- Iteratee MyEvent XournalStateIO HXournalState-changeCurrentCanvasId cid = do xstate1 <- getSt -                               let xstate = set currentCanvas cid xstate1-                               putSt xstate-                               return xstate-                               -getCanvasInfo :: CanvasId -> HXournalState -> CanvasInfo -getCanvasInfo cid xstate = -  let cinfoMap = get canvasInfoMap xstate-      maybeCvs = M.lookup cid cinfoMap-  in maybeError ("no canvas with id = " ++ show cid) maybeCvs-{-  in  case maybeCvs of -        Nothing -> error $ "no canvas with id = " ++ show cid -        Just cvsInfo -> cvsInfo -} -getCurrentCanvasInfo :: HXournalState -> CanvasInfo -getCurrentCanvasInfo xstate = getCanvasInfo (get currentCanvas xstate) xstate-      +-- |  -getCanvasGeometry :: CanvasInfo -> MainCoroutine CanvasPageGeometry -- Iteratee MyEvent XournalStateIO CanvasPageGeometry+changeCurrentCanvasId :: CanvasId -> MainCoroutine HXournalState +changeCurrentCanvasId cid = do +    xstate1 <- getSt+    (>>=) (return . M.lookup cid . get canvasInfoMap $ xstate1) $+     maybe (return xstate1) +           (\cinfo -> do +               let nst = set currentCanvas (cid,cinfo) xstate1 +                   ui = get gtkUIManager nst +               liftIO $ reflectUI ui cinfo+               putSt nst >> return nst+           )++-- | reflect UI for current canvas info ++reflectUI :: UIManager -> CanvasInfoBox -> IO ()+reflectUI ui cinfobox = do +    agr <- uiManagerGetActionGroups ui+    Just ra1 <- actionGroupGetAction (head agr) "ONEPAGEA"+    selectBoxAction (fsingle ra1) (fcont ra1) cinfobox +  where fsingle ra1 cinfo =  +          Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1 ] +        fcont ra1 cinfo =  +          Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 0 ] +          +  +-- | ++printViewPortBBox :: CanvasId -> MainCoroutine ()+printViewPortBBox cid = do +  cvsInfo <- return . getCanvasInfo cid =<< getSt +  liftIO $ putStrLn $ show (unboxGet (viewPortBBox.pageArrangement.viewInfo) cvsInfo)++-- | +  +printViewPortBBoxCurr :: MainCoroutine ()+printViewPortBBoxCurr = do +  cvsInfo <- return . get currentCanvasInfo =<< getSt +  liftIO $ putStrLn $ show (unboxGet (viewPortBBox.pageArrangement.viewInfo) cvsInfo)+++-- | ++unboxGetPage :: CanvasInfoBox -> (Page EditMode) +unboxGetPage = either id (gcast :: Page SelectMode -> Page EditMode) . unboxGet currentPage++-- | ++getCanvasGeometryCvsId :: CanvasId -> HXournalState -> IO CanvasGeometry +getCanvasGeometryCvsId cid xstate = do +  let cinfobox = getCanvasInfo cid xstate+      page = unboxGetPage cinfobox+      cpn = PageNum . unboxGet currentPageNum $ cinfobox +      canvas = unboxGet drawArea cinfobox+      xojstate = get xournalstate xstate +      fsingle = flip (makeCanvasGeometry EditMode (cpn,page)) canvas +                . get (pageArrangement.viewInfo) +  boxAction fsingle cinfobox++-- |++getCanvasGeometry :: HXournalState -> IO CanvasGeometry +getCanvasGeometry xstate = do +  let cinfobox = get currentCanvasInfo xstate+      page = unboxGetPage cinfobox+      cpn = PageNum . unboxGet currentPageNum $ cinfobox +      canvas = unboxGet drawArea cinfobox+      xojstate = get xournalstate xstate +      fsingle = flip (makeCanvasGeometry EditMode (cpn,page)) canvas +                . get (pageArrangement.viewInfo) ++  selectBoxAction fsingle fsingle cinfobox+  ++{-+getCanvasGeometry :: CanvasInfo SinglePage -> MainCoroutine CanvasPageGeometry  getCanvasGeometry cinfo = do      let canvas = get drawArea cinfo         page = getPage cinfo-        (x0,y0) = get (viewPortOrigin.viewInfo) cinfo+        (x0,y0) = bbox_upperleft . unViewPortBBox . get (viewPortBBox.pageArrangement.viewInfo) $ cinfo     liftIO (getCanvasPageGeometry canvas page (x0,y0))+-}++++++

lib/Application/HXournal/Config.hs view

@@ -20,8 +20,6 @@ import System.Directory import System.FilePath import Control.Concurrent -import Control.Applicative--- import Application.HXournal.NetworkClipboard.Client.Config  emptyConfigString :: String  emptyConfigString = "\n#config file for hxournal \n "

lib/Application/HXournal/Coroutine/Commit.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.Commit @@ -9,6 +8,8 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Commit where  import Application.HXournal.Type.XournalState @@ -21,7 +22,6 @@ import Application.HXournal.ModelAction.Page  import Data.Label--- import Control.Monad (liftM) import Control.Monad.Trans import Application.HXournal.Accessor @@ -48,11 +48,9 @@       Nothing -> liftIO $ putStrLn "no undo item yet"       Just (xojstate1,newtable) -> do          xojstate <- liftIO $ resetXournalStateBuffers xojstate1 -        let xstate' = set xournalstate xojstate-                      . set undoTable newtable -                      . updatePageAll xojstate -                      $ xstate -        putSt xstate'+        putSt . set xournalstate xojstate+              . set undoTable newtable +              =<< (liftIO (updatePageAll xojstate xstate))         invalidateAll           @@ -65,11 +63,9 @@       Nothing -> liftIO $ putStrLn "no redo item"       Just (xojstate1,newtable) -> do          xojstate <- liftIO $ resetXournalStateBuffers xojstate1         -        let xstate' = set xournalstate xojstate-                      . set undoTable newtable -                      . updatePageAll xojstate -                      $ xstate -        putSt xstate'+        putSt . set xournalstate xojstate+              . set undoTable newtable +              =<< (liftIO (updatePageAll xojstate xstate))         invalidateAll   clearUndoHistory :: MainCoroutine ()

lib/Application/HXournal/Coroutine/Default.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- |@@ -9,6 +10,8 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Default where  import Graphics.UI.Gtk hiding (get,set)@@ -18,9 +21,7 @@ import Application.HXournal.Type.Canvas import Application.HXournal.Type.XournalState import Application.HXournal.Type.Clipboard- import Application.HXournal.Accessor- import Application.HXournal.GUI.Menu import Application.HXournal.Coroutine.Callback import Application.HXournal.Coroutine.Commit@@ -36,10 +37,11 @@ import Application.HXournal.Coroutine.Window -- import Application.HXournal.Coroutine.Network import Application.HXournal.Coroutine.Layer - import Application.HXournal.ModelAction.Window +import Application.HXournal.ModelAction.Page import Application.HXournal.Type.Window  import Application.HXournal.Device+import Control.Applicative ((<$>)) import Control.Monad.Coroutine import Control.Monad.Coroutine.SuspensionFunctors import qualified Control.Monad.State as St @@ -50,25 +52,34 @@ import Data.Label import Prelude hiding ((.), id) import Data.IORef--+import Application.HXournal.Type.PageArrangement+import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.BBox import Data.Xournal.Generic +-- |+ guiProcess :: MainCoroutine () guiProcess = do    initialize+  liftIO $ putStrLn "hi!"+  +  liftIO $ putStrLn "welcome to hxournal"   changePage (const 0)   xstate <- getSt   let cinfoMap  = get canvasInfoMap xstate       assocs = M.toList cinfoMap -      f (cid,cinfo) = do let canvas = get drawArea cinfo-                         (w',h') <- liftIO $ widgetGetSize canvas-                         defaultEventProcess (CanvasConfigure cid+      f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox+                            (w',h') <- liftIO $ widgetGetSize canvas+                            defaultEventProcess (CanvasConfigure cid                                                 (fromIntegral w')                                                  (fromIntegral h'))    mapM_ f assocs   sequence_ (repeat dispatchMode) ++-- |+ initCoroutine :: DeviceList -> Window -> IO (TRef,SRef) initCoroutine devlst window = do    let st0 = (emptyHXournalState :: HXournalState)@@ -76,11 +87,7 @@   tref <- newIORef (undefined :: SusAwait)   (r,st') <- St.runStateT (resume guiProcess) st0    writeIORef sref st' -  case r of -    Left aw -> do -      writeIORef tref aw -    Right _ -> error "what?"-+  either (writeIORef tref) (error "what?") r    let st0new = set deviceList devlst               . set rootOfRootWindow window              . set callBack (bouncecallback tref sref) @@ -90,15 +97,25 @@   putStrLn "hi"     let st1 = set gtkUIManager ui st0new -  initcvs <- initCanvasInfo st1 1 -  let initcmap = M.insert (get canvasId initcvs) initcvs M.empty-  let startingXstate = set currentCanvas (get canvasId initcvs)-                       . set canvasInfoMap initcmap -                       . set frameState (Node 1)-                       $ st1+  -- (initcvstemp :: CanvasInfo SinglePage) <- initCanvasInfo st1 1 +  let initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } +  let initcvsbox = CanvasInfoBox initcvs+      --  initcmap = M.insert (get canvasId initcvs) initcvsbox M.empty+  let -- startingXstate = set canvasInfoMap initcmap +      --                  . set frameState (Node 1)+      --                 $ st1+      st2 = set frameState (Node 1) +            . updateFromCanvasInfoAsCurrentCanvas initcvsbox +            . set canvasInfoMap (M.empty)+            $ st1 +  (st3,cvs,wconf) <- constructFrame st2 (get frameState st2)+  (st4,wconf') <- eventConnect st3 (get frameState st3)+  let startingXstate = set frameState wconf' . set rootWindow cvs $ st4+                          writeIORef sref startingXstate      return (tref,sref) + initialize :: MainCoroutine () initialize = do ev <- await                  liftIO $ putStrLn $ show ev @@ -106,14 +123,19 @@                   Initialized -> return ()                    _ -> initialize +-- |   dispatchMode :: MainCoroutine () -dispatchMode = do -  xojstate <- return . get xournalstate =<< lift St.get-  case xojstate of +dispatchMode = getSt >>= return . xojstateEither . get xournalstate+                     >>= either (const viewAppendMode) (const selectMode)+                     +{-  xojstate <- return . get xournalstate =<< getSt +    case xojstate of      ViewAppendState _ -> viewAppendMode-    SelectState _ -> selectMode+    SelectState _ -> selectMode -} +-- | + viewAppendMode :: MainCoroutine ()  viewAppendMode = do    r1 <- await @@ -135,7 +157,8 @@       ptype <- return . get (selectType.selectInfo) =<< lift St.get        case ptype of          SelectRectangleWork -> selectRectStart cid pcoord -        _ -> return () +        SelectRegionWork -> selectLassoStart cid pcoord+        _ -> return ()     PenColorChanged c -> selectPenColorChanged c     PenWidthChanged w -> selectPenWidthChanged w     _ -> defaultEventProcess r1@@ -145,38 +168,16 @@ defaultEventProcess :: MyEvent -> MainCoroutine () defaultEventProcess (UpdateCanvas cid) = invalidate cid    defaultEventProcess (Menu m) = menuEventProcess m-defaultEventProcess (HScrollBarMoved cid v) = do -    xstate <- getSt -    let cinfoMap = get canvasInfoMap xstate-        maybeCvs = M.lookup cid cinfoMap -    case maybeCvs of -      Nothing -> return ()-      Just cvsInfo -> do -        let vm_orig = get (viewPortOrigin.viewInfo) cvsInfo-        let cvsInfo' = set (viewPortOrigin.viewInfo) (v,snd vm_orig) -                         $ cvsInfo-            xstate' = set currentCanvas cid -                    . updateCanvasInfo cvsInfo' -                    $ xstate-        lift . St.put $ xstate'-        invalidate cid-defaultEventProcess (VScrollBarMoved cid v) = do -    xstate <- lift St.get -    let cinfoMap = get canvasInfoMap xstate-        cvsInfo = case M.lookup cid cinfoMap of -                     Nothing -> error "No such canvas in defaultEventProcess" -                     Just cvs -> cvs-    let vm_orig = get (viewPortOrigin.viewInfo) cvsInfo-    let cvsInfo' = set (viewPortOrigin.viewInfo) (fst vm_orig,v)-                   $ cvsInfo -        xstate' = set currentCanvas cid -                  . updateCanvasInfo cvsInfo' $ xstate-    lift . St.put $ xstate'-    invalidate cid+defaultEventProcess (HScrollBarMoved cid v) = hscrollBarMoved cid v+defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v defaultEventProcess (VScrollBarStart cid _v) = vscrollStart cid -defaultEventProcess (CanvasConfigure cid _w' _h') = canvasZoomUpdate Nothing cid +defaultEventProcess (CanvasConfigure cid w' h') = +  canvasConfigure cid (CanvasDimension (Dim w' h'))+   defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode defaultEventProcess ToSelectMode = modeChange ToSelectMode +defaultEventProcess ToSinglePage = viewModeChange ToSinglePage+defaultEventProcess ToContSinglePage = viewModeChange ToContSinglePage defaultEventProcess _ = return ()  askQuitProgram :: MainCoroutine () @@ -204,12 +205,10 @@ menuEventProcess MenuNextPage =  changePage (+1) menuEventProcess MenuFirstPage = changePage (const 0) menuEventProcess MenuLastPage = do -  xstate <- getSt-  let totalnumofpages = case get xournalstate xstate of -                          ViewAppendState xoj ->  M.size . get g_pages $ xoj-                          SelectState txoj    -> M.size . gselectAll $ txoj+  totalnumofpages <- (either (M.size. get g_pages) (M.size . get g_selectAll) +                      . xojstateEither . get xournalstate) <$> getSt    changePage (const (totalnumofpages-1))-menuEventProcess MenuNewPageBefore = newPageBefore +menuEventProcess MenuNewPageBefore = return () -- newPageBefore  menuEventProcess MenuNew  = askIfSave fileNew  menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF menuEventProcess MenuUndo = undo @@ -242,14 +241,17 @@                     case x of                        [] -> error "No action group? "                       y:_ -> return y )-  uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> -                        return (castToToggleAction x) )+  uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA") +              >>= maybe (error "MenuUseXInput") (return . castToToggleAction)   b <- liftIO $ toggleActionGetActive uxinputa   let cmap = get canvasInfoMap xstate-      canvases = map (get drawArea) . M.elems $ cmap +      canvases = map (getDrawAreaFromBox) . M.elems $ cmap       if b     then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases     else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases           menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m +++

lib/Application/HXournal/Coroutine/Draw.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE Rank2Types #-}  ----------------------------------------------------------------------------- -- |@@ -9,84 +10,79 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Draw where -import Application.HXournal.Type.Event import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas import Application.HXournal.Type.XournalState-import Application.HXournal.Draw+import Application.HXournal.Type.PageArrangement+import Application.HXournal.View.Draw import Application.HXournal.Accessor-- import Data.Xournal.BBox- import Control.Applicative  import Control.Monad 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)+import Application.HXournal.View.Coordinate+import Application.HXournal.Type.Alias+import Application.HXournal.ModelAction.Page -invalidateSelSingle :: CanvasId -> Maybe BBox -                       -> PageDrawF-                       -> PageDrawFSel -                       -> MainCoroutine () -invalidateSelSingle cid mbbox drawf drawfsel = do-  xstate <- lift St.get  -  let  maybeCvs = M.lookup cid (get canvasInfoMap xstate)-  case maybeCvs of -    Nothing -> return ()-    Just cvsInfo -> do -      case get currentPage cvsInfo of -        Left page ->  liftIO (drawf <$> get drawArea -                                    <*> pure page -                                    <*> get viewInfo -                                    <*> pure mbbox-                                    $ cvsInfo )-        Right tpage -> liftIO (drawfsel <$> get drawArea -                                        <*> pure tpage-                                        <*> get viewInfo-                                        <*> pure mbbox-                                        $ cvsInfo )+data DrawingFunctionSet = +  DrawingFunctionSet { singleEditDraw :: DrawingFunction SinglePage EditMode+                     , singleSelectDraw :: DrawingFunction SinglePage SelectMode+                     , contEditDraw :: DrawingFunction ContinuousSinglePage EditMode+                     , contSelectDraw :: DrawingFunction ContinuousSinglePage SelectMode +                     } -invalidateGenSingle :: CanvasId -> Maybe BBox -> PageDrawF-                    -> MainCoroutine () -invalidateGenSingle cid mbbox drawf = do-  xstate <- lift St.get  -  let  maybeCvs = M.lookup cid (get canvasInfoMap xstate)-  case maybeCvs of -    Nothing -> return ()-    Just cvsInfo -> do -      let page = case get currentPage cvsInfo of-                   Right _ -> error "no invalidateGenSingle implementation yet"-                   Left pg -> pg-      liftIO (drawf <$> get drawArea -                    <*> pure page -                    <*> get viewInfo -                    <*> pure mbbox-                    $ cvsInfo ) +-- |  -invalidateAll :: MainCoroutine () -invalidateAll = do-  xstate <- getSt-  let cinfoMap  = get canvasInfoMap xstate-      keys = M.keys cinfoMap -  forM_ keys invalidate +invalidateGeneral :: CanvasId -> Maybe BBox +                  -> DrawingFunction SinglePage EditMode+                  -> DrawingFunction SinglePage SelectMode+                  -> DrawingFunction ContinuousSinglePage EditMode+                  -> DrawingFunction ContinuousSinglePage SelectMode+                  -> MainCoroutine () +invalidateGeneral cid mbbox drawf drawfsel drawcont drawcontsel = do +    xst <- getSt +    selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst+  where fsingle :: HXournalState -> CanvasInfo SinglePage -> MainCoroutine () +        fsingle xstate cvsInfo = do +          let cpn = PageNum . get currentPageNum $ cvsInfo +              isCurrentCvs = cid == get currentCanvasId xstate+          case get currentPage cvsInfo of +            Left page -> do  +              liftIO (unSinglePageDraw drawf isCurrentCvs +                        <$> get drawArea <*> pure (cpn,page) +                        <*> get viewInfo <*> pure mbbox $ cvsInfo )+            Right tpage -> do +              liftIO (unSinglePageDraw drawfsel isCurrentCvs+                        <$> get drawArea <*> pure (cpn,tpage) +                        <*> get viewInfo <*> pure mbbox $ cvsInfo )+        fcont :: HXournalState -> CanvasInfo ContinuousSinglePage -> MainCoroutine () +        fcont xstate cvsInfo = do +          let xojstate = get xournalstate xstate +              isCurrentCvs = cid == get currentCanvasId xstate+          case xojstate of +            ViewAppendState xoj -> do  +              liftIO (unContPageDraw drawcont isCurrentCvs cvsInfo mbbox xoj)+            SelectState txoj -> +              liftIO (unContPageDraw drawcontsel isCurrentCvs cvsInfo mbbox txoj)+          +          invalidateOther :: MainCoroutine ()  invalidateOther = do    xstate <- getSt-  let currCvsId = get currentCanvas xstate+  let currCvsId = get currentCanvasId xstate       cinfoMap  = get canvasInfoMap xstate       keys = M.keys cinfoMap    mapM_ invalidate (filter (/=currCvsId) keys)@@ -95,53 +91,82 @@ -- | invalidate clear   invalidate :: CanvasId -> MainCoroutine () -invalidate cid = invalidateSelSingle cid Nothing drawPageClearly drawPageSelClearly+invalidate = invalidateInBBox Nothing  +{-  invalidateGeneral cid Nothing +    drawPageClearly drawPageSelClearly drawContXojClearly drawContXojSelClearly-}  --- | Drawing objects only in BBox+-- |  -invalidateInBBox :: CanvasId -> BBox -> MainCoroutine () -invalidateInBBox cid bbox = invalidateSelSingle cid (Just bbox) drawPageInBBox drawSelectionInBBox+invalidateInBBox :: Maybe BBox -- ^ desktop coord+                    -> CanvasId -> MainCoroutine ()+invalidateInBBox mbbox cid = do +  invalidateGeneral cid mbbox+    drawPageClearly drawPageSelClearly drawContXojClearly drawContXojSelClearly --- | Drawing BBox+-- |  -invalidateDrawBBox :: CanvasId -> BBox -> MainCoroutine () -invalidateDrawBBox cid bbox = invalidateSelSingle cid (Just bbox) drawBBox drawBBoxSel+invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate +                       -> MainCoroutine ()+invalidateAllInBBox mbbox = do                        +  xstate <- getSt+  let cinfoMap  = get canvasInfoMap xstate+      keys = M.keys cinfoMap +  forM_ keys (invalidateInBBox mbbox) +-- |  +invalidateAll :: MainCoroutine () +invalidateAll = invalidateAllInBBox Nothing --- | Drawing using layer buffer -invalidateWithBuf :: CanvasId -> MainCoroutine () -invalidateWithBuf = invalidateWithBufInBBox Nothing-   --- | Drawing using layer buffer in BBox+-- | Invalidate Current canvas -invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () -invalidateWithBufInBBox mbbox cid = invalidateSelSingle cid mbbox drawBuf drawSelectionInBBox-                                    +invalidateCurrent :: MainCoroutine () +invalidateCurrent = invalidate . get currentCanvasId =<< getSt+        -- | 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 +    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      +              pnum = PageNum . get currentPageNum $ 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 () +invalidateWithBuf = invalidateWithBufInBBox Nothing+  ++-- | Drawing using layer buffer in BBox  ++invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () +invalidateWithBufInBBox mbbox cid =  +  invalidateGeneral cid mbbox drawBuf drawSelBuf drawContXojBuf drawContXojSelClearly+++-- | check current canvas id and new active canvas id and invalidate if it's changed. ++chkCvsIdNInvalidate :: CanvasId -> MainCoroutine () +chkCvsIdNInvalidate cid = do +  currcid <- liftM (get currentCanvasId) getSt +  when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll)+  ++

lib/Application/HXournal/Coroutine/Eraser.hs view

@@ -8,6 +8,7 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.Coroutine.Eraser where @@ -16,8 +17,10 @@ import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas import Application.HXournal.Type.XournalState+import Application.HXournal.Type.PageArrangement import Application.HXournal.Device-import Application.HXournal.Draw+-- import Application.HXournal.View.Draw+import Application.HXournal.View.Coordinate import Application.HXournal.Coroutine.EventConnect import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.Commit@@ -39,41 +42,35 @@ import Data.Label import qualified Data.IntMap as IM import Prelude hiding ((.), id)---- for test-import Control.Compose-import Data.Xournal.Select-import qualified Data.Sequence as Seq+import Application.HXournal.Coroutine.Pen   eraserStart :: CanvasId                 -> PointerCoord                 -> MainCoroutine () -eraserStart cid pcoord = do -    xstate <- changeCurrentCanvasId cid -    let cvsInfo = getCanvasInfo cid xstate-        zmode = get (zoomMode.viewInfo) cvsInfo-    geometry <- getCanvasGeometry cvsInfo -    let (x,y) = device2pageCoord geometry zmode pcoord -    connidup   <- connectPenUp cvsInfo     -    connidmove <- connectPenMove cvsInfo   -    strs <- getAllStrokeBBoxInCurrentLayer-    eraserProcess cid geometry connidup connidmove strs (x,y)-  +eraserStart cid = commonPenStart eraserAction cid  +  where eraserAction _cinfo pnum geometry (cidup,cidmove) (x,y) = do +          strs <- getAllStrokeBBoxInCurrentLayer+          eraserProcess cid pnum geometry cidup cidmove strs (x,y)+ eraserProcess :: CanvasId-              -> CanvasPageGeometry+              -> PageNum +              -> CanvasGeometry               -> ConnectId DrawingArea -> ConnectId DrawingArea                -> [StrokeBBox]                -> (Double,Double)               -> MainCoroutine () -eraserProcess cid cpg connidmove connidup strs (x0,y0) = do -  r <- await -  xstate <- getSt-  let cvsInfo = getCanvasInfo cid xstate -  case r of -    PenMove _cid' pcoord -> do -      let zmode  = get (zoomMode.viewInfo) cvsInfo-          (x,y) = device2pageCoord cpg zmode pcoord -          line = ((x0,y0),(x,y))+eraserProcess cid pnum geometry connidmove connidup strs (x0,y0) = do +    r <- await +    xst <- getSt+    boxAction (f r xst) . getCanvasInfo cid $ xst +  where +    f :: (ViewMode a) => MyEvent -> HXournalState -> CanvasInfo a -> MainCoroutine ()+    f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact +                                 (moveact xstate cvsInfo) upact+    defact = eraserProcess cid pnum geometry connidup connidmove strs (x0,y0)+    upact _ = disconnect connidmove >> disconnect connidup >> invalidateAll+    moveact xstate cvsInfo (x,y) = do +      let line = ((x0,y0),(x,y))           hittestbbox = mkHitTestBBox line strs              (hitteststroke,hitState) =              St.runState (hitTestStrokes line hittestbbox) False@@ -85,21 +82,20 @@               currlayer = maybe (error "eraserProcess") id mcurrlayer           let (newstrokes,maybebbox1) = St.runState (eraseHitted hitteststroke) Nothing               maybebbox = fmap (flip inflate 2.0) maybebbox1-          newlayerbbox <- liftIO . updateLayerBuf maybebbox . set g_bstrokes newstrokes $ currlayer +          newlayerbbox <- liftIO . updateLayerBuf maybebbox +                          . set g_bstrokes newstrokes $ currlayer            let newpagebbox = adjustCurrentLayer newlayerbbox currpage -              newxojbbox = currxoj { gpages= IM.adjust (const newpagebbox) pgnum (gpages currxoj) }+              newxojbbox = modify g_pages (IM.adjust (const newpagebbox) pgnum) currxoj               newxojstate = ViewAppendState newxojbbox           commit . set xournalstate newxojstate -                 . updatePageAll newxojstate $ xstate -          -- invalidateWithBufInBBox maybebbox cid +            =<< (liftIO (updatePageAll newxojstate xstate))           invalidateWithBuf cid            newstrs <- getAllStrokeBBoxInCurrentLayer-          eraserProcess cid cpg connidup connidmove newstrs (x,y)-        else eraserProcess cid cpg connidmove connidup strs (x,y) -    PenUp _cid' _pcoord -> do -      disconnect connidmove -      disconnect connidup -      invalidateAll-    _ -> return ()-    +          eraserProcess cid pnum geometry connidup connidmove newstrs (x,y)+        else eraserProcess cid pnum geometry connidmove connidup strs (x,y) +            ++++

lib/Application/HXournal/Coroutine/EventConnect.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.EventConnect @@ -17,8 +16,9 @@ import Application.HXournal.Type.XournalState import Application.HXournal.Device import Application.HXournal.Type.Coroutine+import Application.HXournal.Accessor -import qualified Control.Monad.State as St+-- import qualified Control.Monad.State as St import Control.Applicative import Control.Monad.Trans @@ -26,40 +26,33 @@ import Data.Label  import Prelude hiding ((.), id) -disconnect :: (WidgetClass w) => ConnectId w -              -> MainCoroutine () --  Iteratee MyEvent XournalStateIO ()+disconnect :: (WidgetClass w) => ConnectId w -> MainCoroutine ()  disconnect = liftIO . signalDisconnect -connectPenUp :: CanvasInfo -> MainCoroutine (ConnectId DrawingArea) -- Iteratee MyEvent XournalStateIO (ConnectId DrawingArea)+connectPenUp :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea)  connectPenUp cinfo = do    let cid = get canvasId cinfo       canvas = get drawArea cinfo    connPenUp canvas cid  -connectPenMove :: CanvasInfo -> MainCoroutine (ConnectId DrawingArea) -- Iteratee MyEvent XournalStateIO (ConnectId DrawingArea)+connectPenMove :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea)  connectPenMove cinfo = do    let cid = get canvasId cinfo       canvas = get drawArea cinfo    connPenMove canvas cid  -connPenMove :: (WidgetClass w) => -               w -               -> CanvasId -               -> MainCoroutine (ConnectId w) -- Iteratee MyEvent XournalStateIO (ConnectId w) +connPenMove :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w)  connPenMove c cid = do -  callbk <- get callBack <$> lift St.get -  dev <- get deviceList <$> lift St.get +  callbk <- get callBack <$> getSt+  dev <- get deviceList <$> getSt   liftIO (c `on` motionNotifyEvent $ tryEvent $ do               p <- getPointer dev              liftIO (callbk (PenMove cid p))) -connPenUp :: (WidgetClass w) => -             w -             -> CanvasId-             -> MainCoroutine (ConnectId w) -- Iteratee MyEvent XournalStateIO (ConnectId w) +connPenUp :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w) connPenUp c cid = do -  callbk <- get callBack <$> lift St.get -  dev <- get deviceList <$> lift St.get +  callbk <- get callBack <$> getSt+  dev <- get deviceList <$> getSt   liftIO (c `on` buttonReleaseEvent $ tryEvent $ do               p <- getPointer dev              liftIO (callbk (PenMove cid p)))

lib/Application/HXournal/Coroutine/File.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.File @@ -9,6 +8,8 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.File where  import Application.HXournal.Type.Event@@ -18,6 +19,7 @@ import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.Commit import Application.HXournal.ModelAction.Window+import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.File import Text.Xournal.Builder  import Control.Monad.Trans@@ -55,8 +57,10 @@ fileNew = do       xstate <- getSt     xstate' <- liftIO $ getFileContent Nothing xstate -    commit xstate' -    liftIO $ setTitleFromFileName xstate'+    ncvsinfo <- liftIO $ setPage xstate' 0 (get currentCanvasId xstate')+    xstate'' <- return $ modifyCurrentCanvasInfo (const ncvsinfo) xstate'+    liftIO $ setTitleFromFileName xstate''+    commit xstate''      invalidateAll   @@ -96,7 +100,9 @@           Just filename -> do              liftIO $ putStrLn $ show filename              xstate <- getSt -            xstateNew <- liftIO $ getFileContent (Just filename) xstate+            xstate' <- liftIO $ getFileContent (Just filename) xstate+            ncvsinfo <- liftIO $ setPage xstate' 0 (get currentCanvasId xstate')+            xstateNew <- return $ modifyCurrentCanvasInfo (const ncvsinfo) xstate'             putSt . set isSaved True                    $ xstateNew              liftIO $ setTitleFromFileName xstateNew

lib/Application/HXournal/Coroutine/Highlighter.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.Highlighter @@ -9,14 +8,13 @@ -- 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

lib/Application/HXournal/Coroutine/Layer.hs view

@@ -10,14 +10,16 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.Coroutine.Layer where  import Application.HXournal.Type.Canvas import Application.HXournal.Type.XournalState import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.Alias  import Application.HXournal.Accessor-import Application.HXournal.Util+ import Application.HXournal.ModelAction.Layer import Application.HXournal.ModelAction.Page import Application.HXournal.Coroutine.Commit@@ -32,24 +34,28 @@ import Data.Label import Prelude hiding ((.),id) -import Data.Xournal.Simple + import Data.IORef  import qualified Data.Sequence as Seq import Graphics.UI.Gtk hiding (get,set) -layerAction :: (XournalState -> Int -> TPageBBoxMapPDFBuf -> MainCoroutine XournalState) -> MainCoroutine HXournalState+layerAction :: (XournalState -> Int -> Page EditMode -> MainCoroutine XournalState) +            -> MainCoroutine HXournalState layerAction action = do -    xstate <- getSt-    let epage = get currentPage . getCurrentCanvasInfo $ xstate-        cpn = get currentPageNum . getCurrentCanvasInfo $ xstate-        xojstate = get xournalstate xstate-    newxojstate <- either (action xojstate cpn) (action xojstate cpn . gcast) epage -    return . updatePageAll newxojstate -           . set xournalstate newxojstate -           $ xstate+    xst <- getSt +    selectBoxAction (fsingle xst) (fsingle xst)  . get currentCanvasInfo $ xst+  where +    fsingle xstate cvsInfo = do+      let epage = get currentPage cvsInfo+          cpn = get currentPageNum cvsInfo+          xojstate = get xournalstate xstate+      newxojstate <- either (action xojstate cpn) (action xojstate cpn . gcast) epage +      return =<< (liftIO (updatePageAll newxojstate . set xournalstate newxojstate $ xstate)) +-- | + makeNewLayer :: MainCoroutine ()  makeNewLayer = layerAction newlayeraction >>= commit    where newlayeraction xojstate cpn page = do @@ -74,8 +80,6 @@             Just _ -> liftIO $ putStrLn "Just"           let Select (O (Just ll)) = get g_layers npage               SZ (_,(x1,x2)) = ll -          liftIO$ print (Seq.length x1, Seq.length x2)-           return . setPageMap (M.adjust (const npage) cpn . getPageMap $ xojstate) $ xojstate    gotoPrevLayer :: MainCoroutine ()@@ -90,8 +94,6 @@           case mlyrzipper of              Nothing -> liftIO $ putStrLn "Nothing"             Just _ -> liftIO $ putStrLn "Just"-          liftIO$ print (Seq.length x1, Seq.length x2)-           return . setPageMap (M.adjust (const npage) cpn . getPageMap $ xojstate) $ xojstate    @@ -104,7 +106,6 @@               npage = maybe currpage (\x -> set g_layers (Select (O (Just x))) currpage) mlyrzipper           let Select (O (Just ll)) = get g_layers npage               SZ (_,(x1,x2)) = ll -          liftIO $ print (Seq.length x1, Seq.length x2)           return . setPageMap (M.adjust (const npage) cpn . getPageMap $ xojstate) $ xojstate    @@ -112,9 +113,8 @@ deleteCurrentLayer = layerAction deletelayeraction >>= commit   where deletelayeraction xojstate cpn page = do            let (mcurrlayer,currpage) = getCurrentLayerOrSet page-          case mcurrlayer of -            Nothing -> return xojstate -            Just currlayer -> do +          flip (maybe (return xojstate)) mcurrlayer $  +            const $ do                let Select (O (Just lyrzipper)) = get g_layers currpage                     mlyrzipper = deleteCurrent lyrzipper                    npage = maybe currpage @@ -123,24 +123,21 @@               return . setPageMap (M.adjust (const npage) cpn . getPageMap $ xojstate) $ xojstate    startGotoLayerAt :: MainCoroutine ()-startGotoLayerAt = do -    liftIO $ putStrLn "startGotoLayerAt"-    xstate <- getSt -    let epage = get currentPage . getCurrentCanvasInfo $ xstate -        cpn = get currentPageNum . getCurrentCanvasInfo $ xstate-        xojstate = get xournalstate xstate -        page = either id gcast epage -        (_,currpage) = getCurrentLayerOrSet page-        Select (O (Just lyrzipper)) = get g_layers currpage-        cidx = currIndex lyrzipper-        len  = lengthSZ lyrzipper -   -    lref <- liftIO $ newIORef cidx--    dialog <- liftIO (layerChooseDialog lref cidx len)--    res <- liftIO $ dialogRun dialog-    case res of +startGotoLayerAt = +    selectBoxAction fsingle fsingle . get currentCanvasInfo =<< getSt+     {- (error "startGotoLayerAt") -}+  where +    fsingle cvsInfo = do +      let epage = get currentPage cvsInfo+          page = either id gcast epage +          (_,currpage) = getCurrentLayerOrSet page+          Select (O (Just lyrzipper)) = get g_layers currpage+          cidx = currIndex lyrzipper+          len  = lengthSZ lyrzipper +      lref <- liftIO $ newIORef cidx+      dialog <- liftIO (layerChooseDialog lref cidx len)+      res <- liftIO $ dialogRun dialog+      case res of          ResponseDeleteEvent -> liftIO $ widgetDestroy dialog         ResponseOk ->  do           liftIO $ widgetDestroy dialog@@ -149,5 +146,5 @@           gotoLayerAt newnum         ResponseCancel -> liftIO $ widgetDestroy dialog         _ -> error "??? in fileOpen " -    return ()+      return ()

lib/Application/HXournal/Coroutine/Mode.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-}  ----------------------------------------------------------------------------- -- |@@ -9,50 +10,103 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Mode where  import Application.HXournal.Type.Event import Application.HXournal.Type.Coroutine import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Alias+import Application.HXournal.Type.PageArrangement+import Application.HXournal.Type.Canvas+import Application.HXournal.View.Coordinate import Application.HXournal.Accessor-+import Application.HXournal.ModelAction.Page+import Application.HXournal.Coroutine.Scroll+import Application.HXournal.Coroutine.Draw --import Data.Foldable import Data.Traversable--+import Control.Applicative import Control.Monad.Trans-- import Control.Category import Data.Label-+import Data.Xournal.Simple (Dimension(..)) import Data.Xournal.Generic import Graphics.Xournal.Render.BBoxMapPDF-+import Graphics.UI.Gtk (adjustmentSetUpper,adjustmentGetValue,adjustmentSetValue) import Prelude hiding ((.),id, mapM_, mapM) +modeChange :: MyEvent -> MainCoroutine () +modeChange command = case command of +                       ToViewAppendMode -> updateXState select2edit+                       ToSelectMode     -> updateXState edit2select +                       _ -> return ()+  where select2edit xst =  +          either (noaction xst) (whenselect xst) . xojstateEither . get xournalstate $ xst+        edit2select xst = +          either (whenedit xst) (noaction xst) . xojstateEither . get xournalstate $ xst+        noaction :: HXournalState -> a -> MainCoroutine HXournalState+        noaction xstate = const (return xstate)+        whenselect :: HXournalState -> Xournal SelectMode -> MainCoroutine HXournalState+        whenselect xstate txoj = return . flip (set xournalstate) xstate +                                 . ViewAppendState . GXournal (get g_selectTitle txoj)+                                 =<< liftIO (mapM resetPageBuffers (get g_selectAll txoj)) +        whenedit :: HXournalState -> Xournal EditMode -> MainCoroutine HXournalState   +        whenedit xstate xoj = return . flip (set xournalstate) xstate +                              . SelectState  +                              $ GSelect (get g_title xoj) (gpages xoj) Nothing -modeChange :: MyEvent -> MainCoroutine () --  Iteratee MyEvent XournalStateIO ()-modeChange ToViewAppendMode = do -  xstate <- getSt-  let xojstate = get xournalstate xstate-  case xojstate of -    ViewAppendState _ -> return () -    SelectState txoj -> do -      liftIO $ putStrLn "to view append mode"-      let pages = get g_selectAll txoj -      newpages <- liftIO $ mapM resetPageBuffers pages -      putSt -        . set xournalstate (ViewAppendState (GXournal (get g_selectTitle txoj) newpages ))-        $ xstate  -modeChange ToSelectMode = do -  xstate <- getSt-  let xojstate = get xournalstate xstate-  case xojstate of -    ViewAppendState xoj -> do -      liftIO $ putStrLn "to select mode"-      putSt-        . set xournalstate (SelectState (GSelect (get g_title xoj) (gpages xoj) Nothing))-        $ xstate  -    SelectState _ -> return ()-modeChange _ = return ()+++viewModeChange :: MyEvent -> MainCoroutine () +viewModeChange command = do +    case command of +      ToSinglePage -> updateXState cont2single >> invalidateAll +      ToContSinglePage -> updateXState single2cont >> invalidateAll +      _ -> return ()+    adjustScrollbarWithGeometryCurrent     +  where cont2single xst =  +          selectBoxAction (noaction xst) (whencont xst) . get currentCanvasInfo $ xst+        single2cont xst = +          selectBoxAction (whensing xst) (noaction xst) . get currentCanvasInfo $ xst+        noaction :: HXournalState -> a -> MainCoroutine HXournalState  +        noaction xstate = const (return xstate)++        whencont xstate _ = do +          liftIO $ putStrLn "cont2single"+          return xstate++        whensing xstate cinfo = do +          liftIO $ putStrLn "single2cont"+          cdim <- liftIO $  return . canvasDim =<< getCanvasGeometry xstate +          let zmode = get (zoomMode.viewInfo) cinfo+              canvas = get drawArea cinfo +              cpn = PageNum . get currentPageNum $ cinfo +              page = getPage cinfo+              (hadj,vadj) = get adjustments cinfo +          (xpos,ypos) <- liftIO $ (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj++          let arr = makeContinuousSingleArrangement zmode cdim (getXournal xstate) +                                                    (cpn, PageCoord (xpos,ypos))+              ContinuousSingleArrangement _ (DesktopDimension (Dim w h)) _ _ = arr  +          geometry <- liftIO $ makeCanvasGeometry EditMode (cpn,page) arr canvas+          let DeskCoord (nxpos,nypos) = page2Desktop geometry (cpn,PageCoord (xpos,ypos))+          let vinfo = get viewInfo cinfo +              nvinfo = ViewInfo (get zoomMode vinfo) arr +              ncinfotemp = CanvasInfo (get canvasId cinfo)+                                      (get drawArea cinfo)+                                      (get scrolledWindow cinfo)+                                      nvinfo +                                      (get currentPageNum cinfo)+                                      (get currentPage cinfo)+                                      hadj +                                      vadj +                                      (get horizAdjConnId cinfo)+                                      (get vertAdjConnId cinfo)+              ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos))+              ncinfo = modify currentPageNum (const (unPageNum ncpn)) ncinfotemp++          return . modifyCurrentCanvasInfo (const (CanvasInfoBox ncinfo)) $ xstate++

lib/Application/HXournal/Coroutine/Page.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.Page @@ -9,140 +8,183 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Page where -import Control.Applicative -import Control.Compose-import Application.HXournal.Type.Event+import Control.Monad import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas+import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.XournalState-import Application.HXournal.Draw+import Application.HXournal.Util+import Application.HXournal.View.Draw+import Application.HXournal.View.Coordinate import Application.HXournal.Accessor import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.Commit-import Application.HXournal.ModelAction.Adjustment-+import Application.HXournal.Coroutine.Scroll+-- import Application.HXournal.ModelAction.Adjustment+import Application.HXournal.ModelAction.Page+import Application.HXournal.Type.Alias import Graphics.Xournal.Render.BBoxMapPDF import Data.Xournal.Generic-import Data.Xournal.Select - import Graphics.UI.Gtk hiding (get,set)-import Application.HXournal.ModelAction.Page- import Control.Monad.Trans import Control.Category import Data.Label import Prelude hiding ((.), id)-import Data.Xournal.Simple-import qualified Data.IntMap as IM+import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.BBox+import qualified Data.IntMap as M -changePage :: (Int -> Int) -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () -changePage modifyfn = do -    xstate <- getSt -    let currCvsId = get currentCanvas xstate-        currCvsInfo = getCanvasInfo currCvsId xstate   -    let xojst = get xournalstate $ xstate -    case xojst of -      ViewAppendState xoj -> do -        let pgs = gpages xoj -            totalnumofpages = IM.size pgs-            oldpage = get currentPageNum currCvsInfo-            lpage = case IM.lookup (totalnumofpages-1) pgs of-                      Nothing -> error "error in changePage"-                      Just p -> p            -        (xstate',xoj',_pages',_totalnumofpages',newpage) <--          if (modifyfn oldpage >= totalnumofpages) -          then do +-- | change page of current canvas using a modify function++changePage :: (Int -> Int) -> MainCoroutine () +changePage modifyfn = updateXState changePageAction +                      >> adjustScrollbarWithGeometryCurrent+                      >> invalidateCurrent+  where changePageAction xst = selectBoxAction (fsingle xst) (fcont xst) +                               . get currentCanvasInfo $ xst+        fsingle xstate cvsInfo = do +          let xojst = get xournalstate $ xstate  +              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'+          when b (commit xstatefinal)+          return xstatefinal +        +        fcont xstate cvsInfo = do +          let xojst = get xournalstate $ xstate  +              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'+          when b (commit xstatefinal)+          return xstatefinal +++-- | +        +changePageInXournalState :: Int -> XournalState -> (Bool,Int,Page EditMode,XournalState)+changePageInXournalState npgnum xojstate =+    let exoj = xojstateEither xojstate +        pgs = either (get g_pages) (get g_selectAll) exoj+        totnumpages = M.size pgs+        lpage = maybeError "changePage" (M.lookup (totnumpages-1) pgs)+        (isChanged,npgnum',npage',exoj') +          | npgnum >= totnumpages =              let npage = newSinglePageFromOld lpage-                npages = IM.insert totalnumofpages npage pgs -                newxoj = xoj { gpages = npages } -                xstate' = set xournalstate (ViewAppendState newxoj) xstate-            commit xstate'-            return (xstate',newxoj,npages,totalnumofpages+1,totalnumofpages)-          else if modifyfn oldpage < 0 -                 then return (xstate,xoj,pgs,totalnumofpages,0)-                 else return (xstate,xoj,pgs,totalnumofpages,modifyfn oldpage)-        let Dim w h = gdimension lpage-            (hadj,vadj) = get adjustments currCvsInfo-        liftIO $ do -          adjustmentSetUpper hadj w -          adjustmentSetUpper vadj h -          adjustmentSetValue hadj 0-          adjustmentSetValue vadj 0-        let currCvsInfo' = setPage (ViewAppendState xoj') newpage currCvsInfo -            xstate'' = updatePageAll (ViewAppendState xoj')-                       . updateCanvasInfo currCvsInfo' -                       $ xstate'-        putSt xstate'' -        invalidate currCvsId -      SelectState txoj -> do -        let pgs = gselectAll txoj -            totalnumofpages = IM.size pgs-            oldpage = get currentPageNum currCvsInfo-            lpage = case IM.lookup (totalnumofpages-1) pgs of-                      Nothing -> error "error in changePage"-                      Just p -> p            -        (xstate',txoj',_pages',_totalnumofpages',newpage) <--          if (modifyfn oldpage >= totalnumofpages) -          then do-            nlyr <- liftIO emptyTLayerBBoxBufLyBuf  -            let npage = set g_layers (Select . O . Just . singletonSZ $ nlyr) lpage -                npages = IM.insert totalnumofpages npage pgs -                newtxoj = txoj { gselectAll = npages } -                xstate' = set xournalstate (SelectState newtxoj) xstate-            commit xstate'-            return (xstate',newtxoj,npages,totalnumofpages+1,totalnumofpages)-          else if modifyfn oldpage < 0 -                 then return (xstate,txoj,pgs,totalnumofpages,0)-                 else return (xstate,txoj,pgs,totalnumofpages,modifyfn oldpage)-        let Dim w h = gdimension lpage-            (hadj,vadj) = get adjustments currCvsInfo-        liftIO $ do -          adjustmentSetUpper hadj w -          adjustmentSetUpper vadj h -          adjustmentSetValue hadj 0-          adjustmentSetValue vadj 0-        let currCvsInfo' = setPage (SelectState txoj') newpage currCvsInfo -            xstate'' = updatePageAll (SelectState txoj')-                       . updateCanvasInfo currCvsInfo' -                       $ xstate'-        putSt xstate'' -        invalidate currCvsId -      -canvasZoomUpdate :: Maybe ZoomMode -> CanvasId -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()-canvasZoomUpdate mzmode cid = do -    xstate <- getSt -    let cinfoMap = get canvasInfoMap xstate-    case IM.lookup cid cinfoMap of -      Nothing -> do-        liftIO $ putStrLn $ "canvasZoomUpdate : no cid = " ++ show cid -        return () -      Just cvsInfo -> do -        let zmode = maybe (get (zoomMode.viewInfo) cvsInfo) id mzmode-        let canvas = get drawArea cvsInfo-        let page = getPage cvsInfo -        let Dim w h = gdimension page-        cpg <- liftIO (getCanvasPageGeometry canvas page (0,0))        -        let (w',h') = canvas_size cpg -        let (hadj,vadj) = get adjustments cvsInfo -            s = 1.0 / getRatioFromPageToCanvas cpg zmode-        liftIO $ setAdjustments (hadj,vadj) (w,h) (0,0) (0,0) (w'*s,h'*s)-        let cvsInfo' = set (zoomMode.viewInfo) zmode-                       . set (viewPortOrigin.viewInfo) (0,0)-                       $ cvsInfo -            xstate' = updateCanvasInfo cvsInfo' xstate-        putSt xstate' -        invalidate cid       +                npages = M.insert totnumpages npage pgs +            in (True,totnumpages,npage,+                either (Left . set g_pages npages) (Right. set g_selectAll npages) exoj )+          | otherwise = let npg = if npgnum < 0 then 0 else npgnum+                            pg = maybeError "changePage" (M.lookup npg pgs)+                        in (False,npg,pg,exoj) +    in (isChanged,npgnum',npage',either ViewAppendState SelectState exoj')  -pageZoomChange :: ZoomMode -> MainCoroutine () --  Iteratee MyEvent XournalStateIO () -pageZoomChange zmode = do -    xstate <- getSt -    let currCvsId = get currentCanvas xstate-    canvasZoomUpdate (Just zmode) currCvsId         +-- |  -newPageBefore :: MainCoroutine () --  Iteratee MyEvent XournalStateIO () +canvasZoomUpdateCvsId :: CanvasId -> Maybe ZoomMode -> MainCoroutine ()+canvasZoomUpdateCvsId cid mzmode = updateXState zoomUpdateAction +                                   >> adjustScrollbarWithGeometryCurrent+                                   >> invalidateAll+  where zoomUpdateAction xst =  +          selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst +          +        fsingle xstate cinfo = do   +          geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo +          let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode          +              page = getPage cinfo +              pdim = PageDimension $ get g_dimension page+              cdim = canvasDim geometry +              narr = makeSingleArrangement zmode pdim cdim (0,0)+              ncinfobox = CanvasInfoBox+                          . set (pageArrangement.viewInfo) narr+                          . set (zoomMode.viewInfo) zmode $ cinfo+          return . modifyCanvasInfo cid (const ncinfobox) $ xstate+          +        fcont xstate cinfo = do   +          geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo +          let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode          +              cpn = PageNum $ get currentPageNum cinfo +              page = getPage cinfo +              pdim = PageDimension $ get g_dimension page+              cdim = canvasDim geometry +              xoj = getXournal xstate +              narr = makeContinuousSingleArrangement zmode cdim xoj (cpn,PageCoord (0,0))+              ncinfobox = CanvasInfoBox+                          . set (pageArrangement.viewInfo) narr+                          . set (zoomMode.viewInfo) zmode $ cinfo+          return . modifyCanvasInfo cid (const ncinfobox) $ xstate++-- |+          +canvasZoomUpdateAll :: MainCoroutine () +canvasZoomUpdateAll = do +  klst <- liftM (M.keys . get canvasInfoMap) getSt+  mapM_ (flip canvasZoomUpdateCvsId Nothing) klst +++-- | +    +canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine () +canvasZoomUpdate mzmode = do  +  cid <- (liftM (get currentCanvasId) getSt)+  canvasZoomUpdateCvsId cid mzmode+  +{-  +  updateXState zoomUpdateAction +                          >> adjustScrollbarWithGeometryCurrent+                          >> invalidateAll+  where zoomUpdateAction xst =  +          selectBoxAction (fsingle xst) (fcont xst) . get currentCanvasInfo $ xst +          +        fsingle xstate cinfo = do   +          geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo +          let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode          +              page = getPage cinfo +              pdim = PageDimension $ get g_dimension page+              cdim = canvasDim geometry +              narr = makeSingleArrangement zmode pdim cdim (0,0)+              ncinfobox = CanvasInfoBox+                          . set (pageArrangement.viewInfo) narr+                          . set (zoomMode.viewInfo) zmode $ cinfo+          return . modifyCurrentCanvasInfo (const ncinfobox) $ xstate+          +        fcont xstate cinfo = do   +          geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo +          let zmode = maybe (get (zoomMode.viewInfo) cinfo) id mzmode          +              cpn = PageNum $ get currentPageNum cinfo +              page = getPage cinfo +              pdim = PageDimension $ get g_dimension page+              cdim = canvasDim geometry +              xoj = getXournal xstate +              narr = makeContinuousSingleArrangement zmode cdim xoj (cpn,PageCoord (0,0))+              ncinfobox = CanvasInfoBox+                          . set (pageArrangement.viewInfo) narr+                          . set (zoomMode.viewInfo) zmode $ cinfo+          return . modifyCurrentCanvasInfo (const ncinfobox) $ xstate+-}++-- |++pageZoomChange :: ZoomMode -> MainCoroutine () +pageZoomChange = canvasZoomUpdate . Just ++{-++-- |++newPageBefore :: MainCoroutine ()  newPageBefore = do    liftIO $ putStrLn "newPageBefore called"   xstate <- getSt@@ -151,7 +193,7 @@     ViewAppendState xoj -> do        liftIO $ putStrLn " In View "        let currCvsId = get currentCanvas xstate -          mcurrCvsInfo = IM.lookup currCvsId (get canvasInfoMap xstate)+          mcurrCvsInfo = M.lookup currCvsId (get canvasInfoMap xstate)       xoj' <- maybe (error $ "something wrong in newPageBefore")                     (liftIO . newPageBeforeAction xoj)                     $ (,) <$> pure currCvsId <*> mcurrCvsInfo  @@ -161,4 +203,7 @@       commit xstate'       invalidate currCvsId      SelectState txoj -> liftIO $ putStrLn " In Select State, this is not implemented yet."++-}+

lib/Application/HXournal/Coroutine/Pen.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE Rank2Types, GADTs, ScopedTypeVariables, TupleSections #-}  ----------------------------------------------------------------------------- -- |@@ -9,6 +10,8 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Pen where  import Graphics.UI.Gtk hiding (get,set,disconnect)@@ -17,85 +20,161 @@ import Application.HXournal.Type.Enum import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas+import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.XournalState import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.EventConnect import Application.HXournal.Coroutine.Commit import Application.HXournal.Accessor-import Application.HXournal.Util import Application.HXournal.ModelAction.Pen import Application.HXournal.ModelAction.Page-import Application.HXournal.Draw+import Application.HXournal.View.Coordinate+import Application.HXournal.View.Draw+import Application.HXournal.Type.Alias+import Application.HXournal.Util+import Control.Monad import Control.Monad.Trans-+import Control.Monad.Coroutine.SuspensionFunctors import Data.Xournal.Predefined import Data.Xournal.Generic-import Control.Monad.Coroutine.SuspensionFunctors+import Data.Xournal.BBox+import Graphics.Xournal.Render.BBox import Data.Sequence hiding (filter) import qualified Data.Map as M+import qualified Data.IntMap as IM import Data.Maybe  import Control.Category import Data.Label import Prelude hiding ((.), id)-import Graphics.Xournal.Render.BBox ++-- | page switch if pen click a page different than the current page++penPageSwitch :: (ViewMode a) => +                 CanvasInfo a -> PageNum -> MainCoroutine (CanvasInfo a)+penPageSwitch cinfo pgn = do (xst,cinfo') <- getSt >>= switchact +                             putSt xst     +                             return cinfo'+  where switchact xst = do +          let xoj = getXournal xst+          let page = maybeError "no such page in penPageSwitch" +                      $ IM.lookup (unPageNum pgn) (get g_pages xoj)+              ncinfo = set currentPageNum (unPageNum pgn)+                       . set currentPage (Left page) +                       $ cinfo+              mfunc = const (return . CanvasInfoBox $ ncinfo)  +          return . (,ncinfo) =<< modifyCurrCvsInfoM mfunc xst+++-- | Common Pen Work starting point ++commonPenStart :: (forall a. ViewMode a => CanvasInfo a -> PageNum -> CanvasGeometry  +                    -> (ConnectId DrawingArea, ConnectId DrawingArea) +                    -> (Double,Double) -> MainCoroutine () )+               -> CanvasId -> PointerCoord +               -> MainCoroutine ()+commonPenStart action cid pcoord = do+    oxstate <- getSt +    let currcid = get currentCanvasId oxstate+    when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll)+    nxstate <- getSt+    boxAction f . getCanvasInfo cid $ nxstate+  where f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine ()+        f cvsInfo = do +          let page = getPage cvsInfo+              cpn = PageNum . get currentPageNum $ cvsInfo+              arr = get (pageArrangement.viewInfo) cvsInfo              +              canvas = get drawArea cvsInfo+          geometry <- liftIO $ makeCanvasGeometry EditMode (cpn,page) arr canvas+          let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord +          maybeFlip pagecoord (return ()) +            $ \(pgn,PageCoord (x,y)) -> do +                 nCvsInfo <- if (cpn /= pgn) +                               then penPageSwitch cvsInfo pgn+                               else return cvsInfo                   +                 connidup   <- connectPenUp nCvsInfo +                 connidmove <- connectPenMove nCvsInfo+                 action nCvsInfo pgn geometry (connidup,connidmove) (x,y) ++       -- | enter pen drawing mode  penStart :: CanvasId -> PointerCoord -> MainCoroutine () -penStart cid pcoord = do -    xstate <- changeCurrentCanvasId cid -    let cvsInfo = getCanvasInfo cid xstate -    let currxoj = unView . get xournalstate $ xstate        -        pagenum = get currentPageNum cvsInfo-        pinfo = get penInfo xstate-        zmode = get (zoomMode.viewInfo) cvsInfo-    geometry <- getCanvasGeometry cvsInfo -    let (x,y) = device2pageCoord geometry zmode pcoord -    connidup   <- connectPenUp   cvsInfo -    connidmove <- connectPenMove cvsInfo +penStart cid = commonPenStart penAction cid +  where penAction :: forall b. (ViewMode b) => CanvasInfo b -> PageNum -> CanvasGeometry -> (ConnectId DrawingArea, ConnectId DrawingArea) -> (Double,Double) -> MainCoroutine ()+        penAction cinfo pnum geometry (cidmove,cidup) (x,y) = do +          xstate <- getSt+          let currxoj = unView . get xournalstate $ xstate        +              pinfo = get penInfo xstate+          pdraw <-penProcess cid pnum geometry cidmove cidup (empty |> (x,y)) (x,y) +          (newxoj,bbox) <- liftIO $ addPDraw pinfo currxoj pnum pdraw+          commit . set xournalstate (ViewAppendState newxoj) +                 =<< (liftIO (updatePageAll (ViewAppendState newxoj) xstate))+          let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord+              nbbox = xformBBox f bbox +          -- invalidateAll+          invalidateAllInBBox (Just (inflate nbbox 2.0)) -    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.currentTool.penInfo) xstate) -        xstate' = set xournalstate (ViewAppendState newxoj) -                  . updatePageAll (ViewAppendState newxoj)-                  $ xstate-    commit xstate'-    invalidateAll -    -- mapM_ (flip invalidateInBBox bbox') . filter (/=cid) $ otherCanvas xstate'    -- | main pen coordinate adding process -penProcess :: CanvasId-           -> CanvasPageGeometry+-- | now being changed++penProcess :: CanvasId -> PageNum +           -> CanvasGeometry            -> ConnectId DrawingArea -> ConnectId DrawingArea             -> Seq (Double,Double) -> (Double,Double)             -> MainCoroutine (Seq (Double,Double))-penProcess cid cpg connidmove connidup pdraw (x0,y0) = do -  r <- await -  xstate <- getSt-  let cvsInfo = getCanvasInfo cid xstate+penProcess cid pnum geometry connidmove connidup pdraw (x0,y0) = do +    r <- await +    xst <- getSt +    selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst+  where +    fsingle :: forall b. (ViewMode b) => +               MyEvent -> HXournalState -> CanvasInfo b -> MainCoroutine (Seq (Double,Double))+    fsingle r xstate cvsInfo = +      penMoveAndUpOnly r pnum geometry +        (penProcess cid pnum geometry connidmove connidup pdraw (x0,y0))+        (\(x,y) -> do +           let canvas = get drawArea cvsInfo+               ptype  = get (penType.penInfo) xstate+               pcolor = get (penColor.currentTool.penInfo) xstate +               pwidth = get (penWidth.currentTool.penInfo) xstate +               (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 $ drawCurvebit canvas geometry pwidth pcolRGBA pnum (x0,y0) (x,y)+           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 +    let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord +   +    maybeFlip pagecoord skipaction +      $ \(cpn, PageCoord (x,y)) -> if pgn == cpn then realaction (x,y) else skipaction+                                                                 +        ++penMoveAndUpOnly :: Monad m => MyEvent +                    -> PageNum +                    -> CanvasGeometry +                    -> m a +                    -> ((Double,Double) -> m a) +                    -> (PointerCoord -> m a) +                    -> m a+penMoveAndUpOnly r pgn geometry defact moveaction upaction =    case r of -    PenMove _cid' pcoord -> do -      let canvas = get drawArea cvsInfo-          zmode  = get (zoomMode.viewInfo) cvsInfo-          ptype  = get (penType.penInfo) xstate-          pcolor = get (penColor.currentTool.penInfo) xstate -          pwidth = get (penWidth.currentTool.penInfo) xstate -          (x,y) = device2pageCoord cpg zmode pcoord -          (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 -      let zmode = get (zoomMode.viewInfo) cvsInfo-          (x,y) = device2pageCoord cpg zmode pcoord -      disconnect connidmove-      disconnect connidup-      return (pdraw |> (x,y)) -    _ -> do-      penProcess cid cpg connidmove connidup pdraw (x0,y0) +    PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction  +    PenUp _ pcoord -> upaction pcoord  +    _ -> defact +  +++

lib/Application/HXournal/Coroutine/Scroll.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.Scroll @@ -9,48 +8,124 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Scroll where  import Application.HXournal.Type.Event  import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas import Application.HXournal.Type.XournalState+import Application.HXournal.Type.PageArrangement+import qualified Application.HXournal.ModelAction.Adjustment as A import Application.HXournal.Coroutine.Draw-import qualified Data.IntMap as IM-import Control.Monad.Trans-import qualified Control.Monad.State as St+import Application.HXournal.Accessor+import Application.HXournal.View.Coordinate+import Control.Monad import Control.Monad.Coroutine.SuspensionFunctors import Control.Category+import Data.Xournal.BBox import Data.Label+import Control.Monad.Trans+ import Prelude hiding ((.), id) -vscrollStart :: CanvasId -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () -vscrollStart cid = vscrollMove cid +-- | ++adjustScrollbarWithGeometryCvsId :: CanvasId -> MainCoroutine ()+adjustScrollbarWithGeometryCvsId cid = do+  xstate <- getSt+  let cinfobox = getCanvasInfo cid xstate+      +  geometry <- liftIO . getCanvasGeometry $ xstate+  let (hadj,vadj) = unboxGet adjustments cinfobox +      connidh = unboxGet horizAdjConnId cinfobox +      connidv = unboxGet vertAdjConnId cinfobox+  liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv))  +++-- | ++adjustScrollbarWithGeometryCurrent :: MainCoroutine ()+adjustScrollbarWithGeometryCurrent = do+  xstate <- getSt+  geometry <- liftIO . getCanvasGeometry $ xstate+  let cinfobox = get currentCanvasInfo xstate+  let (hadj,vadj) = unboxGet adjustments cinfobox +      connidh = unboxGet horizAdjConnId cinfobox +      connidv = unboxGet vertAdjConnId cinfobox+  liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv))  ++-- | +   +hscrollBarMoved :: CanvasId -> Double -> MainCoroutine ()         +hscrollBarMoved cid v = +    changeCurrentCanvasId cid +    >> updateXState (return . hscrollmoveAction) +    >> invalidate cid +  where hscrollmoveAction = modifyCurrentCanvasInfo (selectBox fsimple fsimple)+        fsimple cinfo = +          let BBox vm_orig _ = unViewPortBBox $ get (viewPortBBox.pageArrangement.viewInfo) cinfo+          in modify (viewPortBBox.pageArrangement.viewInfo) (apply (moveBBoxULCornerTo (v,snd vm_orig))) $ cinfo+++-- |          -vscrollMove :: CanvasId -> MainCoroutine () -- Iteratee MyEvent XournalStateIO () +vscrollBarMoved :: CanvasId -> Double -> MainCoroutine ()         +vscrollBarMoved cid v = +    -- changeCurrentCanvasId cid +    chkCvsIdNInvalidate cid +    >> updateXState (return . vscrollmoveAction) +    >> invalidate cid+  where vscrollmoveAction = modifyCurrentCanvasInfo (selectBox fsimple fsimple)+        fsimple cinfo =  +          let BBox vm_orig _ = unViewPortBBox $ get (viewPortBBox.pageArrangement.viewInfo) cinfo+          in modify (viewPortBBox.pageArrangement.viewInfo) (apply (moveBBoxULCornerTo (fst vm_orig,v))) $ cinfo++-- | ++vscrollStart :: CanvasId -> MainCoroutine () +vscrollStart cid = do +  chkCvsIdNInvalidate cid +  vscrollMove cid +        ++-- |                   ++vscrollMove :: CanvasId -> MainCoroutine ()  vscrollMove cid = do    -  ev <- await -  case ev of-    VScrollBarMoved _cid' v -> do -      xstate <- lift St.get -      let cinfoMap = get canvasInfoMap xstate-          maybeCvs = IM.lookup cid cinfoMap -      case maybeCvs of -        Nothing -> return ()-        Just cvsInfo -> do -          let vm_orig = get (viewPortOrigin.viewInfo) cvsInfo-          let cvsInfo' = set (viewPortOrigin.viewInfo) (fst vm_orig,v)-                         $ cvsInfo -              cinfoMap' = IM.adjust (const cvsInfo') cid cinfoMap  -              xstate' = set canvasInfoMap cinfoMap' -                        . set currentCanvas cid-                        $ xstate-          lift . St.put $ xstate'-          invalidateWithBuf cid -          vscrollMove cid -    VScrollBarEnd cid' _v -> do -      invalidate cid' -      return ()-    _ -> return ()       -    -    +    ev <- await +    xst <- getSt +    geometry <- liftIO (getCanvasGeometry xst)+    case ev of+      VScrollBarMoved cid' v -> do +        updateXState $ return.modifyCurrentCanvasInfo +                         (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v))+        invalidateWithBuf cid +        vscrollMove cid +      VScrollBarEnd cid' v -> do +        updateXState $ return.modifyCurrentCanvasInfo +                         (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) +        invalidate cid' +        return ()+      _ -> return ()       +  where scrollmovecanvas v cvsInfo = +          let BBox vm_orig _ = unViewPortBBox $ get (viewPortBBox.pageArrangement.viewInfo) cvsInfo+          in modify (viewPortBBox.pageArrangement.viewInfo) +                    (apply (moveBBoxULCornerTo (fst vm_orig,v))) cvsInfo +             +        scrollmovecanvasCont geometry v cvsInfo = +          let BBox vm_orig _ = unViewPortBBox $ get (viewPortBBox.pageArrangement.viewInfo) cvsInfo+              cpn = PageNum . get currentPageNum $ cvsInfo +              ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (0,v))+          in  modify currentPageNum (const (unPageNum ncpn)) +              . modify (viewPortBBox.pageArrangement.viewInfo) +                       (apply (moveBBoxULCornerTo (fst vm_orig,v))) $ cvsInfo ++++++++

lib/Application/HXournal/Coroutine/Select.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Coroutine.Select @@ -9,6 +8,8 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Select where  import Graphics.UI.Gtk hiding (get,set,disconnect)@@ -17,104 +18,58 @@ import Application.HXournal.Type.Coroutine import Application.HXournal.Type.Canvas import Application.HXournal.Type.Clipboard+import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Alias import Application.HXournal.Accessor import Application.HXournal.Device-import Application.HXournal.Draw-import Application.HXournal.Util+import Application.HXournal.View.Draw+import Application.HXournal.View.Coordinate import Application.HXournal.Coroutine.EventConnect import Application.HXournal.Coroutine.Draw+import Application.HXournal.Coroutine.Pen import Application.HXournal.Coroutine.Mode import Application.HXournal.Coroutine.Commit import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Select import Application.HXournal.ModelAction.Layer  import Control.Monad+import Control.Monad.Identity 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.Simple (Dimension(..)) import Data.Xournal.Generic import Data.Xournal.BBox-import Data.Xournal.Select+import Graphics.Rendering.Cairo+import Data.Monoid +import Data.Sequence (Seq,(|>))+import qualified Data.Sequence as Sq (empty)+import Data.Time.Clock import Graphics.Xournal.Render.Type 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+createTempSelectRender :: PageNum -> CanvasGeometry -> Page EditMode                           -> 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+createTempSelectRender pnum geometry page x = do +    let Dim cw ch = unCanvasDimension . canvasDim $ geometry+        xformfunc = cairoXform4PageCoordinate geometry pnum          renderfunc = do              xformfunc            cairoRenderOption (InBBoxOption Nothing) (InBBox page)            return ()-    tempsurface <- liftIO $ createImageSurface FormatARGB32 cw ch  -    let tempselection = TempSelectRender tempsurface cwch x+    tempsurface <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch)  +    let tempselection = TempSelectRender tempsurface (cw,ch) x     liftIO $ updateTempSelection tempselection renderfunc True     return tempselection  @@ -124,69 +79,61 @@ --   selected selection.   selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine ()-selectRectStart cid pcoord = do    -    xstate <- changeCurrentCanvasId cid -    let cvsInfo = getCanvasInfo cid xstate-        zmode = get (zoomMode.viewInfo) cvsInfo     -    geometry <- getCanvasGeometry cvsInfo-    let (x,y) = device2pageCoord geometry zmode pcoord -    connidup   <- connectPenUp cvsInfo -    connidmove <- connectPenMove cvsInfo-    strs <- getAllStrokeBBoxInCurrentLayer-    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)      -  +selectRectStart cid = commonPenStart rectaction cid+  where rectaction cinfo pnum geometry (cidup,cidmove) (x,y) = do+          strs <- getAllStrokeBBoxInCurrentLayer+          ctime <- liftIO $ getCurrentTime+          let newSelectAction page = do   +                tsel <- createTempSelectRender pnum geometry page [] +                newSelectRectangle cid pnum geometry cidmove cidup strs +                                   (x,y) ((x,y),ctime) tsel+                surfaceFinish (tempSurface tsel)          +          let +              action (Right tpage) | hitInHandle tpage (x,y) = +                case getULBBoxFromSelected tpage of +                  Middle bbox ->  +                    maybe (return ()) (\handle -> do { tsel <- createTempSelectRender pnum geometry (gcast tpage :: Page EditMode) (getSelectedStrokes tpage); resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel ; surfaceFinish (tempSurface tsel) }) (checkIfHandleGrasped bbox (x,y))+                  _ -> return () +              action (Right tpage) | hitInSelection tpage (x,y) = do+                tsel <- createTempSelectRender pnum geometry+                          (gcast tpage :: Page EditMode) (getSelectedStrokes tpage)+                moveSelect cid pnum geometry cidmove cidup +                           (x,y) ((x,y),ctime) tsel +                surfaceFinish (tempSurface tsel)                  +                  +              action (Right tpage) | otherwise = newSelectAction (gcast tpage :: Page EditMode )+              action (Left page) = newSelectAction page+          action (get currentPage cinfo)        -newSelectRectangle :: CanvasInfo-                   -> CanvasPageGeometry-                   -> ZoomMode+newSelectRectangle :: CanvasId+                   -> PageNum +                   -> CanvasGeometry                    -> ConnectId DrawingArea -> ConnectId DrawingArea                    -> [StrokeBBox]                     -> (Double,Double)                    -> ((Double,Double),UTCTime)                    -> TempSelection                     -> MainCoroutine () -newSelectRectangle cinfo geometry zmode connidmove connidup strs orig -                   (prev,otime) -                   tempselection = do  -  let cid = get canvasId cinfo  -  r <- await -  case r of -    PenMove _cid' pcoord -> do -      let (x,y) = device2pageCoord geometry zmode pcoord +newSelectRectangle cid pnum geometry connidmove connidup strs orig +                   (prev,otime) tempselection = do  +    r <- await +    xst <- getSt +    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)+    defact = newSelectRectangle cid pnum geometry connidmove connidup strs orig +                         (prev,otime) tempselection +    moveact xstate cinfo (x,y) = do        let bbox = BBox orig (x,y)-          prevbbox = BBox orig prev           hittestbbox = mkHitTestInsideBBox bbox strs           hittedstrs = concat . map unHitted . getB $ hittestbbox-      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 +      let page = either id gcast $ get currentPage cinfo            (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+        let xformfunc = cairoXform4PageCoordinate geometry pnum              ulbbox = unUnion . mconcat . fmap (Union .Middle . flip inflate 5 . strokebbox_bbox) $ fstrs             renderfunc = do                  xformfunc @@ -194,10 +141,10 @@                 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)+                Middle sbbox -> do +                  let redrawee = filter (hitTestBBoxBBox sbbox.strokebbox_bbox) hittedstrs  +                  cairoRenderOption (InBBoxOption (Just sbbox)) (InBBox page)+                  clipBBox (Just sbbox)                   mapM_ renderSelectedStroke redrawee                  Bottom -> return ()               mapM_ renderSelectedStroke sstrs @@ -205,11 +152,12 @@       when willUpdate $           invalidateTemp cid (tempSurface tempselection)                             (renderBoxSelection bbox) -      newSelectRectangle cinfo geometry zmode connidmove connidup strs orig +      newSelectRectangle cid pnum geometry connidmove connidup strs orig                           (ncoord,ntime)                          tempselection { tempSelectInfo = hittedstrs }-    PenUp _cid' pcoord -> do -      let (x,y) = device2pageCoord geometry zmode pcoord +    upact xstate cinfo pcoord = do       +      let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord +          (x,y) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return       let epage = get currentPage cinfo            cpn = get currentPageNum cinfo        let bbox = BBox orig (x,y)@@ -235,30 +183,41 @@           newtxoj = txoj { gselectSelected = Just (cpn,newpage) }        let ui = get gtkUIManager xstate       liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectstrs)-      putSt (set xournalstate (SelectState newtxoj) -             . updatePageAll (SelectState newtxoj)-             $ xstate) +      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 -    _ -> return ()+++-- |           -moveSelectRectangle :: CanvasInfo-                    -> CanvasPageGeometry-                    -> ZoomMode-                    -> ConnectId DrawingArea -                    -> ConnectId DrawingArea-                    -> (Double,Double)-                    -> ((Double,Double),UTCTime)-                    -> TempSelection-                    -> MainCoroutine ()-moveSelectRectangle cinfo geometry zmode connidmove connidup orig@(x0,y0) -                    (prev,otime) tempselection = do-  xstate <- getSt-  r <- await -  case r of -    PenMove cid pcoord -> do -      let (x,y) = device2pageCoord geometry zmode pcoord +moveSelect :: CanvasId+              -> PageNum+              -> CanvasGeometry+              -> ConnectId DrawingArea +              -> ConnectId DrawingArea+              -> (Double,Double)+              -> ((Double,Double),UTCTime)+              -> TempSelection+              -> MainCoroutine ()+moveSelect cid pnum geometry connidmove connidup orig@(x0,y0) +           (prev,otime) tempselection = do+    xst <- getSt+    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) +    defact = moveSelect cid pnum geometry connidmove connidup orig (prev,otime) +               tempselection+    moveact xstate cinfo (x,y) = do        (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)        when willUpdate $ do          let strs = tempSelectInfo tempselection@@ -266,9 +225,11 @@             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 +      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       let offset = (x-x0,y-y0)           SelectState txoj = get xournalstate xstate           epage = get currentPage cinfo @@ -278,31 +239,34 @@           let newtpage = changeSelectionByOffset offset tpage            newtxoj <- liftIO $ updateTempXournalSelectIO txoj newtpage pagenum            commit . set xournalstate (SelectState newtxoj)-                 . updatePageAll (SelectState newtxoj) -                 $ xstate -        Left _ -> error "this is impossible, in moveSelectRectangle" +                 =<< (liftIO (updatePageAll (SelectState newtxoj) xstate))+        Left _ -> error "this is impossible, in moveSelect"        disconnect connidmove       disconnect connidup        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 ++-- |+      +resizeSelect :: Handle +                -> CanvasId+                -> PageNum +                -> CanvasGeometry+                -> ConnectId DrawingArea +                -> ConnectId DrawingArea+                -> BBox+                -> ((Double,Double),UTCTime)+                -> TempSelection+                -> MainCoroutine ()+resizeSelect handle cid pnum geometry connidmove connidup origbbox +             (prev,otime) tempselection = do+    xst <- getSt+    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)+    defact = resizeSelect handle cid pnum geometry connidmove connidup +               origbbox (prev,otime) tempselection+    moveact xstate cinfo (x,y) = do        (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)        when willUpdate $ do          let strs = tempSelectInfo tempselection@@ -312,10 +276,11 @@             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 +      resizeSelect handle cid pnum geometry connidmove connidup +                   origbbox (ncoord,ntime) tempselection+    upact xstate cinfo pcoord = do +      let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord +          (x,y) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return           newbbox = getNewBBoxFromHandlePos handle origbbox (x,y)           SelectState txoj = get xournalstate xstate           epage = get currentPage cinfo @@ -326,15 +291,15 @@           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" +                 =<< (liftIO (updatePageAll (SelectState newtxoj) xstate))+        Left _ -> error "this is impossible, in resizeSelect"        disconnect connidmove       disconnect connidup        invalidateAll       return ()    -    _ -> return ()  +-- |+ deleteSelection :: MainCoroutine () deleteSelection = do    liftIO $ putStrLn "delete selection is called"@@ -349,9 +314,9 @@           oldlayers = glayers tpage           newpage = tpage { glayers = oldlayers { gselectedlayerbuf = GLayerBuf (get g_buffer slayer) (TEitherAlterHitted newlayer) } }        newtxoj <- liftIO $ updateTempXournalSelectIO txoj newpage n          -      let newxstate = updatePageAll (SelectState newtxoj) -                      . set xournalstate (SelectState newtxoj)-                      $ xstate +      newxstate <- liftIO $ updatePageAll (SelectState newtxoj) +                            . set xournalstate (SelectState newtxoj)+                            $ xstate        commit newxstate        let ui = get gtkUIManager newxstate       liftIO $ toggleCutCopyDelete ui False @@ -364,60 +329,52 @@   deleteSelection  copySelection :: MainCoroutine ()-copySelection = do -  liftIO $ putStrLn "copySelection called"-  xstate <- getSt-  let cinfo = getCurrentCanvasInfo xstate -      etpage = get currentPage cinfo -  case etpage of-    Left _ -> return ()-    Right tpage -> do -      case getActiveLayer tpage of -        Left _ -> return ()-        Right alist -> do -          let strs = takeHittedStrokes alist -          if null strs -            then return () -            else do -              let newclip = Clipboard strs-                  xstate' = set clipboard newclip xstate -              let ui = get gtkUIManager xstate'-              liftIO $ togglePaste ui True -              putSt xstate'-              invalidateAll +copySelection = updateXState copySelectionAction >> invalidateAll +  where copySelectionAction xst = +          selectBoxAction (fsingle xst) (fsingle xst) . get currentCanvasInfo $ xst+        fsingle xstate cinfo = maybe (return xstate) id $ +          eitherMaybe (get currentPage cinfo) `pipe` getActiveLayer +                                              `pipe` (Right . xstateadj . takeHittedStrokes)+          where eitherMaybe (Left _) = Nothing+                eitherMaybe (Right a) = Just a +                x `pipe` a = x >>= eitherMaybe . a +                infixl 6 `pipe`+                xstateadj strs | null strs = return xstate+                               | otherwise = do let newclip = Clipboard strs+                                                    xstate' = set clipboard newclip xstate +                                                    ui = get gtkUIManager xstate'+                                                liftIO $ togglePaste ui True +                                                return xstate'   pasteToSelection :: MainCoroutine () -pasteToSelection = do -  liftIO $ putStrLn "pasteToSelection called" -  modeChange ToSelectMode    -  xstate <- getSt-  let SelectState txoj = get xournalstate xstate-      clipstrs = getClipContents . get clipboard $ xstate-      cinfo = getCurrentCanvasInfo xstate -      pagenum = get currentPageNum cinfo -      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 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) -                            :- Hitted clipstrs -                            :- Empty )-      tpage' = tpage { glayers = ls { gselectedlayerbuf = newlayerselect } } -  txoj' <- liftIO $ updateTempXournalSelectIO txoj tpage' pagenum -  let xstate' = updatePageAll (SelectState txoj') -                . set xournalstate (SelectState txoj') -                $ xstate -  commit xstate' -  let ui = get gtkUIManager xstate' -  liftIO $ toggleCutCopyDelete ui True-  invalidateAll +pasteToSelection = modeChange ToSelectMode >> updateXState pasteAction >> invalidateAll  +  where pasteAction xst = +          boxAction (fsimple xst) . get currentCanvasInfo $ xst+        fsimple xstate cinfo = do +          let SelectState txoj = get xournalstate xstate+              clipstrs = getClipContents . get clipboard $ xstate+              pagenum = get currentPageNum cinfo +              tpage = either gcast id (get currentPage cinfo)+              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)+                Right alist -> (GLayerBuf gbuf . TEitherAlterHitted . Right) +                               (concat (interleave id unHitted alist) +                                 :- Hitted clipstrs +                                 :- Empty )+              tpage' = tpage { glayers = ls { gselectedlayerbuf = newlayerselect } } +          txoj' <- liftIO $ updateTempXournalSelectIO txoj tpage' pagenum +          xstate' <- liftIO $ updatePageAll (SelectState txoj') +                              . set xournalstate (SelectState txoj') +                              $ xstate +          commit xstate' +          let ui = get gtkUIManager xstate' +          liftIO $ toggleCutCopyDelete ui True+          return xstate' +        +-- |     selectPenColorChanged :: PenColor -> MainCoroutine ()  selectPenColorChanged pcolor = do @@ -435,9 +392,8 @@           ls = glayers tpage            newpage = tpage { glayers = ls { gselectedlayerbuf = GLayerBuf (get g_buffer slayer) (TEitherAlterHitted newlayer) }}        newtxoj <- liftIO $ updateTempXournalSelectIO txoj newpage n-      commit . updatePageAll (SelectState newtxoj) -             . set xournalstate (SelectState newtxoj) -             $ xstate                       +      commit =<< liftIO (updatePageAll (SelectState newtxoj)+                        . set xournalstate (SelectState newtxoj) $ xstate )       invalidateAll             selectPenWidthChanged :: Double -> MainCoroutine () @@ -456,14 +412,98 @@           ls = get g_layers tpage            newpage = tpage { glayers = ls { gselectedlayerbuf = GLayerBuf (get g_buffer slayer) (TEitherAlterHitted newlayer) }}        newtxoj <- liftIO $ updateTempXournalSelectIO txoj newpage n          -      commit . updatePageAll (SelectState newtxoj) -             . set xournalstate (SelectState newtxoj)-             $ xstate +      commit =<< liftIO (updatePageAll (SelectState newtxoj) +                         . set xournalstate (SelectState newtxoj) $ xstate )       invalidateAll  --+-- | main mouse pointer click entrance in lasso selection mode. +--   choose either starting new rectangular selection or move previously +--   selected selection.  +selectLassoStart :: CanvasId -> PointerCoord -> MainCoroutine ()+selectLassoStart cid = commonPenStart lassoAction cid +  where lassoAction cinfo pnum geometry (cidup,cidmove) (x,y) = do +          strs <- getAllStrokeBBoxInCurrentLayer+          ctime <- liftIO $ getCurrentTime+          let newSelectAction page = do   +                tsel <- createTempSelectRender pnum geometry page [] +                newSelectLasso cinfo pnum geometry cidmove cidup strs +                               (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel+                surfaceFinish (tempSurface tsel)          +          let action (Right tpage) | hitInSelection tpage (x,y) = do+                tsel <- createTempSelectRender +                          pnum geometry (gcast tpage :: Page EditMode)+                          (getSelectedStrokes tpage)+                moveSelect (get canvasId cinfo) pnum geometry cidmove cidup +                           (x,y) ((x,y),ctime) tsel +                surfaceFinish (tempSurface tsel)+              action (Right tpage) | hitInHandle tpage (x,y) = +                case getULBBoxFromSelected tpage of +                  Middle bbox ->  +                    maybe (return ()) (\handle -> do { tsel <- createTempSelectRender pnum geometry (gcast tpage :: Page EditMode) (getSelectedStrokes tpage); resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel ; surfaceFinish (tempSurface tsel) }) (checkIfHandleGrasped bbox (x,y))+                  _ -> return () +              action (Right tpage) | otherwise = newSelectAction (gcast tpage :: Page EditMode )+              action (Left page) = newSelectAction page+          action (get currentPage cinfo)      +          +newSelectLasso :: (ViewMode a) => CanvasInfo a+                  -> PageNum +                  -> CanvasGeometry+                  -> ConnectId DrawingArea -> ConnectId DrawingArea+                  -> [StrokeBBox] +                  -> (Double,Double)+                  -> ((Double,Double),UTCTime)+                  -> Seq (Double,Double)+                  -> TempSelection +                  -> MainCoroutine ()+newSelectLasso cvsInfo pnum geometry cidmove cidup strs orig (prev,otime) lasso tsel = do+    r <- await +    fsingle r cvsInfo +  where  +    fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact+                        (moveact cinfo) (upact cinfo)+    defact = newSelectLasso cvsInfo pnum geometry cidmove cidup strs orig +               (prev,otime) lasso tsel+    moveact cinfo (x,y) = do +      let nlasso = lasso |> (x,y)+      (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)+      when willUpdate $ do +        invalidateTemp (get canvasId cinfo) (tempSurface tsel) (renderLasso nlasso) +      newSelectLasso cinfo pnum geometry cidmove cidup strs orig +                     (ncoord,ntime) nlasso tsel+    upact cinfo pcoord = do +      let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord +          (x,y) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return prev) return+          nlasso = lasso |> (x,y)+      let epage = get currentPage cinfo +          cpn = get currentPageNum cinfo +      let hittestlasso = mkHitTestAL (hitLassoStroke (nlasso |> orig)) strs+          selectstrs = fmapAL unNotHitted id hittestlasso+      xstate <- getSt    +      let SelectState txoj = get xournalstate xstate+          newpage = case epage of +                      Left pagebbox -> +                        let (mcurrlayer,npagebbox) = getCurrentLayerOrSet pagebbox+                            currlayer = maybe (error "newSelectLasso") 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 +                      Right tpage -> +                        let ls = glayers tpage +                            currlayer = gselectedlayerbuf ls+                            newlayer = GLayerBuf (get g_buffer currlayer) (TEitherAlterHitted (Right selectstrs))+                            npage = tpage { glayers = ls { gselectedlayerbuf = newlayer } } +                        in npage+          newtxoj = txoj { gselectSelected = Just (cpn,newpage) } +      let ui = get gtkUIManager xstate+      liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectstrs)+      putSt . set xournalstate (SelectState newtxoj) +            =<< (liftIO (updatePageAll (SelectState newtxoj) xstate))+      disconnect cidmove+      disconnect cidup +      invalidateAll

lib/Application/HXournal/Coroutine/Window.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- |@@ -9,96 +10,123 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.Window where -import Application.HXournal.Type.Event import Application.HXournal.Type.Canvas import Application.HXournal.Type.Window import Application.HXournal.Type.XournalState import Application.HXournal.Type.Coroutine+import Application.HXournal.Type.PageArrangement+import Application.HXournal.Util import Control.Monad.Trans import Application.HXournal.ModelAction.Window+import Application.HXournal.ModelAction.Page+import Application.HXournal.Coroutine.Page+import Application.HXournal.Coroutine.Draw import Application.HXournal.Accessor import Control.Category import Data.Label-import Prelude hiding ((.),id) import Graphics.UI.Gtk hiding (get,set)+import Graphics.Rendering.Cairo import qualified Data.IntMap as M+import Data.Maybe+import Data.Xournal.Simple (Dimension(..))+import Prelude hiding ((.),id) -eitherSplit :: SplitType -> MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+-- | ++canvasConfigure :: CanvasId -> CanvasDimension -> MainCoroutine () +canvasConfigure cid cdim@(CanvasDimension (Dim w' h')) = do +    xstate <- getSt +    let cinfobox = getCanvasInfo cid xstate+    xstate' <- selectBoxAction (fsingle xstate) (fcont xstate) cinfobox+    putSt xstate'+    canvasZoomUpdateAll +  where cdim = CanvasDimension (Dim w' h')+        fsingle :: HXournalState -> CanvasInfo SinglePage -> MainCoroutine HXournalState+        fsingle xstate cinfo = do +          let cinfo' = updateCanvasDimForSingle cdim cinfo +          return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate+        fcont xstate cinfo = do +          let cinfo' = updateCanvasDimForContSingle cdim cinfo +          return $ setCanvasInfo (cid,CanvasInfoBox cinfo') xstate +++-- | ++eitherSplit :: SplitType -> MainCoroutine ()  eitherSplit stype = do     xstate <- getSt     let cmap = get canvasInfoMap xstate-        currcid = get currentCanvas xstate+        (currcid,_) = get currentCanvas xstate         newcid = newCanvasId cmap          fstate = get frameState xstate         enewfstate = splitWindow currcid (newcid,stype) fstate      case enewfstate of        Left _ -> return ()       Right fstate' -> do -        let oldcinfo = case M.lookup currcid cmap of-                         Nothing -> error "noway! in eitherSplit " -                         Just c -> c -        liftIO $ removePanes fstate -        cinfo <- liftIO $ initCanvasInfo xstate newcid -        let cinfo' = set viewInfo (get viewInfo oldcinfo)-                     . set currentPageNum (get currentPageNum oldcinfo)-                     . set currentPage (get currentPage oldcinfo)-                     $ cinfo-        let cmap' = M.insert newcid cinfo' cmap-        liftIO $ putStrLn $ "in window " ++ show (M.keys cmap')-        let rtwin = get rootWindow xstate-            rtcntr = get rootContainer xstate -            xstate' = set canvasInfoMap cmap'-                      . set frameState fstate'-                      $ xstate-        putSt xstate'-        liftIO $ containerRemove rtcntr rtwin+        case maybeError "eitherSplit" . M.lookup currcid $ cmap of +          CanvasInfoBox oldcinfo -> do +            let rtwin = get rootWindow xstate+                rtcntr = get rootContainer xstate +            liftIO $ containerRemove rtcntr rtwin+            (xstate'',win,fstate'') <- +              liftIO $ constructFrame' (CanvasInfoBox oldcinfo) xstate fstate'+            let xstate3 = set frameState fstate'' +                            . set rootWindow win +                            $ xstate''+            putSt xstate3 +            liftIO $ boxPackEnd rtcntr win PackGrow 0 +            liftIO $ widgetShowAll rtcntr  +            (xstate4,wconf) <- liftIO $ eventConnect xstate3 (get frameState xstate3)+            canvasZoomUpdateAll+            xstate5 <- liftIO $ updatePageAll (get xournalstate xstate4) xstate4+            putSt xstate5 +            invalidateAll  -        (win,fstate'') <- liftIO $ constructFrame fstate' cmap'         -        let xstate'' = set frameState fstate'' -                       . set rootWindow win $ xstate'-        putSt xstate''-        liftIO $ boxPackEnd rtcntr win PackGrow 0 -        liftIO $ widgetShowAll rtcntr +                  -deleteCanvas :: MainCoroutine () -- Iteratee MyEvent XournalStateIO ()+-- | ++deleteCanvas :: MainCoroutine ()  deleteCanvas = do -    liftIO $ putStrLn "deleteCanvas"       xstate <- getSt     let cmap = get canvasInfoMap xstate-        currcid = get currentCanvas xstate+        (currcid,_) = get currentCanvas xstate         fstate = get frameState xstate         enewfstate = removeWindow currcid fstate      case enewfstate of        Left _ -> return ()       Right Nothing -> return ()       Right (Just fstate') -> do -        let oldcinfo = case M.lookup currcid cmap of-                         Nothing -> error "noway! in deleteCanvas " -                         Just c -> c -        liftIO $ removePanes fstate --        let cmap' = M.delete currcid cmap-            newcurrcid = maximum (M.keys cmap')-        xstate' <- changeCurrentCanvasId newcurrcid -        liftIO $ putStrLn $ "in window " ++ show (M.keys cmap')-        let rtwin = get rootWindow xstate'-            rtcntr = get rootContainer xstate' -            xstate'' = set canvasInfoMap cmap'-                       . set frameState fstate'-                       $ xstate'-        putSt xstate''-        liftIO $ containerRemove rtcntr rtwin--        (win,fstate'') <- liftIO $ constructFrame fstate' cmap'         -        let xstate''' = set frameState fstate'' -                        . set rootWindow win $ xstate''-        putSt xstate'''-        liftIO $ boxPackEnd rtcntr win PackGrow 0 -        liftIO $ widgetShowAll rtcntr --        liftIO $ widgetDestroy (get scrolledWindow oldcinfo)-        liftIO $ widgetDestroy (get drawArea oldcinfo)-        +        case maybeError "deleteCanvas" (M.lookup currcid cmap) of+          CanvasInfoBox oldcinfo -> do +            let cmap' = M.delete currcid cmap+                newcurrcid = maximum (M.keys cmap')+            xstate0 <- changeCurrentCanvasId newcurrcid +            let xstate1 = set canvasInfoMap cmap' xstate0+            putSt xstate1+            let rtwin = get rootWindow xstate1+                rtcntr = get rootContainer xstate1 +            liftIO $ containerRemove rtcntr rtwin+            (xstate'',win,fstate'') <- liftIO $ constructFrame xstate1 fstate'+            let xstate3 = set frameState fstate'' +                            . set rootWindow win +                            $ xstate''+            putSt xstate3+            liftIO $ boxPackEnd rtcntr win PackGrow 0 +            liftIO $ widgetShowAll rtcntr  +            (xstate4,wconf) <- liftIO $ eventConnect xstate3 (get frameState xstate3)+            canvasZoomUpdateAll+            xstate5 <- liftIO $ updatePageAll (get xournalstate xstate4) xstate4+            putSt xstate5 +            invalidateAll +            +{-            liftIO $ boxPackEnd rtcntr win PackGrow 0 +            liftIO $ widgetShowAll rtcntr   +            liftIO $ widgetDestroy (get scrolledWindow oldcinfo)+            liftIO $ widgetDestroy (get drawArea oldcinfo)+ -}

lib/Application/HXournal/Device.hsc view

@@ -10,6 +10,7 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  #include <gtk/gtk.h> #include "template-hsc-gtk2hs.h"@@ -19,14 +20,12 @@ import Application.HXournal.Config import Data.Configurator.Types - import Control.Applicative  import Control.Monad.Reader  import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.C-import Foreign.C.String  import Foreign.Storable  import Graphics.UI.Gtk

− lib/Application/HXournal/Draw.hs

@@ -1,555 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : Application.HXournal.Draw --- Copyright   : (c) 2011, 2012 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----module Application.HXournal.Draw where--import Graphics.UI.Gtk hiding (get)-import Graphics.Rendering.Cairo--import Control.Applicative -import Control.Category-import Data.Label-import Prelude hiding ((.),id)--import Data.Monoid-import Data.Xournal.Simple-import Data.Xournal.Generic--import Data.Xournal.BBox-import Graphics.Xournal.Render.Type--import Graphics.Xournal.Render.BBox -import Graphics.Xournal.Render.BBoxMapPDF -import Graphics.Xournal.Render.PDFBackground-import Graphics.Xournal.Render.Generic-import Graphics.Xournal.Render.HitTest-import Application.HXournal.Type -import Application.HXournal.Device-import Application.HXournal.Util---data CanvasPageGeometry = -  CanvasPageGeometry { screen_size :: (Double,Double) -                     , canvas_size :: (Double,Double)-                     , page_size :: (Double,Double)-                     , canvas_origin :: (Double,Double) -                     , page_origin :: (Double,Double)-                     }-  deriving (Show)  --type PageDrawF = DrawingArea -> TPageBBoxMapPDFBuf -> ViewInfo -> Maybe BBox -                 -> IO ()--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) -                         -> IO CanvasPageGeometry-getCanvasPageGeometry canvas page (xorig,yorig) = do -  win <- widgetGetDrawWindow canvas-  (w',h') <- widgetGetSize canvas-  screen <- widgetGetScreen canvas-  (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen-  let (Dim w h) = gdimension page-  (x0,y0) <- drawWindowGetOrigin win-  return $ CanvasPageGeometry (fromIntegral ws, fromIntegral hs) -                              (fromIntegral w', fromIntegral h') -                              (w,h) -                              (fromIntegral x0,fromIntegral y0)-                              (xorig, yorig)--visibleViewPort :: CanvasPageGeometry -> ZoomMode -> BBox  -visibleViewPort cpg@(CanvasPageGeometry (_ws,_hs) (w',h') (_w,_h) (_x0,_y0) (xorig,yorig)) zmode = -  let (xend,yend) = canvasToPageCoord cpg zmode (w',h')-  in  BBox (xorig,yorig) (xend,yend)---core2pageCoord :: CanvasPageGeometry -> ZoomMode -                  -> (Double,Double) -> (Double,Double)-core2pageCoord cpg@(CanvasPageGeometry (_ws,_hs) (_w',_h') (_w,_h) (_x0,_y0) (xorig,yorig))-               zmode (px,py) = -  let s =  1.0 / getRatioFromPageToCanvas cpg zmode -      (xo,yo) = case zmode of-                  Original -> (xorig,yorig)-                  FitWidth -> (0,yorig)-                  FitHeight -> (xorig,0)-                  _ -> error "not implemented yet in core2pageCoord"-  in (px*s+xo, py*s+yo)-  -wacom2pageCoord :: CanvasPageGeometry -                   -> ZoomMode -                   -> (Double,Double) -                   -> (Double,Double)-wacom2pageCoord cpg@(CanvasPageGeometry (ws,hs) (_w',_h') (_w,_h) (x0,y0) (xorig,yorig)) -                zmode -                (px,py) -  = let (x1,y1) = (ws*px-x0,hs*py-y0)-        s = 1.0 / getRatioFromPageToCanvas cpg zmode-        (xo,yo) = case zmode of-                    Original -> (xorig,yorig)-                    FitWidth -> (0,yorig)-                    FitHeight -> (xorig,0)-                    _ -> error "not implemented wacom2pageCoord"-    in  (x1*s+xo,y1*s+yo)--device2pageCoord :: CanvasPageGeometry -                 -> ZoomMode -                 -> PointerCoord  -                 -> (Double,Double)-device2pageCoord cpg zmode pcoord@(PointerCoord _ _ _)  = - let (px,py) = (,) <$> pointerX <*> pointerY $ pcoord  - in case pointerType pcoord of -      Core -> core2pageCoord  cpg zmode (px,py)-      _    -> wacom2pageCoord cpg zmode (px,py)-device2pageCoord _ _ NoPointerCoord = (-100,-100)--pageToCanvasCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double)-pageToCanvasCoord cpg@(CanvasPageGeometry _ _ _ _ (xorig,yorig)) zmode (x,y) = -  let s = getRatioFromPageToCanvas cpg zmode-      (xo,yo) = case zmode of -                  Original -> (xorig,yorig)-                  FitWidth -> (0,yorig)-                  FitHeight -> (xorig,0)-                  _ -> error "not implemented yet in pageToScreenCoord"-  in ((x-xo)*s,(y-yo)*s)--canvasToPageCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double) -canvasToPageCoord = core2pageCoord--transformForPageCoord :: CanvasPageGeometry -> ZoomMode -> Render ()-transformForPageCoord cpg zmode = do -  let (xo,yo) = page_origin cpg-  let s = getRatioFromPageToCanvas cpg zmode  -  scale s s-  translate (-xo) (-yo)      -  --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-        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-        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 -> -                     cairoRenderOption (DrawBkgPDF,DrawFull) (gcast page :: TPageBBoxMapPDF)-                     -drawPageSelClearly :: PageDrawFSel                      -drawPageSelClearly = drawFuncSelGen rendercontent renderselect -  where rendercontent tpg _mbbox = do-          let pg = (gcast tpg :: TPageBBoxMapPDFBuf)-          cairoRenderOption (DrawBkgPDF,DrawFull) (gcast pg :: TPageBBoxMapPDF)-        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-  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 =   -  let viewbbox = visibleViewPort geometry zmode-  in  toMaybe $ (fromMaybe mbbox :: IntersectBBox)  -                `mappend` -                (Intersect (Middle viewbbox))---drawPageInBBox :: PageDrawF -drawPageInBBox 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-  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 -  let zmode  = get zoomMode vinfo-      origin = get viewPortOrigin vinfo-  geometry <- getCanvasPageGeometry canvas page origin-  win <- widgetGetDrawWindow canvas-  -- 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 -  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-      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 = -  let (w,_)  = page_size cpg -      (w',_) = canvas_size cpg -  in  w'/w-getRatioFromPageToCanvas cpg FitHeight = -  let (_,h)  = page_size cpg -      (_,h') = canvas_size cpg -  in  h'/h-getRatioFromPageToCanvas _cpg (Zoom s) = s --drawSegment :: DrawingArea-               -> CanvasPageGeometry -               -> ZoomMode -               -> Double -               -> (Double,Double,Double,Double) -               -> (Double,Double) -               -> (Double,Double) -               -> IO () -drawSegment canvas cpg zmode wdth (r,g,b,a) (x0,y0) (x,y) = do -  win <- widgetGetDrawWindow canvas-  renderWithDrawable win $ do-    transformForPageCoord cpg zmode-    setSourceRGBA r g b a-    setLineWidth wdth-    moveTo x0 y0-    lineTo x y-    stroke-  --showBBox :: DrawingArea -> CanvasPageGeometry -> ZoomMode -> BBox -> IO ()-showBBox canvas cpg zmode (BBox (ulx,uly) (lrx,lry)) = do -  win <- widgetGetDrawWindow canvas-  renderWithDrawable win $ do-    transformForPageCoord cpg zmode-    setSourceRGBA 0.0 1.0 0.0 1.0 -    setLineWidth  1.0 -    rectangle ulx uly (lrx-ulx) (lry-uly)    -    stroke-  return ()--dummyDraw :: PageDrawFSel -dummyDraw _canvas _pgslct _vinfo _mbbox = do -  putStrLn "dummy draw"-  return ()-  -  -drawSelectionInBBox :: PageDrawFSel -drawSelectionInBBox 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-  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   -  let layers = get g_layers tpg -      slayer = gselectedlayerbuf layers -  case unTEitherAlterHitted . get g_bstrokes $ slayer of-    Right alist -> do -      clipBBox mbbox-      setSourceRGBA 0.0 0.0 1.0 1.0-      let hitstrs = concatMap unHitted (getB alist)-          oneboxdraw str = do -            let bbox@(BBox (x1,y1) (x2,y2)) = strokebbox_bbox str-                drawbox = do { rectangle x1 y1 (x2-x1) (y2-y1); stroke }-            case mbbox of -              Just bboxarg -> if hitTestBBoxBBox bbox bboxarg -                              then do -- drawbox-                                drawbox -                              else return () -              Nothing -> drawbox -      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-      origin = get viewPortOrigin vinfo-  geometry <- getCanvasPageGeometry canvas page origin-  let mbboxnew = adjustBBoxWithView geometry zmode mbbox-  win <- widgetGetDrawWindow canvas-  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 -  let zmode  = get zoomMode vinfo-      origin = get viewPortOrigin vinfo-      page = (gcast tpg :: TPageBBoxMapPDFBuf)-  geometry <- getCanvasPageGeometry canvas page origin-  win <- widgetGetDrawWindow canvas-  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.hs view

@@ -26,6 +26,7 @@ import Application.HXournal.Coroutine -- import Application.HXournal.GUI.Menu import Application.HXournal.ModelAction.File +import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Window  import Graphics.UI.Gtk hiding (get,set)@@ -54,27 +55,21 @@                \mmax -> maybe (return 50) (return . id) mmax   -- ncconf <- getNetworkInfo  cfg   -  let st1 = -- set networkClipboardInfo ncconf-            set undoTable (emptyUndo maxundo) -            $ st0 +  let st1 = set undoTable (emptyUndo maxundo) st0                 -- let st1 = set gtkUIManager ui st0+  putStrLn "before st2"   st2 <- getFileContent mfname st1+  putStrLn "after st2"   let ui = get gtkUIManager st2    writeIORef sref st2-  (winCvsArea, wconf) <- constructFrame -                         <$> get frameState -                         <*> get canvasInfoMap $ st2-  -  setTitleFromFileName st2+  -- (st3, winCvsArea, wconf) <- constructFrame <*> get frameState $ st2+  let st3 = st2                          +  setTitleFromFileName st3   vbox <- vBoxNew False 0    -  -  let st3 = set frameState wconf -            . set rootWindow winCvsArea -            . set rootContainer (castToBox vbox) $ st2-  writeIORef sref st3-  +  let st4 = set rootContainer (castToBox vbox) st3+  writeIORef sref st4   xinputbool <- getXInputConfig cfg    agr <- uiManagerGetActionGroups ui >>= \x ->            case x of @@ -83,7 +78,7 @@   uxinputa <- actionGroupGetAction agr "UXINPUTA" >>= \(Just x) ->                  return (castToToggleAction x)    toggleActionSetActive uxinputa xinputbool-  let canvases = map (get drawArea) . M.elems . get canvasInfoMap $ st3+  let canvases = map (getDrawAreaFromBox) . M.elems . get canvasInfoMap $ st4   if xinputbool       then mapM_ (flip widgetSetExtensionEvents [ExtensionEventsAll]) canvases       else mapM_ (flip widgetSetExtensionEvents [ExtensionEventsNone]) canvases@@ -108,12 +103,14 @@   boxPackStart vbox menubar PackNatural 0    boxPackStart vbox toolbar1 PackNatural 0   boxPackStart vbox toolbar2 PackNatural 0 -  boxPackEnd vbox winCvsArea PackGrow 0 +  boxPackEnd vbox (get rootWindow st4) PackGrow 0    -- cursorDot <- cursorNew BlankCursor     window `on` deleteEvent $ do     liftIO $ bouncecallback tref sref (Menu MenuQuit)     return True+  putStrLn "before widget show all "    widgetShowAll window+  putStrLn "after widget show all "       -- initialized   bouncecallback tref sref Initialized

@@ -496,7 +496,7 @@         ]         actionGroupAddAction agr uxinputa -  actionGroupAddRadioActions agr viewmods 0 (\_ -> return ())+  actionGroupAddRadioActions agr viewmods 0 (assignViewMode tref sref)   actionGroupAddRadioActions agr pointmods 0 (assignPoint sref)   actionGroupAddRadioActions agr penmods   0 (assignPenMode tref sref)   actionGroupAddRadioActions agr colormods 0 (assignColor sref) @@ -536,7 +536,7 @@   Gtk.set (castToRadioAction ra2) [radioActionCurrentValue := 2]    Just ra3 <- actionGroupGetAction agr "SELREGNA"-  actionSetSensitive ra3 False+  actionSetSensitive ra3 True     Just ra4 <- actionGroupGetAction agr "VERTSPA"   actionSetSensitive ra4 False@@ -545,7 +545,7 @@   actionSetSensitive ra5 False    Just ra6 <- actionGroupGetAction agr "CONTA"-  actionSetSensitive ra6 False +  actionSetSensitive ra6 True    Just toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1"   toolbarSetStyle (castToToolbar toolbar1) ToolbarIcons @@ -554,6 +554,18 @@   toolbarSetStyle (castToToolbar toolbar2) ToolbarIcons       return ui   ++assignViewMode :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))+                 -> IORef HXournalState -> RadioAction -> IO ()+assignViewMode tref sref a = do +    v <- radioActionGetCurrentValue a+    st <- readIORef sref +    case v of +      1 -> bouncecallback tref sref ToSinglePage+      0 -> bouncecallback tref sref ToContSinglePage+      _ -> return ()++  assignPenMode :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))                  -> IORef HXournalState -> RadioAction -> IO ()

lib/Application/HXournal/ModelAction/Adjustment.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.ModelAction.Adjustment @@ -9,9 +8,38 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.ModelAction.Adjustment where +import Application.HXournal.Type.PageArrangement+import Application.HXournal.View.Coordinate+import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.BBox (BBox(..)) import Graphics.UI.Gtk ++-- | adjust values, upper limit and page size according to canvas geometry ++adjustScrollbarWithGeometry :: CanvasGeometry +                               -> ((Adjustment,Maybe (ConnectId Adjustment))+                                  ,(Adjustment,Maybe (ConnectId Adjustment))) +                               -> IO ()+adjustScrollbarWithGeometry geometry ((hadj,mconnidh),(vadj,mconnidv)) = do +  let DesktopDimension (Dim w h) = desktopDim geometry +      ViewPortBBox (BBox (x0,y0) (x1,y1)) = canvasViewPort geometry +      xsize = x1-x0+      ysize = y1-y0 +  maybe (return ()) signalBlock mconnidh+  maybe (return ()) signalBlock mconnidv+  adjustmentSetUpper hadj w +  adjustmentSetUpper vadj h +  adjustmentSetValue hadj x0 +  adjustmentSetValue vadj y0+  adjustmentSetPageSize hadj (min xsize w)+  adjustmentSetPageSize vadj (min ysize h)+  maybe (return ()) signalUnblock mconnidh+  maybe (return ()) signalUnblock mconnidv+-- |   setAdjustments :: (Adjustment,Adjustment)                    -> (Double,Double)

lib/Application/HXournal/ModelAction/File.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP #-}+{-# LANGUAGE OverloadedStrings, CPP, GADTs #-}  ----------------------------------------------------------------------------- -- |@@ -10,24 +10,28 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.ModelAction.File where  import Application.HXournal.Type.XournalState import Application.HXournal.Type.Canvas import Application.HXournal.ModelAction.Page+import Application.HXournal.Type.PageArrangement+import Application.HXournal.Util+import Data.Xournal.BBox import qualified Text.Xournal.Parse as P import qualified Data.IntMap as M+import Data.Maybe   import Control.Monad import Control.Category import Data.Label import Prelude hiding ((.),id) -import Data.Xournal.Map import Data.Xournal.Simple import Data.Xournal.Generic-import Graphics.Xournal.Render.Generic+ import Graphics.Xournal.Render.BBoxMapPDF import Graphics.Xournal.Render.PDFBackground @@ -57,35 +61,34 @@         xstate' = set currFileName Nothing                    . set xournalstate newxojstate                   $ xstate -        cmap = get canvasInfoMap xstate'-    let Dim w h = page_dim . (!! 0) .  xoj_pages $ defaultXournal-        ciupdt = setPage newxojstate 0                       -                 . set viewInfo (ViewInfo OnePage Original (0,0) (w,h))-                 . set currentPageNum 0 -        cmap' = M.map ciupdt cmap-    return (set canvasInfoMap cmap' xstate')+    -- let dim = get g_dimension . maybeError "getFileContent" . M.lookup 0 . get g_pages +    --         $ newxoj  +    -- let cvschange = setPage xstate' 0 +    -- modifyCurrCvsInfoM cvschange xstate'+    return xstate' ++-- |+     constructNewHXournalStateFromXournal :: Xournal -> HXournalState -> IO HXournalState  constructNewHXournalStateFromXournal xoj' xstate = do -    let currcid = get currentCanvas xstate -        cmap = get canvasInfoMap xstate      xoj <- mkTXournalBBoxMapPDFBufFromNoBuf <=< mkTXournalBBoxMapPDF $ xoj'-    let Dim width height = case M.lookup 0 (gpages xoj) of    -                             Nothing -> error "no first page in getFileContent" -                             Just p -> gdimension p +    let dim = get g_dimension . maybeError "constructNewHxournalStateFromXournal" . M.lookup 0 +              . get g_pages $ xoj         startingxojstate = ViewAppendState xoj-    let changefunc c = -          setPage startingxojstate 0 -          . set viewInfo (ViewInfo OnePage Original (0,0) (width,height))-          . set currentPageNum 0 -          $ c -        cmap' = fmap changefunc cmap-    return $ set xournalstate startingxojstate-             . set canvasInfoMap cmap'-             . set currentCanvas currcid -             $ xstate+        -- forSingle = set (pageDimension.pageArrangement.viewInfo) (PageDimension dim)+        --             . set currentPageNum 0 +        +    return $ set xournalstate startingxojstate xstate+--        cvschange = setPage xstate' 0 +--    modifyCurrCvsInfoM  cvschange xstate' +      +      -- rentCanvasInfo (selectBox forSingle (error "construct..."))+ --    return $ setPage xstate' 0 xstate'  +-- | + makeNewXojWithPDF :: FilePath -> IO (Maybe Xournal) makeNewXojWithPDF fp = do  #ifdef POPPLER@@ -103,8 +106,6 @@           xoj = set s_title fname                  . set s_pages (map (createPage dim fname) [1..n])                  $ emptyXournal-      putStrLn $ "total num of pages " ++ show n -      putStrLn $ "size = " ++ show (w,h)       return (Just xoj) #else   error "makeNewXojWithPDF should not be used without poppler lib"

lib/Application/HXournal/ModelAction/Layer.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.ModelAction.Layer @@ -9,27 +8,23 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.ModelAction.Layer where  import Application.HXournal.Util-+import Application.HXournal.Type.Alias import Control.Compose import Control.Category import Data.Label import Prelude hiding ((.),id)--import Data.Xournal.BBox import Data.Xournal.Generic-import Data.Xournal.Buffer import Data.Xournal.Select-import Graphics.Xournal.Render.BBoxMapPDF- import Graphics.UI.Gtk hiding (get,set)-import qualified Graphics.UI.Gtk as Gtk (get,set)-+import qualified Graphics.UI.Gtk as Gtk (get) import Data.IORef -getCurrentLayerOrSet :: TPageBBoxMapPDFBuf -> (Maybe (TLayerBBoxBuf LyBuf),TPageBBoxMapPDFBuf)+getCurrentLayerOrSet :: Page EditMode -> (Maybe (Layer EditMode), Page EditMode) getCurrentLayerOrSet pg =    let olayers = get g_layers pg       nlayers = case olayers of @@ -40,10 +35,9 @@       Select osz -> (return . current =<< unO osz, set g_layers nlayers pg)  -adjustCurrentLayer :: TLayerBBoxBuf LyBuf -> TPageBBoxMapPDFBuf -> TPageBBoxMapPDFBuf+adjustCurrentLayer :: Layer EditMode -> Page EditMode -> Page EditMode adjustCurrentLayer nlayer pg =    let (molayer,pg') = getCurrentLayerOrSet pg-      layerzipper = pg'   in maybe (set g_layers (Select .O . Just . singletonSZ $ nlayer) pg')            (const $ let layerzipper = maybe (error "adjustCurrentLayer") id . unO . zipper . get g_layers $  pg'                     in set g_layers (Select . O . Just . replace nlayer $ layerzipper) pg' )@@ -55,7 +49,6 @@     layerentry <- entryNew     entrySetText layerentry (show (succ cidx))     label <- labelNew (Just (" / " ++ show len))-    -- button <- buttonNewWithLabel "test"     hbox <- hBoxNew False 0      upper <- dialogGetUpper dialog     boxPackStart upper hbox PackNatural 0 @@ -63,7 +56,7 @@     boxPackStart hbox label PackGrow 0      widgetShowAll upper     buttonOk <- dialogAddButton dialog stockOk ResponseOk-    buttonCancel <- dialogAddButton dialog stockCancel ResponseCancel+    _buttonCancel <- dialogAddButton dialog stockCancel ResponseCancel      buttonOk `on` buttonActivated $ do        txt <- Gtk.get layerentry entryText

lib/Application/HXournal/ModelAction/Page.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE GADTs #-}  ----------------------------------------------------------------------------- -- |@@ -9,87 +10,179 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.ModelAction.Page where  import Application.HXournal.Type.XournalState import Application.HXournal.Type.Canvas-import Data.Xournal.Simple+import Application.HXournal.Type.PageArrangement+import Application.HXournal.Type.Alias+import Application.HXournal.View.Coordinate+import Application.HXournal.Util++import Control.Applicative+import Control.Monad (liftM)+import Data.Xournal.BBox (moveBBoxToOrigin)+import Data.Xournal.Simple (Dimension(..)) import Data.Xournal.Generic import Data.Xournal.Select +import Data.Traversable (mapM)+ import Graphics.Xournal.Render.BBoxMapPDF  import Control.Category import Data.Label-import Prelude hiding ((.),id)+import Prelude hiding ((.),id,mapM) import qualified Data.IntMap as M  -getPageMap :: XournalState -> M.IntMap TPageBBoxMapPDFBuf-getPageMap xojstate = case xojstate of -                        ViewAppendState xoj -> get g_pages xoj -                        SelectState txoj -> get g_selectAll txoj +import Graphics.UI.Gtk (adjustmentSetUpper,adjustmentGetValue) -setPageMap :: M.IntMap TPageBBoxMapPDFBuf -> XournalState -> XournalState-setPageMap nmap xojstate = -  case xojstate of -    ViewAppendState xoj -> ViewAppendState (set g_pages nmap xoj)-    SelectState txoj -> let ntxoj = set g_selectSelected Nothing-                                    . set g_selectAll nmap -                                    $ txoj -                        in SelectState ntxoj-   -- SelectState (set g_selectAll nmap txoj)+-- |++getPageMap :: XournalState -> M.IntMap (Page EditMode)+getPageMap = either (get g_pages) (get g_selectAll) . xojstateEither +  +-- |             +             +setPageMap :: M.IntMap (Page EditMode) -> XournalState -> XournalState+setPageMap nmap = +  either (ViewAppendState . set g_pages nmap)+         (SelectState . set g_selectSelected Nothing . set g_selectAll nmap )+  . xojstateEither+           -updatePageFromCanvasToXournal :: CanvasInfo -> XournalState -> XournalState +updatePageFromCanvasToXournal :: (ViewMode a) => CanvasInfo a -> XournalState -> XournalState  updatePageFromCanvasToXournal cinfo xojstate =    let cpn = get currentPageNum cinfo        epg = get currentPage cinfo       page = either id gcast epg   in  setPageMap (M.adjust (const page) cpn . getPageMap $ xojstate) xojstate  +-- | -updatePageAll :: XournalState -                 -> HXournalState -                 -> HXournalState-updatePageAll xst xstate = +updatePageAll :: XournalState -> HXournalState -> IO HXournalState+updatePageAll xojst xstate = do    let cmap = get canvasInfoMap xstate-      cmap' = fmap (updatePage xst . adjustPage xst) cmap-  in  set canvasInfoMap cmap' xstate +  cmap' <- mapM (updatePage xojst . adjustPage xojst) cmap+  let cid = get currentCanvasId xstate +      cinfobox = maybeError "updatePageAll" (M.lookup cid cmap')+  let newxstate = set currentCanvas (cid,cinfobox)+                  . set canvasInfoMap cmap' +                  . set xournalstate xojst $ xstate+  return newxstate -adjustPage :: XournalState -> CanvasInfo -> CanvasInfo-adjustPage xojstate cinfo =-    let cpn = get currentPageNum cinfo -        pagemap = getPageMap xojstate-    in  adjustwork cpn pagemap              -  where adjustwork cpn pagemap = -         if M.notMember cpn pagemap  -         then let (minp,_) = M.findMin pagemap -                  (maxp,_) = M.findMax pagemap -              in if cpn > maxp -                   then set currentPageNum maxp cinfo-                   else set currentPageNum minp cinfo-         else cinfo+adjustPage :: XournalState -> CanvasInfoBox -> CanvasInfoBox  +adjustPage xojstate = selectBox fsingle fsingle  +  where fsingle :: CanvasInfo a -> CanvasInfo a +        fsingle cinfo = let cpn = get currentPageNum cinfo +                            pagemap = getPageMap xojstate+                        in  adjustwork cpn pagemap              +          where adjustwork cpn pagemap = +                  if M.notMember cpn pagemap  +                  then let (minp,_) = M.findMin pagemap +                           (maxp,_) = M.findMax pagemap +                       in if cpn > maxp +                          then set currentPageNum maxp cinfo+                          else set currentPageNum minp cinfo+                  else cinfo     getPageFromGXournalMap :: Int -> GXournal M.IntMap a -> a-getPageFromGXournalMap pagenum xoj  = -  case M.lookup pagenum (get g_pages xoj) of -    Nothing -> error "something wrong in getPageFromGXournalMap"-    Just p -> p+getPageFromGXournalMap pagenum = +  maybeError ("getPageFromGXournalMap " ++ show pagenum) . M.lookup pagenum . get g_pages -updatePage :: XournalState -> CanvasInfo -> CanvasInfo -updatePage (ViewAppendState xojbbox) cinfo = -  let pagenum = get currentPageNum cinfo -      pg = getPageFromGXournalMap pagenum xojbbox -      Dim w h = gdimension pg-  in  set currentPageNum pagenum -      . set (pageDimension.viewInfo) (w,h)       -      . set currentPage (Left pg)-      $ cinfo -updatePage (SelectState txoj) cinfo = -  let pagenum = get currentPageNum cinfo-      mspage = gselectSelected txoj -      pageFromArg = case M.lookup pagenum (gselectAll txoj) of ++-- | ++updateCvsInfoFrmXoj :: Xournal EditMode -> CanvasInfoBox -> IO CanvasInfoBox+updateCvsInfoFrmXoj xoj cinfobox = selectBoxAction fsingle fcont cinfobox+  where fsingle cinfo = do +          let pagenum = get currentPageNum cinfo +              page = getPage cinfo +          let oarr = get (pageArrangement.viewInfo) cinfo +              canvas = get drawArea cinfo +              zmode = get (zoomMode.viewInfo) cinfo+          geometry <- makeCanvasGeometry EditMode (PageNum pagenum,page) +                                         oarr canvas+          let cdim = canvasDim geometry +              pg = getPageFromGXournalMap pagenum xoj +              pdim@(PageDimension (Dim w h)) = PageDimension $ get g_dimension pg+              (hadj,vadj) = get adjustments cinfo+          (xpos,ypos) <- (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj +          let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos)+          adjustmentSetUpper hadj w +          adjustmentSetUpper vadj h +          return . CanvasInfoBox +                 . set currentPageNum pagenum  +                 . set (pageArrangement.viewInfo) arr+                 . set currentPage (Left pg) $ cinfo+        fcont cinfo = do +          let pagenum = get currentPageNum cinfo +              page = getPage cinfo +          let oarr = get (pageArrangement.viewInfo) cinfo +              canvas = get drawArea cinfo +              zmode = get (zoomMode.viewInfo) cinfo+              (hadj,vadj) = get adjustments cinfo+          (xdesk,ydesk) <- (,) <$> adjustmentGetValue hadj +                               <*> adjustmentGetValue vadj +          geometry <- makeCanvasGeometry EditMode (PageNum pagenum,page)+                                         oarr canvas +          let ulcoord = maybeError "updateCvsFromXoj" $ +                          desktop2Page geometry (DeskCoord (xdesk,ydesk))+          let cdim = canvasDim geometry +              pg = getPageFromGXournalMap pagenum xoj +              pdim = PageDimension $ get g_dimension pg+          let arr = makeContinuousSingleArrangement zmode cdim xoj ulcoord +              ContinuousSingleArrangement _ (DesktopDimension (Dim w h)) _ _ = arr  +          adjustmentSetUpper hadj w +          adjustmentSetUpper vadj h +          return . CanvasInfoBox+                 . set currentPageNum pagenum  +                 . set (pageArrangement.viewInfo) arr+                 . set currentPage (Left pg) $ cinfo ++              ++-- |+{-+updatePage :: XournalState -> CanvasInfoBox -> IO CanvasInfoBox +updatePage = either updateCvsInfoFrmXoj . either id makexoj . xojstateEither  +  where makexoj txoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj)+-}+++updatePage :: XournalState -> CanvasInfoBox -> IO CanvasInfoBox +updatePage (ViewAppendState xojbbox) cinfobox = updateCvsInfoFrmXoj xojbbox cinfobox+updatePage (SelectState txoj) cinfobox = selectBoxAction fsingle fcont cinfobox+  where getselectedpage :: CanvasInfo a -> Either (Page EditMode) (Page SelectMode)+        getselectedpage cinfo = +          let pagenum = get currentPageNum cinfo +              pgs = get g_selectAll txoj+              pg = maybeError "??" (M.lookup pagenum pgs)+              spg = case get g_selectSelected txoj of +                      Nothing -> Left pg +                      Just (spnum,tpg) -> if spnum == pagenum then Right tpg else Left pg+          in spg+        fsingle cinfo = do +          let xoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj)+          CanvasInfoBox cinfo' <- updateCvsInfoFrmXoj xoj cinfobox+          return . CanvasInfoBox . set currentPage (getselectedpage cinfo)  $ cinfo' +          +        fcont cinfo = do +          let xoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj)+          CanvasInfoBox cinfo' <- updateCvsInfoFrmXoj xoj cinfobox+          return . CanvasInfoBox . set currentPage (getselectedpage cinfo)  $ cinfo' +  +  + {- +  +  +  let pagenum = unboxGet currentPageNum cinfobox+      mspage = get g_selectSelected txoj +      pageFromArg = case M.lookup pagenum (get g_selectAll txoj) of                        Nothing -> error "no such page in updatePage"                       Just p -> p       (newpage,Dim w h) = @@ -103,47 +196,68 @@      . set (pageDimension.viewInfo) (w,h)             . set currentPage newpage      $ cinfo -  -setPage :: XournalState -> Int -> CanvasInfo -> CanvasInfo-setPage (ViewAppendState xojbbox) pagenum cinfo = -  let pg = getPageFromGXournalMap pagenum xojbbox-      Dim w h = gdimension pg-  in  set currentPageNum pagenum -      . set (viewPortOrigin.viewInfo) (0,0) -      . set (pageDimension.viewInfo) (w,h)       -      . set currentPage (Left pg)-      $ cinfo -setPage (SelectState txoj) pagenum cinfo = -  let mspage = gselectSelected  txoj -      pageFromArg = case M.lookup pagenum (gselectAll txoj) of -                      Nothing -> error "no such page in setPage"-                      Just p -> p-      (newpage,Dim w h) = -        case mspage of -          Nothing -> (Left pageFromArg, gdimension pageFromArg)-          Just (spagenum,page) -> -            if spagenum == pagenum -              then (Right page, gdimension page) -              else (Left pageFromArg, gdimension pageFromArg)-  in set currentPageNum pagenum -     . set (viewPortOrigin.viewInfo) (0,0) -     . set (pageDimension.viewInfo) (w,h)       -     . set currentPage newpage-     $ cinfo -                            -getPage :: CanvasInfo -> TPageBBoxMapPDFBuf-getPage cinfo = -  case get currentPage cinfo of -    Right tpgs -> gcast tpgs :: TPageBBoxMapPDFBuf -    Left pg -> pg -                   -newSinglePageFromOld :: TPageBBoxMapPDFBuf -> TPageBBoxMapPDFBuf +-}++-- | ++setPage :: HXournalState -> PageNum -> CanvasId -> IO CanvasInfoBox+setPage xstate pnum cid = do  +  let cinfobox =  getCanvasInfo cid xstate+  selectBoxAction (liftM CanvasInfoBox . setPageSingle xstate pnum) +                  (liftM CanvasInfoBox . setPageCont xstate pnum)+                  cinfobox++-- | setPageSingle : in Single Page mode   ++setPageSingle :: HXournalState -> PageNum  +              -> CanvasInfo SinglePage+              -> IO (CanvasInfo SinglePage)+setPageSingle xstate pnum cinfo = do +  let xoj = getXournal xstate+  geometry <- getCvsGeomFrmCvsInfo cinfo+  let cdim = canvasDim geometry +  let pg = getPageFromGXournalMap (unPageNum pnum) xoj+      pdim = PageDimension (get g_dimension pg)+      zmode = get (zoomMode.viewInfo) cinfo+      arr = makeSingleArrangement zmode pdim cdim (0,0)  +  return $ set currentPageNum (unPageNum pnum)+           . set (pageArrangement.viewInfo) arr+           . set currentPage (Left pg)+           $ cinfo +++-- | setPageCont : in ContinuousSingle Page mode   ++setPageCont :: HXournalState -> PageNum  +            -> CanvasInfo ContinuousSinglePage+            -> IO (CanvasInfo ContinuousSinglePage)+setPageCont xstate pnum cinfo = do +  let xoj = getXournal xstate+  geometry <- getCvsGeomFrmCvsInfo cinfo+  let cdim = canvasDim geometry +  let pg = getPageFromGXournalMap (unPageNum pnum) xoj+      zmode = get (zoomMode.viewInfo) cinfo+      arr = makeContinuousSingleArrangement zmode cdim xoj (pnum,PageCoord (0,0))  +  return $ set currentPageNum (unPageNum pnum)+           . set (pageArrangement.viewInfo) arr+           . set currentPage (Left pg)+           $ cinfo +++-- | ++newSinglePageFromOld :: Page EditMode -> Page EditMode  newSinglePageFromOld =    set g_layers (NoSelect [GLayerBuf (LyBuf Nothing) []])  -newPageBeforeAction :: TXournalBBoxMapPDFBuf -> (CanvasId, CanvasInfo) -> IO TXournalBBoxMapPDFBuf-newPageBeforeAction xoj (cid,cinfo) = do +-- | ++newPageBeforeAction :: (ViewMode a) => +                       Xournal EditMode+                    -> (CanvasId, CanvasInfo a) +                    -> IO (Xournal EditMode)+newPageBeforeAction xoj (_cid,cinfo) = do    let cpn = get currentPageNum cinfo   let pagelst = M.elems . get g_pages $ xoj        pagekeylst = M.keys . get g_pages $ xoj @@ -151,6 +265,5 @@       npage = newSinglePageFromOld (head pagesafter)       npagelst = pagesbefore ++ (npage : pagesafter)       nxoj = set g_pages (M.fromList . zip [0..] $ npagelst) xoj -  putStrLn . show $ pagekeylst    return nxoj

lib/Application/HXournal/ModelAction/Pen.hs view

@@ -10,14 +10,16 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.ModelAction.Pen where -import Application.HXournal.Accessor+ import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Layer import Application.HXournal.Type.Canvas import Application.HXournal.Type.Enum+import Application.HXournal.Type.PageArrangement import Data.Foldable import Data.Maybe import qualified Data.Map as M@@ -30,24 +32,22 @@ import Data.Xournal.Simple import Data.Xournal.Generic import Data.Xournal.BBox-import Data.Xournal.Select ---import Application.HXournal.Util-import System.IO.Unsafe- import Graphics.Xournal.Render.BBoxMapPDF+import Application.HXournal.View.Coordinate -addPDraw :: PenInfo -> TXournalBBoxMapPDFBuf -> Int -> Seq (Double,Double) -            -> IO (TXournalBBoxMapPDFBuf,BBox)-addPDraw pinfo xoj pgnum pdraw = do +addPDraw :: PenInfo +            -> TXournalBBoxMapPDFBuf +            -> PageNum +            -> Seq (Double,Double) +            -> IO (TXournalBBoxMapPDFBuf,BBox) +                       -- ^ new xournal and bbox in page coordinate+addPDraw pinfo xoj (PageNum pgnum) pdraw = do    let ptype = get penType pinfo       pcolor = get (penColor.currentTool) pinfo       pcolname = fromJust (M.lookup pcolor penColorNameMap)       pwidth = get (penWidth.currentTool) pinfo       (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGXournalMap pgnum xoj)       currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer -       newstroke = Stroke { stroke_tool = case ptype of                                             PenWork -> "pen"                                             HighlighterWork -> "highlighter"@@ -61,14 +61,12 @@   newlayerbbox <- updateLayerBuf (Just bbox)                    . set g_bstrokes (get g_bstrokes currlayer ++ [newstrokebbox])                     $ currlayer-  let newpagebbox = adjustCurrentLayer newlayerbbox currpage  -    -- unsafePerformIO (do { putStrLn "currpage" ; testPage currpage ; return (adjustCurrentLayer newlayerbbox currpage)})+  let newpagebbox = adjustCurrentLayer newlayerbbox currpage        newxojbbox = set g_pages (IM.adjust (const newpagebbox) pgnum (get g_pages xoj) ) xoj -         return (newxojbbox,bbox) -  -- (unsafePerformIO (do { putStrLn "newpage" ; testPage newpagebbox ; return (newxojbbox,bbox)})) +

lib/Application/HXournal/ModelAction/Select.hs view

@@ -8,12 +8,18 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.ModelAction.Select where  import Application.HXournal.Type.Enum import Application.HXournal.Type.Canvas-import Application.HXournal.Draw-+import Application.HXournal.Type.Alias+import Application.HXournal.Type.PageArrangement+import Application.HXournal.View.Draw+import Application.HXournal.View.Coordinate+import Data.Sequence (ViewL(..),viewl,Seq)+import Data.Foldable (foldl') import Data.Monoid import Data.Xournal.Generic import Data.Xournal.BBox@@ -21,7 +27,10 @@ import Graphics.Xournal.Render.BBoxMapPDF import Graphics.Xournal.Render.HitTest +import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set)+import Data.Time.Clock+import Control.Monad  import Data.Strict.Tuple import qualified Data.IntMap as M@@ -31,6 +40,7 @@ import Prelude hiding ((.),id) import Data.Algorithm.Diff + data Handle = HandleTL             | HandleTR                  | HandleBL@@ -41,7 +51,6 @@             | 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)@@ -50,49 +59,51 @@       ny = (y-oy1)*scaley+ny1   in (nx,ny) -isBBoxDeltaSmallerThan :: Double ->CanvasPageGeometry -> ZoomMode -                          -> BBox -> BBox -> Bool -isBBoxDeltaSmallerThan delta cpg zmode -                       (BBox (x11,y11) (x12,y12)) (BBox (x21,y21) (x22,y22)) = -  let (x11',y11') = pageToCanvasCoord cpg zmode (x11,y11)-      (x12',y12') = pageToCanvasCoord cpg zmode (x12,y12)-      (x21',y21') = pageToCanvasCoord cpg zmode (x21,y21)-      (x22',y22') = pageToCanvasCoord cpg zmode (x22,y22)-  in (x11'-x21' > (-delta) && x11'-x21' < delta) -     && (y11'-y21' > (-delta) && y11'-y21' < delta)  -     && (x12'-x22' > (-delta) && x12'-x22' < delta)-     && (y11'-y21' > (-delta) && y12'-y22' < delta)+isBBoxDeltaSmallerThan :: Double -> PageNum -> CanvasGeometry -> BBox -> BBox -> Bool +isBBoxDeltaSmallerThan delta pnum geometry +                       (BBox (x11,y11) (x12,y12)) (BBox (x21,y21) (x22,y22)) =   +    let (x11',y11') = coordtrans (x11,y11)+        (x12',y12') = coordtrans (x12,y12)+        (x21',y21') = coordtrans (x21,y21)+        (x22',y22') = coordtrans (x22,y22)+    in (x11'-x21' > (-delta) && x11'-x21' < delta) +       && (y11'-y21' > (-delta) && y11'-y21' < delta)  +       && (x12'-x22' > (-delta) && x12'-x22' < delta)+       && (y11'-y21' > (-delta) && y12'-y22' < delta)+  where coordtrans (x,y) = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry +                           $ (pnum,PageCoord (x,y))  -- | modify stroke using a function  changeStrokeBy :: ((Double,Double)->(Double,Double)) -> StrokeBBox -> StrokeBBox-changeStrokeBy func (StrokeBBox t c w ds bbox) = +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 -getActiveLayer :: TTempPageSelectPDFBuf -> Either [StrokeBBox] (TAlterHitted StrokeBBox)-getActiveLayer tpage = -  let ls = glayers tpage+getActiveLayer :: Page SelectMode -> Either [StrokeBBox] (TAlterHitted StrokeBBox)+getActiveLayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . get g_layers++{-  let ls = glayers tpage       slayer = gselectedlayerbuf ls-      buf = get g_buffer slayer -  in unTEitherAlterHitted . get g_bstrokes $ slayer +  in  et  $ slayer -}   -getSelectedStrokes :: TTempPageSelectPDFBuf -> [StrokeBBox]-getSelectedStrokes tpage =   -  let activelayer = getActiveLayer tpage +getSelectedStrokes :: Page SelectMode -> [StrokeBBox]+getSelectedStrokes = either (const []) (concatMap unHitted . getB) . getActiveLayer   +  + {- let activelayer = getActiveLayer tpage    in case activelayer of         Left _ -> [] -       Right alist -> concatMap unHitted . getB $ alist  +       Right alist -> concatMap unHitted . getB $ alist  -}   -- | modify the whole selection using a function  changeSelectionBy :: ((Double,Double) -> (Double,Double))-                     -> TTempPageSelectPDFBuf -> TTempPageSelectPDFBuf+                     -> Page SelectMode -> Page SelectMode changeSelectionBy func tpage =    let activelayer = getActiveLayer tpage       ls = glayers tpage@@ -106,15 +117,10 @@              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 :: (Double,Double) -> Page SelectMode -> Page SelectMode changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy))  offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) @@ -122,10 +128,8 @@   -updateTempXournalSelect :: TTempXournalSelectPDFBuf -                           -> TTempPageSelectPDFBuf-                           -> Int -                           -> TTempXournalSelectPDFBuf+updateTempXournalSelect :: Xournal SelectMode -> Page SelectMode -> Int +                           -> Xournal SelectMode  updateTempXournalSelect txoj tpage pagenum =                   let pgs = gselectAll txoj        pgs' = M.adjust (const (gcast tpage)) pagenum pgs@@ -133,10 +137,8 @@      . set g_selectSelected (Just (pagenum,tpage))      $ txoj       -updateTempXournalSelectIO :: TTempXournalSelectPDFBuf-                             -> TTempPageSelectPDFBuf-                             -> Int-                             -> IO TTempXournalSelectPDFBuf+updateTempXournalSelectIO :: Xournal SelectMode -> Page SelectMode -> Int+                             -> IO (Xournal SelectMode) updateTempXournalSelectIO txoj tpage pagenum = do      let pgs = gselectAll txoj    newpage <- resetPageBuffers (gcast tpage)@@ -146,16 +148,23 @@             $ txoj         -hitInSelection :: TTempPageSelectPDFBuf -> (Double,Double) -> Bool +hitInSelection :: Page SelectMode -> (Double,Double) -> Bool  hitInSelection tpage point =    let activelayer = unTEitherAlterHitted . get g_bstrokes .  gselectedlayerbuf . glayers $ tpage   in case activelayer of         Left _ -> False           Right alist -> -         let bboxes = map strokebbox_bbox . takeHittedStrokes $ alist-         in  any (flip hitTestBBoxPoint point) bboxes +         let Union bboxall = mconcat+                             . map ( Union . Middle. strokebbox_bbox ) +                             . takeHittedStrokes $ alist+         +         in  case bboxall of +               Middle bbox -> hitTestBBoxPoint bbox point +               _ -> False +          +             -- any (flip hitTestBBoxPoint point) bboxes      -getULBBoxFromSelected :: TTempPageSelectPDFBuf -> ULMaybe BBox +getULBBoxFromSelected :: Page SelectMode -> ULMaybe BBox  getULBBoxFromSelected tpage =    let activelayer = unTEitherAlterHitted . get g_bstrokes .  gselectedlayerbuf . glayers $ tpage   in case activelayer of @@ -163,26 +172,12 @@        Right alist ->           unUnion . mconcat . fmap (Union . Middle . strokebbox_bbox) . takeHittedStrokes $ alist       -hitInHandle :: TTempPageSelectPDFBuf -> (Double,Double) -> Bool +hitInHandle :: Page SelectMode -> (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  @@ -233,7 +228,7 @@ 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)+        f (B,_x) (fs,ss) = (fs,ss)          getDiffStrokeBBox :: [StrokeBBox] -> [StrokeBBox] -> [(DI, StrokeBBox)] getDiffStrokeBBox lst1 lst2 = @@ -244,7 +239,7 @@               checkIfHandleGrasped :: BBox -> (Double,Double) -> Maybe Handle-checkIfHandleGrasped bbox@(BBox (ulx,uly) (lrx,lry)) (x,y)  +checkIfHandleGrasped (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@@ -267,4 +262,82 @@       HandleML -> BBox (x,oy1) (ox2,oy2)       HandleMR -> BBox (ox1,oy1) (x,oy2) -                                                               ++angleBAC :: (Double,Double) -> (Double,Double) -> (Double,Double) -> Double +angleBAC (bx,by) (ax,ay) (cx,cy) = +    let theta1 | ax==bx && ay>by = pi/2.0 +               | ax==bx && ay<=by = -pi/2.0 +               | ax<bx && ay>by = atan ((ay-by)/(ax-bx)) + pi +               | ax<bx && ay<=by = atan ((ay-by)/(ax-bx)) - pi+               | otherwise = atan ((ay-by)/(ax-bx)) +        theta2 | cx==bx && cy>by = pi/2.0 +               | cx==bx && cy<=by = -pi/2.0                                         +               | cx<bx && cy>by = atan ((cy-by)/(cx-bx)) +pi+               | cx<bx && cy<=by = atan ((cy-by)/(cx-bx)) - pi+               | otherwise = atan ((cy-by)/(cx-bx))+        dtheta = theta2 - theta1 +        result | dtheta > pi = dtheta - 2.0*pi+               | dtheta < (-pi) = dtheta + 2.0*pi+               | otherwise = dtheta+    in result +++wrappingAngle :: Seq (Double,Double) -> (Double,Double) -> Double+wrappingAngle lst p = +    case viewl lst of +      EmptyL -> 0 +      x :< xs -> Prelude.snd $ foldl' f (x,0) xs +  where f (q',theta) q = let theta' = angleBAC p q' q+                         in theta' `seq` (q,theta'+theta)  +                          +mappingDegree :: Seq (Double,Double) -> (Double,Double) -> Int                        +mappingDegree lst = round . (/(2.0*pi)) . wrappingAngle lst +++hitLassoPoint :: Seq (Double,Double) -> (Double,Double) -> Bool +hitLassoPoint lst = odd . mappingDegree lst++hitLassoStroke :: Seq (Double,Double) -> StrokeBBox -> Bool +hitLassoStroke lst strk = all (\(x :!: y)-> hitLassoPoint lst (x,y)) $ strokebbox_data strk+++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))+

lib/Application/HXournal/ModelAction/Window.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- |@@ -9,13 +10,17 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.ModelAction.Window where  import Application.HXournal.Type.Canvas import Application.HXournal.Type.Event+import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.Window import Application.HXournal.Type.XournalState import Application.HXournal.Device+import Application.HXournal.Util import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set) import Control.Monad.Trans @@ -25,6 +30,8 @@ import qualified Data.IntMap as M import System.FilePath +-- | set frame title according to file name+ setTitleFromFileName :: HXournalState -> IO ()  setTitleFromFileName xstate = do    case get currFileName xstate of@@ -33,16 +40,24 @@     Just filename -> Gtk.set (get rootOfRootWindow xstate)                               [ windowTitle := takeFileName filename]  +-- | + newCanvasId :: CanvasInfoMap -> CanvasId  newCanvasId cmap =    let cids = M.keys cmap    in  (maximum cids) + 1   +-- | initialize CanvasInfo with creating windows and connect events -initCanvasInfo :: HXournalState -> CanvasId -> IO CanvasInfo -initCanvasInfo xstate cid = do -    let callback = get callBack xstate-        dev = get deviceList xstate +initCanvasInfo :: ViewMode a => HXournalState -> CanvasId -> IO (CanvasInfo a)+initCanvasInfo xstate cid = +  minimalCanvasInfo xstate cid >>= connectDefaultEventCanvasInfo xstate+  ++-- | only creating windows ++minimalCanvasInfo :: ViewMode a => HXournalState -> CanvasId -> IO (CanvasInfo a)+minimalCanvasInfo xstate cid = do      canvas <- drawingAreaNew     scrwin <- scrolledWindowNew Nothing Nothing      containerAdd scrwin canvas@@ -51,20 +66,36 @@     scrolledWindowSetHAdjustment scrwin hadj      scrolledWindowSetVAdjustment scrwin vadj      -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic +    return $ CanvasInfo cid canvas scrwin (error "no viewInfo" :: ViewInfo a) 0 (error "No page")  hadj vadj Nothing Nothing+++-- | only connect events ++connectDefaultEventCanvasInfo :: ViewMode a =>  +                                 HXournalState -> CanvasInfo a -> IO (CanvasInfo a )+connectDefaultEventCanvasInfo xstate cinfo = do +    let callback = get callBack xstate+        dev = get deviceList xstate +        canvas = _drawArea cinfo +        cid = _canvasId cinfo +        scrwin = _scrolledWindow cinfo+        hadj = _horizAdjustment cinfo +        vadj = _vertAdjustment cinfo ++    sizereq <- canvas `on` sizeRequest $ return (Requisition 800 400)         -    canvas `on` sizeRequest $ return (Requisition 480 400)    -    canvas `on` buttonPressEvent $ tryEvent $ do -      p <- getPointer dev-      liftIO (callback (PenDown cid p))-    canvas `on` configureEvent $ tryEvent $ do -      (w,h) <- eventSize -      liftIO $ callback -                 (CanvasConfigure cid (fromIntegral w) (fromIntegral h))-    canvas `on` buttonReleaseEvent $ tryEvent $ do -      p <- getPointer dev-      liftIO (callback (PenUp cid p))-    canvas `on` exposeEvent $ tryEvent $ do -      liftIO $ callback (UpdateCanvas cid) +    bpevent <- canvas `on` buttonPressEvent $ tryEvent $ do +                 p <- getPointer dev+                 liftIO (callback (PenDown cid p))+    confevent <- canvas `on` configureEvent $ tryEvent $ do +                   (w,h) <- eventSize +                   liftIO $ callback +                     (CanvasConfigure cid (fromIntegral w) (fromIntegral h))+    brevent <- canvas `on` buttonReleaseEvent $ tryEvent $ do +                 p <- getPointer dev+                 liftIO (callback (PenUp cid p))+    exposeev <- canvas `on` exposeEvent $ tryEvent $ do +                  liftIO $ callback (UpdateCanvas cid)       {-     canvas `on` enterNotifyEvent $ tryEvent $ do @@ -87,53 +118,119 @@       then widgetSetExtensionEvents canvas [ExtensionEventsAll]       else widgetSetExtensionEvents canvas [ExtensionEventsNone] -    afterValueChanged hadj $ do -      v <- adjustmentGetValue hadj -      callback (HScrollBarMoved cid v)-    afterValueChanged vadj $ do -      v <- adjustmentGetValue vadj     -      callback (VScrollBarMoved cid v)+    hadjconnid <- afterValueChanged hadj $ do +                    v <- adjustmentGetValue hadj +                    callback (HScrollBarMoved cid v)+    vadjconnid <- afterValueChanged vadj $ do +                    v <- adjustmentGetValue vadj     +                    callback (VScrollBarMoved cid v)     Just vscrbar <- scrolledWindowGetVScrollbar scrwin-    vscrbar `on` buttonPressEvent $ do -      v <- liftIO $ adjustmentGetValue vadj -      liftIO (callback (VScrollBarStart cid v))-      return False-    vscrbar `on` buttonReleaseEvent $ do -      v <- liftIO $ adjustmentGetValue vadj -      liftIO (callback (VScrollBarEnd cid v))-      return False-    return $ CanvasInfo cid canvas scrwin (error "no viewInfo") 0 (error "No page")  hadj vadj -  -constructFrame :: WindowConfig -> CanvasInfoMap -> IO (Widget,WindowConfig)-constructFrame (Node cid) cmap = do -    case (M.lookup cid cmap) of-      Nothing -> error $ "no such cid = " ++ show cid ++ " in constructFrame"-      Just cinfo -> return (castToWidget . get scrolledWindow $ cinfo, Node cid)-constructFrame (HSplit hpane wconf1 wconf2) cmap = do  -    (win1,wconf1') <- constructFrame wconf1 cmap-    (win2,wconf2') <- constructFrame wconf2 cmap -    hpane' <- case hpane of-                Nothing -> hPanedNew -                Just h -> return h+    bpevtvscrbar <- vscrbar `on` buttonPressEvent $ do +                      v <- liftIO $ adjustmentGetValue vadj +                      liftIO (callback (VScrollBarStart cid v))+                      return False+    brevtvscrbar <- vscrbar `on` buttonReleaseEvent $ do +                      v <- liftIO $ adjustmentGetValue vadj +                      liftIO (callback (VScrollBarEnd cid v))+                      return False+    +    +    return $ cinfo { _horizAdjConnId = Just hadjconnid+                   , _vertAdjConnId = Just vadjconnid }+    +++-- | recreate windows from old canvas info but no event connect++reinitCanvasInfoStage1 :: (ViewMode a) => +                           HXournalState +                           ->  CanvasInfo a -> IO (CanvasInfo a)+reinitCanvasInfoStage1 xstate oldcinfo = do +  let cid = get canvasId oldcinfo +  newcinfo <- minimalCanvasInfo xstate cid      +  return $ newcinfo { _viewInfo = _viewInfo oldcinfo +                    , _currentPageNum = _currentPageNum oldcinfo +                    , _currentPage = _currentPage oldcinfo } ++    +-- | event connect++reinitCanvasInfoStage2 :: (ViewMode a) => +                           HXournalState -> CanvasInfo a -> IO (CanvasInfo a)+reinitCanvasInfoStage2 = connectDefaultEventCanvasInfo+    +-- | event connecting for all windows                          +                         +eventConnect :: HXournalState -> WindowConfig +                -> IO (HXournalState,WindowConfig)+eventConnect xstate (Node cid) = do +    let cmap = get canvasInfoMap xstate +        cinfobox = maybeError "eventConnect" $ M.lookup cid cmap+    case cinfobox of       +      CanvasInfoBox cinfo -> do +        ncinfo <- reinitCanvasInfoStage2 xstate cinfo +        let xstate' = updateFromCanvasInfoAsCurrentCanvas (CanvasInfoBox ncinfo) xstate+        return (xstate', Node cid)+eventConnect xstate (HSplit wconf1 wconf2) = do  +    (xstate',wconf1') <- eventConnect xstate wconf1 +    (xstate'',wconf2') <- eventConnect xstate' wconf2 +    return (xstate'',HSplit wconf1' wconf2')+eventConnect xstate (VSplit wconf1 wconf2) = do  +    (xstate',wconf1') <- eventConnect xstate wconf1 +    (xstate'',wconf2') <- eventConnect xstate' wconf2 +    return (xstate'',VSplit wconf1' wconf2')+    +++-- | default construct frame     ++constructFrame :: HXournalState -> WindowConfig +                  -> IO (HXournalState,Widget,WindowConfig)+constructFrame = constructFrame' (CanvasInfoBox defaultCvsInfoSinglePage)++++-- | construct frames with template++constructFrame' :: CanvasInfoBox -> +                   HXournalState -> WindowConfig +                   -> IO (HXournalState,Widget,WindowConfig)+constructFrame' template oxstate (Node cid) = do +    let ocmap = get canvasInfoMap oxstate +    (cinfobox,cmap,xstate) <- case M.lookup cid ocmap of +      Just cinfobox' -> return (cinfobox',ocmap,oxstate)+      Nothing -> do +        let cinfobox' = setCanvasId cid template +            cmap' = M.insert cid cinfobox' ocmap+            xstate' = set canvasInfoMap cmap' oxstate+        return (cinfobox',cmap',xstate')+    case cinfobox of       +      CanvasInfoBox cinfo -> do +        ncinfo <- reinitCanvasInfoStage1 xstate cinfo +        let xstate' = updateFromCanvasInfoAsCurrentCanvas (CanvasInfoBox ncinfo) xstate+        return (xstate', castToWidget . get scrolledWindow $ ncinfo, Node cid)+constructFrame' template xstate (HSplit wconf1 wconf2) = do  +    (xstate',win1,wconf1') <- constructFrame' template xstate wconf1     +    (xstate'',win2,wconf2') <- constructFrame' template xstate' wconf2 +    hpane' <- hPanedNew     panedPack1 hpane' win1 True False     panedPack2 hpane' win2 True False     widgetShowAll hpane' -    return (castToWidget hpane', HSplit (Just hpane') wconf1' wconf2')-constructFrame (VSplit vpane wconf1 wconf2) cmap = do  -    (win1,wconf1') <- constructFrame wconf1 cmap-    (win2,wconf2') <- constructFrame wconf2 cmap -    vpane' <- case vpane of -                Nothing -> vPanedNew -                Just v -> return v+    return (xstate'',castToWidget hpane', HSplit wconf1' wconf2')+constructFrame' template xstate (VSplit wconf1 wconf2) = do  +    (xstate',win1,wconf1') <- constructFrame' template xstate wconf1 +    (xstate'',win2,wconf2') <- constructFrame' template xstate' wconf2 +    vpane' <- vPanedNew      panedPack1 vpane' win1 True False     panedPack2 vpane' win2 True False     widgetShowAll vpane' -    return (castToWidget vpane', VSplit (Just vpane') wconf1' wconf2')-  +    return (xstate'',castToWidget vpane', VSplit wconf1' wconf2')   +{-   removePanes :: WindowConfig -> IO WindowConfig removePanes n@(Node _) = return n-removePanes (HSplit hpane wconf1 wconf2) = do +removePanes (HSplit wconf1 wconf2) = do +    putStrLn "here@@@@"     case hpane of        Just h -> do          panedGetChild1 h >>= \x -> case x of @@ -146,8 +243,9 @@       Nothing -> return ()     wconf1' <- removePanes wconf1        wconf2' <- removePanes wconf2 -    return (HSplit Nothing wconf1' wconf2')-removePanes (VSplit vpane wconf1 wconf2) = do +    putStrLn "there@@@@"+    return (HSplit wconf1' wconf2')+removePanes (VSplit wconf1 wconf2) = do      case vpane of        Just v -> do          panedGetChild1 v >>= \x -> case x of @@ -160,5 +258,70 @@       Nothing -> return ()     wconf1' <- removePanes wconf1      wconf2' <- removePanes wconf2 -    return (VSplit Nothing wconf1' wconf2')  -   +    return (VSplit wconf1' wconf2')  + -}  +++{-    let callback = get callBack xstate+        dev = get deviceList xstate +    canvas <- drawingAreaNew+    scrwin <- scrolledWindowNew Nothing Nothing +    containerAdd scrwin canvas+    hadj <- adjustmentNew 0 0 500 100 200 200 +    vadj <- adjustmentNew 0 0 500 100 200 200 +    scrolledWindowSetHAdjustment scrwin hadj +    scrolledWindowSetVAdjustment scrwin vadj +    -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic +    +    canvas `on` sizeRequest $ return (Requisition 800 400)    +    canvas `on` buttonPressEvent $ tryEvent $ do +      p <- getPointer dev+      liftIO (callback (PenDown cid p))+    canvas `on` configureEvent $ tryEvent $ do +      (w,h) <- eventSize +      liftIO $ callback +                 (CanvasConfigure cid (fromIntegral w) (fromIntegral h))+    canvas `on` buttonReleaseEvent $ tryEvent $ do +      p <- getPointer dev+      liftIO (callback (PenUp cid p))+    canvas `on` exposeEvent $ tryEvent $ do +      liftIO $ callback (UpdateCanvas cid) ++    {-+    canvas `on` enterNotifyEvent $ tryEvent $ do +      win <- liftIO $ widgetGetDrawWindow canvas+      liftIO $ drawWindowSetCursor win (Just cursorDot)+      return ()+    -}  +    widgetAddEvents canvas [PointerMotionMask,Button1MotionMask]      +    -- widgetSetExtensionEvents canvas [ExtensionEventsAll]+    -- widgetSetExtensionEvents canvas +    let ui = get gtkUIManager xstate +    agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->+                      case x of +                        [] -> error "No action group? "+                        y:_ -> return y )+    uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> +                          return (castToToggleAction x) )+    b <- liftIO $ toggleActionGetActive uxinputa+    if b+      then widgetSetExtensionEvents canvas [ExtensionEventsAll]+      else widgetSetExtensionEvents canvas [ExtensionEventsNone]++    hadjconnid <- afterValueChanged hadj $ do +                    v <- adjustmentGetValue hadj +                    callback (HScrollBarMoved cid v)+    vadjconnid <- afterValueChanged vadj $ do +                    v <- adjustmentGetValue vadj     +                    callback (VScrollBarMoved cid v)+    Just vscrbar <- scrolledWindowGetVScrollbar scrwin+    vscrbar `on` buttonPressEvent $ do +      v <- liftIO $ adjustmentGetValue vadj +      liftIO (callback (VScrollBarStart cid v))+      return False+    vscrbar `on` buttonReleaseEvent $ do +      v <- liftIO $ adjustmentGetValue vadj +      liftIO (callback (VScrollBarEnd cid v))+      return False+    return $ CanvasInfo cid canvas scrwin (error "no viewInfo" :: ViewInfo a) 0 (error "No page")  hadj vadj (Just hadjconnid) (Just vadjconnid)+-}

lib/Application/HXournal/Type.hs view

@@ -8,6 +8,7 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.Type  ( module Application.HXournal.Type.Event

+ lib/Application/HXournal/Type/Alias.hs view

@@ -0,0 +1,59 @@+{-# LANGUAGE EmptyDataDecls, TypeFamilies, RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Application.HXournal.Type.Alias+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+----------------------------------------------------------------------------++module Application.HXournal.Type.Alias where++import Data.Xournal.Generic+import Data.Xournal.Buffer+import Data.Xournal.Select+import Graphics.Xournal.Render.Type.Select+import Graphics.Xournal.Render.BBoxMapPDF+import Graphics.Xournal.Render.PDFBackground++data EditMode = EditMode +data SelectMode = SelectMode ++type family Xournal a :: *+-- type family Page a :: * +type family Layer a :: * +     +class GPageable a where  +  type AssocBkg a :: *+  type AssocStream a :: * -> *+  type AssocLayer a :: *+       +       +type Page a = GPage (AssocBkg a) (AssocStream a) (AssocLayer a)++instance GPageable EditMode where+  type AssocBkg EditMode = BackgroundPDFDrawable+  type AssocStream EditMode = ZipperSelect+  type AssocLayer EditMode = TLayerBBoxBuf LyBuf +  +instance GPageable SelectMode where+  type AssocBkg SelectMode = BackgroundPDFDrawable+  type AssocStream SelectMode = TLayerSelectInPageBuf ZipperSelect+  type AssocLayer SelectMode = TLayerBBoxBuf LyBuf+  +  +-- type instance Page EditMode = TPageBBoxMapPDFBuf+-- type instance Page SelectMode = TTempPageSelectPDFBuf +++type instance Layer EditMode = TLayerBBoxBuf LyBuf+type instance Layer SelectMode = TLayerSelectInPageBuf ZipperSelect (TLayerBBoxBuf LyBuf)++type instance Xournal EditMode = TXournalBBoxMapPDFBuf +type instance Xournal SelectMode = TTempXournalSelectPDFBuf +

lib/Application/HXournal/Type/Canvas.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-# LANGUAGE TemplateHaskell, TypeOperators, ExistentialQuantification,+             Rank2Types, GADTs #-}  ----------------------------------------------------------------------------- -- |@@ -10,21 +11,28 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.Type.Canvas where  import Application.HXournal.Type.Enum +import Application.HXournal.Type.Alias  import Data.Sequence import qualified Data.IntMap as M+import Control.Applicative ((<*>),(<$>)) 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.Simple (Dimension(..))+import Data.Xournal.BBox+import Data.Xournal.Generic import Data.Xournal.Predefined +import Application.HXournal.Type.PageArrangement +import Control.Monad.Identity (Identity(..))+ type CanvasId = Int   data PenDraw = PenDraw { _points :: Seq (Double,Double) } @@ -33,32 +41,145 @@ emptyPenDraw :: PenDraw emptyPenDraw = PenDraw empty -data PageMode = Continous | OnePage-              deriving (Show,Eq)  -data ZoomMode = Original | FitWidth | FitHeight | Zoom Double -              deriving (Show,Eq)+data ViewInfo a  = (ViewMode a) => +                   ViewInfo { _zoomMode :: ZoomMode +                            , _pageArrangement :: PageArrangement a }  -data ViewInfo = ViewInfo { _pageMode :: PageMode-                         , _zoomMode :: ZoomMode-                         , _viewPortOrigin :: (Double,Double)-                         , _pageDimension :: (Double,Double) -                         }-                deriving (Show) -data CanvasInfo = CanvasInfo { _canvasId :: CanvasId-                             , _drawArea :: DrawingArea-                             , _scrolledWindow :: ScrolledWindow-                             , _viewInfo :: ViewInfo -                             , _currentPageNum :: Int-                             , _currentPage :: Either TPageBBoxMapPDFBuf TTempPageSelectPDFBuf -                             , _horizAdjustment :: Adjustment-                             , _vertAdjustment :: Adjustment -                             }+defaultViewInfoSinglePage :: ViewInfo SinglePage+defaultViewInfoSinglePage = +  ViewInfo { _zoomMode = Original +           , _pageArrangement = +             SingleArrangement (CanvasDimension (Dim 100 100))+                               (PageDimension (Dim 100 100)) +                               (ViewPortBBox (BBox (0,0) (100,100))) }   -type CanvasInfoMap = M.IntMap CanvasInfo+zoomMode :: ViewInfo a :-> ZoomMode +zoomMode = lens _zoomMode (\a f -> f { _zoomMode = a } ) ++pageArrangement :: ViewInfo a :-> PageArrangement a  +pageArrangement = lens _pageArrangement (\a f -> f { _pageArrangement = a })++data CanvasInfo a = +    (ViewMode a) => CanvasInfo { _canvasId :: CanvasId+                               , _drawArea :: DrawingArea+                               , _scrolledWindow :: ScrolledWindow+                               , _viewInfo :: ViewInfo a+                               , _currentPageNum :: Int+                               , _currentPage :: Either (Page EditMode) (Page SelectMode)+                               , _horizAdjustment :: Adjustment+                               , _vertAdjustment :: Adjustment +                               , _horizAdjConnId :: Maybe (ConnectId Adjustment)+                               , _vertAdjConnId :: Maybe (ConnectId Adjustment)+                               }+    +defaultCvsInfoSinglePage :: CanvasInfo SinglePage+defaultCvsInfoSinglePage = +  CanvasInfo { _canvasId = error "cvsid"+             , _drawArea = error "DrawingArea"+             , _scrolledWindow = error "ScrolledWindow"+             , _viewInfo = defaultViewInfoSinglePage+             , _currentPageNum = 0 +             , _currentPage = error "currentPage" +             , _horizAdjustment = error "adjustment"+             , _vertAdjustment = error "vadjust"+             , _horizAdjConnId = Nothing+             , _vertAdjConnId =  Nothing+             }++canvasId :: CanvasInfo a :-> CanvasId +canvasId = lens _canvasId (\a f -> f { _canvasId = a })++drawArea :: CanvasInfo a :-> DrawingArea+drawArea = lens _drawArea (\a f -> f { _drawArea = a })++scrolledWindow :: CanvasInfo a :-> ScrolledWindow+scrolledWindow = lens _scrolledWindow (\a f -> f { _scrolledWindow = a })++viewInfo :: CanvasInfo a :-> ViewInfo a +viewInfo = lens _viewInfo (\a f -> f { _viewInfo = a }) ++currentPageNum :: CanvasInfo a :-> Int +currentPageNum = lens _currentPageNum (\a f -> f { _currentPageNum = a })++currentPage :: CanvasInfo a :-> Either (Page EditMode) (Page SelectMode)+currentPage = lens _currentPage (\a f -> f { _currentPage = a })++horizAdjustment :: CanvasInfo a :-> Adjustment +horizAdjustment = lens _horizAdjustment (\a f -> f { _horizAdjustment = a })++vertAdjustment :: CanvasInfo a :-> Adjustment +vertAdjustment = lens _vertAdjustment (\a f -> f { _vertAdjustment = a })++horizAdjConnId :: CanvasInfo a :-> Maybe (ConnectId Adjustment )+horizAdjConnId = lens _horizAdjConnId (\a f -> f { _horizAdjConnId = a })++vertAdjConnId :: CanvasInfo a :-> Maybe (ConnectId Adjustment)+vertAdjConnId = lens _vertAdjConnId (\a f -> f { _vertAdjConnId = a })+++++-- | ++adjustments :: CanvasInfo a :-> (Adjustment,Adjustment) +adjustments = Lens $ (,) <$> (fst `for` horizAdjustment)+                         <*> (snd `for` vertAdjustment)+++data CanvasInfoBox = forall a. (ViewMode a) => CanvasInfoBox (CanvasInfo a) ++getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea +getDrawAreaFromBox = unboxGet drawArea --  (CanvasInfoBox x) = get drawArea x ++unboxGet :: (forall a. (ViewMode a) => CanvasInfo a :-> b) -> CanvasInfoBox -> b +unboxGet f (CanvasInfoBox x) = get f x++fmapBox :: (forall a. (ViewMode a) => CanvasInfo a -> CanvasInfo a)+        -> CanvasInfoBox -> CanvasInfoBox+fmapBox f (CanvasInfoBox cinfo) = CanvasInfoBox (f cinfo)+++boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b) +             -> CanvasInfoBox -> m b +boxAction f (CanvasInfoBox cinfo) = f cinfo +++selectBoxAction :: (Monad m) => +                   (CanvasInfo SinglePage -> m a) +                -> (CanvasInfo ContinuousSinglePage -> m a) -> CanvasInfoBox -> m a +selectBoxAction fsingle fcont (CanvasInfoBox cinfo) = +  case get (pageArrangement.viewInfo) cinfo of +    SingleArrangement _ _ _ ->  fsingle cinfo +    ContinuousSingleArrangement _ _ _ _ -> fcont cinfo ++selectBox :: (CanvasInfo SinglePage -> CanvasInfo SinglePage)+          -> (CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage)+          -> CanvasInfoBox -> CanvasInfoBox +selectBox fsingle fcont = +  let idaction :: CanvasInfoBox -> Identity CanvasInfoBox+      idaction = selectBoxAction (return . CanvasInfoBox . fsingle) (return . CanvasInfoBox . fcont)+  in runIdentity . idaction   ++pageArrEitherFromCanvasInfoBox :: CanvasInfoBox +                 -> Either (PageArrangement SinglePage) (PageArrangement ContinuousSinglePage)+pageArrEitherFromCanvasInfoBox (CanvasInfoBox cinfo) = +  pageArrEither . get (pageArrangement.viewInfo) $ cinfo +++viewModeBranch :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) +               -> (CanvasInfo ContinuousSinglePage -> CanvasInfo ContinuousSinglePage) +               -> CanvasInfo v -> CanvasInfo v +viewModeBranch fsingle fcont cinfo = +  case get (pageArrangement.viewInfo) cinfo of +    SingleArrangement _ _ _ ->  fsingle cinfo +    ContinuousSingleArrangement _ _ _ _ -> fcont cinfo ++type CanvasInfoMap = M.IntMap CanvasInfoBox+ data PenType = PenWork               | HighlighterWork               | EraserWork @@ -77,8 +198,6 @@                              deriving (Show)                        data PenInfo = PenInfo { _penType :: PenType-                       -- , _penWidth :: Double-                       -- , _penColor :: PenColor                         , _penSet :: PenHighlighterEraserSet }               deriving (Show)  @@ -97,10 +216,17 @@                           EraserWork -> pset { _currEraser = wcs }                           TextWork -> pset { _currText = wcs }           in  pinfo { _penSet = psetnew } -                                           ++defaultPenWCS :: WidthColorStyle                                            defaultPenWCS = WidthColorStyle predefined_medium ColorBlack               ++defaultEraserWCS :: WidthColorStyle defaultEraserWCS = WidthColorStyle predefined_eraser_medium ColorWhite++defaultTextWCS :: WidthColorStyle defaultTextWCS = defaultPenWCS++defaultHighligherWCS :: WidthColorStyle defaultHighligherWCS = WidthColorStyle predefined_highlighter_medium ColorYellow  @@ -113,5 +239,42 @@                                               , _currText = defaultTextWCS }           }                                             -$(mkLabels [''PenDraw, ''ViewInfo, ''PenInfo, ''PenHighlighterEraserSet, ''WidthColorStyle, ''CanvasInfo])+$(mkLabels [''PenDraw, ''ViewInfo, ''PenInfo, ''PenHighlighterEraserSet, ''WidthColorStyle ]) +-- | ++getPage :: (ViewMode a) => CanvasInfo a -> (Page EditMode)+getPage = either id (gcast :: Page SelectMode -> Page EditMode) . get currentPage+++-- | ++updateCanvasDimForSingle :: CanvasDimension +                            -> CanvasInfo SinglePage  +                            -> CanvasInfo SinglePage +updateCanvasDimForSingle cdim@(CanvasDimension (Dim w' h')) cinfo = +  let zmode = get (zoomMode.viewInfo) cinfo+      arr@(SingleArrangement _ pdim vbbox@(ViewPortBBox bbox)) +        = get (pageArrangement.viewInfo) cinfo+      (x,y) = bbox_upperleft bbox +      (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim +      nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy)+      arr' = SingleArrangement cdim pdim (ViewPortBBox nbbox)+  in set (pageArrangement.viewInfo) arr' cinfo+     +-- | ++updateCanvasDimForContSingle :: CanvasDimension +                                -> CanvasInfo ContinuousSinglePage +                                -> CanvasInfo ContinuousSinglePage +updateCanvasDimForContSingle cdim@(CanvasDimension (Dim w' h')) cinfo = +  let zmode = get (zoomMode.viewInfo) cinfo+      arr@(ContinuousSingleArrangement _ ddim  func vbbox@(ViewPortBBox bbox)) +        = get (pageArrangement.viewInfo) cinfo+      (x,y) = bbox_upperleft bbox +      dim = get g_dimension . getPage $ cinfo +      (sinvx,sinvy) = getRatioPageCanvas zmode (PageDimension dim) cdim +      nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy)+      arr' = ContinuousSingleArrangement cdim ddim func (ViewPortBBox nbbox)+  in set (pageArrangement.viewInfo) arr' cinfo+

lib/Application/HXournal/Type/Enum.hs view

@@ -10,6 +10,7 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.Type.Enum where

lib/Application/HXournal/Type/Event.hs view

@@ -28,6 +28,8 @@              | VScrollBarEnd   Int Double              | ToViewAppendMode              | ToSelectMode+             | ToSinglePage+             | ToContSinglePage              | Menu MenuEvent               deriving (Show,Eq,Ord)

+ lib/Application/HXournal/Type/PageArrangement.hs view

@@ -0,0 +1,195 @@+{-# LANGUAGE EmptyDataDecls, GADTs, TypeOperators, GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Application.HXournal.Type.PageArrangement+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.Type.PageArrangement where++import Control.Category ((.))+import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.Generic+import Data.Xournal.BBox+import Data.Label +import Prelude hiding ((.),id)+-- import qualified Data.IntMap as M++import Application.HXournal.Type.Predefined +import Application.HXournal.Type.Alias+import Application.HXournal.Util++data ZoomMode = Original | FitWidth | FitHeight | Zoom Double +              deriving (Show,Eq)++class ViewMode a ++data SinglePage = SinglePage+data ContinuousSinglePage = ContinuousSinglePage++instance ViewMode SinglePage +instance ViewMode ContinuousSinglePage++newtype PageNum = PageNum { unPageNum :: Int } +                deriving (Eq,Show,Ord,Num)++newtype ScreenCoordinate = ScrCoord { unScrCoord :: (Double,Double) } +                         deriving (Show)+newtype CanvasCoordinate = CvsCoord { unCvsCoord :: (Double,Double) }+                         deriving (Show)+newtype DesktopCoordinate = DeskCoord { unDeskCoord :: (Double,Double) } +                          deriving (Show)+newtype PageCoordinate = PageCoord { unPageCoord :: (Double,Double) } +                       deriving (Show)++newtype ScreenDimension = ScreenDimension { unScreenDimension :: Dimension } +                        deriving (Show)+newtype CanvasDimension = CanvasDimension { unCanvasDimension :: Dimension }+                        deriving (Show)+newtype CanvasOrigin = CanvasOrigin { unCanvasOrigin :: (Double,Double) } +                       deriving (Show)+newtype PageOrigin = PageOrigin { unPageOrigin :: (Double,Double) } +                   deriving (Show)+newtype PageDimension = PageDimension { unPageDimension :: Dimension } +                      deriving (Show)+newtype DesktopDimension = DesktopDimension { unDesktopDimension :: Dimension }+                         deriving (Show)+newtype ViewPortBBox = ViewPortBBox { unViewPortBBox :: BBox } +                     deriving (Show)++                     +apply :: (BBox -> BBox) -> ViewPortBBox -> ViewPortBBox +apply f (ViewPortBBox bbox1) = ViewPortBBox (f bbox1)+{-# INLINE apply #-}++-- | data structure for coordinate arrangement of pages in desktop coordinate++data PageArrangement a where+  SingleArrangement:: CanvasDimension +                      -> PageDimension +                      -> ViewPortBBox +                      -> PageArrangement SinglePage +  ContinuousSingleArrangement :: CanvasDimension  +                                 -> DesktopDimension +                                 -> (PageNum -> Maybe PageOrigin) +                                 -> ViewPortBBox -> PageArrangement ContinuousSinglePage++-- | ++pageFunction :: PageArrangement ContinuousSinglePage -> PageNum -> Maybe PageOrigin+pageFunction (ContinuousSingleArrangement _ _ pfunc _ ) = pfunc ++-- | ++pageArrEither :: PageArrangement a +                 -> Either (PageArrangement SinglePage) (PageArrangement ContinuousSinglePage)+pageArrEither arr@(SingleArrangement _ _ _) = Left arr +pageArrEither arr@(ContinuousSingleArrangement _ _ _ _) = Right arr ++-- |++getRatioPageCanvas :: ZoomMode -> PageDimension -> CanvasDimension -> (Double,Double)+getRatioPageCanvas zmode (PageDimension (Dim w h)) (CanvasDimension (Dim w' h')) = +  case zmode of +    Original -> (1.0,1.0)+    FitWidth -> (w'/w,w'/w)+    FitHeight -> (h'/h,h'/h)+    Zoom s -> (s,s)++-- |++makeSingleArrangement :: ZoomMode +                         -> PageDimension +                         -> CanvasDimension +                         -> (Double,Double) +                         -> PageArrangement SinglePage+makeSingleArrangement zmode pdim cdim@(CanvasDimension (Dim w' h')) (x,y) = +  let (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim+      bbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy)+  in SingleArrangement cdim pdim (ViewPortBBox bbox) +++  ++-- | ++makeContinuousSingleArrangement :: ZoomMode -> CanvasDimension +                                   -> Xournal EditMode +                                   -> (PageNum,PageCoordinate) +                                   -> PageArrangement ContinuousSinglePage+makeContinuousSingleArrangement zmode cdim@(CanvasDimension (Dim cw ch)) +                                xoj (pnum,PageCoord (xpos,ypos)) = +  let PageOrigin (_,y0) = maybeError "makeContSingleArr" $ pageArrFuncContSingle xoj pnum +      dim@(Dim pw ph) = 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 ++-- |++pageArrFuncContSingle :: Xournal EditMode -> PageNum -> Maybe PageOrigin +pageArrFuncContSingle xoj pnum@(PageNum n)+  | n < 0 = Nothing +  | n >= len = Nothing +  | otherwise = Just (PageOrigin (0,ys !! n))+  where addf x y = x + y + predefinedPageSpacing+        pgs = gToList . get g_pages $ xoj +        len = length pgs +        ys = scanl addf 0 . map (dim_height.get g_dimension) $ pgs  +        ++deskDimContSingle :: Xournal EditMode -> DesktopDimension +deskDimContSingle xoj = +  let plst = gToList . get g_pages $ xoj+      PageOrigin (_,h') = maybeError +                         ("deskdimContSingle" ++ +                          show (map (pageArrFuncContSingle xoj . PageNum) [0..5])) +                         $ pageArrFuncContSingle xoj +                             (PageNum . (\x->x-1) . length $ plst )+      Dim _ h2 = get g_dimension (last plst)+      h = h' + h2 +      w = maximum . map (dim_width.get g_dimension) $ plst+  in DesktopDimension (Dim w h)++-- lenses++pageDimension :: PageArrangement SinglePage :-> PageDimension+pageDimension = lens getter setter +  where getter (SingleArrangement _ pdim _) = pdim+        setter pdim (SingleArrangement cdim _ vbbox) = SingleArrangement cdim pdim vbbox++canvasDimension :: PageArrangement a :-> CanvasDimension +canvasDimension = lens getter setter +  where +    getter (SingleArrangement cdim _ _) = cdim+    getter (ContinuousSingleArrangement cdim _ _ _) = cdim+    setter cdim (SingleArrangement _ pdim vbbox) = SingleArrangement cdim pdim vbbox+    setter cdim (ContinuousSingleArrangement _ ddim pfunc vbbox) = +      ContinuousSingleArrangement cdim ddim pfunc vbbox++    +viewPortBBox :: PageArrangement a :-> ViewPortBBox +viewPortBBox = lens getter setter +  where +    getter (SingleArrangement _ _ vbbox) = vbbox +    getter (ContinuousSingleArrangement _ _ _ vbbox) = vbbox +    setter vbbox (SingleArrangement cdim pdim _) = SingleArrangement cdim pdim vbbox +    setter vbbox (ContinuousSingleArrangement cdim ddim pfunc _) = +      ContinuousSingleArrangement cdim ddim pfunc vbbox++desktopDimension :: PageArrangement a :-> DesktopDimension +desktopDimension = lens getter (error "setter for desktopDimension is not defined")+  where getter (SingleArrangement _ (PageDimension dim) _) = DesktopDimension dim+        getter (ContinuousSingleArrangement _ ddim _ _) = ddim +++++

+ lib/Application/HXournal/Type/Predefined.hs view

@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Application.HXournal.Type.Predefined+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+----------------------------------------------------------------------------++module Application.HXournal.Type.Predefined where++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) ++predefinedPageSpacing :: Double+predefinedPageSpacing = 10

lib/Application/HXournal/Type/Undo.hs view

@@ -11,50 +11,7 @@ -- module Application.HXournal.Type.Undo where -import Data.Sequence import Data.Xournal.Select--{--type SeqZipper a = (a, (Seq a,Seq a))--                 --singletonSZ :: a -> SeqZipper a  -singletonSZ x = (x, (empty,empty))--appendGoLast :: SeqZipper a -> a -> SeqZipper a-appendGoLast (y,(y1s,y2s)) x = (x, ((y1s |> y) >< y2s, empty))--chopFirst :: SeqZipper a -> Maybe (SeqZipper a)-chopFirst (y,(y1s,y2s)) = -  case viewl y1s of-    EmptyL -> case viewl y2s of -                EmptyL -> Nothing -                z :< zs -> Just (z,(empty,zs))-    z :< zs -> Just (y,(zs,y2s))-    -moveLeft :: SeqZipper a -> Maybe (SeqZipper a)-moveLeft (x,(x1s,x2s)) = -  case viewr x1s of-    EmptyR -> Nothing -    zs :> z -> Just (z,(zs,x<|x2s))--moveRight :: SeqZipper a -> Maybe (SeqZipper a) -moveRight (x,(x1s,x2s)) = -  case viewl x2s of -    EmptyL -> Nothing-    z :< zs -> Just (z,(x1s|>x,zs)) ---current :: SeqZipper a -> a -current (x,(_,_)) = x--prev :: SeqZipper a -> Maybe a -prev = fmap current . moveLeft--next :: SeqZipper a -> Maybe a -next = fmap current . moveRight--}  data UndoTable a = UndoTable { undo_allowednum :: Int                              , undo_totalnum :: Int

lib/Application/HXournal/Type/Window.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Type.Window @@ -9,6 +8,8 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Type.Window where  import Application.HXournal.Type.Canvas@@ -16,8 +17,9 @@ import Graphics.UI.Gtk hiding (get,set)  data WindowConfig = Node CanvasId -                  | HSplit (Maybe HPaned) WindowConfig WindowConfig-                  | VSplit (Maybe VPaned) WindowConfig WindowConfig +                  | HSplit WindowConfig WindowConfig+                  | VSplit WindowConfig WindowConfig +                  deriving (Show,Eq)  data SplitType = SplitHorizontal | SplitVertical                 deriving (Show)@@ -31,24 +33,24 @@ splitWindow cidold (cidnew,stype) (Node cid) =    if cid == cidold      then case stype of -           SplitHorizontal -> Right (HSplit Nothing (Node cid) (Node cidnew))-           SplitVertical -> Right (VSplit Nothing (Node cid) (Node cidnew))+           SplitHorizontal -> Right (HSplit (Node cid) (Node cidnew))+           SplitVertical -> Right (VSplit  (Node cid) (Node cidnew))     else Left (Node cid)-splitWindow cidold (cidnew,stype) (HSplit hpane wconf1 wconf2) =+splitWindow cidold (cidnew,stype) (HSplit wconf1 wconf2) =   let r1 = splitWindow cidold (cidnew,stype) wconf1       r2 = splitWindow cidold (cidnew,stype) wconf2   in  case (r1,r2) of -        (Left nwconf1, Left nwconf2) -> Left (HSplit hpane nwconf1 nwconf2)-        (Left nwconf1, Right nwconf2) -> Right (HSplit hpane nwconf1 nwconf2)-        (Right nwconf1, Left nwconf2) -> Right (HSplit hpane nwconf1 nwconf2)+        (Left nwconf1, Left nwconf2) -> Left (HSplit nwconf1 nwconf2)+        (Left nwconf1, Right nwconf2) -> Right (HSplit nwconf1 nwconf2)+        (Right nwconf1, Left nwconf2) -> Right (HSplit nwconf1 nwconf2)         (Right _, Right _) -> error "such case cannot happen in splitWindow"-splitWindow cidold (cidnew,stype) (VSplit vpane wconf1 wconf2) =+splitWindow cidold (cidnew,stype) (VSplit wconf1 wconf2) =   let r1 = splitWindow cidold (cidnew,stype) wconf1       r2 = splitWindow cidold (cidnew,stype) wconf2   in  case (r1,r2) of -        (Left nwconf1, Left nwconf2) -> Left (VSplit vpane nwconf1 nwconf2)-        (Left nwconf1, Right nwconf2) -> Right (VSplit vpane nwconf1 nwconf2)-        (Right nwconf1, Left nwconf2) -> Right (VSplit vpane nwconf1 nwconf2)+        (Left nwconf1, Left nwconf2) -> Left (VSplit nwconf1 nwconf2)+        (Left nwconf1, Right nwconf2) -> Right (VSplit nwconf1 nwconf2)+        (Right nwconf1, Left nwconf2) -> Right (VSplit nwconf1 nwconf2)         (Right _, Right _) -> error "such case cannot happen in splitWindow"       @@ -59,32 +61,32 @@   if cid == cid'      then Right Nothing     else Left (Node cid')-removeWindow cid (HSplit hpane wconf1 wconf2) =+removeWindow cid (HSplit wconf1 wconf2) =   let r1 = removeWindow cid wconf1       r2 = removeWindow cid wconf2   in  case (r1,r2) of -        (Left nwconf1, Left nwconf2) -> Left (HSplit hpane nwconf1 nwconf2)+        (Left nwconf1, Left nwconf2) -> Left (HSplit nwconf1 nwconf2)         (Left nwconf1, Right mnwconf2) ->            case mnwconf2 of -            Just nwconf2 -> Right (Just (HSplit hpane nwconf1 nwconf2))+            Just nwconf2 -> Right (Just (HSplit nwconf1 nwconf2))             Nothing -> Right (Just nwconf1)         (Right mnwconf1, Left nwconf2) ->            case mnwconf1 of-            Just nwconf1 -> Right (Just (HSplit hpane nwconf1 nwconf2))+            Just nwconf1 -> Right (Just (HSplit nwconf1 nwconf2))             Nothing -> Right (Just nwconf2)         (Right _, Right _) -> error "such case cannot happen in removeWindow"-removeWindow cid (VSplit vpane wconf1 wconf2) =+removeWindow cid (VSplit wconf1 wconf2) =   let r1 = removeWindow cid wconf1       r2 = removeWindow cid wconf2   in  case (r1,r2) of -        (Left nwconf1, Left nwconf2) -> Left (VSplit vpane nwconf1 nwconf2)+        (Left nwconf1, Left nwconf2) -> Left (VSplit nwconf1 nwconf2)         (Left nwconf1, Right mnwconf2) ->            case mnwconf2 of -            Just nwconf2 -> Right (Just (VSplit vpane nwconf1 nwconf2))+            Just nwconf2 -> Right (Just (VSplit nwconf1 nwconf2))             Nothing -> Right (Just nwconf1)         (Right mnwconf1, Left nwconf2) ->            case mnwconf1 of-            Just nwconf1 -> Right (Just (VSplit vpane nwconf1 nwconf2))+            Just nwconf1 -> Right (Just (VSplit nwconf1 nwconf2))             Nothing -> Right (Just nwconf2)         (Right _, Right _) -> error "such case cannot happen in removeWindow"

lib/Application/HXournal/Type/XournalState.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeOperators #-}  ----------------------------------------------------------------------------- -- |@@ -10,41 +10,44 @@ -- Stability   : experimental -- Portability : GHC --+-----------------------------------------------------------------------------  module Application.HXournal.Type.XournalState where  import Application.HXournal.Device import Application.HXournal.Type.Event -import Application.HXournal.Type.Enum import Application.HXournal.Type.Canvas import Application.HXournal.Type.Clipboard import Application.HXournal.Type.Window  import Application.HXournal.Type.Undo-+import Application.HXournal.Type.Alias +import Application.HXournal.Type.PageArrangement+import Application.HXournal.Util -- import Application.HXournal.NetworkClipboard.Client.Config import Data.Xournal.Map- import Graphics.Xournal.Render.BBoxMapPDF- import Control.Category-import Control.Monad.State--import Data.Xournal.Predefined -import Graphics.UI.Gtk hiding (Clipboard)+import Control.Monad.State hiding (get,modify)+import Graphics.UI.Gtk hiding (Clipboard, get,set) import Data.Maybe import Data.Label +import Data.Xournal.Generic+import qualified Data.IntMap as M+ import Prelude hiding ((.), id) + type XournalStateIO = StateT HXournalState IO   data XournalState = ViewAppendState { unView :: TXournalBBoxMapPDFBuf }                   | SelectState { tempSelect :: TTempXournalSelectPDFBuf }+                      data HXournalState =    HXournalState { _xournalstate :: XournalState                 , _currFileName :: Maybe FilePath                 , _canvasInfoMap :: CanvasInfoMap -                , _currentCanvas :: Int+                , _currentCanvas :: (CanvasId,CanvasInfoBox)                 , _frameState :: WindowConfig                  , _rootWindow :: Widget                 , _rootContainer :: Box@@ -58,7 +61,7 @@                 , _gtkUIManager :: UIManager                  , _isSaved :: Bool                  , _undoTable :: UndoTable XournalState---                , _networkClipboardInfo :: Maybe HXournalClipClientConfiguration+                --  , _networkClipboardInfo :: Maybe HXournalClipClientConfiguration                 }   @@ -79,7 +82,7 @@   , _clipboard = emptyClipboard   , _callBack = error "emtpyHxournalState.callBack"   , _deviceList = error "emtpyHxournalState.deviceList"-  , _penInfo = defaultPenInfo -- PenInfo PenWork predefined_medium ColorBlack+  , _penInfo = defaultPenInfo    , _selectInfo = SelectInfo SelectRectangleWork    , _gtkUIManager = error "emptyHXournalState.gtkUIManager"   , _isSaved = False @@ -87,9 +90,114 @@ --  , _networkClipboardInfo = Nothing    } +-- | ++getXournal :: HXournalState -> Xournal EditMode +getXournal = either id makexoj . xojstateEither . get xournalstate +  where makexoj txoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj)+++-- | +        +currentCanvasId :: HXournalState :-> CanvasId+currentCanvasId = lens getter setter +  where getter = fst . _currentCanvas +        setter a = modify currentCanvas (\(_,x)->(a,x))++currentCanvasInfo :: HXournalState :-> CanvasInfoBox+currentCanvasInfo = lens getter setter +  where getter = snd . _currentCanvas+        setter a = modify currentCanvas (\(x,_)->(x,a)) ++ resetXournalStateBuffers :: XournalState -> IO XournalState  resetXournalStateBuffers xojstate1 =    case xojstate1 of      ViewAppendState xoj -> liftIO . liftM ViewAppendState . resetXournalBuffers $ xoj     _ -> return xojstate1++-- |+    +getCanvasInfo :: CanvasId -> HXournalState -> CanvasInfoBox +getCanvasInfo cid xstate = +  let cinfoMap = get canvasInfoMap xstate+      maybeCvs = M.lookup cid cinfoMap+  in maybeError ("no canvas with id = " ++ show cid) maybeCvs++-- | ++setCanvasInfo :: (CanvasId,CanvasInfoBox) -> HXournalState -> HXournalState +setCanvasInfo (cid,cinfobox) xstate = +  let cmap = get canvasInfoMap xstate+      cmap' = M.insert cid cinfobox cmap +      xstate' = set canvasInfoMap cmap' xstate+  in xstate' +++-- | change current canvas. this is the master function  ++updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> HXournalState -> HXournalState+updateFromCanvasInfoAsCurrentCanvas cinfobox xstate = +  let cid = unboxGet canvasId cinfobox +      cmap = get canvasInfoMap xstate+      cmap' = M.insert cid cinfobox cmap +      -- implement the following later+      -- page = gcast (unboxGet currentPage cinfobox) :: Page EditMode +  in xstate { _currentCanvas = (cid,cinfobox)+            , _canvasInfoMap = cmap' }++-- | ++setCanvasId :: CanvasId -> CanvasInfoBox -> CanvasInfoBox +setCanvasId cid (CanvasInfoBox cinfo) = CanvasInfoBox (cinfo { _canvasId = cid })+++-- | ++modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) -> HXournalState+                    -> HXournalState+modifyCanvasInfo cid f =  modify currentCanvasInfo f +                          . modify canvasInfoMap (M.adjust f cid) ++                    ++-- | should be deprecated++modifyCurrentCanvasInfo :: (CanvasInfoBox -> CanvasInfoBox) +                        -> HXournalState+                        -> HXournalState+modifyCurrentCanvasInfo f st =  modify currentCanvasInfo f . modify canvasInfoMap (M.adjust f cid) $ st +  where cid = get currentCanvasId st ++-- | should be deprecated +        +modifyCurrCvsInfoM :: (Monad m) => (CanvasInfoBox -> m CanvasInfoBox) +                      -> HXournalState+                      -> m HXournalState+modifyCurrCvsInfoM f st = do +  let cinfobox = get currentCanvasInfo st +      cid = get currentCanvasId st +  ncinfobox <- f cinfobox+  let cinfomap = get canvasInfoMap st+      ncinfomap = M.adjust (const ncinfobox) cid cinfomap +      nst = set currentCanvasInfo ncinfobox +            . set canvasInfoMap ncinfomap +            $ st +  return nst++-- | ++xojstateEither :: XournalState -> Either (Xournal EditMode) (Xournal SelectMode) +xojstateEither xojstate = case xojstate of +                            ViewAppendState xoj -> Left xoj +                            SelectState txoj -> Right txoj +                            +++-- | ++showCanvasInfoMapViewPortBBox :: HXournalState -> IO ()+showCanvasInfoMapViewPortBBox xstate = do +  let cmap = get canvasInfoMap xstate+  putStrLn . show . map (unboxGet (viewPortBBox.pageArrangement.viewInfo)) . M.elems $ cmap

lib/Application/HXournal/Util.hs view

@@ -1,4 +1,3 @@- ----------------------------------------------------------------------------- -- | -- Module      : Application.HXournal.Util @@ -9,25 +8,19 @@ -- Stability   : experimental -- Portability : GHC ---module Application.HXournal.Util where+----------------------------------------------------------------------------- -import Graphics.Xournal.Render.BBoxMapPDF+module Application.HXournal.Util where  import Data.Maybe--import Data.Xournal.Generic- import Data.Xournal.Simple--import Graphics.Xournal.Render.PDFBackground-import qualified Data.ByteString.Lazy as L   -- for test -- import Blaze.ByteString.Builder -- import Text.Xournal.Builder   {--testPage :: TPageBBoxMapPDFBuf -> IO () +testPage :: Page Edit -> IO ()  testPage page = do     let pagesimple = toPage bkgFromBkgPDF . tpageBBoxMapPDFFromTPageBBoxMapPDFBuf $ page      L.putStrLn . toLazyByteString . Text.Xournal.Builder.fromPage $ pagesimple @@ -43,10 +36,11 @@   L.putStrLn (builder xojsimple) -} +maybeFlip :: Maybe a -> b -> (a->b) -> b  +maybeFlip m n j = maybe n j m     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

+ lib/Application/HXournal/View/Coordinate.hs view

@@ -0,0 +1,215 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Application.HXournal.View.Coordinate+-- Copyright   : (c) 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.View.Coordinate where ++import Graphics.UI.Gtk hiding (get,set)+import Control.Applicative+import Control.Category+import Data.Label +import Prelude hiding ((.),id)+import qualified Data.IntMap as M+import Data.Maybe+import Data.Monoid+import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.Generic+import Data.Xournal.BBox +-- import Graphics.Xournal.Render.HitTest+import Application.HXournal.Device+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.PageArrangement+import Application.HXournal.Type.Alias++import Debug.Trace+++-- | data structure for transformation among screen, canvas, desktop and page coordinates++data CanvasGeometry = +  CanvasGeometry +  { screenDim :: ScreenDimension+  , canvasDim :: CanvasDimension+  -- , canvasOrigin :: CanvasOrigin +  , desktopDim :: DesktopDimension +  , canvasViewPort :: ViewPortBBox -- ^ in desktop coordinate +  , screen2Canvas :: ScreenCoordinate -> CanvasCoordinate+  , canvas2Screen :: CanvasCoordinate -> ScreenCoordinate+  , canvas2Desktop :: CanvasCoordinate -> DesktopCoordinate+  , desktop2Canvas :: DesktopCoordinate -> CanvasCoordinate+  , desktop2Page :: DesktopCoordinate -> Maybe (PageNum,PageCoordinate)+  , page2Desktop :: (PageNum,PageCoordinate) -> DesktopCoordinate+  } ++-- | make a canvas geometry data structure from current status ++makeCanvasGeometry :: (GPageable em) => +                      em +                      -> (PageNum, Page em)+                      -> PageArrangement vm +                      -> DrawingArea +                      -> IO CanvasGeometry +makeCanvasGeometry typ (cpn,page) arr canvas = do  +  win <- widgetGetDrawWindow canvas+  -- (w',h') <- return . ((,) <$> fromIntegral.fst <*> fromIntegral.snd) =<< widgetGetSize canvas+  let cdim@(CanvasDimension (Dim w' h')) = get canvasDimension arr+  screen <- widgetGetScreen canvas+  (ws,hs) <- (,) <$> (fromIntegral <$> screenGetWidth screen)+                 <*> (fromIntegral <$> screenGetHeight screen)+  (x0,y0) <- return . ((,) <$> fromIntegral.fst <*> fromIntegral.snd ) =<< drawWindowGetOrigin win+  let (Dim w h) = get g_dimension page+      corig = CanvasOrigin (x0,y0)+  let (deskdim, cvsvbbox, p2d, d2p) = +        case arr of  +          SingleArrangement _ pdim vbbox -> ( DesktopDimension . unPageDimension $ pdim+                                               , vbbox+                                               , DeskCoord . unPageCoord . snd+                                               , \(DeskCoord coord) ->Just (cpn,(PageCoord coord)) )+          ContinuousSingleArrangement _ ddim pfunc vbbox -> +            ( ddim, vbbox, makePage2Desktop pfunc, makeDesktop2Page pfunc ) +  let s2c = xformScreen2Canvas corig+      c2s = xformCanvas2Screen corig+      c2d = xformCanvas2Desk cdim cvsvbbox +      d2c = xformDesk2Canvas cdim cvsvbbox+  return $ CanvasGeometry (ScreenDimension (Dim ws hs)) (CanvasDimension (Dim w' h')) +                          deskdim cvsvbbox s2c c2s c2d d2c d2p p2d+    ++++++-- |+ +makePage2Desktop :: (PageNum -> Maybe PageOrigin) +                    -> (PageNum,PageCoordinate) -> DesktopCoordinate+makePage2Desktop pfunc (pnum,PageCoord (x,y)) = +  maybe (DeskCoord (-100,-100)) (\(PageOrigin (x0,y0)) -> DeskCoord (x0+x,y0+y)) (pfunc pnum) +     +-- | ++makeDesktop2Page :: (PageNum -> Maybe PageOrigin) -> DesktopCoordinate +                    -> Maybe (PageNum, PageCoordinate)+makeDesktop2Page pfunc (DeskCoord (x,y)) =+  let (prev,next) = break (y<) . map (snd.unPageOrigin) . catMaybes+                    . takeWhile isJust . map (pfunc.PageNum) $ [0..] +  in Just (PageNum (length prev-1),PageCoord (x,y- last prev)) ++    +-- |   +  +xformScreen2Canvas :: CanvasOrigin -> ScreenCoordinate -> CanvasCoordinate+xformScreen2Canvas (CanvasOrigin (x0,y0)) (ScrCoord (sx,sy)) = CvsCoord (sx-x0,sy-y0)++-- |++xformCanvas2Screen :: CanvasOrigin -> CanvasCoordinate -> ScreenCoordinate +xformCanvas2Screen (CanvasOrigin (x0,y0)) (CvsCoord (cx,cy)) = ScrCoord (cx+x0,cy+y0)++-- |++xformCanvas2Desk :: CanvasDimension -> ViewPortBBox -> CanvasCoordinate +                    -> DesktopCoordinate +xformCanvas2Desk (CanvasDimension (Dim w h)) (ViewPortBBox (BBox (x1,y1) (x2,y2))) +                 (CvsCoord (cx,cy)) = DeskCoord (cx*(x2-x1)/w+x1,cy*(y2-y1)/h+y1) ++-- |++xformDesk2Canvas :: CanvasDimension -> ViewPortBBox -> DesktopCoordinate +                    -> CanvasCoordinate+xformDesk2Canvas (CanvasDimension (Dim w h)) (ViewPortBBox (BBox (x1,y1) (x2,y2)))+                 (DeskCoord (dx,dy)) = CvsCoord ((dx-x1)*w/(x2-x1),(dy-y1)*h/(y2-y1))+                                       +-- | ++screen2Desktop :: CanvasGeometry -> ScreenCoordinate -> DesktopCoordinate+screen2Desktop geometry = canvas2Desktop geometry . screen2Canvas geometry  ++-- | ++desktop2Screen :: CanvasGeometry -> DesktopCoordinate -> ScreenCoordinate+desktop2Screen geometry = canvas2Screen geometry . desktop2Canvas geometry++-- |++core2Desktop :: CanvasGeometry -> (Double,Double) -> DesktopCoordinate +core2Desktop geometry = canvas2Desktop geometry . CvsCoord ++-- |++wacom2Desktop :: CanvasGeometry -> (Double,Double) -> DesktopCoordinate+wacom2Desktop geometry (x,y) = let Dim w h = unScreenDimension (screenDim geometry)+                               in screen2Desktop geometry . ScrCoord $ (w*x,h*y) +                                  +wacom2Canvas :: CanvasGeometry -> (Double,Double) -> CanvasCoordinate                       +wacom2Canvas geometry (x,y) = let Dim w h = unScreenDimension (screenDim geometry)+                              in screen2Canvas geometry . ScrCoord $ (w*x,h*y) +         ++-- | ++device2Desktop :: CanvasGeometry -> PointerCoord -> DesktopCoordinate +device2Desktop geometry (PointerCoord typ x y) =  +  case typ of +    Core -> core2Desktop geometry (x,y)+    Stylus -> wacom2Desktop geometry (x,y)+    Eraser -> wacom2Desktop geometry (x,y)+device2Desktop geometry NoPointerCoord = error "NoPointerCoordinate device2Desktop"+         +-- | ++getPagesInViewPortRange :: CanvasGeometry -> Xournal EditMode -> [PageNum]+getPagesInViewPortRange geometry xoj = +  let ViewPortBBox bbox = canvasViewPort geometry+      ivbbox = Intersect (Middle bbox)+      pagemap = get g_pages xoj +      pnums = map PageNum [ 0 .. (length . gToList $ pagemap)-1 ]+      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 +                          Intersect Bottom -> False +                          _ -> True +      f (PageNum n) = maybe False (pgcheck n) . M.lookup n $ pagemap +  in filter f pnums++-- | ++getCvsGeomFrmCvsInfo :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry +getCvsGeomFrmCvsInfo cinfo = do +  let page = getPage cinfo+      cpn = PageNum . get currentPageNum $ cinfo +      canvas = get drawArea cinfo+      arr = get (pageArrangement.viewInfo) cinfo +  makeCanvasGeometry EditMode (cpn,page) arr canvas +  ++++++++      -- contained (ViewPortBBox bbox) (DeskCoord (x,y)) = hitTestBBoxPoint bbox (x,y) +                        {- contained vbbox ul || contained vbbox ur +                        || contained vbbox ll || contained vbbox lr -}+                         -- ur = page2Desktop geometry (PageNum n,PageCoord (w,0))+                         -- ll = page2Desktop geometry (PageNum n,PageCoord (0,h)) +{- trace (show n ++ ": " ++ show (intersectBBox bbox nbbox)+                               ++ "\nivbbox = " ++ show ivbbox +                               ++ "\ninbbox = " ++ show inbbox +                               ++ "\nresult = " ++ show result) $ -}+

+ lib/Application/HXournal/View/Draw.hs view

@@ -0,0 +1,882 @@+{-# LANGUAGE GADTs, Rank2Types, TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Application.HXournal.View.Draw +-- Copyright   : (c) 2011, 2012 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.View.Draw where++import Graphics.UI.Gtk hiding (get)+import Graphics.Rendering.Cairo++import Control.Applicative +import Control.Category (id,(.))+import Control.Monad (liftM,(<=<),when)+import Data.Label+import Prelude hiding ((.),id,mapM_,concatMap)+import Data.Foldable+import qualified Data.IntMap as M+import Data.Maybe hiding (fromMaybe)+import Data.Monoid+import Data.Sequence+import Data.Xournal.Simple (Dimension(..))+import Data.Xournal.Generic+import Data.Xournal.BBox+import Graphics.Xournal.Render.Type+import Graphics.Xournal.Render.BBox +import Graphics.Xournal.Render.BBoxMapPDF +import Graphics.Xournal.Render.PDFBackground+import Graphics.Xournal.Render.Generic+import Application.HXournal.Type.Canvas+import Application.HXournal.Type.Alias +import Application.HXournal.Device+import Application.HXournal.Util+import Application.HXournal.Type.PageArrangement+import Application.HXournal.Type.Predefined+import Application.HXournal.Type.Enum+import Application.HXournal.View.Coordinate+import Application.HXournal.ModelAction.Page+++-- type DrawingFunction = forall a. (ViewMode a) => ViewInfo a -> Maybe BBox -> IO ()++type family DrawingFunction v :: * -> * ++newtype SinglePageDraw a = +  SinglePageDraw { unSinglePageDraw :: Bool +                                       -> DrawingArea +                                       -> (PageNum, Page a) +                                       -> ViewInfo SinglePage +                                       -> Maybe BBox +                                       -> IO () }+++newtype ContPageDraw a = +  ContPageDraw +  { unContPageDraw :: Bool+                      -> CanvasInfo ContinuousSinglePage +                      -> Maybe BBox +                      -> Xournal a +                      -> IO () }+                    +type instance DrawingFunction SinglePage = SinglePageDraw+type instance DrawingFunction ContinuousSinglePage = ContPageDraw++-- | ++getCanvasViewPort :: CanvasGeometry -> ViewPortBBox +getCanvasViewPort geometry = +  let DeskCoord (x0,y0) = canvas2Desktop geometry (CvsCoord (0,0)) +      CanvasDimension (Dim w h) = canvasDim geometry  +      DeskCoord (x1,y1) = canvas2Desktop geometry (CvsCoord (w,h))+  in ViewPortBBox (BBox (x0,y0) (x1,y1))++-- | ++getBBoxInPageCoord :: CanvasGeometry -> PageNum -> BBox -> BBox  +getBBoxInPageCoord geometry pnum bbox@(BBox (x1,y1) (x2,y2)) = +  let DeskCoord (x0,y0) = page2Desktop geometry (pnum,PageCoord (0,0))  +  in moveBBoxByOffset (-x0,-y0) bbox+     +-- | ++getViewableBBox :: CanvasGeometry +                   -- -> Maybe (PageNum, Maybe BBox) -- ^ in page coordinate+                   -> Maybe BBox   -- ^ in desktop coordinate +                   -> IntersectBBox+                                            -- Maybe BBox   -- ^ in desktop coordinate+getViewableBBox geometry mbbox = -- (Just (pnum,mbbox)) = +  let ViewPortBBox vportbbox = getCanvasViewPort geometry  +  in (fromMaybe mbbox :: IntersectBBox) `mappend` (Intersect (Middle vportbbox))+               +{- getViewableBBox geometry Nothing = +  let ViewPortBBox vportbbox = getCanvasViewPort geometry +  in (Just vportbbox) -}+++-- | common routine for double buffering ++doubleBufferDraw :: DrawWindow -> CanvasGeometry -> Render () -> Render () +                    -> IntersectBBox+                    -> IO ()+doubleBufferDraw win geometry xform rndr (Intersect ibbox) = do +  let Dim cw ch = unCanvasDimension . canvasDim $ geometry +      mbbox' = case ibbox of +        Top -> Just (BBox (0,0) (cw,ch))+        Middle bbox -> Just (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord) bbox)+        Bottom -> Nothing +  let action = withImageSurface FormatARGB32 (floor cw) (floor ch) $ \tempsurface -> do +        renderWith tempsurface $ do +          setSourceRGBA 0.5 0.5 0.5 1+          rectangle 0 0 cw ch +          fill +          rndr +        renderWithDrawable win $ do +          clipBBox mbbox'+          setSourceSurface tempsurface 0 0   +          setOperator OperatorSource +          -- xform+          paint +  case ibbox of+    Top -> action+    Middle _ -> action +    Bottom -> return ()++-- | ++cairoXform4PageCoordinate :: CanvasGeometry -> PageNum -> Render () +cairoXform4PageCoordinate geometry pnum = do +  let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0))+      CvsCoord (x1,y1) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (1,1))+      sx = x1-x0 +      sy = y1-y0+  translate x0 y0      +  scale sx sy+  +-- | ++drawCurvebit :: DrawingArea +               -> CanvasGeometry +               -> Double +               -> (Double,Double,Double,Double) +               -> PageNum +               -> (Double,Double) +               -> (Double,Double) +               -> IO () +drawCurvebit canvas geometry wdth (r,g,b,a) pnum (x0,y0) (x,y) = do +  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    cairoXform4PageCoordinate geometry pnum +    setSourceRGBA r g b a+    setLineWidth wdth+    moveTo x0 y0+    lineTo x y+    stroke++-- | +    +drawFuncGen :: (GPageable em) => em -> +               ((PageNum,Page em) -> Maybe BBox -> Render ()) -> DrawingFunction SinglePage em+drawFuncGen typ render = SinglePageDraw func +  where func isCurrentCvs canvas (pnum,page) vinfo mbbox = do +          let arr = get pageArrangement vinfo+          geometry <- makeCanvasGeometry typ (pnum,page) arr canvas+          win <- widgetGetDrawWindow canvas+          let ibboxnew = getViewableBBox geometry mbbox +          let mbboxnew = toMaybe ibboxnew +              xformfunc = cairoXform4PageCoordinate geometry pnum+              renderfunc = do+                xformfunc +                clipBBox (fmap (flip inflate 1) mbboxnew) -- mbboxnew+                render (pnum,page) mbboxnew +                when isCurrentCvs (emphasisCanvasRender ColorBlue geometry)  +                resetClip +          doubleBufferDraw win geometry xformfunc renderfunc ibboxnew ++drawFuncSelGen :: ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) +                  -> ((PageNum,Page SelectMode) -> Maybe BBox -> Render ())+                  -> DrawingFunction SinglePage SelectMode  +drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\x y -> rencont x y >> rensel x y) ++-- |++emphasisCanvasRender :: PenColor -> CanvasGeometry -> Render ()+emphasisCanvasRender pcolor geometry = do +  identityMatrix+  let CanvasDimension (Dim cw ch) = canvasDim geometry +  let (r,g,b,a) = convertPenColorToRGBA pcolor+  setSourceRGBA r g b a +  setLineWidth 10+  rectangle 0 0 cw ch +  stroke+++-- |++drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) +                   -> DrawingFunction ContinuousSinglePage EditMode+drawContPageGen render = ContPageDraw func +  where func isCurrentCvs cinfo mbbox xoj = do +          let arr = get (pageArrangement.viewInfo) cinfo+              pnum = PageNum . get currentPageNum $ cinfo +              page = getPage cinfo +              canvas = get drawArea cinfo +          geometry <- makeCanvasGeometry EditMode (pnum,page) arr canvas+          let pgs = get g_pages xoj +          let drawpgs = catMaybes . map f +                        $ (getPagesInViewPortRange geometry xoj) +                where f k = maybe Nothing (\a->Just (k,a)) +                            . M.lookup (unPageNum k) $ pgs+          win <- widgetGetDrawWindow canvas+          let ibboxnew = getViewableBBox geometry mbbox +          let mbboxnew = toMaybe ibboxnew +              xformfunc = cairoXform4PageCoordinate geometry pnum+              emphasispagerender (pn,pg) = do +                identityMatrix +                cairoXform4PageCoordinate geometry pn+                let Dim w h = get g_dimension pg +                setSourceRGBA 1.0 0 0 0.2+                rectangle 0 0 w h +                fill +              onepagerender (pn,pg) = do  +                identityMatrix +                cairoXform4PageCoordinate geometry pn+                let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew+                clipBBox (fmap (flip inflate 1) pgmbbox)     +                render (pn,pg) pgmbbox+              renderfunc = do+                xformfunc +                -- clipBBox mbboxnew+                mapM_ onepagerender drawpgs +                -- emphasispagerender (pnum,page)+                when isCurrentCvs (emphasisCanvasRender ColorRed geometry)+                resetClip +          doubleBufferDraw win geometry xformfunc renderfunc ibboxnew++cairoBBox :: BBox -> Render () +cairoBBox bbox = do +  let (x1,y1) = bbox_upperleft bbox+      (x2,y2) = bbox_lowerright bbox+  rectangle x1 y1 (x2-x1) (y2-y1)+  stroke+++drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) +                      -> ((PageNum, Page SelectMode) -> Maybe BBox -> Render ())+                      -> DrawingFunction ContinuousSinglePage SelectMode+drawContPageSelGen rendergen rendersel = ContPageDraw func +  where func isCurrentCvs cinfo mbbox txoj = do +          let arr = get (pageArrangement.viewInfo) cinfo+              pnum = PageNum . get currentPageNum $ cinfo +              page = getPage cinfo +              tpage = get currentPage cinfo +              canvas = get drawArea cinfo +          geometry <- makeCanvasGeometry EditMode (pnum,page) arr canvas+          let pgs = get g_selectAll txoj +              xoj = GXournal (get g_selectTitle txoj) pgs +          let drawpgs = catMaybes . map f +                        $ (getPagesInViewPortRange geometry xoj) +                where f k = maybe Nothing (\a->Just (k,a)) +                            . M.lookup (unPageNum k) $ pgs+          win <- widgetGetDrawWindow canvas+          let ibboxnew = getViewableBBox geometry mbbox --  mpnumbbox+              mbboxnew = toMaybe ibboxnew+              xformfunc = cairoXform4PageCoordinate geometry pnum+              emphasispagerender (pn,pg) = do +                identityMatrix +                cairoXform4PageCoordinate geometry pn+                let Dim w h = get g_dimension pg +                setSourceRGBA 1.0 0 0 0.2+                rectangle 0 0 w h +                fill +              onepagerender (pn,pg) = do  +                identityMatrix +                cairoXform4PageCoordinate geometry pn+                rendergen (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew)+              selpagerender (pn,pg) = do +                identityMatrix +                cairoXform4PageCoordinate geometry pn+                rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew)+              renderfunc = do+                xformfunc +                -- clipBBox mbboxnew+                mapM_ onepagerender drawpgs +                -- emphasispagerender (pnum,page)+                case tpage of +                  Left page' -> return () +                  Right tpage' -> selpagerender (pnum,tpage')+                when isCurrentCvs (emphasisCanvasRender ColorGreen geometry)  +                  +                resetClip +          doubleBufferDraw win geometry xformfunc renderfunc ibboxnew+++drawPageClearly :: DrawingFunction SinglePage EditMode+drawPageClearly = drawFuncGen EditMode $ \(_,page) _mbbox -> +                     cairoRenderOption (DrawBkgPDF,DrawFull) (gcast page :: TPageBBoxMapPDF )+++drawPageSelClearly :: DrawingFunction SinglePage SelectMode         +drawPageSelClearly = drawFuncSelGen rendercontent renderselect +  where rendercontent (_pnum,tpg)  _mbbox = do+          let pg' = gcast tpg :: Page EditMode+          cairoRenderOption (DrawBkgPDF,DrawFull) (gcast pg' :: TPageBBoxMapPDF)+        renderselect (_pnum,tpg) mbbox = do +          cairoHittedBoxDraw tpg mbbox++-- | +        +drawContXojClearly :: DrawingFunction ContinuousSinglePage EditMode+drawContXojClearly = +  drawContPageGen $ \(_,page) _mbbox -> +                       cairoRenderOption (DrawBkgPDF,DrawFull) +                                         (gcast page :: TPageBBoxMapPDF )+++drawContXojSelClearly :: DrawingFunction ContinuousSinglePage SelectMode+drawContXojSelClearly = drawContPageSelGen renderother {- rendercontent -} renderselect +  where +        renderother (_,page) _mbbox  = +          cairoRenderOption (DrawBkgPDF,DrawFull) (gcast page :: TPageBBoxMapPDF )    +        renderselect (_pnum,tpg) mbbox =  +          cairoHittedBoxDraw tpg mbbox+++++-- |++drawBuf :: DrawingFunction SinglePage EditMode+drawBuf = drawFuncGen EditMode $ \(_,page) mbbox -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) +  +-- |++drawSelBuf :: DrawingFunction SinglePage SelectMode+drawSelBuf = drawFuncSelGen rencont rensel  +  where rencont (_pnum,tpg) mbbox = do +          let page = (gcast tpg :: Page EditMode)+          cairoRenderOption (InBBoxOption mbbox) (InBBox (gcast page :: TPageBBoxMapPDF))+        rensel (_pnum,tpg) mbbox = do +          cairoHittedBoxDraw tpg mbbox  +             +-- | ++drawContXojBuf :: DrawingFunction ContinuousSinglePage EditMode+drawContXojBuf = +  drawContPageGen $ \(_,page) mbbox -> +                       cairoRenderOption (InBBoxOption mbbox) (InBBox page)   +++-- |++cairoHittedBoxDraw :: Page SelectMode -> Maybe BBox -> Render () +cairoHittedBoxDraw tpg mbbox = do   +  let layers = get g_layers tpg +      slayer = gselectedlayerbuf layers +  case unTEitherAlterHitted . get g_bstrokes $ slayer of+    Right alist -> do +      clipBBox mbbox+      setSourceRGBA 0.0 0.0 1.0 1.0+      let hitstrs = concatMap unHitted (getB alist)+      mapM_ renderSelectedStroke hitstrs  +      let ulbbox = unUnion . mconcat . fmap (Union .Middle . strokebbox_bbox) +                   $ hitstrs +      case ulbbox of +        Middle bbox -> renderSelectHandle bbox +        _ -> return () +      resetClip+    Left _ -> return ()  +++-- | ++renderLasso :: Seq (Double,Double) -> Render ()+renderLasso lst = do +  setLineWidth predefinedLassoWidth+  uncurry4 setSourceRGBA predefinedLassoColor+  uncurry setDash predefinedLassoDash +  case viewl lst of +    EmptyL -> return ()+    x :< xs -> do uncurry moveTo x+                  mapM_ (uncurry lineTo) xs +                  stroke ++++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 +  setLineWidth 1.5+  setSourceRGBA 0 0 1 1+  cairoOneStrokeSelected str++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+++++{-  +  canvas page vinfo mbbox = do +    let arr = get pageArrangement 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   ++-}++{-             +             do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+      page = (gcast tpg :: Page EditMode)+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  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   +-}+++{-  +canvas page vinfo mbbox = do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  let mbboxnew = adjustBBoxWithView geometry zmode mbbox+  win <- widgetGetDrawWindow canvas+  let xformfunc = transformForPageCoord geometry zmode+  let renderfunc = do   +        xformfunc +        cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) +        return ()+  doubleBuffering win geometry xformfunc renderfunc   -}++++-- | obsolete+{-+data CanvasPageGeometry = +  CanvasPageGeometry { screen_size :: (Double,Double) +                     , canvas_size :: (Double,Double)+                     , page_size :: (Double,Double)+                     , canvas_origin :: (Double,Double) +                     , page_origin :: (Double,Double)+                     }+  deriving (Show)  +++-- | obsolete                            ++type PageDrawF = DrawingArea -> Page EditMode +                 -> ViewInfo SinglePage -> Maybe BBox -> IO ()++-- | obsolete++type PageDrawFSel = DrawingArea -> Page SelectMode -> ViewInfo SinglePage -> Maybe BBox -> IO ()+++-- | obsolete ++getCanvasPageGeometry :: DrawingArea +                         -> GPage b s a+                         -> (Double,Double) +                         -> IO CanvasPageGeometry+getCanvasPageGeometry canvas page (xorig,yorig) = do +  win <- widgetGetDrawWindow canvas+  (w',h') <- widgetGetSize canvas+  screen <- widgetGetScreen canvas+  (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen+  let (Dim w h) = gdimension page+  (x0,y0) <- drawWindowGetOrigin win+  return $ CanvasPageGeometry (fromIntegral ws, fromIntegral hs) +                              (fromIntegral w', fromIntegral h') +                              (w,h) +                              (fromIntegral x0,fromIntegral y0)+                              (xorig, yorig)++-- | obsolete++visibleViewPort :: CanvasPageGeometry -> ZoomMode -> BBox  +visibleViewPort cpg@(CanvasPageGeometry (_ws,_hs) (w',h') (_w,_h) (_x0,_y0) (xorig,yorig)) zmode = +  let (xend,yend) = canvasToPageCoord cpg zmode (w',h')+  in  BBox (xorig,yorig) (xend,yend)+++-- | obsolete ++core2pageCoord :: CanvasPageGeometry -> ZoomMode +                  -> (Double,Double) -> (Double,Double)+core2pageCoord cpg@(CanvasPageGeometry (_ws,_hs) (_w',_h') (_w,_h) (_x0,_y0) (xorig,yorig))+               zmode (px,py) = +  let s =  1.0 / getRatioFromPageToCanvas cpg zmode +      (xo,yo) = case zmode of+                  Original -> (xorig,yorig)+                  FitWidth -> (0,yorig)+                  FitHeight -> (xorig,0)+                  _ -> error "not implemented yet in core2pageCoord"+  in (px*s+xo, py*s+yo)+  +-- | obsolete      ++wacom2pageCoord :: CanvasPageGeometry +                   -> ZoomMode +                   -> (Double,Double) +                   -> (Double,Double)+wacom2pageCoord cpg@(CanvasPageGeometry (ws,hs) (_w',_h') (_w,_h) (x0,y0) (xorig,yorig)) +                zmode +                (px,py) +  = let (x1,y1) = (ws*px-x0,hs*py-y0)+        s = 1.0 / getRatioFromPageToCanvas cpg zmode+        (xo,yo) = case zmode of+                    Original -> (xorig,yorig)+                    FitWidth -> (0,yorig)+                    FitHeight -> (xorig,0)+                    _ -> error "not implemented wacom2pageCoord"+    in  (x1*s+xo,y1*s+yo)++-- | obsolete ++device2pageCoord :: CanvasPageGeometry +                 -> ZoomMode +                 -> PointerCoord  +                 -> (Double,Double)+device2pageCoord cpg zmode pcoord@(PointerCoord _ _ _)  = + let (px,py) = (,) <$> pointerX <*> pointerY $ pcoord  + in case pointerType pcoord of +      Core -> core2pageCoord  cpg zmode (px,py)+      _    -> wacom2pageCoord cpg zmode (px,py)+device2pageCoord _ _ NoPointerCoord = (-100,-100)++-- | obsolete ++pageToCanvasCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double)+pageToCanvasCoord cpg@(CanvasPageGeometry _ _ _ _ (xorig,yorig)) zmode (x,y) = +  let s = getRatioFromPageToCanvas cpg zmode+      (xo,yo) = case zmode of +                  Original -> (xorig,yorig)+                  FitWidth -> (0,yorig)+                  FitHeight -> (xorig,0)+                  _ -> error "not implemented yet in pageToScreenCoord"+  in ((x-xo)*s,(y-yo)*s)++-- | obsolete ++canvasToPageCoord :: CanvasPageGeometry -> ZoomMode -> (Double,Double) -> (Double,Double) +canvasToPageCoord = core2pageCoord++-- | obsolete++transformForPageCoord :: CanvasPageGeometry -> ZoomMode -> Render ()+transformForPageCoord cpg zmode = do +  let (xo,yo) = page_origin cpg+  let s = getRatioFromPageToCanvas cpg zmode  +  scale s s+  translate (-xo) (-yo)      +  +++  +  +                     ++drawBBoxOnly :: PageDrawF+drawBBoxOnly canvas page vinfo _mbbox = do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) $ vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  let xformfunc = transformForPageCoord geometry zmode+      renderfunc = do +        cairoRenderOption (DrawWhite,DrawBoxOnly) (gcast page :: TPageBBoxMapPDF)+  doubleBuffering win geometry xformfunc renderfunc   +++-- | obsolete++adjustBBoxWithView :: CanvasPageGeometry -> ZoomMode -> Maybe BBox +                      -> Maybe BBox+adjustBBoxWithView geometry zmode mbbox =   +  let viewbbox = visibleViewPort geometry zmode+  in  toMaybe $ (fromMaybe mbbox :: IntersectBBox)  +                `mappend` +                (Intersect (Middle viewbbox))+++++drawPageInBBox :: PageDrawF +drawPageInBBox canvas page vinfo mbbox = do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox .get (viewPortBBox.pageArrangement) $ vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  let mbboxnew = adjustBBoxWithView geometry zmode mbbox+      xformfunc = transformForPageCoord geometry zmode+      renderfunc = do +        cairoRenderOption (InBBoxOption mbboxnew) (InBBox page) +        return ()+  doubleBuffering win geometry xformfunc renderfunc   +++-- | deprecated++drawBBox :: PageDrawF +drawBBox _ _ _ Nothing = return ()+drawBBox canvas page vinfo (Just bbox) = do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  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 +  let page = (gcast tpg :: Page EditMode)+  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  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 (Just _) = do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  let xformfunc = transformForPageCoord geometry zmode+      renderbelow = do+        transformForPageCoord geometry zmode+        cairoRenderOption  (InBBoxOption Nothing) (InBBox page)+      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)+    ++++-- |++drawSelTempBBox :: BBox -> PageDrawFSel +drawSelTempBBox _bbox _ _ _ Nothing = return ()+drawSelTempBBox bbox canvas tpg vinfo mbbox@(Just _) = do +  let page = (gcast tpg :: Page EditMode)+  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  let xformfunc = transformForPageCoord geometry zmode+      renderbelow = do+        cairoRenderOption (InBBoxOption Nothing) (InBBox page)+        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)+++++-- | obsolete ++getRatioFromPageToCanvas :: CanvasPageGeometry -> ZoomMode -> Double +getRatioFromPageToCanvas _cpg Original = 1.0 +getRatioFromPageToCanvas cpg FitWidth = +  let (w,_)  = page_size cpg +      (w',_) = canvas_size cpg +  in  w'/w+getRatioFromPageToCanvas cpg FitHeight = +  let (_,h)  = page_size cpg +      (_,h') = canvas_size cpg +  in  h'/h+getRatioFromPageToCanvas _cpg (Zoom s) = s ++-- | +++-- | obsolete ++drawSegment :: DrawingArea+               -> CanvasPageGeometry +               -> ZoomMode +               -> Double +               -> (Double,Double,Double,Double) +               -> (Double,Double) +               -> (Double,Double) +               -> IO () +drawSegment canvas cpg zmode wdth (r,g,b,a) (x0,y0) (x,y) = do +  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord cpg zmode+    setSourceRGBA r g b a+    setLineWidth wdth+    moveTo x0 y0+    lineTo x y+    stroke+  ++showBBox :: DrawingArea -> CanvasPageGeometry -> ZoomMode -> BBox -> IO ()+showBBox canvas cpg zmode (BBox (ulx,uly) (lrx,lry)) = do +  win <- widgetGetDrawWindow canvas+  renderWithDrawable win $ do+    transformForPageCoord cpg zmode+    setSourceRGBA 0.0 1.0 0.0 1.0 +    setLineWidth  1.0 +    rectangle ulx uly (lrx-ulx) (lry-uly)    +    stroke+  return ()++dummyDraw :: PageDrawFSel +dummyDraw _canvas _pgslct _vinfo _mbbox = do +  putStrLn "dummy draw"+  return ()+  +  +drawSelectionInBBox :: PageDrawFSel +drawSelectionInBBox canvas tpg vinfo mbbox = do +  let zmode  = get zoomMode vinfo+      BBox origin _ = unViewPortBBox $ get (viewPortBBox.pageArrangement) vinfo+      page = (gcast tpg :: Page EditMode)+  geometry <- getCanvasPageGeometry canvas page origin+  win <- widgetGetDrawWindow canvas+  let mbboxnew = adjustBBoxWithView geometry zmode mbbox+  let xformfunc = transformForPageCoord geometry zmode+      renderfunc = do+        xformfunc +        cairoRenderOption (InBBoxOption mbboxnew) (InBBox page)+        cairoHittedBoxDraw tpg mbboxnew  +  doubleBuffering win geometry xformfunc renderfunc   +    +  ++---- +    ++-- | obsolete ++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 +      xform+      paint +  +  +-- |   ++ ++-}+{-+type instance PageDrawingFunction SinglePage SelectMode = +  DrawingArea -> (PageNum, Page SelectMode) -> ViewInfo SinglePage -> Maybe BBox -> IO ()+++type instance PageDrawingFunction ContinuousSinglePage EditMode = +  DrawingArea -> Xournal EditMode -> ViewInfo ContinuousSinglePage -> Maybe BBox -> IO ()+  +type instance PageDrawingFunction ContinuousSinglePage SelectMode = +  DrawingArea -> Xournal SelectMode -> ViewInfo ContinuousSinglePage -> Maybe BBox -> IO ()++-}++{- type PageDrawingFunction v a = +       DrawingArea -> (PageNum,Page a) -> ViewInfo v -> Maybe BBox -> IO () -}++{-                           +type PageDrawingFunctionForSelection +      = DrawingArea -> (PageNum,Page SelectMode) -> ViewInfo SinglePage -> Maybe BBox -> IO ()+-}+