hxournal 0.6.5.0 → 0.6.6
raw patch · 38 files changed
+757/−939 lines, 38 filesdep +dyredep ~xournal-render
Dependencies added: dyre
Dependency ranges changed: xournal-render
Files
- CHANGES +3/−0
- exe/hxournal.hs +24/−7
- hxournal.cabal +11/−7
- lib/Application/HXournal/Accessor.hs +6/−30
- lib/Application/HXournal/Command.hs +5/−4
- lib/Application/HXournal/Coroutine/Commit.hs +5/−0
- lib/Application/HXournal/Coroutine/Default.hs +18/−15
- lib/Application/HXournal/Coroutine/Draw.hs +3/−13
- lib/Application/HXournal/Coroutine/Eraser.hs +4/−7
- lib/Application/HXournal/Coroutine/EventConnect.hs +12/−0
- lib/Application/HXournal/Coroutine/File.hs +76/−42
- lib/Application/HXournal/Coroutine/Highlighter.hs +2/−0
- lib/Application/HXournal/Coroutine/Page.hs +69/−24
- lib/Application/HXournal/Coroutine/Pen.hs +1/−6
- lib/Application/HXournal/Coroutine/Scroll.hs +6/−3
- lib/Application/HXournal/Coroutine/Select.hs +5/−6
- lib/Application/HXournal/GUI.hs +6/−3
- lib/Application/HXournal/GUI/Menu.hs +65/−43
- lib/Application/HXournal/Job.hs +5/−3
- lib/Application/HXournal/ModelAction/Adjustment.hs +10/−2
- lib/Application/HXournal/ModelAction/File.hs +3/−17
- lib/Application/HXournal/ModelAction/Page.hs +27/−83
- lib/Application/HXournal/ModelAction/Pen.hs +29/−40
- lib/Application/HXournal/ModelAction/Select.hs +36/−10
- lib/Application/HXournal/ModelAction/Window.hs +2/−107
- lib/Application/HXournal/Script.hs +43/−0
- lib/Application/HXournal/Script/Coroutine.hs +47/−0
- lib/Application/HXournal/Script/Hook.hs +23/−0
- lib/Application/HXournal/StartUp.hs +71/−0
- lib/Application/HXournal/Type/Clipboard.hs +14/−1
- lib/Application/HXournal/Type/Enum.hs +11/−0
- lib/Application/HXournal/Type/Event.hs +3/−0
- lib/Application/HXournal/Type/PageArrangement.hs +45/−3
- lib/Application/HXournal/Type/Predefined.hs +17/−1
- lib/Application/HXournal/Type/XournalState.hs +19/−1
- lib/Application/HXournal/Util.hs +13/−1
- lib/Application/HXournal/View/Coordinate.hs +2/−5
- lib/Application/HXournal/View/Draw.hs +16/−455
CHANGES view
@@ -25,3 +25,6 @@ 0.6.5: 12 Feb 2012 * pen button support, pen pressure support, using faster xoj parser ++0.6.6: 28 Feb 2012 + * scripting support, zoom in/out implemented. page functions are implemented
exe/hxournal.hs view
@@ -1,13 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- Copyright : (c) 2011, 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------+ module Main where -import System.Console.CmdArgs+-- import System.Console.CmdArgs -import Application.HXournal.ProgType-import Application.HXournal.Command+-- import Application.HXournal.ProgType+-- import Application.HXournal.Command +import Application.HXournal.Script +import Application.HXournal.StartUp+ main :: IO () -main = do - putStrLn "hxournal"- param <- cmdArgs mode+main = hxournalStartMain defaultScriptConfig - commandLineProcess param+-- startUp+-- do +-- putStrLn "hxournal"+-- param <- cmdArgs mode+-- commandLineProcess param
hxournal.cabal view
@@ -1,5 +1,5 @@ Name: hxournal-Version: 0.6.5.0+Version: 0.6.6 Synopsis: A pen notetaking program written in haskell Description: notetaking program written in haskell and gtk2hs Homepage: http://ianwookim.org/hxournal@@ -62,7 +62,8 @@ poppler == 0.12.*, time == 1.2.*, TypeCompose == 0.9.*, - Diff == 0.1.*+ Diff == 0.1.*, + dyre == 0.8.* else Build-Depends: base == 4.*, mtl == 2.*,@@ -75,7 +76,7 @@ transformers == 0.2.*, xournal-types == 0.4.*, xournal-parser == 0.4.*,- xournal-render == 0.6.*,+ xournal-render >= 0.6.0 && < 0.7, xournal-builder >= 0.1.1 && < 0.2, containers == 0.4.*, template-haskell == 2.*,@@ -86,10 +87,13 @@ configurator == 0.2.*, time == 1.2.*, TypeCompose == 0.9.*, - Diff == 0.1.*--+ Diff == 0.1.*, + dyre == 0.8.* Exposed-Modules: + Application.HXournal.StartUp+ Application.HXournal.Script+ Application.HXournal.Script.Hook+ Application.HXournal.Script.Coroutine Application.HXournal.ProgType Application.HXournal.Job Application.HXournal.Command @@ -140,7 +144,7 @@ Application.HXournal.Device Application.HXournal.Accessor Application.HXournal.Config-+-- Paths_hxournal Other-Modules: Paths_hxournal c-sources:
lib/Application/HXournal/Accessor.hs view
@@ -49,7 +49,6 @@ updateXState :: (HXournalState -> MainCoroutine HXournalState) -> MainCoroutine () updateXState action = putSt =<< action =<< getSt - -- | getPenType :: MainCoroutine PenType @@ -75,8 +74,6 @@ case cinfobox of CanvasInfoBox cinfo -> return (getCurrentPageFromXojState cinfo xojstate) -- -- | getCurrentPageEitherFromXojState :: (ViewMode a) => @@ -93,9 +90,7 @@ Just (n,tpage) -> if cpn == n then Right tpage else Left page- - -- | getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox] @@ -112,10 +107,11 @@ currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer return (get g_bstrokes currlayer) +-- |+ otherCanvas :: HXournalState -> [Int] otherCanvas = M.keys . getCanvasInfoMap - -- | changeCurrentCanvasId :: CanvasId -> MainCoroutine HXournalState @@ -131,7 +127,6 @@ reflectUI ui cinfo return xst - -- | reflect UI for current canvas info reflectUI :: UIManager -> CanvasInfoBox -> MainCoroutine ()@@ -158,6 +153,7 @@ liftIO $ putStrLn $ show (unboxGet (viewPortBBox.pageArrangement.viewInfo) cvsInfo) -- | + printViewPortBBoxAll :: MainCoroutine () printViewPortBBoxAll = do xstate <- getSt @@ -178,19 +174,8 @@ printModes cid = do cvsInfo <- return . getCanvasInfo cid =<< getSt liftIO $ printCanvasMode cid cvsInfo-{- let zmode = unboxGet (zoomMode.viewInfo) cvsInfo- f :: PageArrangement a -> String - f (SingleArrangement _ _ _) = "SingleArrangement"- f (ContinuousSingleArrangement _ _ _ _) = "ContinuousSingleArrangement" - g :: CanvasInfo a -> String - g cinfo = f . get (pageArrangement.viewInfo) $ cinfo- - arrmode :: String - arrmode = boxAction g cvsInfo - - incid = unboxGet canvasId cvsInfo - liftIO $ putStrLn $ show (cid,incid,zmode,arrmode) -}+-- | printCanvasMode :: CanvasId -> CanvasInfoBox -> IO () printCanvasMode cid cvsInfo = do @@ -198,30 +183,21 @@ f :: PageArrangement a -> String f (SingleArrangement _ _ _) = "SingleArrangement" f (ContinuousSingleArrangement _ _ _ _) = "ContinuousSingleArrangement"- g :: CanvasInfo a -> String g cinfo = f . get (pageArrangement.viewInfo) $ cinfo- arrmode :: String arrmode = boxAction g cvsInfo - incid = unboxGet canvasId cvsInfo putStrLn $ show (cid,incid,zmode,arrmode) -+-- |+ printModesAll :: MainCoroutine () printModesAll = do xstate <- getSt let cmap = getCanvasInfoMap xstate cids = M.keys cmap mapM_ printModes cids ----- | -{--unboxGetPage :: CanvasInfoBox -> (Page EditMode) -unboxGetPage = either id (gcast :: Page SelectMode -> Page EditMode) . unboxGet currentPage--} -- |
lib/Application/HXournal/Command.hs view
@@ -8,15 +8,16 @@ -- Stability : experimental -- Portability : GHC --+----------------------------------------------------------------------------- module Application.HXournal.Command where import Application.HXournal.ProgType import Application.HXournal.Job+import Application.HXournal.Script.Hook -commandLineProcess :: Hxournal -> IO ()-commandLineProcess (Test mfname) = do - putStrLn "test called"- startJob mfname+commandLineProcess :: Hxournal -> Maybe Hook -> IO ()+commandLineProcess (Test mfname) mhook = do + startJob mfname mhook
lib/Application/HXournal/Coroutine/Commit.hs view
@@ -37,6 +37,11 @@ putSt xstate' -- | + +commit_ :: MainCoroutine ()+commit_ = getSt >>= commit ++-- | undo :: MainCoroutine () undo = do
lib/Application/HXournal/Coroutine/Default.hs view
@@ -17,12 +17,14 @@ import Graphics.UI.Gtk hiding (get,set) import Application.HXournal.Type.Event+import Application.HXournal.Type.Enum import Application.HXournal.Type.Coroutine 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.Script import Application.HXournal.Coroutine.Callback import Application.HXournal.Coroutine.Commit import Application.HXournal.Coroutine.Draw@@ -80,7 +82,6 @@ guiProcess = do initialize liftIO $ putStrLn "hi!"- liftIO $ putStrLn "welcome to hxournal" changePage (const 0) xstate <- initViewModeIOAction @@ -113,20 +114,18 @@ ui <- getMenuUI tref sref putStrLn "hi" let st1 = set gtkUIManager ui st0new-- -- (initcvstemp :: CanvasInfo SinglePage) <- initCanvasInfo st1 1 - let initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } - let initcvsbox = CanvasInfoBox initcvs+ initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } + initcvsbox = CanvasInfoBox initcvs st2 = set frameState (Node 1) . updateFromCanvasInfoAsCurrentCanvas initcvsbox $ st1 { _cvsInfoMap = M.empty } (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 @@ -141,11 +140,6 @@ dispatchMode = getSt >>= return . xojstateEither . get xournalstate >>= either (const viewAppendMode) (const selectMode) -{- xojstate <- return . get xournalstate =<< getSt - case xojstate of - ViewAppendState _ -> viewAppendMode- SelectState _ -> selectMode -}- -- | viewAppendMode :: MainCoroutine () @@ -166,6 +160,8 @@ _ -> return () _ -> defaultEventProcess r1 +-- |+ selectMode :: MainCoroutine () selectMode = do r1 <- await @@ -181,6 +177,7 @@ _ -> defaultEventProcess r1 +-- | defaultEventProcess :: MyEvent -> MainCoroutine () defaultEventProcess (UpdateCanvas cid) = invalidate cid @@ -191,13 +188,14 @@ defaultEventProcess PaneMoveStart = paneMoveStart defaultEventProcess (CanvasConfigure cid w' h') = doCanvasConfigure 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 () askQuitProgram = do dialog <- liftIO $ messageDialogNew Nothing [DialogModal] @@ -212,6 +210,8 @@ liftIO $ widgetDestroy dialog return () +-- |+ menuEventProcess :: MenuEvent -> MainCoroutine () menuEventProcess MenuQuit = do xstate <- getSt@@ -226,7 +226,9 @@ totalnumofpages <- (either (M.size. get g_pages) (M.size . get g_selectAll) . xojstateEither . get xournalstate) <$> getSt changePage (const (totalnumofpages-1))-menuEventProcess MenuNewPageBefore = return () -- newPageBefore +menuEventProcess MenuNewPageBefore = newPage PageBefore +menuEventProcess MenuNewPageAfter = newPage PageAfter+menuEventProcess MenuDeletePage = deleteCurrentPage menuEventProcess MenuNew = askIfSave fileNew menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF menuEventProcess MenuUndo = undo @@ -240,6 +242,8 @@ menuEventProcess MenuDelete = deleteSelection -- menuEventProcess MenuNetCopy = clipCopyToNetworkClipboard -- menuEventProcess MenuNetPaste = clipPasteFromNetworkClipboard+menuEventProcess MenuZoomIn = pageZoomChangeRel ZoomIn +menuEventProcess MenuZoomOut = pageZoomChangeRel ZoomOut menuEventProcess MenuNormalSize = pageZoomChange Original menuEventProcess MenuPageWidth = pageZoomChange FitWidth menuEventProcess MenuPageHeight = pageZoomChange FitHeight@@ -251,7 +255,6 @@ menuEventProcess MenuPrevLayer = gotoPrevLayer menuEventProcess MenuGotoLayer = startGotoLayerAt menuEventProcess MenuDeleteLayer = deleteCurrentLayer- menuEventProcess MenuUseXInput = do xstate <- getSt let ui = get gtkUIManager xstate @@ -268,7 +271,6 @@ if b then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases- menuEventProcess MenuPressureSensitivity = updateXState pressSensAction where pressSensAction xstate = do let ui = get gtkUIManager xstate @@ -281,6 +283,7 @@ (return . castToToggleAction) b <- liftIO $ toggleActionGetActive pressrsensa return (set (variableWidthPen.penInfo) b xstate) +menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m
lib/Application/HXournal/Coroutine/Draw.hs view
@@ -32,6 +32,8 @@ import Graphics.UI.Gtk hiding (get,set) import Application.HXournal.Type.Alias +-- |+ data DrawingFunctionSet = DrawingFunctionSet { singleEditDraw :: DrawingFunction SinglePage EditMode , singleSelectDraw :: DrawingFunction SinglePage SelectMode@@ -39,7 +41,6 @@ , contSelectDraw :: DrawingFunction ContinuousSinglePage SelectMode } - -- | invalidateGeneral :: CanvasId -> Maybe BBox @@ -75,7 +76,7 @@ SelectState txoj -> liftIO (unContPageDraw drawcontsel isCurrentCvs cvsInfo mbbox txoj) - +-- | invalidateOther :: MainCoroutine () invalidateOther = do @@ -85,15 +86,11 @@ keys = M.keys cinfoMap mapM_ invalidate (filter (/=currCvsId) keys) - -- | invalidate clear invalidate :: CanvasId -> MainCoroutine () invalidate = invalidateInBBox Nothing -{- invalidateGeneral cid Nothing - drawPageClearly drawPageSelClearly drawContXojClearly drawContXojSelClearly-} - -- | invalidateInBBox :: Maybe BBox -- ^ desktop coord@@ -117,8 +114,6 @@ invalidateAll :: MainCoroutine () invalidateAll = invalidateAllInBBox Nothing -- -- | Invalidate Current canvas invalidateCurrent :: MainCoroutine () @@ -143,7 +138,6 @@ xformfunc rndr - -- | Drawing temporary gadgets with coordinate based on base page invalidateTempBasePage :: CanvasId -> Surface -> PageNum -> Render () @@ -168,14 +162,12 @@ 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 () @@ -183,5 +175,3 @@ currcid <- liftM (getCurrentCanvasId) getSt when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) --
lib/Application/HXournal/Coroutine/Eraser.hs view
@@ -28,9 +28,7 @@ import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.Eraser import Application.HXournal.ModelAction.Layer- import Data.Xournal.Generic- import Data.Xournal.BBox import Graphics.Xournal.Render.HitTest import Graphics.Xournal.Render.BBoxMapPDF@@ -43,6 +41,8 @@ import Prelude hiding ((.), id) import Application.HXournal.Coroutine.Pen +-- |+ eraserStart :: CanvasId -> PointerCoord -> MainCoroutine () @@ -51,6 +51,8 @@ strs <- getAllStrokeBBoxInCurrentLayer eraserProcess cid pnum geometry cidup cidmove strs (x,y) +-- |+ eraserProcess :: CanvasId -> PageNum -> CanvasGeometry@@ -94,8 +96,3 @@ 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
@@ -8,6 +8,8 @@ -- Stability : experimental -- Portability : GHC --+-----------------------------------------------------------------------------+ module Application.HXournal.Coroutine.EventConnect where import Graphics.UI.Gtk hiding (get,set,disconnect)@@ -26,21 +28,29 @@ import Data.Label import Prelude hiding ((.), id) +-- |+ disconnect :: (WidgetClass w) => ConnectId w -> MainCoroutine () disconnect = liftIO . signalDisconnect +-- |+ connectPenUp :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea) connectPenUp cinfo = do let cid = get canvasId cinfo canvas = get drawArea cinfo connPenUp canvas cid +-- |+ 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) connPenMove c cid = do callbk <- get callBack <$> getSt@@ -49,6 +59,8 @@ (_,p) <- getPointer dev liftIO (callbk (PenMove cid p))) +-- | + connPenUp :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w) connPenUp c cid = do callbk <- get callBack <$> getSt
lib/Application/HXournal/Coroutine/File.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Coroutine.File @@ -20,11 +22,13 @@ import Application.HXournal.ModelAction.Window import Application.HXournal.ModelAction.Page import Application.HXournal.ModelAction.File+import Application.HXournal.Script.Hook+import qualified Application.HXournal.Script.Coroutine as S import Text.Xournal.Builder import Control.Monad.Trans import Control.Applicative import Data.Xournal.Generic-+import Data.ByteString.Char8 as B (pack) import Graphics.UI.Gtk hiding (get,set) import Control.Category import Data.Label@@ -32,10 +36,12 @@ import qualified Data.ByteString.Lazy as L import Data.Xournal.Simple-- import System.Directory+import System.FilePath+import Debug.Trace +-- | + askIfSave :: MainCoroutine () -> MainCoroutine () askIfSave action = do xstate <- getSt @@ -52,6 +58,8 @@ return () else action +-- | + fileNew :: MainCoroutine () fileNew = do xstate <- getSt@@ -62,6 +70,7 @@ commit xstate'' invalidateAll +-- | fileSave :: MainCoroutine () fileSave = do @@ -77,12 +86,12 @@ putSt . set isSaved True $ xstate let ui = get gtkUIManager xstate liftIO $ toggleSave ui False+ S.afterSaveHook xoj -- | main coroutine for open a file fileOpen :: MainCoroutine () fileOpen = do - liftIO $ putStrLn "file open clicked" cwd <- liftIO getCurrentDirectory dialog <- liftIO $ fileChooserDialogNew Nothing Nothing FileChooserActionOpen @@ -97,7 +106,6 @@ case mfilename of Nothing -> return () Just filename -> do - liftIO $ putStrLn $ show filename xstate <- getSt xstate' <- liftIO $ getFileContent (Just filename) xstate ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate')@@ -116,47 +124,64 @@ fileSaveAs :: MainCoroutine () fileSaveAs = do - liftIO $ putStrLn "file save as clicked"- cwd <- liftIO getCurrentDirectory- dialog <- liftIO $ fileChooserDialogNew Nothing Nothing - FileChooserActionSave - [ ("OK", ResponseOk) - , ("Cancel", ResponseCancel) ]- liftIO $ fileChooserSetCurrentFolder dialog cwd - res <- liftIO $ dialogRun dialog- case res of - ResponseDeleteEvent -> liftIO $ widgetDestroy dialog- ResponseOk -> do- mfilename <- liftIO $ fileChooserGetFilename dialog - case mfilename of - Nothing -> return () - Just filename -> do - liftIO $ putStrLn $ show filename - xstate <- getSt - let xstateNew = set currFileName (Just filename) xstate - let xojstate = get xournalstate xstateNew- let xoj = case xojstate of - ViewAppendState xojmap -> Xournal - <$> get g_title - <*> gToList . fmap (toPageFromBuf gToBackground) . get g_pages - $ xojmap - SelectState txoj -> Xournal <$> gselectTitle <*> gToList . fmap (toPageFromBuf gToBackground) . gselectAll $ txoj - liftIO . L.writeFile filename . builder $ xoj- putSt . set isSaved True $ xstateNew - let ui = get gtkUIManager xstateNew- liftIO $ toggleSave ui False- liftIO $ setTitleFromFileName xstateNew - liftIO $ widgetDestroy dialog- ResponseCancel -> liftIO $ widgetDestroy dialog- _ -> error "??? in fileSaveAs"- return ()-+ xstate <- getSt + let xojstate = get xournalstate xstate+ let xoj = case xojstate of + ViewAppendState xojmap -> gcast xojmap+ SelectState txoj -> gcast txoj+ maybe (defSaveAsAction xstate xoj) (\f -> liftIO (f xoj))+ (hookSaveAsAction xstate) + where + hookSaveAsAction xstate = do + hset <- get hookSet xstate+ saveAsHook hset+ defSaveAsAction xstate xoj = do + cwd <- liftIO getCurrentDirectory+ dialog <- liftIO $ fileChooserDialogNew Nothing Nothing + FileChooserActionSave + [ ("OK", ResponseOk) + , ("Cancel", ResponseCancel) ]+ liftIO $ fileChooserSetCurrentFolder dialog cwd + res <- liftIO $ dialogRun dialog+ case res of + ResponseDeleteEvent -> liftIO $ widgetDestroy dialog+ ResponseOk -> do+ mfilename <- liftIO $ fileChooserGetFilename dialog + case mfilename of + Nothing -> return () + Just filename -> do + let ntitle = B.pack . snd . splitFileName $ filename + let (xojstate',xoj') = case get xournalstate xstate of+ ViewAppendState xojmap -> + if get g_title xojmap == "untitled"+ then ( ViewAppendState . set g_title ntitle+ $ xojmap+ , (set s_title ntitle xoj))+ else (ViewAppendState xojmap,xoj)+ SelectState txoj -> + if gselectTitle txoj == "untitled"+ then ( SelectState $ + txoj { gselectTitle = ntitle }+ , set s_title ntitle xoj) + else (SelectState txoj,xoj)+ let xstateNew = set currFileName (Just filename) + . set xournalstate xojstate' $ xstate + liftIO . L.writeFile filename . builder $ xoj'+ putSt . set isSaved True $ xstateNew + let ui = get gtkUIManager xstateNew+ liftIO $ toggleSave ui False+ liftIO $ setTitleFromFileName xstateNew + S.afterSaveHook xoj'+ liftIO $ widgetDestroy dialog+ ResponseCancel -> liftIO $ widgetDestroy dialog+ _ -> error "??? in fileSaveAs"+ return () +-- | fileAnnotatePDF :: MainCoroutine () fileAnnotatePDF = do xstate <- getSt- liftIO $ putStrLn "file annotate PDf clicked" cwd <- liftIO getCurrentDirectory dialog <- liftIO $ fileChooserDialogNew Nothing Nothing FileChooserActionOpen @@ -171,7 +196,6 @@ case mfilename of Nothing -> return () Just filename -> do - liftIO $ putStrLn $ show filename mxoj <- liftIO $ makeNewXojWithPDF filename flip (maybe (return ())) mxoj $ \xoj -> do xstateNew <- return . set currFileName Nothing @@ -183,3 +207,13 @@ ResponseCancel -> liftIO $ widgetDestroy dialog _ -> error "??? in fileOpen " return ()+++++ {- Xournal + <$> get g_title + <*> gToList . fmap (toPageFromBuf gToBackground) . get g_pages + $ xojmap -} + + {- Xournal <$> gselectTitle <*> gToList . fmap (toPageFromBuf gToBackground) . gselectAll $ txoj -}
lib/Application/HXournal/Coroutine/Highlighter.hs view
@@ -19,6 +19,8 @@ import Control.Monad.Trans +-- | + highlighterStart :: CanvasId -> PointerCoord -> MainCoroutine () highlighterStart cid pcoord = do liftIO $ putStrLn "highlighter started"
lib/Application/HXournal/Coroutine/Page.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE GADTs #-}+ ----------------------------------------------------------------------------- -- | -- Module : Application.HXournal.Coroutine.Page @@ -17,13 +19,13 @@ import Application.HXournal.Type.Canvas import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.XournalState+import Application.HXournal.Type.Enum import Application.HXournal.Util import Application.HXournal.View.Coordinate import Application.HXournal.Accessor import Application.HXournal.Coroutine.Draw import Application.HXournal.Coroutine.Commit import Application.HXournal.Coroutine.Scroll--- import Application.HXournal.ModelAction.Adjustment import Application.HXournal.ModelAction.Page import Application.HXournal.Type.Alias import Data.Xournal.Generic@@ -153,38 +155,81 @@ canvasZoomUpdate mzmode = do cid <- (liftM (getCurrentCanvasId) getSt) canvasZoomUpdateCvsId cid mzmode- - -- | pageZoomChange :: ZoomMode -> MainCoroutine () pageZoomChange = canvasZoomUpdate . Just -{-+-- | +pageZoomChangeRel :: ZoomModeRel -> MainCoroutine () +pageZoomChangeRel rzmode = do + boxAction fsingle . get currentCanvasInfo =<< getSt + where + fsingle :: (ViewMode a) => CanvasInfo a -> MainCoroutine ()+ fsingle cinfo = do + let czmode = get (zoomMode.viewInfo) cinfo + cpn = PageNum (get currentPageNum cinfo)+ arr = get (pageArrangement.viewInfo) cinfo + canvas = get drawArea cinfo + geometry <- liftIO $ makeCanvasGeometry cpn arr canvas+ let nratio = relZoomRatio geometry rzmode+ pageZoomChange (Zoom nratio)+ -- | -newPageBefore :: MainCoroutine () -newPageBefore = do - liftIO $ putStrLn "newPageBefore called"- xstate <- getSt- let xojstate = get xournalstate xstate- case xojstate of - ViewAppendState xoj -> do - liftIO $ putStrLn " In View " - let currCvsId = get currentCanvas xstate - mcurrCvsInfo = M.lookup currCvsId (get canvasInfoMap xstate)- xoj' <- maybe (error $ "something wrong in newPageBefore")- (liftIO . newPageBeforeAction xoj)- $ (,) <$> pure currCvsId <*> mcurrCvsInfo - let xstate' = updatePageAll (ViewAppendState xoj')- . set xournalstate (ViewAppendState xoj') - $ xstate - commit xstate'- invalidate currCvsId - SelectState txoj -> liftIO $ putStrLn " In Select State, this is not implemented yet."+newPage :: AddDirection -> MainCoroutine () +newPage dir = updateXState npgBfrAct + >> commit_ + >> canvasZoomUpdateAll + >> invalidateAll+ where + npgBfrAct xst = boxAction (fsimple xst) . get currentCanvasInfo $ xst+ fsimple :: (ViewMode a) => HXournalState -> CanvasInfo a + -> MainCoroutine HXournalState+ fsimple xstate cinfo = do + case get xournalstate xstate of + ViewAppendState xoj -> do + xoj' <- liftIO $ addNewPageInXoj dir xoj (get currentPageNum cinfo)+ return =<< liftIO . updatePageAll (ViewAppendState xoj')+ . set xournalstate (ViewAppendState xoj') $ xstate + SelectState _ -> do + liftIO $ putStrLn " not implemented yet"+ return xstate+ +-- | delete current page of current canvas+ +deleteCurrentPage :: MainCoroutine () +deleteCurrentPage = do + updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll+ where + delpgact xst = boxAction (fsimple xst) . get currentCanvasInfo $ xst+ fsimple :: (ViewMode a) => HXournalState -> CanvasInfo a+ -> MainCoroutine HXournalState+ fsimple xstate cinfo = do + let cpn = PageNum (get currentPageNum cinfo) + case get xournalstate xstate of + ViewAppendState xoj -> do + xoj' <- liftIO $ deletePageInXoj xoj + (PageNum (get currentPageNum cinfo))+ return =<< liftIO . updatePageAll (ViewAppendState xoj')+ . set xournalstate (ViewAppendState xoj') $ xstate + SelectState _ -> do + liftIO $ putStrLn " not implemented yet"+ return xstate+ +-- | delete designated page+ +deletePageInXoj :: Xournal EditMode -> PageNum -> IO (Xournal EditMode)+deletePageInXoj xoj (PageNum pgn) = do + putStrLn "deletePageInxoj is called"+ let pagelst = M.elems . get g_pages $ xoj + (pagesbefore,cpage:pagesafter) = splitAt pgn pagelst+ npage = newSinglePageFromOld cpage+ npagelst = pagesbefore ++ pagesafter+ nxoj = set g_pages (M.fromList . zip [0..] $ npagelst) xoj + return nxoj --}
lib/Application/HXournal/Coroutine/Pen.hs view
@@ -52,8 +52,7 @@ putSt xst return cinfo' where switchact xst = do - let -- xoj = getXournal xst- ncinfo = set currentPageNum (unPageNum pgn) cinfo + let ncinfo = set currentPageNum (unPageNum pgn) cinfo mfunc = const (return . CanvasInfoBox $ ncinfo) return . (,ncinfo) =<< modifyCurrCvsInfoM mfunc xst @@ -104,13 +103,9 @@ =<< (liftIO (updatePageAll (ViewAppendState newxoj) xstate)) let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord nbbox = xformBBox f bbox - -- invalidateAll invalidateAllInBBox (Just (inflate nbbox 2.0)) -- -- | main pen coordinate adding process- -- | now being changed penProcess :: CanvasId -> PageNum
lib/Application/HXournal/Coroutine/Scroll.hs view
@@ -21,13 +21,13 @@ import Application.HXournal.Coroutine.Draw import Application.HXournal.Accessor import Application.HXournal.View.Coordinate+import Application.HXournal.Util 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) -- | @@ -97,17 +97,20 @@ xst <- getSt geometry <- liftIO (getCanvasGeometryCvsId cid xst) case ev of- VScrollBarMoved _cid' v -> do + VScrollBarMoved cid' v -> do + when (cid /= cid') $ error "something wrong in vscrollMove" updateXState $ return.modifyCurrentCanvasInfo (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) invalidateWithBuf cid vscrollMove cid VScrollBarEnd cid' v -> do + when (cid /= cid') $ error "something wrong in vscrollMove" updateXState $ return.modifyCurrentCanvasInfo (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) invalidate cid' return ()- _ -> return () + VScrollBarStart cid v -> vscrollStart cid + other -> return () where scrollmovecanvas v cvsInfo = let BBox vm_orig _ = unViewPortBBox $ get (viewPortBBox.pageArrangement.viewInfo) cvsInfo in modify (viewPortBBox.pageArrangement.viewInfo)
lib/Application/HXournal/Coroutine/Select.hs view
@@ -136,7 +136,7 @@ (prev,otime) tempselection = do r <- await xst <- getSt - selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst+ boxAction (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo)@@ -234,7 +234,7 @@ (prev,otime) tempselection = do xst <- getSt r <- await - selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst + boxAction (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpInterPage r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) @@ -361,7 +361,7 @@ (prev,otime) tempselection = do xst <- getSt r <- await - selectBoxAction (fsingle r xst) (fsingle r xst) . getCanvasInfo cid $ xst+ boxAction (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 @@ -442,7 +442,7 @@ copySelection :: MainCoroutine () copySelection = updateXState copySelectionAction >> invalidateAll where copySelectionAction xst = - selectBoxAction (fsingle xst) (fsingle xst) . get currentCanvasInfo $ xst+ boxAction (fsingle xst) . get currentCanvasInfo $ xst fsingle xstate cinfo = maybe (return xstate) id $ do let xojstate = get xournalstate xstate let epage = getCurrentPageEitherFromXojState cinfo xojstate@@ -463,8 +463,7 @@ pasteToSelection :: MainCoroutine () pasteToSelection = modeChange ToSelectMode >> updateXState pasteAction >> invalidateAll - where pasteAction xst = - boxAction (fsimple xst) . get currentCanvasInfo $ xst+ where pasteAction xst = boxAction (fsimple xst) . get currentCanvasInfo $ xst fsimple xstate cinfo = do geometry <- liftIO (getGeometry4CurrCvs xstate) let pagenum = get currentPageNum cinfo
lib/Application/HXournal/GUI.hs view
@@ -28,6 +28,7 @@ -- import Application.HXournal.GUI.Menu import Application.HXournal.ModelAction.File import Application.HXournal.ModelAction.Window+import Application.HXournal.Script.Hook import Graphics.UI.Gtk hiding (get,set) import Control.Monad.Trans import Data.IORef@@ -38,8 +39,8 @@ -- | -startGUI :: Maybe FilePath -> IO () -startGUI mfname = do +startGUI :: Maybe FilePath -> Maybe Hook -> IO () +startGUI mfname mhook = do initGUI window <- windowNew @@ -51,7 +52,9 @@ \mmax -> maybe (return 50) (return . id) mmax -- ncconf <- getNetworkInfo cfg - let st1 = set undoTable (emptyUndo maxundo) st0 + let st1 = set hookSet mhook + . set undoTable (emptyUndo maxundo) + $ st0 -- let st1 = set gtkUIManager ui st0 putStrLn "before st2"
lib/Application/HXournal/GUI/Menu.hs view
@@ -31,9 +31,13 @@ import Data.Xournal.Predefined import Paths_hxournal +-- | + justMenu :: MenuEvent -> Maybe MyEvent justMenu = Just . Menu +-- |+ uiDeclTest :: String uiDeclTest = [verbatim|<ui> <menubar>@@ -47,6 +51,8 @@ </menubar> </ui>|] +-- | + uiDecl :: String uiDecl = [verbatim|<ui> <menubar>@@ -190,6 +196,7 @@ <separator /> <menuitem action="AUTOSAVEPREFA" /> <menuitem action="SAVEPREFA" />+ <menuitem action="RELAUNCHA" /> </menu> <menu action="HMA"> <menuitem action="ABOUTA" />@@ -284,11 +291,15 @@ , ("white.png" , "mywhite") ] +-- | + viewmods :: [RadioActionEntry] viewmods = [ RadioActionEntry "CONTA" "Continuous" Nothing Nothing Nothing 0 , RadioActionEntry "ONEPAGEA" "One Page" Nothing Nothing Nothing 1 ] +-- | + pointmods :: [RadioActionEntry] pointmods = [ RadioActionEntry "PENVERYFINEA" "Very fine" Nothing Nothing Nothing 0 , RadioActionEntry "PENFINEA" "Fine" (Just "mythin") Nothing Nothing 1@@ -299,6 +310,8 @@ , RadioActionEntry "PENMEDIUMA" "Medium" (Just "mymedium") Nothing Nothing 2 ] +-- | + penmods :: [RadioActionEntry] penmods = [ RadioActionEntry "PENA" "Pen" (Just "mypen") Nothing Nothing 0 , RadioActionEntry "ERASERA" "Eraser" (Just "myeraser") Nothing Nothing 1@@ -310,6 +323,8 @@ , RadioActionEntry "HANDA" "Hand Tool" (Just "myhand") Nothing Nothing 7 ] +-- | + colormods :: [RadioActionEntry] colormods = [ RadioActionEntry "BLUEA" "Blue" (Just "myblue") Nothing Nothing 1 , RadioActionEntry "REDA" "Red" (Just "myred") Nothing Nothing 2@@ -324,6 +339,8 @@ , RadioActionEntry "BLACKA" "Black" (Just "myblack") Nothing Nothing 0 ] +-- |+ iconResourceAdd :: IconFactory -> FilePath -> (FilePath, StockId) -> IO () iconResourceAdd iconfac resdir (fp,stid) = do @@ -338,31 +355,35 @@ iconSetAddSource myIconSet myIconSourceSmall iconFactoryAdd iconfac stid myIconSet -getMenuUI :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))- -> IORef HXournalState - -> IO UIManager-getMenuUI tref sref = do +-- | - let actionNewAndRegister :: String -> String +actionNewAndRegisterRef :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))+ -> IORef HXournalState+ -> String -> String -> Maybe String -> Maybe StockId -> Maybe MyEvent -> IO Action- actionNewAndRegister name label tooltip stockId myevent = do - a <- actionNew name label tooltip stockId - case myevent of - Nothing -> return a - Just ev -> do - a `on` actionActivated $ do - bouncecallback tref sref ev- return a- +actionNewAndRegisterRef tref sref name label tooltip stockId myevent = do + a <- actionNew name label tooltip stockId + case myevent of + Nothing -> return a + Just ev -> do + a `on` actionActivated $ do + bouncecallback tref sref ev+ return a++-- | ++getMenuUI :: IORef (Await MyEvent (Iteratee MyEvent XournalStateIO ()))+ -> IORef HXournalState + -> IO UIManager+getMenuUI tref sref = do + let actionNewAndRegister = actionNewAndRegisterRef tref sref -- icons myiconfac <- iconFactoryNew iconFactoryAddDefault myiconfac - resDir <- getDataDir >>= return . (</> "resource") mapM_ (iconResourceAdd myiconfac resDir) iconList - fma <- actionNewAndRegister "FMA" "File" Nothing Nothing Nothing ema <- actionNewAndRegister "EMA" "Edit" Nothing Nothing Nothing vma <- actionNewAndRegister "VMA" "View" Nothing Nothing Nothing@@ -392,12 +413,9 @@ -- netcopya <- actionNewAndRegister "NETCOPYA" "Copy to NetworkClipboard" (Just "Just a Stub") Nothing (justMenu MenuNetCopy) -- netpastea <- actionNewAndRegister "NETPASTEA" "Paste from NetworkClipboard" (Just "Just a Stub") Nothing (justMenu MenuNetPaste) - -- view menu-- fscra <- actionNewAndRegister "FSCRA" "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen)- zooma <- actionNewAndRegister "ZOOMA" "Zoom" (Just "Just a Stub") Nothing (justMenu MenuZoom)+ zooma <- actionNewAndRegister "ZOOMA" "Zoom" (Just "Just a Stub") Nothing Nothing -- (justMenu MenuZoom) zmina <- actionNewAndRegister "ZMINA" "Zoom In" (Just "Zoom In") (Just stockZoomIn) (justMenu MenuZoomIn) zmouta <- actionNewAndRegister "ZMOUTA" "Zoom Out" (Just "Zoom Out") (Just stockZoomOut) (justMenu MenuZoomOut) nrmsizea <- actionNewAndRegister "NRMSIZEA" "Normal Size" (Just "Normal Size") (Just stockZoom100) (justMenu MenuNormalSize)@@ -450,7 +468,8 @@ defhiltra <- actionNewAndRegister "DEFHILTRA" "Default Highlighter" (Just "Just a Stub") Nothing (justMenu MenuDefaultHighlighter) deftxta <- actionNewAndRegister "DEFTXTA" "Default Text" (Just "Just a Stub") Nothing (justMenu MenuDefaultText) setdefopta <- actionNewAndRegister "SETDEFOPTA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultOption)- + relauncha <- actionNewAndRegister "RELAUNCHA" "Relaunch Application" (Just "Just a Stub") Nothing (justMenu MenuRelaunch)+ -- options menu uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing uxinputa `on` actionToggled $ do @@ -488,9 +507,12 @@ agr <- actionGroupNew "AGR" mapM_ (actionGroupAddAction agr) [fma,ema,vma,jma,tma,oma,hma]+ mapM_ (actionGroupAddAction agr) + [ undoa, redoa, cuta, copya, pastea, deletea ] + -- actionGroupAddActionWithAccel agr undoa (Just "<control>z") mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing) [ newa, annpdfa, opena, savea, saveasa, recenta, printa, exporta, quita- , undoa, redoa, cuta, copya, pastea, deletea {- , netcopya, netpastea -}+ {- , netcopya, netpastea -} , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma , fstpagea, prvpagea, nxtpagea, lstpagea, shwlayera, hidlayera , hsplita, vsplita, delcvsa@@ -498,7 +520,7 @@ , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa , shpreca, rulera, clra, penopta , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta- , setdefopta+ , setdefopta, relauncha , dcrdcorea, ersrtipa, pghilta, mltpgvwa , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa @@ -520,9 +542,9 @@ let disabledActions = [ recenta, printa, exporta , cuta, copya, pastea, deletea- , fscra, zmina, zmouta, setzma+ , fscra, setzma , shwlayera, hidlayera- , newpgaa, newpgea, delpga, {- newlyra, dellyra, -} ppsizea, ppclra+ , newpgea, {- delpga, -} ppsizea, ppclra , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa , shpreca, rulera , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta@@ -537,58 +559,49 @@ [ opena, savea, saveasa, quita, fstpagea, prvpagea, nxtpagea, lstpagea , clra, penopta, zooma, nrmsizea, pgwdtha ]- + -- mapM_ (\x->actionSetSensitive x True) enabledActions mapM_ (\x->actionSetSensitive x False) disabledActions+ --+ + + -- + -- radio actions+ -- ui <- uiManagerNew uiManagerAddUiFromString ui uiDecl uiManagerInsertActionGroup ui agr 0 - -- Just ra1 <- actionGroupGetAction agr "ONEPAGEA" -- Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1] - Just ra2 <- actionGroupGetAction agr "PENFINEA" Gtk.set (castToRadioAction ra2) [radioActionCurrentValue := 2]- Just ra3 <- actionGroupGetAction agr "SELREGNA" actionSetSensitive ra3 True - Just ra4 <- actionGroupGetAction agr "VERTSPA" actionSetSensitive ra4 False- Just ra5 <- actionGroupGetAction agr "HANDA" actionSetSensitive ra5 False- Just ra6 <- actionGroupGetAction agr "CONTA" actionSetSensitive ra6 True- Just toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1" toolbarSetStyle (castToToolbar toolbar1) ToolbarIcons - Just toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2" 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 putStrLn "in assignmViewMode" printCanvasMode (getCurrentCanvasId st) (get currentCanvasInfo st) putStrLn "still in assignViewMode" viewModeToMyEvent a >>= bouncecallback tref 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 ()@@ -606,6 +619,7 @@ writeIORef sref stNew bouncecallback tref sref ToSelectMode +-- | assignColor :: IORef HXournalState -> RadioAction -> IO () assignColor sref a = do @@ -617,6 +631,8 @@ writeIORef sref stNew callback (PenColorChanged c) +-- | + assignPoint :: IORef HXournalState -> RadioAction -> IO () assignPoint sref a = do v <- radioActionGetCurrentValue a@@ -628,6 +644,8 @@ writeIORef sref stNew callback (PenWidthChanged w) +-- | + int2PenType :: Int -> Either PenType SelectType int2PenType 0 = Left PenWork int2PenType 1 = Left EraserWork@@ -639,6 +657,8 @@ int2PenType 7 = Right SelectHandToolWork int2PenType _ = error "No such pentype" +-- | + int2Point :: PenType -> Int -> Double int2Point PenWork 0 = predefined_veryfine int2Point PenWork 1 = predefined_fine@@ -665,6 +685,8 @@ int2Point TextWork 4 = predefined_verythick int2Point TextWork 5 = predefined_ultrathick int2Point _ _ = error "No such point"++-- | int2Color :: Int -> PenColor int2Color 0 = ColorBlack
lib/Application/HXournal/Job.hs view
@@ -13,15 +13,17 @@ module Application.HXournal.Job where +import Application.HXournal.Script.Hook+ import Application.HXournal.GUI -- import Application.HXournal.Builder -startJob :: Maybe FilePath -> IO () -startJob mfname = do +startJob :: Maybe FilePath -> Maybe Hook -> IO () +startJob mfname mhook = do putStrLn "job started"- startGUI mfname+ startGUI mfname mhook {- startTestBuilder :: FilePath -> IO ()
lib/Application/HXournal/ModelAction/Adjustment.hs view
@@ -39,15 +39,21 @@ adjustmentSetPageSize vadj (min ysize h) maybe (return ()) signalUnblock mconnidh maybe (return ()) signalUnblock mconnidv+ -- | -setAdjustments :: (Adjustment,Adjustment) +setAdjustments :: ((Adjustment,Maybe (ConnectId Adjustment))+ ,(Adjustment,Maybe (ConnectId Adjustment))) -> (Double,Double) -> (Double,Double) -> (Double,Double) -> (Double,Double) -> IO ()-setAdjustments (hadj,vadj) (upperx,uppery) (lowerx,lowery) (valuex,valuey) (pagex,pagey) = do +setAdjustments ((hadj,mconnidh),(vadj,mconnidv)) + (upperx,uppery) (lowerx,lowery) + (valuex,valuey) (pagex,pagey) = do + maybe (return ()) signalBlock mconnidh+ maybe (return ()) signalBlock mconnidv adjustmentSetUpper hadj upperx adjustmentSetUpper vadj uppery adjustmentSetLower hadj lowerx@@ -56,6 +62,8 @@ adjustmentSetValue vadj valuey adjustmentSetPageSize hadj pagex adjustmentSetPageSize vadj pagey+ maybe (return ()) signalUnblock mconnidh+ maybe (return ()) signalUnblock mconnidv
lib/Application/HXournal/ModelAction/File.hs view
@@ -56,12 +56,6 @@ $ xstate return xstate' - -- let dim = get g_dimension . maybeError "getFileContent" . M.lookup 0 . get g_pages - -- $ newxoj -- -- let cvschange = setPage xstate' 0 - -- modifyCurrCvsInfoM cvschange xstate'- -- | constructNewHXournalStateFromXournal :: Xournal -> HXournalState -> IO HXournalState @@ -70,16 +64,6 @@ let startingxojstate = ViewAppendState xoj return $ set xournalstate startingxojstate xstate - -- dim = get g_dimension . maybeError "constructNewHxournalStateFromXournal" . M.lookup 0 - -- . get g_pages $ xoj- -- forSingle = set (pageDimension.pageArrangement.viewInfo) (PageDimension dim)- -- . set currentPageNum 0 - -- cvschange = setPage xstate' 0 - -- modifyCurrCvsInfoM cvschange xstate' - -- rentCanvasInfo (selectBox forSingle (error "construct..."))- -- return $ setPage xstate' 0 xstate'-- -- | makeNewXojWithPDF :: FilePath -> IO (Maybe Xournal)@@ -104,6 +88,7 @@ error "makeNewXojWithPDF should not be used without poppler lib" #endif +-- | createPage :: Dimension -> B.ByteString -> Int -> Page createPage dim fn n @@ -112,7 +97,8 @@ | otherwise = let bkg = BackgroundPdf "pdf" Nothing Nothing n in Page dim bkg [emptyLayer] - +-- | + toggleSave :: UIManager -> Bool -> IO () toggleSave ui b = do agr <- uiManagerGetActionGroups ui >>= \x ->
lib/Application/HXournal/ModelAction/Page.hs view
@@ -18,26 +18,22 @@ import Application.HXournal.Type.Canvas import Application.HXournal.Type.PageArrangement import Application.HXournal.Type.Alias+import Application.HXournal.Type.Enum+import Application.HXournal.Type.Predefined 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,mapM) import qualified Data.IntMap as M --import Graphics.UI.Gtk (adjustmentSetUpper,adjustmentGetValue)+import Graphics.UI.Gtk (adjustmentGetValue) -- | @@ -52,18 +48,6 @@ (SelectState . set g_selectSelected Nothing . set g_selectAll nmap ) . xojstateEither - -{--updatePageFromCanvasToXournal :: (ViewMode a) => CanvasInfo a -> XournalState -> XournalState -updatePageFromCanvasToXournal cinfo xojstate = - let cpn = get curentPageNum - page = getCurrentPageFromXojState cinfo xojstate - -- either id gcast epg- in setPageMap (M.adjust (const page) cpn . getPageMap $ xojstate) xojstate -- -- epg = get currentPage cinfo--}- -- | updatePageAll :: XournalState -> HXournalState -> IO HXournalState@@ -91,7 +75,7 @@ else set currentPageNum minp cinfo else cinfo -+-- | getPageFromGXournalMap :: Int -> GXournal M.IntMap a -> a getPageFromGXournalMap pagenum = @@ -110,12 +94,10 @@ geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas let cdim = canvasDim geometry pg = getPageFromGXournalMap pagenum xoj - pdim@(PageDimension (Dim w h)) = PageDimension $ get g_dimension pg+ pdim = 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 $ cinfo@@ -131,12 +113,7 @@ 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 $ cinfo @@ -144,13 +121,7 @@ -- |-{--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@@ -161,41 +132,6 @@ let xoj = GXournal (get g_selectTitle txoj) (get g_selectAll txoj) updateCvsInfoFrmXoj xoj cinfobox - - - {- - --- 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--- - 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) = - 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 (pageDimension.viewInfo) (w,h) - . set currentPage newpage- $ cinfo ---}- -- | setPage :: HXournalState -> PageNum -> CanvasId -> IO CanvasInfoBox@@ -221,7 +157,6 @@ return $ set currentPageNum (unPageNum pnum) . set (pageArrangement.viewInfo) arr $ cinfo - -- | setPageCont : in ContinuousSingle Page mode setPageCont :: HXournalState -> PageNum @@ -231,33 +166,42 @@ 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 $ cinfo -- -- | newSinglePageFromOld :: Page EditMode -> Page EditMode newSinglePageFromOld = set g_layers (NoSelect [GLayerBuf (LyBuf Nothing) []]) + -- | -newPageBeforeAction :: (ViewMode a) => - Xournal EditMode- -> (CanvasId, CanvasInfo a) - -> IO (Xournal EditMode)-newPageBeforeAction xoj (_cid,cinfo) = do - let cpn = get currentPageNum cinfo+addNewPageInXoj :: AddDirection + -> Xournal EditMode+ -> Int + -> IO (Xournal EditMode)+addNewPageInXoj dir xoj cpn = do let pagelst = M.elems . get g_pages $ xoj - -- pagekeylst = M.keys . get g_pages $ xoj - (pagesbefore,pagesafter) = splitAt cpn pagelst- npage = newSinglePageFromOld (head pagesafter)- npagelst = pagesbefore ++ (npage : pagesafter)+ (pagesbefore,cpage:pagesafter) = splitAt cpn pagelst+ npage = newSinglePageFromOld cpage+ npagelst = case dir of + PageBefore -> pagesbefore ++ (npage : cpage : pagesafter)+ PageAfter -> pagesbefore ++ (cpage : npage : pagesafter) nxoj = set g_pages (M.fromList . zip [0..] $ npagelst) xoj return nxoj +-- | ++relZoomRatio :: CanvasGeometry -> ZoomModeRel -> Double+relZoomRatio geometry rzmode = + let CvsCoord (cx0,_cy0) = desktop2Canvas geometry (DeskCoord (0,0))+ CvsCoord (cx1,_cy1) = desktop2Canvas geometry (DeskCoord (1,1))+ scalefactor = case rzmode of+ ZoomIn -> predefinedZoomStepFactor+ ZoomOut -> 1.0/predefinedZoomStepFactor+ in (cx1-cx0) * scalefactor+
lib/Application/HXournal/ModelAction/Pen.hs view
@@ -43,47 +43,36 @@ -> 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- pvwpen = get variableWidthPen pinfo- (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGXournalMap pgnum xoj)- currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer - ptool = case ptype of - PenWork -> "pen" - HighlighterWork -> "highlighter"- _ -> error "error in addPDraw"- newstroke = - case pvwpen of - False -> Stroke { stroke_tool = ptool - , stroke_color = pcolname - , stroke_width = pwidth- , stroke_data = map (\(x,y,_)->x:!:y) . toList $ pdraw+ let ptype = get penType pinfo+ pcolor = get (penColor.currentTool) pinfo+ pcolname = fromJust (M.lookup pcolor penColorNameMap)+ pwidth = get (penWidth.currentTool) pinfo+ pvwpen = get variableWidthPen pinfo+ (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGXournalMap pgnum xoj)+ currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer + ptool = case ptype of + PenWork -> "pen" + HighlighterWork -> "highlighter"+ _ -> error "error in addPDraw"+ newstroke = + case pvwpen of + False -> Stroke { stroke_tool = ptool + , stroke_color = pcolname + , stroke_width = pwidth+ , stroke_data = map (\(x,y,_)->x:!:y) . toList $ pdraw } - True -> VWStroke { stroke_tool = ptool- , stroke_color = pcolname - , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw- }+ True -> VWStroke { stroke_tool = ptool+ , stroke_color = pcolname + , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw+ } - newstrokebbox = mkStrokeBBoxFromStroke newstroke- bbox = strokebbox_bbox newstrokebbox- newlayerbbox <- updateLayerBuf (Just bbox)- . set g_bstrokes (get g_bstrokes currlayer ++ [newstrokebbox]) - $ currlayer-- let newpagebbox = adjustCurrentLayer newlayerbbox currpage - newxojbbox = set g_pages (IM.adjust (const newpagebbox) pgnum (get g_pages xoj) ) xoj - return (newxojbbox,bbox)----------+ newstrokebbox = mkStrokeBBoxFromStroke newstroke+ bbox = strokebbox_bbox newstrokebbox+ newlayerbbox <- updateLayerBuf (Just bbox)+ . set g_bstrokes (get g_bstrokes currlayer ++ [newstrokebbox]) + $ currlayer + let newpagebbox = adjustCurrentLayer newlayerbbox currpage + newxojbbox = set g_pages (IM.adjust (const newpagebbox) pgnum (get g_pages xoj) ) xoj + return (newxojbbox,bbox)
lib/Application/HXournal/ModelAction/Select.hs view
@@ -45,6 +45,7 @@ import Prelude hiding ((.),id) import Data.Algorithm.Diff +-- | data Handle = HandleTL | HandleTR @@ -56,6 +57,8 @@ | 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)@@ -64,6 +67,8 @@ ny = (y-oy1)*scaley+ny1 in (nx,ny) +-- |+ isBBoxDeltaSmallerThan :: Double -> PageNum -> CanvasGeometry -> BBox -> BBox -> Bool isBBoxDeltaSmallerThan delta pnum geometry (BBox (x11,y11) (x12,y12)) (BBox (x21,y21) (x22,y22)) = @@ -96,17 +101,16 @@ newbbox = bboxFromStroke nstrk in StrokeBBox nstrk newbbox -+-- | getActiveLayer :: Page SelectMode -> Either [StrokeBBox] (TAlterHitted StrokeBBox) getActiveLayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . get g_layers -+-- | getSelectedStrokes :: Page SelectMode -> [StrokeBBox] getSelectedStrokes = either (const []) (concatMap unHitted . getB) . getActiveLayer - -- | start a select mode with alter list selection makePageSelectMode :: Page EditMode -- ^ base page @@ -121,8 +125,6 @@ npg = tpg { glayers = ls { gselectedlayerbuf = newlayer} } in npg -- -- | get unselected part of page and make an ordinary page deleteSelected :: Page SelectMode -> Page SelectMode @@ -154,16 +156,17 @@ layer' = GLayerBuf buf . TEitherAlterHitted . Right $ alist' in tpage { glayers = ls { gselectedlayerbuf = layer' }} - -- | special case of offset modification changeSelectionByOffset :: (Double,Double) -> Page SelectMode -> Page SelectMode changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy)) +-- |+ offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy) -+-- | updateTempXournalSelect :: Xournal SelectMode -> Page SelectMode -> Int -> Xournal SelectMode @@ -174,6 +177,8 @@ . set g_selectSelected (Just (pagenum,tpage)) $ txoj +-- |+ updateTempXournalSelectIO :: Xournal SelectMode -> Page SelectMode -> Int -> IO (Xournal SelectMode) updateTempXournalSelectIO txoj tpage pagenum = do @@ -190,6 +195,7 @@ calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. strokebbox_bbox ) -- | + hitInSelection :: Page SelectMode -> (Double,Double) -> Bool hitInSelection tpage point = let activelayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . glayers $ tpage@@ -204,14 +210,16 @@ Middle bbox -> hitTestBBoxPoint bbox point _ -> False - +-- | + getULBBoxFromSelected :: Page SelectMode -> ULMaybe BBox getULBBoxFromSelected tpage = let activelayer = unTEitherAlterHitted . get g_bstrokes . gselectedlayerbuf . glayers $ tpage in case activelayer of Left _ -> Bottom Right alist -> bbox4AllStrokes . takeHittedStrokes $ alist --- unUnion . mconcat . fmap (Union . Middle . strokebbox_bbox) . takeHittedStrokes $ alist ++-- | hitInHandle :: Page SelectMode -> (Double,Double) -> Bool hitInHandle tpage point = @@ -219,12 +227,18 @@ Middle bbox -> maybe False (const True) (checkIfHandleGrasped bbox point) _ -> False +-- |+ takeHittedStrokes :: AlterList [StrokeBBox] (Hitted StrokeBBox) -> [StrokeBBox] takeHittedStrokes = concatMap unHitted . getB +-- |+ isAnyHitted :: AlterList [StrokeBBox] (Hitted StrokeBBox) -> Bool isAnyHitted = not . null . takeHittedStrokes +-- |+ toggleCutCopyDelete :: UIManager -> Bool -> IO () toggleCutCopyDelete ui b = do agr <- uiManagerGetActionGroups ui >>= \x -> @@ -237,6 +251,8 @@ let copycutdeletea = [copya,cuta,deletea] mapM_ (flip actionSetSensitive b) copycutdeletea +-- |+ togglePaste :: UIManager -> Bool -> IO () togglePaste ui b = do agr <- uiManagerGetActionGroups ui >>= \x -> @@ -246,6 +262,7 @@ Just pastea <- actionGroupGetAction agr "PASTEA" actionSetSensitive pastea b +-- | changeStrokeColor :: PenColor -> StrokeBBox -> StrokeBBox changeStrokeColor pcolor str =@@ -253,6 +270,7 @@ strsmpl = strokebbox_stroke str in str { strokebbox_stroke = set s_color cname strsmpl } +-- | changeStrokeWidth :: Double -> StrokeBBox -> StrokeBBox changeStrokeWidth pwidth str = @@ -260,23 +278,30 @@ Stroke t c _w d -> Stroke t c pwidth d VWStroke t c d -> Stroke t c pwidth (map (\(x,y,_z) -> (x:!:y)) d) in str { strokebbox_stroke = nstrsmpl } --- str { strokebbox_width = pwidth } ++-- | newtype CmpStrokeBBox = CmpStrokeBBox { unCmpStrokeBBox :: StrokeBBox } deriving Show instance Eq CmpStrokeBBox where CmpStrokeBBox str1 == CmpStrokeBBox str2 = strokebbox_bbox str1 == strokebbox_bbox str2 +-- |+ isSame :: DI -> Bool isSame B = True isSame _ = False +-- |+ separateFS :: [(DI,a)] -> ([a],[a]) separateFS = foldr f ([],[]) where f (F,x) (fs,ss) = (x:fs,ss) f (S,x) (fs,ss) = (fs,x:ss) f (B,_x) (fs,ss) = (fs,ss) +-- |+ getDiffStrokeBBox :: [StrokeBBox] -> [StrokeBBox] -> [(DI, StrokeBBox)] getDiffStrokeBBox lst1 lst2 = let nlst1 = fmap CmpStrokeBBox lst1 @@ -284,6 +309,7 @@ diffresult = getDiff nlst1 nlst2 in map (\(x,y)->(x,unCmpStrokeBBox y)) diffresult +-- | checkIfHandleGrasped :: BBox -> (Double,Double) -> Maybe Handle checkIfHandleGrasped (BBox (ulx,uly) (lrx,lry)) (x,y)
lib/Application/HXournal/ModelAction/Window.hs view
@@ -105,8 +105,6 @@ return () -} widgetAddEvents canvas [PointerMotionMask,Button1MotionMask] - -- widgetSetExtensionEvents canvas [ExtensionEventsAll]- -- widgetSetExtensionEvents canvas let ui = get gtkUIManager xstate agr <- liftIO ( uiManagerGetActionGroups ui >>= \x -> case x of @@ -115,10 +113,8 @@ uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> return (castToToggleAction x) ) b <- liftIO $ toggleActionGetActive uxinputa- if b- then widgetSetExtensionEvents canvas [ExtensionEventsAll]- else widgetSetExtensionEvents canvas [ExtensionEventsNone]-+ if b then widgetSetExtensionEvents canvas [ExtensionEventsAll]+ else widgetSetExtensionEvents canvas [ExtensionEventsNone] hadjconnid <- afterValueChanged hadj $ do v <- adjustmentGetValue hadj callback (HScrollBarMoved cid v)@@ -134,13 +130,9 @@ 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) => @@ -241,102 +233,5 @@ widgetShowAll vpane' return (xstate'',castToWidget vpane', VSplit wconf1' wconf2') -{- -removePanes :: WindowConfig -> IO WindowConfig-removePanes n@(Node _) = return n-removePanes (HSplit wconf1 wconf2) = do - putStrLn "here@@@@"- case hpane of - Just h -> do - panedGetChild1 h >>= \x -> case x of - Just c1 -> containerRemove h c1- Nothing -> return ()- panedGetChild2 h >>= \x -> case x of - Just c2 -> containerRemove h c2- Nothing -> return ()- widgetDestroy h- Nothing -> return ()- wconf1' <- removePanes wconf1 - wconf2' <- removePanes wconf2 - putStrLn "there@@@@"- return (HSplit wconf1' wconf2')-removePanes (VSplit wconf1 wconf2) = do - case vpane of - Just v -> do - panedGetChild1 v >>= \x -> case x of - Just c1 -> containerRemove v c1- Nothing -> return ()- panedGetChild2 v >>= \x -> case x of - Just c2 -> containerRemove v c2- Nothing -> return ()- widgetDestroy v- Nothing -> return ()- wconf1' <- removePanes wconf1 - wconf2' <- removePanes 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/Script.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module : Application.HXournal.Script+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.Script where ++import Application.HXournal.Script.Hook+import Config.Dyre.Relaunch++-- | ++data ScriptConfig = ScriptConfig { message :: Maybe String + , hook :: Maybe Hook+ , errorMsg :: Maybe String + } ++-- | ++defaultScriptConfig :: ScriptConfig +defaultScriptConfig = ScriptConfig Nothing Nothing Nothing++-- | ++showError :: ScriptConfig -> String -> ScriptConfig+showError cfg msg = cfg { errorMsg = Just msg } +++-- | ++relaunchApplication :: IO ()+relaunchApplication = do + putStrLn "relaunching hxournal!"+ relaunchMaster Nothing + +
+ lib/Application/HXournal/Script/Coroutine.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module : Application.HXournal.Script.Coroutine+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.Script.Coroutine where++import Application.HXournal.Type.XournalState+import qualified Application.HXournal.Script.Hook as H+import Application.HXournal.Type.Coroutine+import Application.HXournal.Accessor++import Control.Category +import Control.Monad.Trans+import Data.Label+import Data.Xournal.Simple++import Prelude hiding ((.),id)++-- |++afterSaveHook :: Xournal -> MainCoroutine ()+afterSaveHook xoj = do + xstate <- getSt + let aftersavehk = do + hset <- get hookSet xstate + H.afterSaveHook hset+ maybe (return ()) (\f -> liftIO (f xoj)) aftersavehk ++-- | + +saveAsHook :: Xournal -> MainCoroutine ()+saveAsHook xoj = do + xstate <- getSt + let saveashk = do + hset <- get hookSet xstate + H.saveAsHook hset+ maybe (return ()) (\f -> liftIO (f xoj)) saveashk ++
+ lib/Application/HXournal/Script/Hook.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : Application.HXournal.Script.Hook+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.Script.Hook where ++import Data.Xournal.Simple ++-- | ++data Hook = Hook { saveAsHook :: Maybe (Xournal -> IO ())+ , afterSaveHook :: Maybe (Xournal -> IO ())+ } ++
+ lib/Application/HXournal/StartUp.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module : Application.HXournal.StartUp+-- Copyright : (c) 2012 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Application.HXournal.StartUp where ++import System.Console.CmdArgs+import Application.HXournal.ProgType+import Application.HXournal.Command++import Control.Monad+import Control.Concurrent++import qualified Config.Dyre as Dyre +import Config.Dyre.Relaunch++import System.FilePath+import System.Environment++import Application.HXournal.Script++-- | ++hxournalMain ScriptConfig {..} = do + case errorMsg of + Nothing -> return () + Just em -> putStrLn $ "Error: " ++ em + -- + maybe (return ()) putStrLn message + -- + param <- cmdArgs mode+ commandLineProcess param hook++-- | + +hxournalStartMain = Dyre.wrapMain $ Dyre.defaultParams + { Dyre.projectName = "start"+ , Dyre.configDir = Just dirHXournald+ , Dyre.realMain = hxournalMain + , Dyre.showError = showError + , Dyre.hidePackages = ["meta-hxournal"] + } ++-- | ++dirHXournald :: IO FilePath +dirHXournald = do+ homedir <- getEnv "HOME"+ return (homedir </> ".hxournal.d")+++{-+-- | main starting point of the whole program++startUp :: IO () +startUp = do + -- putStrLn "welcome to hxournal"+ -- param <- cmdArgs mode+ -- commandLineProcess param + hxournalStartMain defaultScriptConfig +-}
lib/Application/HXournal/Type/Clipboard.hs view
@@ -17,28 +17,41 @@ import Control.Category import Data.Label import Prelude hiding ((.), id)- import Data.Xournal.BBox +-- |+ newtype Clipboard = Clipboard { unClipboard :: [StrokeBBox] } +-- |+ emptyClipboard :: Clipboard emptyClipboard = Clipboard [] +-- |+ isEmpty :: Clipboard -> Bool isEmpty = null . unClipboard +-- |+ getClipContents :: Clipboard -> [StrokeBBox] getClipContents = unClipboard +-- |+ replaceClipContents :: [StrokeBBox] -> Clipboard -> Clipboard replaceClipContents strs _ = Clipboard strs +-- |+ data SelectType = SelectRegionWork | SelectRectangleWork | SelectVerticalSpaceWork | SelectHandToolWork deriving (Show,Eq) ++-- | data SelectInfo = SelectInfo { _selectType :: SelectType }
lib/Application/HXournal/Type/Enum.hs view
@@ -20,6 +20,17 @@ import Data.Xournal.Predefined +-- | page add direction++data AddDirection = PageBefore | PageAfter+ deriving (Show,Eq,Ord,Enum)++-- | relative zoom mode ++data ZoomModeRel = ZoomIn | ZoomOut+ deriving (Show,Eq,Ord,Enum)+-- | + data PenColor = ColorBlack | ColorBlue | ColorRed
lib/Application/HXournal/Type/Event.hs view
@@ -16,6 +16,7 @@ import Application.HXournal.Device import Graphics.UI.Gtk +-- | data MyEvent = Initialized | CanvasConfigure Int Double Double @@ -38,6 +39,7 @@ | Menu MenuEvent deriving (Show,Eq,Ord) +-- | data MenuEvent = MenuNew | MenuAnnotatePDF@@ -105,6 +107,7 @@ | MenuDefaultHighlighter | MenuDefaultText | MenuSetAsDefaultOption+ | MenuRelaunch | MenuUseXInput | MenuDiscardCoreEvents | MenuEraserTip
lib/Application/HXournal/Type/PageArrangement.hs view
@@ -20,51 +20,93 @@ 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 #-}
lib/Application/HXournal/Type/Predefined.hs view
@@ -14,22 +14,38 @@ import Data.Time.Clock -+-- | dtime_bound :: NominalDiffTime dtime_bound = realToFrac (picosecondsToDiffTime 100000000000) +-- | + predefinedWinReconfTimeBound :: NominalDiffTime predefinedWinReconfTimeBound = realToFrac (picosecondsToDiffTime 50000000000) +-- |+ 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 ++-- | ++predefinedZoomStepFactor :: Double+predefinedZoomStepFactor = 1.5+
lib/Application/HXournal/Type/XournalState.hs view
@@ -39,6 +39,7 @@ , isOneTimeSelectMode , pageModeSignal , lastTimeCanvasConfigure+, hookSet -- | others , emptyHXournalState , getXournal@@ -58,6 +59,7 @@ , modifyCurrCvsInfoM , xojstateEither , getCurrentPageFromXojState+, getCurrentPageDimFromXojState -- | for debug , showCanvasInfoMapViewPortBBox ) where@@ -70,6 +72,7 @@ import Application.HXournal.Type.Undo import Application.HXournal.Type.Alias import Application.HXournal.Type.PageArrangement+import Application.HXournal.Script.Hook import Application.HXournal.Util -- import Application.HXournal.NetworkClipboard.Client.Config import Data.Xournal.Map@@ -88,9 +91,13 @@ type XournalStateIO = StateT HXournalState IO +-- | + data XournalState = ViewAppendState { unView :: TXournalBBoxMapPDFBuf } | SelectState { tempSelect :: TTempXournalSelectPDFBuf } +-- | + data IsOneTimeSelectMode = NoOneTimeSelectMode | YesBeforeSelect | YesAfterSelect@@ -118,6 +125,7 @@ , _isOneTimeSelectMode :: IsOneTimeSelectMode , _pageModeSignal :: Maybe (ConnectId RadioAction) , _lastTimeCanvasConfigure :: Maybe UTCTime + , _hookSet :: Maybe Hook -- , _networkClipboardInfo :: Maybe HXournalClipClientConfiguration } @@ -148,6 +156,7 @@ , _isOneTimeSelectMode = NoOneTimeSelectMode , _pageModeSignal = Nothing , _lastTimeCanvasConfigure = Nothing + , _hookSet = Nothing -- , _networkClipboardInfo = Nothing } @@ -281,11 +290,20 @@ -- | -getCurrentPageFromXojState :: (ViewMode a) => CanvasInfo a -> XournalState -> Page EditMode +getCurrentPageFromXojState :: (ViewMode a) => CanvasInfo a + -> XournalState -> Page EditMode getCurrentPageFromXojState cinfo xojstate = let cpn = get currentPageNum cinfo pagemap = getPageMapFromXojState xojstate in maybeError "updatePageFromCanvasToXournal" $ M.lookup cpn pagemap ++-- | ++getCurrentPageDimFromXojState :: (ViewMode a) => CanvasInfo a + -> XournalState -> PageDimension+getCurrentPageDimFromXojState cinfo = + PageDimension . get g_dimension . getCurrentPageFromXojState cinfo+ -- |
lib/Application/HXournal/Util.hs view
@@ -14,7 +14,11 @@ import Data.Maybe import Data.Xournal.Simple- ++-- import Data.Time.Clock +-- import Data.Time.Format+-- import System.Locale+ -- for test -- import Blaze.ByteString.Builder -- import Text.Xournal.Builder @@ -64,3 +68,11 @@ if p a then return () else waitUntil p act ++-- | for debugging+{-+timeShow :: String -> IO () +timeShow msg = + putStrLn . (msg ++) . (formatTime defaultTimeLocale "%Q") + =<< getCurrentTime +-}
lib/Application/HXournal/View/Coordinate.hs view
@@ -25,7 +25,6 @@ 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@@ -76,7 +75,6 @@ return $ CanvasGeometry (ScreenDimension (Dim ws hs)) (CanvasDimension (Dim w' h')) deskdim cvsvbbox s2c c2s c2d d2c d2p p2d - -- | makePage2Desktop :: (PageNum -> Maybe PageOrigin) @@ -139,11 +137,12 @@ 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 @@ -194,5 +193,3 @@ Nothing -> Left (DeskCoord (x0,y0)) Just (pgn,pxy) -> Right (pgn,pxy) --
lib/Application/HXournal/View/Draw.hs view
@@ -120,7 +120,6 @@ clipBBox mbbox' setSourceSurface tempsurface 0 0 setOperator OperatorSource - -- xform paint case ibbox of Top -> action@@ -165,7 +164,6 @@ lineTo x y stroke Pressure -> do - -- setLineWidth wdth let wx0 = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z0 wy0 = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z0 wx = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z@@ -175,9 +173,7 @@ lineTo (x+wx) (y+wy) lineTo (x-wx) (y-wy) fill- -- stroke - -- | drawFuncGen :: (GPageable em) => em -> @@ -198,6 +194,8 @@ resetClip doubleBufferDraw win geometry xformfunc renderfunc ibboxnew +-- | + drawFuncSelGen :: ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) -> ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) -> DrawingFunction SinglePage SelectMode @@ -215,7 +213,6 @@ rectangle 0 0 cw ch stroke - -- | drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) @@ -257,6 +254,8 @@ resetClip doubleBufferDraw win geometry xformfunc renderfunc ibboxnew +-- |+ cairoBBox :: BBox -> Render () cairoBBox bbox = do let (x1,y1) = bbox_upperleft bbox@@ -264,6 +263,7 @@ rectangle x1 y1 (x2-x1) (y2-y1) stroke +-- | drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) -> ((PageNum, Page SelectMode) -> Maybe BBox -> Render ())@@ -282,7 +282,7 @@ where f k = maybe Nothing (\a->Just (k,a)) . M.lookup (unPageNum k) $ pgs win <- widgetGetDrawWindow canvas- let ibboxnew = getViewableBBox geometry mbbox -- mpnumbbox+ let ibboxnew = getViewableBBox geometry mbbox mbboxnew = toMaybe ibboxnew xformfunc = cairoXform4PageCoordinate geometry pnum emphasispagerender (pn,pg) = do @@ -307,15 +307,16 @@ -- emphasispagerender (pnum,page) maybe (return ()) (\(n,tpage)-> selpagerender (PageNum n,tpage)) mtpage 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 @@ -333,18 +334,15 @@ cairoRenderOption (DrawBkgPDF,DrawFull) (gcast page :: TPageBBoxMapPDF ) +-- | drawContXojSelClearly :: DrawingFunction ContinuousSinglePage SelectMode-drawContXojSelClearly = drawContPageSelGen renderother {- rendercontent -} renderselect - where - renderother (_,page) _mbbox = +drawContXojSelClearly = drawContPageSelGen renderother renderselect + where renderother (_,page) _mbbox = cairoRenderOption (DrawBkgPDF,DrawFull) (gcast page :: TPageBBoxMapPDF ) renderselect (_pnum,tpg) mbbox = cairoHittedBoxDraw tpg mbbox --- -- | drawBuf :: DrawingFunction SinglePage EditMode@@ -367,7 +365,6 @@ drawContPageGen $ \(_,page) mbbox -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) - -- | cairoHittedBoxDraw :: Page SelectMode -> Maybe BBox -> Render () @@ -388,7 +385,6 @@ resetClip Left _ -> return () - -- | renderLasso :: Seq (Double,Double) -> Render ()@@ -402,7 +398,7 @@ mapM_ (uncurry lineTo) xs stroke -+-- | renderBoxSelection :: BBox -> Render () renderBoxSelection bbox = do@@ -414,12 +410,16 @@ 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@@ -441,7 +441,6 @@ 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@@ -454,442 +453,4 @@ 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 ()--}