hoodle-core 0.7.1 → 0.8
raw patch · 14 files changed
+210/−223 lines, 14 filesdep +eitherdep +errorsdep ~coroutine-objectdep ~hoodle-builderdep ~hoodle-parser
Dependencies added: either, errors
Dependency ranges changed: coroutine-object, hoodle-builder, hoodle-parser, hoodle-render, hoodle-types, lens, poppler, time, xournal-parser
Files
- CHANGES +8/−1
- hoodle-core.cabal +35/−59
- src/Hoodle/Coroutine/Callback.hs +4/−1
- src/Hoodle/Coroutine/Draw.hs +24/−18
- src/Hoodle/Coroutine/Eraser.hs +3/−1
- src/Hoodle/Coroutine/File.hs +2/−1
- src/Hoodle/Coroutine/Page.hs +4/−13
- src/Hoodle/Coroutine/Pen.hs +1/−10
- src/Hoodle/Coroutine/Scroll.hs +3/−1
- src/Hoodle/Coroutine/Select.hs +1/−3
- src/Hoodle/Coroutine/Window.hs +22/−27
- src/Hoodle/GUI.hs +4/−1
- src/Hoodle/ModelAction/Page.hs +15/−17
- src/Hoodle/View/Draw.hs +84/−70
CHANGES view
@@ -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
hoodle-core.cabal view
@@ -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 <ianwookim@gmail.com> 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
src/Hoodle/Coroutine/Callback.hs view
@@ -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 ++ " : " )
src/Hoodle/Coroutine/Draw.hs view
@@ -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.
src/Hoodle/Coroutine/Eraser.hs view
@@ -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)
src/Hoodle/Coroutine/File.hs view
@@ -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
src/Hoodle/Coroutine/Page.hs view
@@ -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
src/Hoodle/Coroutine/Pen.hs view
@@ -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
src/Hoodle/Coroutine/Scroll.hs view
@@ -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"
src/Hoodle/Coroutine/Select.hs view
@@ -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)
src/Hoodle/Coroutine/Window.hs view
@@ -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"
src/Hoodle/GUI.hs view
@@ -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 ()
src/Hoodle/ModelAction/Page.hs view
@@ -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
src/Hoodle/View/Draw.hs view
@@ -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 ()