diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/exe/hxournal.hs b/exe/hxournal.hs --- a/exe/hxournal.hs +++ b/exe/hxournal.hs @@ -1,13 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) 2011, 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 diff --git a/hxournal.cabal b/hxournal.cabal --- a/hxournal.cabal +++ b/hxournal.cabal @@ -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: diff --git a/lib/Application/HXournal/Accessor.hs b/lib/Application/HXournal/Accessor.hs --- a/lib/Application/HXournal/Accessor.hs +++ b/lib/Application/HXournal/Accessor.hs @@ -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 --} -- | diff --git a/lib/Application/HXournal/Command.hs b/lib/Application/HXournal/Command.hs --- a/lib/Application/HXournal/Command.hs +++ b/lib/Application/HXournal/Command.hs @@ -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 diff --git a/lib/Application/HXournal/Coroutine/Commit.hs b/lib/Application/HXournal/Coroutine/Commit.hs --- a/lib/Application/HXournal/Coroutine/Commit.hs +++ b/lib/Application/HXournal/Coroutine/Commit.hs @@ -37,6 +37,11 @@ putSt xstate' -- | + +commit_ :: MainCoroutine () +commit_ = getSt >>= commit + +-- | undo :: MainCoroutine () undo = do diff --git a/lib/Application/HXournal/Coroutine/Default.hs b/lib/Application/HXournal/Coroutine/Default.hs --- a/lib/Application/HXournal/Coroutine/Default.hs +++ b/lib/Application/HXournal/Coroutine/Default.hs @@ -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 diff --git a/lib/Application/HXournal/Coroutine/Draw.hs b/lib/Application/HXournal/Coroutine/Draw.hs --- a/lib/Application/HXournal/Coroutine/Draw.hs +++ b/lib/Application/HXournal/Coroutine/Draw.hs @@ -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) - - diff --git a/lib/Application/HXournal/Coroutine/Eraser.hs b/lib/Application/HXournal/Coroutine/Eraser.hs --- a/lib/Application/HXournal/Coroutine/Eraser.hs +++ b/lib/Application/HXournal/Coroutine/Eraser.hs @@ -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) - - - - - diff --git a/lib/Application/HXournal/Coroutine/EventConnect.hs b/lib/Application/HXournal/Coroutine/EventConnect.hs --- a/lib/Application/HXournal/Coroutine/EventConnect.hs +++ b/lib/Application/HXournal/Coroutine/EventConnect.hs @@ -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 diff --git a/lib/Application/HXournal/Coroutine/File.hs b/lib/Application/HXournal/Coroutine/File.hs --- a/lib/Application/HXournal/Coroutine/File.hs +++ b/lib/Application/HXournal/Coroutine/File.hs @@ -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 -} diff --git a/lib/Application/HXournal/Coroutine/Highlighter.hs b/lib/Application/HXournal/Coroutine/Highlighter.hs --- a/lib/Application/HXournal/Coroutine/Highlighter.hs +++ b/lib/Application/HXournal/Coroutine/Highlighter.hs @@ -19,6 +19,8 @@ import Control.Monad.Trans +-- | + highlighterStart :: CanvasId -> PointerCoord -> MainCoroutine () highlighterStart cid pcoord = do liftIO $ putStrLn "highlighter started" diff --git a/lib/Application/HXournal/Coroutine/Page.hs b/lib/Application/HXournal/Coroutine/Page.hs --- a/lib/Application/HXournal/Coroutine/Page.hs +++ b/lib/Application/HXournal/Coroutine/Page.hs @@ -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 --} diff --git a/lib/Application/HXournal/Coroutine/Pen.hs b/lib/Application/HXournal/Coroutine/Pen.hs --- a/lib/Application/HXournal/Coroutine/Pen.hs +++ b/lib/Application/HXournal/Coroutine/Pen.hs @@ -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 diff --git a/lib/Application/HXournal/Coroutine/Scroll.hs b/lib/Application/HXournal/Coroutine/Scroll.hs --- a/lib/Application/HXournal/Coroutine/Scroll.hs +++ b/lib/Application/HXournal/Coroutine/Scroll.hs @@ -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) diff --git a/lib/Application/HXournal/Coroutine/Select.hs b/lib/Application/HXournal/Coroutine/Select.hs --- a/lib/Application/HXournal/Coroutine/Select.hs +++ b/lib/Application/HXournal/Coroutine/Select.hs @@ -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 diff --git a/lib/Application/HXournal/GUI.hs b/lib/Application/HXournal/GUI.hs --- a/lib/Application/HXournal/GUI.hs +++ b/lib/Application/HXournal/GUI.hs @@ -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" diff --git a/lib/Application/HXournal/GUI/Menu.hs b/lib/Application/HXournal/GUI/Menu.hs --- a/lib/Application/HXournal/GUI/Menu.hs +++ b/lib/Application/HXournal/GUI/Menu.hs @@ -31,9 +31,13 @@ import Data.Xournal.Predefined import Paths_hxournal +-- | + justMenu :: MenuEvent -> Maybe MyEvent justMenu = Just . Menu +-- | + uiDeclTest :: String uiDeclTest = [verbatim| @@ -47,6 +51,8 @@ |] +-- | + uiDecl :: String uiDecl = [verbatim| @@ -190,6 +196,7 @@ + @@ -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 "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 diff --git a/lib/Application/HXournal/Job.hs b/lib/Application/HXournal/Job.hs --- a/lib/Application/HXournal/Job.hs +++ b/lib/Application/HXournal/Job.hs @@ -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 () diff --git a/lib/Application/HXournal/ModelAction/Adjustment.hs b/lib/Application/HXournal/ModelAction/Adjustment.hs --- a/lib/Application/HXournal/ModelAction/Adjustment.hs +++ b/lib/Application/HXournal/ModelAction/Adjustment.hs @@ -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 diff --git a/lib/Application/HXournal/ModelAction/File.hs b/lib/Application/HXournal/ModelAction/File.hs --- a/lib/Application/HXournal/ModelAction/File.hs +++ b/lib/Application/HXournal/ModelAction/File.hs @@ -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 -> diff --git a/lib/Application/HXournal/ModelAction/Page.hs b/lib/Application/HXournal/ModelAction/Page.hs --- a/lib/Application/HXournal/ModelAction/Page.hs +++ b/lib/Application/HXournal/ModelAction/Page.hs @@ -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 + diff --git a/lib/Application/HXournal/ModelAction/Pen.hs b/lib/Application/HXournal/ModelAction/Pen.hs --- a/lib/Application/HXournal/ModelAction/Pen.hs +++ b/lib/Application/HXournal/ModelAction/Pen.hs @@ -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) diff --git a/lib/Application/HXournal/ModelAction/Select.hs b/lib/Application/HXournal/ModelAction/Select.hs --- a/lib/Application/HXournal/ModelAction/Select.hs +++ b/lib/Application/HXournal/ModelAction/Select.hs @@ -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) diff --git a/lib/Application/HXournal/ModelAction/Window.hs b/lib/Application/HXournal/ModelAction/Window.hs --- a/lib/Application/HXournal/ModelAction/Window.hs +++ b/lib/Application/HXournal/ModelAction/Window.hs @@ -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) --} diff --git a/lib/Application/HXournal/Script.hs b/lib/Application/HXournal/Script.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Script.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Application.HXournal.Script +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + diff --git a/lib/Application/HXournal/Script/Coroutine.hs b/lib/Application/HXournal/Script/Coroutine.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Script/Coroutine.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Application.HXournal.Script.Coroutine +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + diff --git a/lib/Application/HXournal/Script/Hook.hs b/lib/Application/HXournal/Script/Hook.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/Script/Hook.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Application.HXournal.Script.Hook +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 ()) + } + + diff --git a/lib/Application/HXournal/StartUp.hs b/lib/Application/HXournal/StartUp.hs new file mode 100644 --- /dev/null +++ b/lib/Application/HXournal/StartUp.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Application.HXournal.StartUp +-- Copyright : (c) 2012 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 +-} diff --git a/lib/Application/HXournal/Type/Clipboard.hs b/lib/Application/HXournal/Type/Clipboard.hs --- a/lib/Application/HXournal/Type/Clipboard.hs +++ b/lib/Application/HXournal/Type/Clipboard.hs @@ -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 } diff --git a/lib/Application/HXournal/Type/Enum.hs b/lib/Application/HXournal/Type/Enum.hs --- a/lib/Application/HXournal/Type/Enum.hs +++ b/lib/Application/HXournal/Type/Enum.hs @@ -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 diff --git a/lib/Application/HXournal/Type/Event.hs b/lib/Application/HXournal/Type/Event.hs --- a/lib/Application/HXournal/Type/Event.hs +++ b/lib/Application/HXournal/Type/Event.hs @@ -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 diff --git a/lib/Application/HXournal/Type/PageArrangement.hs b/lib/Application/HXournal/Type/PageArrangement.hs --- a/lib/Application/HXournal/Type/PageArrangement.hs +++ b/lib/Application/HXournal/Type/PageArrangement.hs @@ -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 #-} diff --git a/lib/Application/HXournal/Type/Predefined.hs b/lib/Application/HXournal/Type/Predefined.hs --- a/lib/Application/HXournal/Type/Predefined.hs +++ b/lib/Application/HXournal/Type/Predefined.hs @@ -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 + diff --git a/lib/Application/HXournal/Type/XournalState.hs b/lib/Application/HXournal/Type/XournalState.hs --- a/lib/Application/HXournal/Type/XournalState.hs +++ b/lib/Application/HXournal/Type/XournalState.hs @@ -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 + -- | diff --git a/lib/Application/HXournal/Util.hs b/lib/Application/HXournal/Util.hs --- a/lib/Application/HXournal/Util.hs +++ b/lib/Application/HXournal/Util.hs @@ -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 +-} diff --git a/lib/Application/HXournal/View/Coordinate.hs b/lib/Application/HXournal/View/Coordinate.hs --- a/lib/Application/HXournal/View/Coordinate.hs +++ b/lib/Application/HXournal/View/Coordinate.hs @@ -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) - - diff --git a/lib/Application/HXournal/View/Draw.hs b/lib/Application/HXournal/View/Draw.hs --- a/lib/Application/HXournal/View/Draw.hs +++ b/lib/Application/HXournal/View/Draw.hs @@ -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 () --}