diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -29,7 +29,14 @@ 0.6.6: 28 Feb 2012 * scripting support, zoom in/out implemented. page functions are implemented +================== + 0.7: 29 Nov 2012 - * new hoodle format, load image, pdf export, simplify namespace to Hoodle + * change to Hoodle + * new hoodle format + * simplify namespace to Hoodle + * inter-process clipboard support using GtkClipboard + * Image embedding support + * pdf export support diff --git a/hoodle-core.cabal b/hoodle-core.cabal --- a/hoodle-core.cabal +++ b/hoodle-core.cabal @@ -1,5 +1,5 @@ Name: hoodle-core -Version: 0.7.1 +Version: 0.8 Synopsis: Core library for hoodle Description: Hoodle is a pen notetaking program written in haskell. hoodle-core is the core library written in haskell and @@ -10,7 +10,7 @@ Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Category: Application -Tested-with: GHC == 7.0 +Tested-with: GHC == 7.4 Build-Type: Custom Cabal-Version: >= 1.8 data-files: template/*.html.st @@ -31,65 +31,41 @@ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind ghc-prof-options: -caf-all -auto-all + Build-Depends: base == 4.*, + mtl == 2.*, + directory == 1.*, + filepath == 1.*, + strict == 0.3.*, + gtk == 0.12.*, + cairo == 0.12.*, + attoparsec == 0.10.*, + coroutine-object >= 0.1, + transformers == 0.3.*, + transformers-free == 1.0.*, + hoodle-types >= 0.1, + hoodle-parser >= 0.1, + xournal-parser >= 0.5, + hoodle-render >= 0.2, + hoodle-builder >= 0.1, + containers == 0.4.*, + template-haskell == 2.*, + bytestring == 0.9.*, + either >= 3, + errors >= 1.3, + lens >= 2.4, + configurator == 0.2.*, + time >= 1.2, + TypeCompose == 0.9.*, + Diff == 0.1.*, + dyre >= 0.8.11, + cereal == 0.3.5.*, + base64-bytestring == 0.1.*, + old-locale >= 1.0 if flag(poppler) - Build-Depends: base == 4.*, - mtl == 2.*, - directory == 1.*, - filepath == 1.*, - strict == 0.3.*, - gtk == 0.12.*, - cairo == 0.12.*, - attoparsec == 0.10.*, - coroutine-object >= 0.0.999 && < 0.2, - transformers == 0.3.*, - transformers-free == 1.0.*, - hoodle-types >= 0.0.999 && < 0.2, - hoodle-parser >= 0.0.999 && < 0.2, - xournal-parser >= 0.4.999 && < 0.6, - hoodle-render >= 0.0.999 && < 0.2, - hoodle-builder >= 0.0.999 && < 0.2, - containers == 0.4.*, - template-haskell == 2.*, - bytestring == 0.9.*, - lens >= 2.4 && < 2.7, - configurator == 0.2.*, - poppler == 0.12.*, - time >= 1.2 && < 1.5, - TypeCompose == 0.9.*, - Diff == 0.1.*, - dyre >= 0.8.11, - cereal == 0.3.5.*, - base64-bytestring == 0.1.*, - old-locale >= 1.0 + Build-Depends: poppler >= 0.12.2.1 else - Build-Depends: base == 4.*, - mtl == 2.*, - directory == 1.*, - filepath == 1.*, - strict == 0.3.*, - gtk == 0.12.*, - cairo == 0.12.*, - attoparsec == 0.10.*, - coroutine-object >= 0.0.999 && < 0.2, - transformers == 0.3.*, - transformers-free == 1.0.*, - hoodle-types >= 0.0.999 && < 0.2 , - hoodle-parser >= 0.0.999 && < 0.2, - xournal-parser >= 0.4.999 && < 0.6, - hoodle-render >= 0.0.999 && < 0.2, - hoodle-builder >= 0.0.999 && < 0.2, - containers == 0.4.*, - template-haskell == 2.*, - bytestring == 0.9.*, - lens >= 2.4 && < 2.7, - configurator == 0.2.*, - time >= 1.2 && < 1.5, - TypeCompose == 0.9.*, - Diff == 0.1.*, - dyre >= 0.8.11, - cereal == 0.3.5.*, - base64-bytestring == 0.1.*, - old-locale >= 1.0 + Build-Depends: + Exposed-Modules: Hoodle.Accessor Hoodle.Config diff --git a/src/Hoodle/Coroutine/Callback.hs b/src/Hoodle/Coroutine/Callback.hs --- a/src/Hoodle/Coroutine/Callback.hs +++ b/src/Hoodle/Coroutine/Callback.hs @@ -15,6 +15,7 @@ import Control.Concurrent import Control.Exception import Data.Time +import System.Directory import System.Environment import System.FilePath import System.Locale @@ -45,7 +46,9 @@ errorlog :: String -> IO () errorlog str = do homepath <- getEnv "HOME" - outh <- openFile (homepath ".hoodle.d" "error.log") AppendMode + let dir = homepath ".hoodle.d" + createDirectoryIfMissing False dir + outh <- openFile (dir "error.log") AppendMode utctime <- getCurrentTime let timestr = formatTime defaultTimeLocale "%F %H:%M:%S %Z" utctime hPutStr outh (timestr ++ " : " ) diff --git a/src/Hoodle/Coroutine/Draw.hs b/src/Hoodle/Coroutine/Draw.hs --- a/src/Hoodle/Coroutine/Draw.hs +++ b/src/Hoodle/Coroutine/Draw.hs @@ -47,13 +47,13 @@ } -- | -invalidateGeneral :: CanvasId -> Maybe BBox +invalidateGeneral :: CanvasId -> Maybe BBox -> DrawFlag -> DrawingFunction SinglePage EditMode -> DrawingFunction SinglePage SelectMode -> DrawingFunction ContinuousPage EditMode -> DrawingFunction ContinuousPage SelectMode -> MainCoroutine () -invalidateGeneral cid mbbox drawf drawfsel drawcont drawcontsel = do +invalidateGeneral cid mbbox flag drawf drawfsel drawcont drawcontsel = do xst <- get selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst where fsingle :: HoodleState -> CanvasInfo SinglePage -> MainCoroutine () @@ -65,20 +65,24 @@ Left page -> do liftIO (unSinglePageDraw drawf isCurrentCvs <$> view drawArea <*> pure (cpn,page) - <*> view viewInfo <*> pure mbbox $ cvsInfo ) + <*> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) + return () Right tpage -> do liftIO (unSinglePageDraw drawfsel isCurrentCvs <$> view drawArea <*> pure (cpn,tpage) - <*> view viewInfo <*> pure mbbox $ cvsInfo ) + <*> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) + return () fcont :: HoodleState -> CanvasInfo ContinuousPage -> MainCoroutine () fcont xstate cvsInfo = do let hdlmodst = view hoodleModeState xstate isCurrentCvs = cid == getCurrentCanvasId xstate case hdlmodst of ViewAppendState hdl -> do - liftIO (unContPageDraw drawcont isCurrentCvs cvsInfo mbbox hdl) - SelectState thdl -> - liftIO (unContPageDraw drawcontsel isCurrentCvs cvsInfo mbbox thdl) + hdl' <- liftIO (unContPageDraw drawcont isCurrentCvs cvsInfo mbbox hdl flag) + put (set hoodleModeState (ViewAppendState hdl') xstate) + SelectState thdl -> do + thdl' <- liftIO (unContPageDraw drawcontsel isCurrentCvs cvsInfo mbbox thdl flag) + put (set hoodleModeState (SelectState thdl') xstate) -- | @@ -93,31 +97,33 @@ -- | invalidate clear invalidate :: CanvasId -> MainCoroutine () -invalidate = invalidateInBBox Nothing +invalidate = invalidateInBBox Nothing Clear -- | invalidateInBBox :: Maybe BBox -- ^ desktop coord + -> DrawFlag -> CanvasId -> MainCoroutine () -invalidateInBBox mbbox cid = do - invalidateGeneral cid mbbox - drawPageClearly drawPageSelClearly drawContHoodleClearly drawContHoodleSelClearly +invalidateInBBox mbbox flag cid = do + invalidateGeneral cid mbbox flag + drawSinglePage drawSinglePageSel drawContHoodle drawContHoodleSel -- | invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate + -> DrawFlag -> MainCoroutine () -invalidateAllInBBox mbbox = do +invalidateAllInBBox mbbox flag = do xstate <- get let cinfoMap = getCanvasInfoMap xstate keys = M.keys cinfoMap - forM_ keys (invalidateInBBox mbbox) + forM_ keys (invalidateInBBox mbbox flag) -- | invalidateAll :: MainCoroutine () -invalidateAll = invalidateAllInBBox Nothing - +invalidateAll = invalidateAllInBBox Nothing Clear + -- | Invalidate Current canvas invalidateCurrent :: MainCoroutine () @@ -160,10 +166,9 @@ paint xformfunc rndr - +{- -- | Drawing using layer buffer - -invalidateWithBuf :: CanvasId -> MainCoroutine () + invalidateWithBuf :: CanvasId -> MainCoroutine () invalidateWithBuf = invalidateWithBufInBBox Nothing -- | Drawing using layer buffer in BBox @@ -171,6 +176,7 @@ invalidateWithBufInBBox :: Maybe BBox -> CanvasId -> MainCoroutine () invalidateWithBufInBBox mbbox cid = invalidateGeneral cid mbbox drawBuf drawSelBuf drawContHoodleBuf drawContHoodleSelClearly +-} -- | check current canvas id and new active canvas id and invalidate if it's changed. diff --git a/src/Hoodle/Coroutine/Eraser.hs b/src/Hoodle/Coroutine/Eraser.hs --- a/src/Hoodle/Coroutine/Eraser.hs +++ b/src/Hoodle/Coroutine/Eraser.hs @@ -33,6 +33,7 @@ import Hoodle.Type.PageArrangement import Hoodle.Device import Hoodle.View.Coordinate +import Hoodle.View.Draw import Hoodle.Coroutine.EventConnect import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Commit @@ -93,7 +94,8 @@ newhdlmodst = ViewAppendState newhdlbbox commit . set hoodleModeState newhdlmodst =<< (liftIO (updatePageAll newhdlmodst xstate)) - invalidateWithBuf cid + -- invalidateWithBuf cid + invalidateInBBox Nothing Efficient cid nitms <- rItmsInCurrLyr eraserProcess cid pnum geometry connidup connidmove nitms (x,y) else eraserProcess cid pnum geometry connidmove connidup itms (x,y) diff --git a/src/Hoodle/Coroutine/File.hs b/src/Hoodle/Coroutine/File.hs --- a/src/Hoodle/Coroutine/File.hs +++ b/src/Hoodle/Coroutine/File.hs @@ -166,7 +166,8 @@ renderjob h ofp = do let p = maybe (error "renderjob") id $ IM.lookup 0 (view gpages h) let Dim width height = view gdimension p - let rf = cairoRenderOption (InBBoxOption Nothing) :: InBBox RPage -> Render () + let rf :: InBBox RPage -> Render () + rf x = cairoRenderOption (InBBoxOption Nothing) x >> return () withPDFSurface ofp width height $ \s -> renderWith s $ -- (sequence1_ showPage . map renderPage . hoodle_pages) h (sequence1_ showPage . map (rf . InBBox) . IM.elems . view gpages ) h diff --git a/src/Hoodle/Coroutine/Page.hs b/src/Hoodle/Coroutine/Page.hs --- a/src/Hoodle/Coroutine/Page.hs +++ b/src/Hoodle/Coroutine/Page.hs @@ -36,11 +36,11 @@ import Hoodle.Type.Enum import Hoodle.Util import Hoodle.View.Coordinate +import Hoodle.View.Draw -- import Prelude hiding ((.), id) -- | change page of current canvas using a modify function - changePage :: (Int -> Int) -> MainCoroutine () changePage modifyfn = updateXState changePageAction >> adjustScrollbarWithGeometryCurrent @@ -127,25 +127,23 @@ . set (viewInfo.zoomMode) zmode $ cinfo return . modifyCanvasInfo cid (const ncinfobox) $ xstate - -- | - canvasZoomUpdateCvsId :: CanvasId -> Maybe ZoomMode -> MainCoroutine () canvasZoomUpdateCvsId = canvasZoomUpdateGenRenderCvsId invalidateAll -- | - canvasZoomUpdateBufAll :: MainCoroutine () canvasZoomUpdateBufAll = do klst <- liftM (M.keys . getCanvasInfoMap) get mapM_ updatefunc klst where updatefunc cid - = canvasZoomUpdateGenRenderCvsId (invalidateWithBuf cid) cid Nothing + = canvasZoomUpdateGenRenderCvsId (invalidateInBBox Nothing Efficient cid) cid Nothing + -- canvasZoomUpdateGenRenderCvsId (invalidateWithBuf cid) cid Nothing + -- | - canvasZoomUpdateAll :: MainCoroutine () canvasZoomUpdateAll = do klst <- liftM (M.keys . getCanvasInfoMap) get @@ -153,19 +151,16 @@ -- | - canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine () canvasZoomUpdate mzmode = do cid <- (liftM (getCurrentCanvasId) get) canvasZoomUpdateCvsId cid mzmode -- | - pageZoomChange :: ZoomMode -> MainCoroutine () pageZoomChange = canvasZoomUpdate . Just -- | - pageZoomChangeRel :: ZoomModeRel -> MainCoroutine () pageZoomChangeRel rzmode = do boxAction fsingle . view currentCanvasInfo =<< get @@ -180,7 +175,6 @@ pageZoomChange (Zoom nratio) -- | - newPage :: AddDirection -> MainCoroutine () newPage dir = updateXState npgBfrAct >> commit_ @@ -201,7 +195,6 @@ return xstate -- | delete current page of current canvas - deleteCurrentPage :: MainCoroutine () deleteCurrentPage = do updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll @@ -221,10 +214,8 @@ return xstate -- | delete designated page - deletePageInHoodle :: Hoodle EditMode -> PageNum -> IO (Hoodle EditMode) deletePageInHoodle hdl (PageNum pgn) = do - putStrLn "deletePageInHoodle is called" let pagelst = M.elems . view gpages $ hdl (pagesbefore,_cpage:pagesafter) = splitAt pgn pagelst npagelst = pagesbefore ++ pagesafter diff --git a/src/Hoodle/Coroutine/Pen.hs b/src/Hoodle/Coroutine/Pen.hs --- a/src/Hoodle/Coroutine/Pen.hs +++ b/src/Hoodle/Coroutine/Pen.hs @@ -55,19 +55,10 @@ penPageSwitch {- cinfo -} pgn = do xstate <- get let cibox = view currentCanvasInfo xstate - -- ncinfo = set currentPageNum (unPageNum pgn) cinfo ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum pgn)) cibox put (set currentCanvasInfo ncibox xstate) return ncibox -{- - mfunc = const (return . CanvasInfoBox $ ncinfo) - (xst,cinfo') <- get >>= switchact - put xst - return cinfo' - where switchact xst = do - return . (,ncinfo) =<< modifyCurrCvsInfoM mfunc xst --} -- | Common Pen Work starting point commonPenStart :: (forall a. ViewMode a => CanvasInfo a -> PageNum -> CanvasGeometry @@ -115,7 +106,7 @@ =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate)) let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord nbbox = xformBBox f bbox - invalidateAllInBBox (Just (inflate nbbox 2.0)) + invalidateAllInBBox (Just (inflate nbbox 2.0)) Efficient -- | main pen coordinate adding process -- | now being changed diff --git a/src/Hoodle/Coroutine/Scroll.hs b/src/Hoodle/Coroutine/Scroll.hs --- a/src/Hoodle/Coroutine/Scroll.hs +++ b/src/Hoodle/Coroutine/Scroll.hs @@ -28,6 +28,7 @@ import Hoodle.Coroutine.Draw import Hoodle.Accessor import Hoodle.View.Coordinate +import Hoodle.View.Draw -- import Prelude hiding ((.), id) @@ -95,7 +96,8 @@ when (cid /= cid') $ error "something wrong in vscrollMove" updateXState $ return . over currentCanvasInfo (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) - invalidateWithBuf cid + -- invalidateWithBuf cid + invalidateInBBox Nothing Efficient cid vscrollMove cid VScrollBarEnd cid' v -> do when (cid /= cid') $ error "something wrong in vscrollMove" diff --git a/src/Hoodle/Coroutine/Select.hs b/src/Hoodle/Coroutine/Select.hs --- a/src/Hoodle/Coroutine/Select.hs +++ b/src/Hoodle/Coroutine/Select.hs @@ -293,11 +293,9 @@ ntpage = makePageSelectMode npage alist coroutineaction = do nthdl2 <- liftIO $ updateTempHoodleSelectIO nthdl1 ntpage (unPageNum newpgn) - let -- ncinfo = set currentPageNum (unPageNum newpgn) $ cinfo - cibox = view currentCanvasInfo xstate1 + let cibox = view currentCanvasInfo xstate1 ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum newpgn)) cibox cmap = getCanvasInfoMap xstate1 - -- cmap' = M.adjust (const (CanvasInfoBox ncinfo)) cid cmap cmap' = M.adjust (const ncibox) cid cmap xst = maybe xstate1 id $ setCanvasInfoMap cmap' xstate1 return . set hoodleModeState (SelectState nthdl2) diff --git a/src/Hoodle/Coroutine/Window.hs b/src/Hoodle/Coroutine/Window.hs --- a/src/Hoodle/Coroutine/Window.hs +++ b/src/Hoodle/Coroutine/Window.hs @@ -17,32 +17,32 @@ import Control.Category import Control.Lens import Control.Monad.State -import Graphics.UI.Gtk hiding (get,set) import qualified Data.IntMap as M import Data.Maybe -import Data.Time.Clock +-- import Data.Time.Clock +import Graphics.UI.Gtk hiding (get,set) -- -import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic +import Data.Hoodle.Simple (Dimension(..)) -- +import Hoodle.Accessor +import Hoodle.Coroutine.Draw +import Hoodle.Coroutine.Page +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Window import Hoodle.Type.Canvas +import Hoodle.Type.Coroutine import Hoodle.Type.Event -import Hoodle.Type.Window import Hoodle.Type.HoodleState -import Hoodle.Type.Coroutine import Hoodle.Type.PageArrangement -import Hoodle.Type.Predefined +-- import Hoodle.Type.Predefined +import Hoodle.Type.Window import Hoodle.Util -import Hoodle.ModelAction.Window -import Hoodle.ModelAction.Page -import Hoodle.Coroutine.Page -import Hoodle.Coroutine.Draw -import Hoodle.Accessor +import Hoodle.View.Draw -- import Prelude hiding ((.),id) -- | canvas configure with general zoom update func - canvasConfigureGenUpdate :: MainCoroutine () -> CanvasId -> CanvasDimension @@ -62,14 +62,13 @@ return $ setCanvasInfo (cid,CanvasContPage cinfo') xstate -- | - doCanvasConfigure :: CanvasId -> CanvasDimension -> MainCoroutine () doCanvasConfigure = canvasConfigureGenUpdate canvasZoomUpdateAll -- | - +{- canvasConfigure' :: CanvasId -> CanvasDimension -> MainCoroutine () canvasConfigure' cid cdim = do xstate <- get @@ -84,10 +83,9 @@ if dtime > predefinedWinReconfTimeBound then defaction else return () - +-} -- | - eitherSplit :: SplitType -> MainCoroutine () eitherSplit stype = do xstate <- get @@ -100,9 +98,9 @@ Left _ -> return () Right fstate' -> do let cinfobox = maybeError "eitherSplit" . M.lookup currcid $ cmap - -- liftIO $ putStrLn "called here" let rtwin = view rootWindow xstate rtcntr = view rootContainer xstate + rtrwin = view rootOfRootWindow xstate liftIO $ containerRemove rtcntr rtwin (xstate'',win,fstate'') <- liftIO $ constructFrame' cinfobox xstate fstate' @@ -112,16 +110,15 @@ put xstate3 liftIO $ boxPackEnd rtcntr win PackGrow 0 liftIO $ widgetShowAll rtcntr + -- liftIO $ widgetShowAll win + liftIO $ widgetQueueDraw rtrwin (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3) xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4 put xstate5 canvasZoomUpdateAll invalidateAll - -- fmap4CvsInfoBox f cinfobox -- \oldcinfo -> do - -- | - deleteCanvas :: MainCoroutine () deleteCanvas = do xstate <- get @@ -133,14 +130,14 @@ Left _ -> return () Right Nothing -> return () Right (Just fstate') -> do - let -- cinfobox = maybeError "deleteCanvas" (M.lookup currcid cmap) - cmap' = M.delete currcid cmap + let cmap' = M.delete currcid cmap newcurrcid = maximum (M.keys cmap') xstate0 <- changeCurrentCanvasId newcurrcid let xstate1 = maybe xstate0 id $ setCanvasInfoMap cmap' xstate0 put xstate1 let rtwin = view rootWindow xstate1 rtcntr = view rootContainer xstate1 + rtrwin = view rootOfRootWindow xstate1 liftIO $ containerRemove rtcntr rtwin (xstate'',win,fstate'') <- liftIO $ constructFrame xstate1 fstate' let xstate3 = set frameState fstate'' @@ -149,6 +146,7 @@ put xstate3 liftIO $ boxPackEnd rtcntr win PackGrow 0 liftIO $ widgetShowAll rtcntr + liftIO $ widgetQueueDraw rtrwin (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3) canvasZoomUpdateAll xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4 @@ -161,9 +159,8 @@ paneMoveStart = do ev <- nextevent case ev of - UpdateCanvas cid -> invalidateWithBuf cid >> paneMoveStart + UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> paneMoveStart PaneMoveEnd -> do - -- canvasZoomUpdateAll return () CanvasConfigure cid w' h'-> do canvasConfigureGenUpdate canvasZoomUpdateBufAll cid (CanvasDimension (Dim w' h')) @@ -171,9 +168,7 @@ _ -> paneMoveStart - --- | - +-- | not yet implemented? paneMoved :: MainCoroutine () paneMoved = do liftIO $ putStrLn "pane moved called" diff --git a/src/Hoodle/GUI.hs b/src/Hoodle/GUI.hs --- a/src/Hoodle/GUI.hs +++ b/src/Hoodle/GUI.hs @@ -22,6 +22,7 @@ import Data.Maybe -- import Data.Time import Graphics.UI.Gtk hiding (get,set) +import System.Directory import System.Environment import System.FilePath import System.IO @@ -91,7 +92,9 @@ mainGUI mainaction `catch` \(_e :: SomeException) -> do homepath <- getEnv "HOME" - outh <- openFile (homepath ".hoodle.d" "error.log") WriteMode + let dir = homepath ".hoodle.d" + createDirectoryIfMissing False dir + outh <- openFile (dir "error.log") WriteMode hPutStrLn outh "error occured" hClose outh return () diff --git a/src/Hoodle/ModelAction/Page.hs b/src/Hoodle/ModelAction/Page.hs --- a/src/Hoodle/ModelAction/Page.hs +++ b/src/Hoodle/ModelAction/Page.hs @@ -112,23 +112,21 @@ (xdesk,ydesk) <- (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas - let ulcoord = maybeError "updateCvsFromHoodle" $ - desktop2Page geometry (DeskCoord (xdesk,ydesk)) - let cdim = canvasDim geometry - let arr = makeContinuousArrangement zmode cdim hdl ulcoord - vinfo = view viewInfo cinfo - nvinfo = xfrmViewInfo (const arr) vinfo - return - . CanvasContPage - . set currentPageNum pagenum - . xfrmCvsInfo (const nvinfo) $ cinfo - --- return . CanvasInfoBox --- . set currentPageNum pagenum --- . set (viewInfo.pageArrangement) arr $ cinfo --- selectBoxAction fsingle fcont cinfobox --- where fsingle cinfo = do - + case desktop2Page geometry (DeskCoord (xdesk,ydesk)) of + Nothing -> return (CanvasContPage cinfo) + Just ulcoord -> do + let cdim = canvasDim geometry + let arr = makeContinuousArrangement zmode cdim hdl ulcoord + vinfo = view viewInfo cinfo + nvinfo = xfrmViewInfo (const arr) vinfo + return + . CanvasContPage + . set currentPageNum pagenum + . xfrmCvsInfo (const nvinfo) $ cinfo + + +-- let ulcoord = maybeError "updateCvsFromHoodle" $ + -- | updatePage :: HoodleModeState -> CanvasInfoBox -> IO CanvasInfoBox diff --git a/src/Hoodle/View/Draw.hs b/src/Hoodle/View/Draw.hs --- a/src/Hoodle/View/Draw.hs +++ b/src/Hoodle/View/Draw.hs @@ -14,14 +14,12 @@ module Hoodle.View.Draw where +-- import Control.Applicative ((<$>)) import Graphics.UI.Gtk hiding (get) import Graphics.Rendering.Cairo import Control.Category ((.)) import Control.Lens import Control.Monad (when) - --- import Data.Label - import Data.Foldable import qualified Data.IntMap as M import Data.Maybe hiding (fromMaybe) @@ -51,7 +49,9 @@ import Prelude hiding ((.),id,mapM_,concatMap) -- | +data DrawFlag = Clear | Efficient +-- | type family DrawingFunction v :: * -> * -- | @@ -62,7 +62,8 @@ -> (PageNum, Page a) -> ViewInfo SinglePage -> Maybe BBox - -> IO () } + -> DrawFlag + -> IO (Page a) } -- | @@ -72,7 +73,8 @@ -> CanvasInfo ContinuousPage -> Maybe BBox -> Hoodle a - -> IO () } + -> DrawFlag + -> IO (Hoodle a) } -- | @@ -109,30 +111,31 @@ -- | common routine for double buffering -doubleBufferDraw :: DrawWindow -> CanvasGeometry -> Render () -> Render () +doubleBufferDraw :: DrawWindow -> CanvasGeometry -> Render () -> Render a -> IntersectBBox - -> IO () + -> IO (Maybe a) doubleBufferDraw win geometry _xform rndr (Intersect ibbox) = do let Dim cw ch = unCanvasDimension . canvasDim $ geometry mbbox' = case ibbox of Top -> Just (BBox (0,0) (cw,ch)) Middle bbox -> Just (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord) bbox) Bottom -> Nothing - let action = withImageSurface FormatARGB32 (floor cw) (floor ch) $ \tempsurface -> do - renderWith tempsurface $ do - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 cw ch - fill - rndr - renderWithDrawable win $ do - clipBBox mbbox' - setSourceSurface tempsurface 0 0 - setOperator OperatorSource - paint + let action = withImageSurface FormatARGB32 (floor cw) (floor ch) $ + \tempsurface -> do + renderWith tempsurface $ do + setSourceRGBA 0.5 0.5 0.5 1 + rectangle 0 0 cw ch + fill + rndr + renderWithDrawable win $ do + clipBBox mbbox' + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint case ibbox of - Top -> action - Middle _ -> action - Bottom -> return () + Top -> action >> return Nothing + Middle _ -> action >> return Nothing + Bottom -> return Nothing -- | @@ -146,11 +149,9 @@ scale sx sy -- | - data PressureMode = NoPressure | Pressure -- | - drawCurvebitGen :: PressureMode -> DrawingArea -> CanvasGeometry @@ -183,12 +184,11 @@ fill -- | - drawFuncGen :: em - -> ((PageNum,Page em) -> Maybe BBox -> Render ()) + -> ((PageNum,Page em) -> Maybe BBox -> DrawFlag -> Render (Page em)) -> DrawingFunction SinglePage em drawFuncGen _typ render = SinglePageDraw func - where func isCurrentCvs canvas (pnum,page) vinfo mbbox = do + where func isCurrentCvs canvas (pnum,page) vinfo mbbox flag = do let arr = view pageArrangement vinfo geometry <- makeCanvasGeometry pnum arr canvas win <- widgetGetDrawWindow canvas @@ -197,21 +197,22 @@ xformfunc = cairoXform4PageCoordinate geometry pnum renderfunc = do xformfunc - clipBBox (fmap (flip inflate 1) mbboxnew) - render (pnum,page) mbboxnew + -- clipBBox (fmap (flip inflate 1) mbboxnew) -- ad hoc ? + pg <- render (pnum,page) mbboxnew flag when isCurrentCvs (emphasisCanvasRender ColorBlue geometry) resetClip + return pg doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + >>= maybe (return page) return --- | -drawFuncSelGen :: ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) - -> ((PageNum,Page SelectMode) -> Maybe BBox -> Render ()) +-- | +drawFuncSelGen :: ((PageNum,Page SelectMode) -> Maybe BBox -> DrawFlag -> Render ()) + -> ((PageNum,Page SelectMode) -> Maybe BBox -> DrawFlag -> Render ()) -> DrawingFunction SinglePage SelectMode -drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\x y -> rencont x y >> rensel x y) +drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\x y f -> rencont x y f >> rensel x y f >> return (snd x)) -- | - emphasisCanvasRender :: PenColor -> CanvasGeometry -> Render () emphasisCanvasRender pcolor geometry = do identityMatrix @@ -223,11 +224,10 @@ stroke -- | - -drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) +drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render ()) -> DrawingFunction ContinuousPage EditMode drawContPageGen render = ContPageDraw func - where func isCurrentCvs cinfo mbbox hdl = do + where func isCurrentCvs cinfo mbbox hdl flag = do let arr = view (viewInfo.pageArrangement) cinfo pnum = PageNum . view currentPageNum $ cinfo canvas = view drawArea cinfo @@ -245,14 +245,15 @@ identityMatrix cairoXform4PageCoordinate geometry pn let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew - clipBBox (fmap (flip inflate 1) pgmbbox) - render (pn,pg) pgmbbox + -- clipBBox (fmap (flip inflate 1) pgmbbox) -- ad hoc + render (pn,pg) pgmbbox flag renderfunc = do xformfunc mapM_ onepagerender drawpgs when isCurrentCvs (emphasisCanvasRender ColorRed geometry) resetClip doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + return hdl -- | @@ -264,11 +265,11 @@ stroke -- | -drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> Render ()) - -> ((PageNum, Page SelectMode) -> Maybe BBox -> Render ()) +drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render ()) + -> ((PageNum, Page SelectMode) -> Maybe BBox -> DrawFlag -> Render ()) -> DrawingFunction ContinuousPage SelectMode drawContPageSelGen rendergen rendersel = ContPageDraw func - where func isCurrentCvs cinfo mbbox thdl = do + where func isCurrentCvs cinfo mbbox thdl flag = do let arr = view (viewInfo.pageArrangement) cinfo pnum = PageNum . view currentPageNum $ cinfo mtpage = view gselSelected thdl @@ -287,11 +288,11 @@ onepagerender (pn,pg) = do identityMatrix cairoXform4PageCoordinate geometry pn - rendergen (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) + rendergen (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag selpagerender (pn,pg) = do identityMatrix cairoXform4PageCoordinate geometry pn - rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) + rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag renderfunc = do xformfunc mapM_ onepagerender drawpgs @@ -299,60 +300,73 @@ when isCurrentCvs (emphasisCanvasRender ColorGreen geometry) resetClip doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + return thdl -- | -drawPageClearly :: DrawingFunction SinglePage EditMode -drawPageClearly = drawFuncGen EditMode $ \(_,page) _mbbox -> - cairoRenderOption (RBkgDrawPDF,DrawFull) page +drawSinglePage :: DrawingFunction SinglePage EditMode +drawSinglePage = drawFuncGen EditMode f + where f (_,page) _ Clear = do + pg' <- cairoRenderOption (RBkgDrawPDF,DrawFull) page + return pg' + f (_,page) mbbox Efficient = do + InBBox pg' <- cairoRenderOption (InBBoxOption mbbox) (InBBox page) + return pg' -- | -drawPageSelClearly :: DrawingFunction SinglePage SelectMode -drawPageSelClearly = drawFuncSelGen rendercontent renderselect - where rendercontent (_pnum,tpg) _mbbox = do +drawSinglePageSel :: DrawingFunction SinglePage SelectMode +drawSinglePageSel = drawFuncSelGen rendercontent renderselect + where rendercontent (_pnum,tpg) mbbox flag = do let pg' = hPage2RPage tpg - cairoRenderOption (RBkgDrawPDF,DrawFull) pg' - -- cairoRenderOption (InBBoxOption mbbox) (InBBox pg') - renderselect (_pnum,tpg) mbbox = do + case flag of + Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) pg' >> return () + Efficient -> cairoRenderOption (InBBoxOption mbbox) (InBBox pg') >> return () + return () + renderselect (_pnum,tpg) mbbox _flag = do cairoHittedBoxDraw tpg mbbox + return () -- | - -drawContHoodleClearly :: DrawingFunction ContinuousPage EditMode -drawContHoodleClearly = - drawContPageGen $ \(_,page) _mbbox -> - cairoRenderOption (RBkgDrawPDF,DrawFull) page +drawContHoodle :: DrawingFunction ContinuousPage EditMode +drawContHoodle = drawContPageGen f + where f (_,page) _ Clear = cairoRenderOption (RBkgDrawPDF,DrawFull) page + >> return () + f (_,page) mbbox Efficient = cairoRenderOption (InBBoxOption mbbox) (InBBox page) + >> return () -- | +drawContHoodleSel :: DrawingFunction ContinuousPage SelectMode +drawContHoodleSel = drawContPageSelGen renderother renderselect + where renderother (_,page) mbbox flag = do + case flag of + Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) page >> return () + Efficient -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) >> return () + return () + renderselect (_pnum,tpg) mbbox _flag = do + cairoHittedBoxDraw tpg mbbox + return () -drawContHoodleSelClearly :: DrawingFunction ContinuousPage SelectMode -drawContHoodleSelClearly = drawContPageSelGen renderother renderselect - where renderother (_,page) _mbbox = - cairoRenderOption (RBkgDrawPDF,DrawFull) page - -- cairoRenderOption (InBBoxOption mbbox) (InBBox page) - renderselect (_pnum,tpg) mbbox = - cairoHittedBoxDraw tpg mbbox +{- -- | - drawBuf :: DrawingFunction SinglePage EditMode -drawBuf = drawFuncGen EditMode $ \(_,page) mbbox -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) +drawBuf = drawFuncGen EditMode $ \(_,page) mbbox _ -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) -- | - drawSelBuf :: DrawingFunction SinglePage SelectMode drawSelBuf = drawFuncSelGen rencont rensel - where rencont (_pnum,tpg) mbbox = do + where rencont (_pnum,tpg) mbbox _ = do let page = hPage2RPage tpg cairoRenderOption (InBBoxOption mbbox) (InBBox page) - rensel (_pnum,tpg) mbbox = do + rensel (_pnum,tpg) mbbox _ = do cairoHittedBoxDraw tpg mbbox -- | drawContHoodleBuf :: DrawingFunction ContinuousPage EditMode drawContHoodleBuf = - drawContPageGen $ \(_,page) mbbox -> + drawContPageGen $ \(_,page) mbbox _ -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) +-} -- | cairoHittedBoxDraw :: Page SelectMode -> Maybe BBox -> Render ()