diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (C) 2011-2013 Ian-Woo Kim +Copyright (C) 2011-2014 Ian-Woo Kim Hoodle is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by 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.13.0.0 +Version: 0.14 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.4, GHC == 7.6 +Tested-with: GHC == 7.6, GHC == 7.8 Build-Type: Custom Cabal-Version: >= 1.8 data-files: template/*.html.st @@ -24,61 +24,64 @@ Library hs-source-dirs: src - ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans + ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans 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, - pango > 0.12, - gd >= 3000.7, + Build-Depends: aeson>=0.7, + aeson-pretty > 0.7, + array, attoparsec >= 0.10, - coroutine-object >= 0.2, - transformers >= 0.3, - transformers-free >= 1.0, - hoodle-types >= 0.2.2, - hoodle-parser >= 0.2.2, - hoodle-builder >= 0.2.2, - xournal-parser >= 0.5.0.2, - hoodle-render >= 0.3.2, - containers >= 0.4, - template-haskell > 2, - bytestring >= 0.9, + base == 4.*, base64-bytestring >= 0.1, - either >= 3.1, - errors >= 1.3, - lens >= 2.5, - process >= 1.1, + binary, + bytestring >= 0.9, + cairo > 0.12, + cereal >= 0.3.5, + containers >= 0.4, configurator >= 0.2, - time >= 1.2, + coroutine-object >= 0.2, + dbus >= 0.10, Diff >= 0.3, + directory > 1, dyre >= 0.8.11, - cereal >= 0.3.5, - base64-bytestring >= 0.1, - old-locale >= 1.0, - uuid >= 1.2.7, + either >= 3.1, + errors >= 1.3, + filepath > 1, + fsnotify >= 0.0.7, + gd >= 3000.7, + gtk > 0.12, + hoodle-builder >= 0.3, + hoodle-parser >= 0.3, + hoodle-render >= 0.4, + hoodle-types >= 0.3, + lens >= 2.5, monad-loops >= 0.3, + mtl > 2, network, + network-info, + network-simple >= 0.3, + old-locale >= 1.0, + pango > 0.12, poppler >= 0.12.2.2, - fsnotify >= 0.0.7, - system-filepath >= 0.4, + process >= 1.1, + pureMD5, + stm >= 2, + strict > 0.3, svgcairo >= 0.12, - binary, - dbus >= 0.10, - network-simple >= 0.3, + system-filepath >= 0.4, + template-haskell > 2, text >= 0.10, - stm >= 2, - pureMD5, - network-info + time >= 1.2, + transformers >= 0.3, + transformers-free >= 1.0, + unordered-containers >= 0.2, + uuid >= 1.2.7, + vector >= 0.10, + xournal-parser >= 0.5.0.2 Exposed-Modules: Hoodle.Accessor Hoodle.Config - Hoodle.Coroutine Hoodle.Coroutine.Callback Hoodle.Coroutine.Commit Hoodle.Coroutine.ContextMenu @@ -87,6 +90,7 @@ Hoodle.Coroutine.Draw Hoodle.Coroutine.Eraser Hoodle.Coroutine.File + Hoodle.Coroutine.HandwritingRecognition Hoodle.Coroutine.Highlighter Hoodle.Coroutine.Layer Hoodle.Coroutine.Link @@ -116,6 +120,7 @@ Hoodle.ModelAction.Pen Hoodle.ModelAction.Select Hoodle.ModelAction.Select.Transform + Hoodle.ModelAction.Text Hoodle.ModelAction.Window Hoodle.Script Hoodle.Script.Coroutine diff --git a/resource/menu.xml b/resource/menu.xml --- a/resource/menu.xml +++ b/resource/menu.xml @@ -5,26 +5,15 @@ - - - - - - - - - - - - - + + - - - - + + + + @@ -36,16 +25,9 @@ - - - - - - + @@ -54,33 +36,56 @@ + + + + - - - - - - - - + + + - - + + + + + + + + + + + + + + + + + + + + + + + + + @@ -92,8 +97,6 @@ - - @@ -103,11 +106,11 @@ - - - - + + + + @@ -118,8 +121,8 @@ - - + + @@ -129,9 +132,9 @@ - - - + + + @@ -144,6 +147,13 @@ + + + + + + + @@ -153,8 +163,7 @@ - - + @@ -165,13 +174,13 @@ - + - + @@ -197,10 +206,10 @@ - + - + @@ -212,11 +221,7 @@ - - - - - + @@ -225,8 +230,6 @@ - - @@ -240,6 +243,5 @@ - diff --git a/src/Hoodle/Accessor.hs b/src/Hoodle/Accessor.hs --- a/src/Hoodle/Accessor.hs +++ b/src/Hoodle/Accessor.hs @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Accessor --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -28,7 +28,7 @@ import Graphics.Hoodle.Render.Type -- from this package -- import Hoodle.GUI.Menu -import Hoodle.GUI.Reflect +-- import Hoodle.GUI.Reflect import Hoodle.ModelAction.Layer import Hoodle.Type import Hoodle.Type.Alias @@ -85,16 +85,6 @@ otherCanvas :: HoodleState -> [Int] otherCanvas = M.keys . getCanvasInfoMap --- | -changeCurrentCanvasId :: CanvasId -> MainCoroutine HoodleState -changeCurrentCanvasId cid = do - xstate1 <- St.get - maybe (return xstate1) - (\xst -> do St.put xst - return xst) - (setCurrentCanvasId cid xstate1) - reflectViewModeUI - St.get -- | apply an action to all canvases applyActionToAllCVS :: (CanvasId -> MainCoroutine ()) -> MainCoroutine () @@ -104,69 +94,7 @@ keys = M.keys cinfoMap forM_ keys action - - -- | -{- -printViewPortBBox :: CanvasId -> MainCoroutine () -printViewPortBBox cid = do - cvsInfo <- return . getCanvasInfo cid =<< St.get - liftIO $ putStrLn $ show (unboxGet (viewInfo.pageArrangement.viewPortBBox) cvsInfo) --} - --- | -{- -printViewPortBBoxAll :: MainCoroutine () -printViewPortBBoxAll = do - xstate <- St.get - let cmap = getCanvasInfoMap xstate - cids = M.keys cmap - mapM_ printViewPortBBox cids --} - --- | -{- -printViewPortBBoxCurr :: MainCoroutine () -printViewPortBBoxCurr = do - cvsInfo <- return . view currentCanvasInfo =<< St.get - liftIO $ putStrLn $ show (unboxGet (viewInfo.pageArrangement.viewPortBBox) cvsInfo) --} - --- | -{- -printModes :: CanvasId -> MainCoroutine () -printModes cid = do - cvsInfo <- return . getCanvasInfo cid =<< St.get - liftIO $ printCanvasMode cid cvsInfo --} - --- | -{- -printCanvasMode :: CanvasId -> CanvasInfoBox -> IO () -printCanvasMode cid cvsInfo = do - let zmode = unboxGet (viewInfo.zoomMode) cvsInfo - f :: PageArrangement a -> String - f (SingleArrangement _ _ _) = "SingleArrangement" - f (ContinuousArrangement _ _ _ _) = "ContinuousArrangement" - g :: CanvasInfo a -> String - g cinfo = f . view (viewInfo.pageArrangement) $ cinfo - arrmode :: String - arrmode = boxAction g cvsInfo - incid = unboxGet canvasId cvsInfo - putStrLn $ show (cid,incid,zmode,arrmode) --} - --- | -{- -printModesAll :: MainCoroutine () -printModesAll = do - xstate <- St.get - let cmap = getCanvasInfoMap xstate - cids = M.keys cmap - mapM_ printModes cids --} - --- | getCanvasGeometryCvsId :: CanvasId -> HoodleState -> IO CanvasGeometry getCanvasGeometryCvsId cid xstate = do let cinfobox = getCanvasInfo cid xstate @@ -187,6 +115,7 @@ fsingle = flip (makeCanvasGeometry cpn) canvas . view (viewInfo.pageArrangement) forBoth' unboxBiAct fsingle cinfobox + -- | update flag in HoodleState when corresponding toggle UI changed updateFlagFromToggleUI :: String -- ^ UI toggle button id diff --git a/src/Hoodle/Coroutine.hs b/src/Hoodle/Coroutine.hs deleted file mode 100644 --- a/src/Hoodle/Coroutine.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : Hoodle.Coroutine --- Copyright : (c) 2011, 2012 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- - -module Hoodle.Coroutine -( module Hoodle.Coroutine.Default -, module Hoodle.Coroutine.Pen -, module Hoodle.Coroutine.Eraser -, module Hoodle.Coroutine.Highlighter -) where - -import Hoodle.Coroutine.Default -import Hoodle.Coroutine.Pen -import Hoodle.Coroutine.Eraser -import Hoodle.Coroutine.Highlighter - 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 @@ -22,7 +22,7 @@ -- import Hoodle.Util -- -import Prelude (show,Maybe(..),) -- hiding (catch) +import Prelude (show,Maybe(..)) -- hiding (catch) eventHandler :: MVar (Maybe (Driver e IO ())) -> e -> IO () eventHandler evar ev = E.eventHandler evar ev `catch` allexceptionproc diff --git a/src/Hoodle/Coroutine/Commit.hs b/src/Hoodle/Coroutine/Commit.hs --- a/src/Hoodle/Coroutine/Commit.hs +++ b/src/Hoodle/Coroutine/Commit.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Commit --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -48,10 +48,11 @@ undo = do xstate <- get let utable = view undoTable xstate + cache = view renderCache xstate case getPrevUndo utable of Nothing -> liftIO $ putStrLn "no undo item yet" Just (hdlmodst1,newtable) -> do - hdlmodst <- liftIO $ resetHoodleModeStateBuffers hdlmodst1 + hdlmodst <- liftIO $ resetHoodleModeStateBuffers cache hdlmodst1 put . set hoodleModeState hdlmodst . set undoTable newtable =<< (liftIO (updatePageAll hdlmodst xstate)) @@ -63,10 +64,11 @@ redo = do xstate <- get let utable = view undoTable xstate + cache = view renderCache xstate case getNextUndo utable of Nothing -> liftIO $ putStrLn "no redo item" Just (hdlmodst1,newtable) -> do - hdlmodst <- liftIO $ resetHoodleModeStateBuffers hdlmodst1 + hdlmodst <- liftIO $ resetHoodleModeStateBuffers cache hdlmodst1 put . set hoodleModeState hdlmodst . set undoTable newtable =<< (liftIO (updatePageAll hdlmodst xstate)) diff --git a/src/Hoodle/Coroutine/ContextMenu.hs b/src/Hoodle/Coroutine/ContextMenu.hs --- a/src/Hoodle/Coroutine/ContextMenu.hs +++ b/src/Hoodle/Coroutine/ContextMenu.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.ContextMenu --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -17,16 +18,20 @@ -- from other packages import Control.Applicative -import Control.Lens (view,set,(%~)) +import Control.Lens (view,set,(%~),(^.)) import Control.Monad.State hiding (mapM_,forM_) +import Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import Data.Foldable (mapM_,forM_) import qualified Data.IntMap as IM +import Data.List (partition) import Data.Monoid import Data.UUID.V4 +import qualified Data.Text as T (unpack, splitAt) import qualified Data.Text.Encoding as TE -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo +-- import qualified Graphics.Rendering.Cairo.SVG as RSVG import Graphics.UI.Gtk hiding (get,set) import System.Directory import System.FilePath @@ -37,18 +42,21 @@ import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Select -import Data.Hoodle.Simple (SVG(..), Item(..), Link(..), defaultHoodle) +import Data.Hoodle.Simple (SVG(..), Item(..), Link(..), Anchor(..), Dimension(..), defaultHoodle) +import qualified Data.Hoodle.Simple as S (Image(..)) import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Type.HitTest import Text.Hoodle.Builder (builder) +import qualified Text.Hoodlet.Builder as Hoodlet (builder) -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Dialog import Hoodle.Coroutine.Draw import Hoodle.Coroutine.File +import Hoodle.Coroutine.HandwritingRecognition import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.Select.Clipboard import Hoodle.Coroutine.Select.ManipulateImage @@ -58,6 +66,7 @@ import Hoodle.ModelAction.Select import Hoodle.ModelAction.Select.Transform import Hoodle.Script.Hook +import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum import Hoodle.Type.Event @@ -86,7 +95,7 @@ processContextMenu CMenuDelete = deleteSelection processContextMenu (CMenuCanvasView cid pnum _x _y) = do xstate <- get - let cmap = view cvsInfoMap xstate + let cmap = xstate ^. cvsInfoMap let mcinfobox = IM.lookup cid cmap case mcinfobox of Nothing -> liftIO $ putStrLn "error in processContextMenu" @@ -96,33 +105,37 @@ adjustScrollbarWithGeometryCvsId cid invalidateAll processContextMenu (CMenuRotate dir imgbbx) = rotateImage dir imgbbx +processContextMenu (CMenuExport imgbbx) = exportImage (bbxed_content imgbbx) processContextMenu CMenuAutosavePage = do xst <- get pg <- getCurrentPageCurr mapM_ liftIO $ do - hset <- view hookSet xst + hset <- xst ^. hookSet customAutosavePage hset <*> pure pg processContextMenu (CMenuLinkConvert nlnk) = either (const (return ())) action . hoodleModeStateEither - . view hoodleModeState =<< get + . (^. hoodleModeState) =<< get where action thdl = do xst <- get - case view gselSelected thdl of + let cache = xst ^. renderCache + case thdl ^. gselSelected of Nothing -> return () Just (n,tpg) -> do let activelayer = rItmsInActiveLyr tpg - buf = view (glayers.selectedLayer.gbuffer) tpg + buf = tpg ^. (glayers.selectedLayer.gbuffer) ntpg <- case activelayer of Left _ -> return tpg - Right (a :- _b :- as ) -> liftIO $ do + Right (a :- _b :- as ) -> do let nitm = ItemLink nlnk - nritm <- cnstrctRItem nitm + callRenderer $ cnstrctRItem nitm >>= return . GotRItem + RenderEv (GotRItem nritm) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) let alist' = (a :- Hitted [nritm] :- as ) layer' = GLayer buf . TEitherAlterHitted . Right $ alist' return (set (glayers.selectedLayer) layer' tpg) Right _ -> error "processContextMenu: activelayer" - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg n + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg n commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst)) invalidateAll @@ -130,7 +143,7 @@ fileChooser FileChooserActionOpen Nothing >>= mapM_ linkSelectionWithFile processContextMenu CMenuAssocWithNewFile = do xst <- get - let msuggestedact = view hookSet xst >>= fileNameSuggestionHook + let msuggestedact = xst ^. hookSet >>= fileNameSuggestionHook (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact fileChooser FileChooserActionSave msuggested >>= @@ -149,10 +162,43 @@ linkSelectionWithFile fp return () ) -processContextMenu (CMenuPangoConvert (x0,y0) txt) = textInput (x0,y0) txt -processContextMenu (CMenuLaTeXConvert (x0,y0) txt) = laTeXInput (x0,y0) txt -processContextMenu (CMenuLaTeXConvertNetwork (x0,y0) txt) = laTeXInputNetwork (x0,y0) txt +processContextMenu (CMenuMakeLinkToAnchor anc) = do + xst <- get + uuidbstr <- liftIO $ B.pack . show <$> nextRandom + docidbstr <- view ghoodleID . getHoodle <$> get + let mloc = view (hoodleFileControl.hoodleFileName) xst + loc = maybe "" B.pack mloc + let lnk = LinkAnchor uuidbstr docidbstr loc (anchor_id anc) "" (0,0) (Dim 50 50) + callRenderer $ cnstrctRItem (ItemLink lnk) >>= return . GotRItem + RenderEv (GotRItem newitem) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) + insertItemAt Nothing newitem +processContextMenu (CMenuPangoConvert (x0,y0) txt) = textInput (Just (x0,y0)) txt +processContextMenu (CMenuLaTeXConvert (x0,y0) txt) = laTeXInput (Just (x0,y0)) txt +processContextMenu (CMenuLaTeXConvertNetwork (x0,y0) txt) = laTeXInputNetwork (Just (x0,y0)) txt +processContextMenu (CMenuLaTeXUpdate (x0,y0) key) = runMaybeT (laTeXInputKeyword (x0,y0) key) >> return () processContextMenu (CMenuCropImage imgbbox) = cropImage imgbbox +processContextMenu (CMenuExportHoodlet itm) = do + res <- handwritingRecognitionDialog + forM_ res $ \(b,txt) -> do + when (not b) $ liftIO $ do + let str = T.unpack txt + homedir <- getHomeDirectory + let hoodled = homedir ".hoodle.d" + hoodletdir = hoodled "hoodlet" + b' <- doesDirectoryExist hoodletdir + when (not b') $ + createDirectory hoodletdir + let fp = hoodletdir str <.> "hdlt" + L.writeFile fp (Hoodlet.builder itm) +processContextMenu (CMenuConvertSelection itm) = do + xstate <- get + let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate + deleteSelection + callRenderer $ return . GotRItem =<< cnstrctRItem itm + RenderEv (GotRItem newitem) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) + let BBox (x0,y0) _ = getBBox newitem + insertItemAt (Just (PageNum pgnum, PageCoord (x0,y0))) newitem processContextMenu CMenuCustom = do either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get where action thdl = do @@ -172,7 +218,8 @@ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms in case ulbbox of Middle bbox -> do - svg <- liftIO $ makeSVGFromSelection hititms bbox + cache <- view renderCache <$> get + svg <- liftIO $ makeSVGFromSelection cache hititms bbox uuid <- liftIO $ nextRandom let uuidbstr = B.pack (show uuid) deleteSelection @@ -185,32 +232,46 @@ exportCurrentSelectionAsSVG hititms bbox@(BBox (ulx,uly) (lrx,lry)) = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action where - action filename = + action filename = do + cache <- view renderCache <$> get -- this is rather temporary not to make mistake if takeExtension filename /= ".svg" - then fileExtensionInvalid (".svg","export") - >> exportCurrentSelectionAsSVG hititms bbox - else do - liftIO $ withSVGSurface filename (lrx-ulx) (lry-uly) $ \s -> renderWith s $ do - translate (-ulx) (-uly) - mapM_ renderRItem hititms + then fileExtensionInvalid (".svg","export") + >> exportCurrentSelectionAsSVG hititms bbox + else do + liftIO $ Cairo.withSVGSurface filename (lrx-ulx) (lry-uly) $ \s -> + Cairo.renderWith s $ do + Cairo.translate (-ulx) (-uly) + mapM_ (renderRItem cache) hititms exportCurrentSelectionAsPDF :: [RItem] -> BBox -> MainCoroutine () exportCurrentSelectionAsPDF hititms bbox@(BBox (ulx,uly) (lrx,lry)) = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action where - action filename = + action filename = do + cache <- view renderCache <$> get -- this is rather temporary not to make mistake if takeExtension filename /= ".pdf" - then fileExtensionInvalid (".svg","export") - >> exportCurrentSelectionAsPDF hititms bbox - else do - liftIO $ withPDFSurface filename (lrx-ulx) (lry-uly) $ \s -> renderWith s $ do - translate (-ulx) (-uly) - mapM_ renderRItem hititms + then fileExtensionInvalid (".svg","export") + >> exportCurrentSelectionAsPDF hititms bbox + else do + liftIO $ Cairo.withPDFSurface filename (lrx-ulx) (lry-uly) $ \s -> + Cairo.renderWith s $ do + Cairo.translate (-ulx) (-uly) + mapM_ (renderRItem cache) hititms +-- | +exportImage :: S.Image -> MainCoroutine () +exportImage img = do + + runMaybeT $ do + pngbstr <- (MaybeT . return . getByteStringIfEmbeddedPNG . S.img_src) img + fp <- MaybeT (fileChooser FileChooserActionSave Nothing) + liftIO $ B.writeFile fp pngbstr + return () + showContextMenu :: (PageNum,(Double,Double)) -> MainCoroutine () showContextMenu (pnum,(x,y)) = do xstate <- get @@ -257,6 +318,12 @@ mapM_ (\mi -> menuAttach menu mi 1 2 5 6) =<< menuCreateALink evhandler sitms case sitms of sitm : [] -> do + menuhdlt <- menuItemNewWithLabel "Make Hoodlet" + menuhdlt `on` menuItemActivate $ + ( evhandler . UsrEv . GotContextMenuSignal + . CMenuExportHoodlet . rItem2Item ) sitm + menuAttach menu menuhdlt 0 1 8 9 + case sitm of RItemLink lnkbbx _msfc -> do let lnk = bbxed_content lnkbbx @@ -269,26 +336,47 @@ mapM_ (\link -> do let LinkDocID _ uuid _ _ _ _ _ _ = link menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) - menuitemcvt `on` menuItemActivate $ do - evhandler (UsrEv (GotContextMenuSignal (CMenuLinkConvert link))) + menuitemcvt `on` menuItemActivate $ + ( evhandler + . UsrEv + . GotContextMenuSignal + . CMenuLinkConvert ) link menuAttach menu menuitemcvt 0 1 4 5 ) LinkDocID i lid file txt cmd rdr pos dim -> do - case (lookupPathFromId =<< view hookSet xstate) of - Nothing -> return () - Just f -> do - rp <- f (B.unpack lid) - case rp of - Nothing -> return () - Just file' -> - if (B.unpack file) == file' - then return () - else do - let link = LinkDocID i lid (B.pack file') txt cmd rdr pos dim - menuitemcvt <- menuItemNewWithLabel ("Correct Path to " ++ show file') - menuitemcvt `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuLinkConvert link))) - menuAttach menu menuitemcvt 0 1 4 5 + runMaybeT $ do + hset <- (MaybeT . return . view hookSet) xstate + f <- (MaybeT . return . lookupPathFromId) hset + file' <- MaybeT (f (B.unpack lid)) + guard ((B.unpack file) /= file') + let link = LinkDocID + i lid (B.pack file') txt cmd rdr pos dim + menuitemcvt <- liftIO $ menuItemNewWithLabel + ("Correct Path to " ++ show file') + liftIO (menuitemcvt `on` menuItemActivate $ + ( evhandler + . UsrEv + . GotContextMenuSignal + . CMenuLinkConvert ) link) + liftIO $ menuAttach menu menuitemcvt 0 1 4 5 + return () + LinkAnchor i lid file aid bstr pos dim -> do + runMaybeT $ do + hset <- (MaybeT . return . view hookSet) xstate + f <- (MaybeT . return . lookupPathFromId) hset + file' <- MaybeT (f (B.unpack lid)) + guard ((B.unpack file) /= file') + let link = LinkAnchor i lid (B.pack file') aid bstr pos dim + menuitemcvt <- liftIO $ menuItemNewWithLabel + ("Correct Path to " ++ show file') + liftIO (menuitemcvt `on` menuItemActivate $ + ( evhandler + . UsrEv + . GotContextMenuSignal + . CMenuLinkConvert) link) + liftIO $ menuAttach menu menuitemcvt 0 1 4 5 + return () + RItemSVG svgbbx _msfc -> do let svg = bbxed_content svgbbx BBox (x0,y0) _ = getBBox svgbbx @@ -312,10 +400,17 @@ evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvertNetwork (x0,y0) txt))) menuAttach menu menuitemnet 0 1 5 6 return () + -- + let (txth,txtt) = T.splitAt 19 txt + when ( txth == "embedlatex:keyword:" ) $ do + menuitemup <- menuItemNewWithLabel ("Update LaTeX") + menuitemup `on` menuItemActivate $ do + evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXUpdate (x0,y0) txtt))) + menuAttach menu menuitemup 0 1 6 7 + return () + _ -> return () RItemImage imgbbx _msfc -> do - let -- img = bbxed_content imgbbx - -- BBox (x0,y0) _ = getBBox imgbbx menuitemcrop <- menuItemNewWithLabel ("Crop Image") menuitemcrop `on` menuItemActivate $ do (evhandler . UsrEv . GotContextMenuSignal . CMenuCropImage) imgbbx @@ -325,15 +420,49 @@ menuitemrotccw <- menuItemNewWithLabel ("Rotate Image CCW") menuitemrotccw `on` menuItemActivate $ do (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CCW imgbbx) + menuitemexport <- menuItemNewWithLabel ("Export Image") + menuitemexport `on` menuItemActivate $ do + (evhandler . UsrEv . GotContextMenuSignal) (CMenuExport imgbbx) -- menuAttach menu menuitemcrop 0 1 4 5 menuAttach menu menuitemrotcw 0 1 5 6 menuAttach menu menuitemrotccw 0 1 6 7 + menuAttach menu menuitemexport 0 1 7 8 -- return () + RItemAnchor ancbbx _ -> do + menuitemmklnk <- menuItemNewWithLabel ("Link to this anchor") + menuitemmklnk `on` menuItemActivate $ + ( evhandler + . UsrEv + . GotContextMenuSignal + . CMenuMakeLinkToAnchor + . bbxed_content) ancbbx + menuAttach menu menuitemmklnk 0 1 4 5 _ -> return () - _ -> return () + _ -> do + let (links,others) = partition ((||) <$> isLinkInRItem <*> isAnchorInRItem) sitms + case links of + l : [] -> do + menuitemreplace <- menuItemNewWithLabel ("replace link/anchor render") + menuitemreplace `on` menuItemActivate $ do + let cache = xstate ^. renderCache + ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) others + case ulbbox of + Middle bbox -> do + let BBox (x0,y0) (x1,y1) = bbox + dim = Dim (x1-x0) (y1-y0) + svg <- svg_render <$> makeSVGFromSelection cache others bbox + let mitm = case l of + RItemLink lnkbbx _ -> (Just . ItemLink) ((bbxed_content lnkbbx) { link_render = svg, link_dim = dim }) + RItemAnchor ancbbx _ -> (Just . ItemAnchor) ((bbxed_content ancbbx) { anchor_render = svg, anchor_dim = dim }) + _ -> Nothing + maybe (return ()) (evhandler . UsrEv . GotContextMenuSignal . CMenuConvertSelection ) mitm + _ -> return () + menuAttach menu menuitemreplace 0 1 8 9 + _ -> return () + case (customContextMenuTitle =<< view hookSet xstate) of Nothing -> return () Just ttl -> do diff --git a/src/Hoodle/Coroutine/Default.hs b/src/Hoodle/Coroutine/Default.hs --- a/src/Hoodle/Coroutine/Default.hs +++ b/src/Hoodle/Coroutine/Default.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Default --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim @@ -17,19 +18,28 @@ module Hoodle.Coroutine.Default where -import Control.Applicative ((<$>)) -import Control.Category +import Control.Applicative hiding (empty) import Control.Concurrent -import Control.Lens (_1,over,view,set,at,(.~),(%~)) -import Control.Monad.Reader -import Control.Monad.State +import Control.Concurrent.STM +import Control.Lens (_1,over,view,set,at,(.~),(%~),(^.)) +-- import Control.Monad.Reader hiding (mapM_) +import Control.Monad.State hiding (mapM_) +import Control.Monad.Trans.Reader (ReaderT(..)) import qualified Data.ByteString.Char8 as B +import Data.Foldable (mapM_) import qualified Data.IntMap as M import Data.IORef import Data.Maybe import Data.Monoid ((<>)) +import Data.Sequence (Seq, (<|),(|>), empty, singleton, viewl, ViewL(..)) +import qualified Data.Sequence as Seq (null) +import qualified Data.Text as T (unpack) import Data.Time.Clock -import Graphics.UI.Gtk hiding (get,set) +import Data.UUID +import qualified Graphics.Rendering.Cairo as Cairo +import qualified Graphics.UI.Gtk as Gtk hiding (get,set) +import qualified Graphics.UI.Gtk.Poppler.Document as Poppler +import qualified Graphics.UI.Gtk.Poppler.Page as Poppler import System.Process -- from hoodle-platform import Control.Monad.Trans.Crtn.Driver @@ -37,9 +47,11 @@ import Control.Monad.Trans.Crtn.Logger.Simple import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.Select -import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Simple (Dimension(..), Background(..), defaultHoodle) import Data.Hoodle.Generic -import Graphics.Hoodle.Render.Type.Background +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Background +import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Callback @@ -48,6 +60,7 @@ import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Eraser import Hoodle.Coroutine.File +import Hoodle.Coroutine.HandwritingRecognition import Hoodle.Coroutine.Highlighter import Hoodle.Coroutine.Layer import Hoodle.Coroutine.Link @@ -84,24 +97,26 @@ import Hoodle.Widget.Layer import Hoodle.Widget.PanZoom -- -import Prelude hiding ((.), id) +import Prelude hiding (mapM_) -- | initCoroutine :: DeviceList - -> Window - -> Maybe FilePath + -> Gtk.Window -> Maybe Hook -> Int -- ^ maxundo -> (Bool,Bool,Bool) -- ^ (xinputbool,usepz,uselyr) - -> Statusbar -- ^ status bar - -> IO (EventVar,HoodleState,UIManager,VBox) -initCoroutine devlst window mfname mhook maxundo (xinputbool,usepz,uselyr) stbar = do + -> Gtk.Statusbar -- ^ status bar + -> IO (EventVar,HoodleState,Gtk.UIManager,Gtk.VBox) +initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr) stbar = do evar <- newEmptyMVar putMVar evar Nothing st0new <- set deviceList devlst . set rootOfRootWindow window . set callBack (eventHandler evar) <$> emptyHoodleState + -- pdf rendering testing code + let tvar = st0new ^. pdfRenderQueue + -- (ui,uicompsighdlr) <- getMenuUI evar let st1 = set gtkUIManager ui st0new initcvs = set (canvasWidgets.widgetConfig.doesUsePanZoomWidget) usepz @@ -113,6 +128,11 @@ $ st1 { _cvsInfoMap = M.empty } (st3,cvs,_wconf) <- constructFrame st2 (view frameState st2) (st4,wconf') <- eventConnect st3 (view frameState st3) + -- testing + -- let handler = const (putStrLn "In getFileContent, got call back") + -- newhdl <- flip runReaderT (undefined,undefined) . cnstrctRHoodle =<< defaultHoodle + -- let nhmodstate = ViewAppendState newhdl + let st5 = set (settings.doesUseXInput) xinputbool . set hookSet mhook . set undoTable (emptyUndo maxundo) @@ -120,17 +140,12 @@ . set rootWindow cvs . set uiComponentSignalHandler uicompsighdlr . set statusBar (Just stbar) - $ st4 - - st6 <- getFileContent mfname st5 - -- very dirty, need to be cleaned - let hdlst6 = view hoodleModeState st6 - hdlst7 <- resetHoodleModeStateBuffers hdlst6 - let st7 = set hoodleModeState hdlst7 st6 - -- - vbox <- vBoxNew False 0 + . set (hoodleFileControl.hoodleFileName) Nothing + -- . set hoodleModeState nhmodstate + $ st4 + vbox <- Gtk.vBoxNew False 0 -- - let startingXstate = set rootContainer (castToBox vbox) st7 + let startingXstate = set rootContainer (Gtk.castToBox vbox) st5 let startworld = world startingXstate . ReaderT $ (\(Arg DoEvent ev) -> guiProcess ev) putMVar evar . Just $ (driver simplelogger startworld) @@ -141,16 +156,32 @@ initialize :: AllEvent -> MainCoroutine () initialize ev = do case ev of - UsrEv Initialized -> do -- additional initialization goes here - viewModeChange ToContSinglePage - pageZoomChange FitWidth + UsrEv (Initialized mfname) -> do -- additional initialization goes here + xst1 <- get + let tvar = xst1 ^. pdfRenderQueue + doIOaction $ \evhandler -> do + let handler = Gtk.postGUIAsync . evhandler . SysEv . RenderCacheUpdate + forkOn 2 $ pdfRendererMain handler tvar + return (UsrEv ActionOrdered) + waitSomeEvent (\case ActionOrdered -> True ; _ -> False ) + + getFileContent mfname + + xst2 <- get + let hdlst = xst2 ^. hoodleModeState + cache = xst2 ^. renderCache + hdlst' <- liftIO $ resetHoodleModeStateBuffers cache hdlst + put (set hoodleModeState hdlst' xst2) + + xst <- get let Just sbar = view statusBar xst - cxtid <- liftIO $ statusbarGetContextId sbar "test" - liftIO $ statusbarPush sbar cxtid "Hello there" + cxtid <- liftIO $ Gtk.statusbarGetContextId sbar "test" + liftIO $ Gtk.statusbarPush sbar cxtid "Hello there" let ui = view gtkUIManager xst liftIO $ toggleSave ui False put (set isSaved True xst) + _ -> do ev' <- nextevent initialize (UsrEv ev') @@ -165,13 +196,25 @@ reflectPenColorUI reflectPenWidthUI let cinfoMap = getCanvasInfoMap xstate + assocs = M.toList cinfoMap f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox - (w',h') <- liftIO $ widgetGetSize canvas - defaultEventProcess (CanvasConfigure cid - (fromIntegral w') - (fromIntegral h')) + (w',h') <- liftIO $ Gtk.widgetGetSize canvas + liftIO $ print (w',h') +-- defaultEventProcess (CanvasConfigure cid +-- (fromIntegral w') +-- (fromIntegral h')) + mapM_ f assocs + + viewModeChange ToContSinglePage + pageZoomChange FitWidth + + -- waitSomeEvent (\x -> case x of CanvasConfigure cid w h -> True ; _ -> False) + + + startLinkReceiver + -- main loop sequence_ (repeat dispatchMode) -- | @@ -277,6 +320,7 @@ let w = int2Point ptype v let stNew = set (penInfo.currentTool.penWidth) w st put stNew + reflectPenWidthUI defaultEventProcess (BackgroundStyleChanged bsty) = do modify (backgroundStyle .~ bsty) xstate <- get @@ -287,12 +331,19 @@ cbkg = view gbackground cpage bstystr = convertBackgroundStyleToByteString bsty -- for the time being, I replace any background to solid background - getnbkg :: RBackground -> RBackground - getnbkg (RBkgSmpl c _ _) = RBkgSmpl c bstystr Nothing - getnbkg (RBkgPDF _ _ _ _ _) = RBkgSmpl "white" bstystr Nothing - getnbkg (RBkgEmbedPDF _ _ _) = RBkgSmpl "white" bstystr Nothing + dim = view gdimension cpage + getnbkg' :: RBackground -> Background + getnbkg' (RBkgSmpl c _ _) = Background "solid" c bstystr + getnbkg' (RBkgPDF _ _ _ _ _) = Background "solid" "white" bstystr + getnbkg' (RBkgEmbedPDF _ _ _) = Background "solid" "white" bstystr -- - npage = set gbackground (getnbkg cbkg) cpage + liftIO $ putStrLn " defaultEventProcess: BackgroundStyleChanged HERE/ " + + callRenderer $ GotRBackground <$> evalStateT (cnstrctRBkg_StateT dim (getnbkg' cbkg)) Nothing + RenderEv (GotRBackground nbkg) <- + waitSomeEvent (\case RenderEv (GotRBackground _) -> True ; _ -> False ) + + let npage = set gbackground nbkg cpage npgs = set (at pgnum) (Just npage) pgs nhdl = set gpages npgs hdl modeChange ToViewAppendMode @@ -317,7 +368,7 @@ then return () else do let ioact = mkIOaction $ \evhandler -> do - postGUISync (evhandler (UsrEv FileReloadOrdered)) + Gtk.postGUISync (evhandler (UsrEv FileReloadOrdered)) return (UsrEv ActionOrdered) modify (tempQueue %~ enqueue ioact) defaultEventProcess FileReloadOrdered = fileReload @@ -351,7 +402,9 @@ where colorfunc c = doIOaction $ \_evhandler -> return (UsrEv (PenColorChanged c)) toolfunc t = doIOaction $ \_evhandler -> return (UsrEv (AssignPenMode (Left t))) -defaultEventProcess (ImageFileDropped fname) = embedImage fname +defaultEventProcess (DBusEv (ImageFileDropped fname)) = embedImage fname +defaultEventProcess (DBusEv (DBusNetworkInput txt)) = dbusNetworkInput txt +defaultEventProcess (DBusEv (GoToLink (docid,anchorid))) = goToAnchorPos docid anchorid defaultEventProcess ev = -- for debugging do liftIO $ putStrLn "--- no default ---" liftIO $ print ev @@ -364,7 +417,7 @@ xstate <- get liftIO $ putStrLn "MenuQuit called" if view isSaved xstate - then liftIO $ mainQuit + then liftIO $ Gtk.mainQuit else askQuitProgram menuEventProcess MenuPreviousPage = changePage (\x->x-1) menuEventProcess MenuNextPage = changePage (+1) @@ -381,8 +434,17 @@ menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG menuEventProcess MenuLoadSVG = fileLoadSVG -menuEventProcess MenuLaTeX = laTeXInput (100,100) (laTeXHeader <> "\n\n" <> laTeXFooter) +menuEventProcess MenuText = textInput (Just (100,100)) "" +menuEventProcess MenuEmbedTextSource = embedTextSource +menuEventProcess MenuEditEmbedTextSource = editEmbeddedTextSource +menuEventProcess MenuEditNetEmbedTextSource = editNetEmbeddedTextSource +menuEventProcess MenuTextFromSource = textInputFromSource (100,100) +menuEventProcess MenuLaTeX = + laTeXInput Nothing (laTeXHeader <> "\n\n" <> laTeXFooter) +menuEventProcess MenuLaTeXNetwork = + laTeXInputNetwork Nothing (laTeXHeader <> "\n\n" <> laTeXFooter) menuEventProcess MenuCombineLaTeX = combineLaTeXText +menuEventProcess MenuLaTeXFromSource = laTeXInputFromSource (100,100) menuEventProcess MenuUndo = undo menuEventProcess MenuRedo = redo menuEventProcess MenuOpen = askIfSave fileOpen @@ -418,8 +480,8 @@ let cmap = getCanvasInfoMap xstate canvases = map (getDrawAreaFromBox) . M.elems $ cmap if b - then mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsAll]) canvases - else mapM_ (\x->liftIO $ widgetSetExtensionEvents x [ExtensionEventsNone] ) canvases + then mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsAll]) canvases + else mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsNone] ) canvases menuEventProcess MenuUseTouch = toggleTouch menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" (settings.doesSmoothScroll) >> return () menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" (settings.doesUsePopUpMenu) >> return () @@ -427,12 +489,14 @@ menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return () menuEventProcess MenuFollowLinks = updateFlagFromToggleUI "FLWLNKA" (settings.doesFollowLinks) >> return () menuEventProcess MenuKeepAspectRatio = updateFlagFromToggleUI "KEEPRATIOA" (settings.doesKeepAspectRatio) >> return () +menuEventProcess MenuUseVariableCursor = updateFlagFromToggleUI "VCURSORA" (settings.doesUseVariableCursor) >> reflectCursor >> return () menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return () menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess MenuColorPicker = colorPick menuEventProcess MenuFullScreen = fullScreen -menuEventProcess MenuText = textInput (100,100) "" menuEventProcess MenuAddLink = addLink +menuEventProcess MenuAddAnchor = addAnchor +menuEventProcess MenuListAnchors = listAnchors menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage menuEventProcess MenuEmbedPredefinedImage2 = embedPredefinedImage2 menuEventProcess MenuEmbedPredefinedImage3 = embedPredefinedImage3 @@ -456,6 +520,8 @@ menuEventProcess MenuTogglePanZoomWidget = (togglePanZoom . view (currentCanvas._1)) =<< get menuEventProcess MenuToggleLayerWidget = (toggleLayer . view (currentCanvas._1)) =<< get menuEventProcess MenuToggleClockWidget = (toggleClock . view (currentCanvas._1)) =<< get +menuEventProcess MenuHandwritingRecognitionDialog = + handwritingRecognitionDialog >>= mapM_ (\(b,txt) -> when b $ embedHoodlet (T.unpack txt)) menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m @@ -467,8 +533,8 @@ mc -- | -colorConvert :: Color -> PenColor -colorConvert (Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0 +colorConvert :: Gtk.Color -> PenColor +colorConvert (Gtk.Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0 -- | colorPickerBox :: String -> MainCoroutine (Maybe PenColor) @@ -480,20 +546,20 @@ action pcolor = mkIOaction $ \_evhandler -> do - dialog <- colorSelectionDialogNew msg - csel <- colorSelectionDialogGetColor dialog + dialog <- Gtk.colorSelectionDialogNew msg + csel <- Gtk.colorSelectionDialogGetColor dialog let (r,g,b,_a) = convertPenColorToRGBA pcolor - color = Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0)) + color = Gtk.Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0)) - colorSelectionSetCurrentColor csel color - res <- dialogRun dialog + Gtk.colorSelectionSetCurrentColor csel color + res <- Gtk.dialogRun dialog mc <- case res of - ResponseOk -> do - clrsel <- colorSelectionDialogGetColor dialog - clr <- colorSelectionGetCurrentColor clrsel + Gtk.ResponseOk -> do + clrsel <- Gtk.colorSelectionDialogGetColor dialog + clr <- Gtk.colorSelectionGetCurrentColor clrsel return (Just (colorConvert clr)) _ -> return Nothing - widgetDestroy dialog + Gtk.widgetDestroy dialog return (UsrEv (ColorChosen mc)) go = do r <- nextevent case r of @@ -501,3 +567,45 @@ UpdateCanvas cid -> -- this is temporary invalidateInBBox Nothing Efficient cid >> go _ -> go + + +pdfRendererMain :: ((UUID,(Double,Cairo.Surface))->IO ()) -> TVar (Seq (UUID,PDFCommand)) -> IO () +pdfRendererMain handler tvar = forever $ do + -- putStrLn "pdfRenderMain called" + p <- atomically $ do + lst' <- readTVar tvar + case viewl lst' of + EmptyL -> retry + p :< ps -> do + writeTVar tvar ps + return p + pdfWorker handler p + +pdfWorker :: ((UUID,(Double,Cairo.Surface))->IO ()) -> (UUID,PDFCommand) -> IO () +pdfWorker _handler (_,GetDocFromFile fp tmvar) = do + -- putStrLn "pdfWorker : GetDocFromFile" + mdoc <- popplerGetDocFromFile fp + atomically $ putTMVar tmvar mdoc +pdfWorker _handler (_,GetDocFromDataURI str tmvar) = do + -- putStrLn "pdfWorker : GetDocFromDataURI" + mdoc <- popplerGetDocFromDataURI str + atomically $ putTMVar tmvar mdoc +pdfWorker _handler (_,GetPageFromDoc doc pn tmvar) = do + -- putStrLn "pdfWorker : GetPageFromDoc" + mpg <- popplerGetPageFromDoc doc pn + atomically $ putTMVar tmvar mpg +pdfWorker handler (uuid,RenderPageScaled page (Dim ow oh) (Dim w h)) = do + -- putStrLn "pdfWorker : RenderPageScaled" + let s = w / ow + sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor w) (floor h) + Cairo.renderWith sfc $ do + Cairo.setSourceRGBA 1 1 1 1 + Cairo.rectangle 0 0 w h + Cairo.fill + Cairo.scale s s + Poppler.pageRender page + handler (uuid,(s,sfc)) + + + + 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 @@ -1,12 +1,15 @@ -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Draw --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -16,17 +19,25 @@ module Hoodle.Coroutine.Draw where -- from other packages -import Control.Applicative -import qualified Data.IntMap as M -import Control.Lens (view,set) +import Control.Applicative +import Control.Concurrent +-- import Control.Concurrent.STM +import Control.Lens (view,set,(^.),(%~)) import Control.Monad -import Control.Monad.Trans import Control.Monad.State --- import Data.Label -import Graphics.Rendering.Cairo +import Control.Monad.Trans.Reader (runReaderT) +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap as M +import Data.Time.Clock +import Data.Time.LocalTime +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform +import Control.Monad.Trans.Crtn +import Control.Monad.Trans.Crtn.Object +import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox +import Graphics.Hoodle.Render.Type.Renderer -- from this package import Hoodle.Accessor import Hoodle.Type.Alias @@ -36,10 +47,51 @@ import Hoodle.Type.Event import Hoodle.Type.PageArrangement import Hoodle.Type.HoodleState +import Hoodle.Type.Widget import Hoodle.View.Draw +-- import Hoodle.Widget.Clock -- +-- | +nextevent :: MainCoroutine UserEvent +nextevent = do Arg DoEvent ev <- request (Res DoEvent ()) + case ev of + SysEv sev -> sysevent sev >> nextevent + UsrEv uev -> return uev + +sysevent :: SystemEvent -> MainCoroutine () +sysevent ClockUpdateEvent = do + utctime <- liftIO $ getCurrentTime + zone <- liftIO $ getCurrentTimeZone + let ltime = utcToLocalTime zone utctime + ltimeofday = localTimeOfDay ltime + (h,m,s) :: (Int,Int,Int) = + (,,) <$> (\x->todHour x `mod` 12) <*> todMin <*> (floor . todSec) + $ ltimeofday + -- liftIO $ print (h,m,s) + xst <- get + let cinfo = view currentCanvasInfo xst + cwgts = view (unboxLens canvasWidgets) cinfo + nwgts = set (clockWidgetConfig.clockWidgetTime) (h,m,s) cwgts + ncinfo = set (unboxLens canvasWidgets) nwgts cinfo + put . set currentCanvasInfo ncinfo $ xst + + when (view (widgetConfig.doesUseClockWidget) cwgts) $ do + let cid = getCurrentCanvasId xst + modify (tempQueue %~ enqueue (Right (UsrEv (UpdateCanvasEfficient cid)))) + -- invalidateInBBox Nothing Efficient cid +sysevent (RenderCacheUpdate (uuid, ssfc)) = do + -- liftIO $ putStrLn "RenderCacheUpdate" + modify (renderCache %~ HM.insert uuid ssfc) + b <- ( ^. doesNotInvalidate ) <$> get + when (not b) $ invalidateAll + + + -- invalidateInBBox Nothing Efficient cid +sysevent ev = liftIO $ print ev + + -- | data DrawingFunctionSet = DrawingFunctionSet { singleEditDraw :: DrawingFunction SinglePage EditMode @@ -58,33 +110,36 @@ invalidateGeneral cid mbbox flag drawf drawfsel drawcont drawcontsel = do xst <- get unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst - where fsingle :: HoodleState -> CanvasInfo SinglePage -> MainCoroutine () - fsingle xstate cvsInfo = do - let cpn = PageNum . view currentPageNum $ cvsInfo - isCurrentCvs = cid == getCurrentCanvasId xstate - epage = getCurrentPageEitherFromHoodleModeState cvsInfo (view hoodleModeState xstate) - cvs = view drawArea cvsInfo - msfc = view mDrawSurface cvsInfo - case epage of - Left page -> do - liftIO (unSinglePageDraw drawf isCurrentCvs (cvs,msfc) (cpn,page) - <$> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) - return () - Right tpage -> do - liftIO (unSinglePageDraw drawfsel isCurrentCvs (cvs,msfc) (cpn,tpage) - <$> 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 - 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) + where + fsingle :: HoodleState -> CanvasInfo SinglePage -> MainCoroutine () + fsingle xstate cvsInfo = do + let cpn = PageNum . view currentPageNum $ cvsInfo + isCurrentCvs = cid == getCurrentCanvasId xstate + epage = getCurrentPageEitherFromHoodleModeState cvsInfo (view hoodleModeState xstate) + cvs = view drawArea cvsInfo + msfc = view mDrawSurface cvsInfo + cache = view renderCache xstate + case epage of + Left page -> do + liftIO (unSinglePageDraw drawf cache isCurrentCvs (cvs,msfc) (cpn,page) + <$> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) + return () + Right tpage -> do + liftIO (unSinglePageDraw drawfsel cache isCurrentCvs (cvs,msfc) (cpn,tpage) + <$> 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 + cache = view renderCache xstate + case hdlmodst of + ViewAppendState hdl -> do + hdl' <- liftIO (unContPageDraw drawcont cache isCurrentCvs cvsInfo mbbox hdl flag) + put (set hoodleModeState (ViewAppendState hdl') xstate) + SelectState thdl -> do + thdl' <- liftIO (unContPageDraw drawcontsel cache isCurrentCvs cvsInfo mbbox thdl flag) + put (set hoodleModeState (SelectState thdl') xstate) -- | @@ -108,7 +163,7 @@ xst <- get geometry <- liftIO $ getCanvasGeometryCvsId cid xst invalidateGeneral cid mbbox flag - drawSinglePage (drawSinglePageSel geometry) drawContHoodle (drawContHoodleSel geometry) + (drawSinglePage geometry) (drawSinglePageSel geometry) (drawContHoodle geometry) (drawContHoodleSel geometry) -- | invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate @@ -118,54 +173,55 @@ -- | invalidateAll :: MainCoroutine () -invalidateAll = invalidateAllInBBox Nothing Clear >> liftIO (putStrLn "The SLOW invalidateAll Called") +invalidateAll = invalidateAllInBBox Nothing Clear -- >> liftIO (putStrLn "The SLOW invalidateAll Called") -- | Invalidate Current canvas invalidateCurrent :: MainCoroutine () invalidateCurrent = invalidate . getCurrentCanvasId =<< get -- | Drawing temporary gadgets -invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine () +invalidateTemp :: CanvasId -> Cairo.Surface -> Cairo.Render () -> MainCoroutine () invalidateTemp cid tempsurface rndr = do xst <- get forBoth' unboxBiAct (fsingle xst) . getCanvasInfo cid $ xst - where fsingle xstate cvsInfo = do - let canvas = view drawArea cvsInfo - pnum = PageNum . view currentPageNum $ cvsInfo - geometry <- liftIO $ getCanvasGeometryCvsId cid xstate - win <- liftIO $ widgetGetDrawWindow canvas - let xformfunc = cairoXform4PageCoordinate geometry pnum - liftIO $ renderWithDrawable win $ do - setSourceSurface tempsurface 0 0 - setOperator OperatorSource - paint - xformfunc - rndr + where + fsingle :: HoodleState -> CanvasInfo a -> MainCoroutine () + fsingle xstate cvsInfo = do + let canvas = view drawArea cvsInfo + pnum = PageNum . view currentPageNum $ cvsInfo + geometry <- liftIO $ getCanvasGeometryCvsId cid xstate + win <- liftIO $ widgetGetDrawWindow canvas + let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum) + liftIO $ renderWithDrawable win $ do + Cairo.setSourceSurface tempsurface 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint + xformfunc + rndr -- | Drawing temporary gadgets with coordinate based on base page - -invalidateTempBasePage :: CanvasId -> Surface -> PageNum -> Render () - -> MainCoroutine () +invalidateTempBasePage :: CanvasId -- ^ current canvas id + -> Cairo.Surface -- ^ temporary cairo surface + -> PageNum -- ^ current page number + -> Cairo.Render () -- ^ temporary rendering function + -> MainCoroutine () invalidateTempBasePage cid tempsurface pnum rndr = do xst <- get forBoth' unboxBiAct (fsingle xst) . getCanvasInfo cid $ xst - where fsingle xstate cvsInfo = do - let canvas = view drawArea cvsInfo - geometry <- liftIO $ getCanvasGeometryCvsId cid xstate - win <- liftIO $ widgetGetDrawWindow canvas - let xformfunc = cairoXform4PageCoordinate geometry pnum - liftIO $ renderWithDrawable win $ do - setSourceSurface tempsurface 0 0 - setOperator OperatorSource - paint - xformfunc - rndr + where + fsingle :: HoodleState -> CanvasInfo a -> MainCoroutine () + fsingle xstate cvsInfo = do + let canvas = view drawArea cvsInfo + geometry <- liftIO $ getCanvasGeometryCvsId cid xstate + win <- liftIO $ widgetGetDrawWindow canvas + let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum) + liftIO $ renderWithDrawable win $ do + Cairo.setSourceSurface tempsurface 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint + xformfunc + rndr --- | check current canvas id and new active canvas id and invalidate if it's changed. -chkCvsIdNInvalidate :: CanvasId -> MainCoroutine () -chkCvsIdNInvalidate cid = do - currcid <- liftM (getCurrentCanvasId) get - when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) -- | waitSomeEvent :: (UserEvent -> Bool) -> MainCoroutine UserEvent @@ -173,5 +229,20 @@ r <- nextevent case r of UpdateCanvas cid -> -- this is temporary - invalidateInBBox Nothing Efficient cid >> waitSomeEvent p + invalidateInBBox Nothing Efficient cid >> waitSomeEvent p _ -> if p r then return r else waitSomeEvent p + + +callRenderer :: Renderer RenderEvent -> MainCoroutine () +callRenderer action = do + tvar <- (^. pdfRenderQueue) <$> get + doIOaction $ \evhandler -> do + let handler = postGUIAsync . evhandler . SysEv . RenderCacheUpdate + UsrEv . RenderEv <$> runReaderT action (handler,tvar) + + +callRenderer_ :: Renderer a -> MainCoroutine () +callRenderer_ action = do + callRenderer $ action >> return GotNone + waitSomeEvent (\case RenderEv GotNone -> True ; _ -> False ) + return () 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 @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Eraser --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -78,9 +78,10 @@ let currhdl = unView . view hoodleModeState $ xstate dim = view gdimension page pgnum = view currentPageNum cvsInfo - currlayer = getCurrentLayer page + currlayer = getCurrentLayer page + cache = view renderCache xstate let (newitms,maybebbox) = St.runState (eraseHitted hittestitem) Nothing - newlayerbbox <- liftIO . updateLayerBuf dim maybebbox + newlayerbbox <- liftIO . updateLayerBuf cache dim maybebbox . set gitems newitms $ currlayer let newpagebbox = adjustCurrentLayer newlayerbbox page newhdlbbox = over gpages (IM.adjust (const newpagebbox) pgnum) currhdl 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 @@ -6,9 +6,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.File --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -20,22 +20,23 @@ -- from other packages import Control.Applicative ((<$>),(<*>)) import Control.Concurrent -import Control.Lens (view,set,over,(%~)) -import Control.Monad.State hiding (mapM,forM_) +import Control.Lens (view,set,over,(%~), (.~)) +import Control.Monad.State hiding (mapM,mapM_,forM_) import Control.Monad.Trans.Either import Control.Monad.Trans.Maybe (MaybeT(..)) -import Data.ByteString (readFile) -import Data.ByteString.Char8 as B (pack,unpack) +-- import Control.Monad.Trans.Reader (runReaderT) +import Data.Attoparsec (parseOnly) +import Data.ByteString.Char8 as B (pack,unpack,readFile) import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 (md5) -import Data.Foldable (forM_) +import Data.Foldable (mapM_,forM_) import qualified Data.List as List import Data.Maybe import qualified Data.IntMap as IM import Data.Time.Clock import Filesystem.Path.CurrentOS (decodeString, encodeString) -import Graphics.Rendering.Cairo -import Graphics.UI.Gtk hiding (get,set) +import qualified Graphics.Rendering.Cairo as Cairo +import qualified Graphics.UI.Gtk as Gtk -- hiding (get,set) import System.Directory import System.FilePath import qualified System.FSNotify as FS @@ -44,15 +45,20 @@ -- from hoodle-platform import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Queue -import Data.Hoodle.BBox +-- import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Simple import Data.Hoodle.Select +import Graphics.Hoodle.Render (Xform4Page(..),cnstrctRHoodle) import Graphics.Hoodle.Render.Generic import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Type.HitTest import Text.Hoodle.Builder +import Text.Hoodle.Migrate.FromXournal +import qualified Text.Hoodlet.Parse.Attoparsec as Hoodlet +import qualified Text.Xournal.Parse.Conduit as XP +-- import qualified Text.Hoodlet.Parse.Attoparsec as Hoodlet -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Dialog @@ -60,13 +66,15 @@ import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Minibuffer import Hoodle.Coroutine.Mode +import Hoodle.Coroutine.Page import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.TextInput +-- import Hoodle.Coroutine.Window import Hoodle.ModelAction.File import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select -import Hoodle.ModelAction.Select.Transform +-- import Hoodle.ModelAction.Select.Transform import Hoodle.ModelAction.Window import qualified Hoodle.Script.Coroutine as S import Hoodle.Script.Hook @@ -77,7 +85,7 @@ import Hoodle.Type.PageArrangement import Hoodle.Util -- -import Prelude hiding (readFile,concat,mapM) +import Prelude hiding (readFile,concat,mapM,mapM_) -- | askIfSave :: MainCoroutine () -> MainCoroutine () @@ -101,11 +109,69 @@ if r then action else return () else action + +-- | get file content from xournal file and update xournal state +getFileContent :: Maybe FilePath -> MainCoroutine () +getFileContent (Just fname) = do + xstate <- get + let ext = takeExtension fname + case ext of + ".hdl" -> do + bstr <- liftIO $ B.readFile fname + r <- liftIO $ checkVersionAndMigrate bstr + case r of + Left err -> liftIO $ putStrLn err + Right h -> do + constructNewHoodleStateFromHoodle h + ctime <- liftIO $ getCurrentTime + modify ( hoodleFileControl.hoodleFileName .~ Just fname ) + modify ( hoodleFileControl.lastSavedTime .~ Just ctime ) + commit_ + ".xoj" -> do + liftIO (XP.parseXojFile fname) >>= \x -> case x of + Left str -> liftIO $ putStrLn $ "file reading error : " ++ str + Right xojcontent -> do + hdlcontent <- liftIO $ mkHoodleFromXournal xojcontent + constructNewHoodleStateFromHoodle hdlcontent + ctime <- liftIO $ getCurrentTime + modify ( hoodleFileControl.hoodleFileName .~ Just fname ) + modify ( hoodleFileControl.lastSavedTime .~ Just ctime ) + commit_ + ".pdf" -> do + let doesembed = view (settings.doesEmbedPDF) xstate + mhdl <- liftIO $ makeNewHoodleWithPDF doesembed fname + case mhdl of + Nothing -> getFileContent Nothing + Just hdl -> do + constructNewHoodleStateFromHoodle hdl + modify ( hoodleFileControl.hoodleFileName .~ Nothing) + commit_ + _ -> getFileContent Nothing + xstate' <- get + doIOaction $ \evhandler -> do + Gtk.postGUIAsync (setTitleFromFileName xstate') + return (UsrEv ActionOrdered) + ActionOrdered <- waitSomeEvent (\case ActionOrdered -> True ; _ -> False ) + return () +getFileContent Nothing = do + constructNewHoodleStateFromHoodle =<< liftIO defaultHoodle + modify ( hoodleFileControl.hoodleFileName .~ Nothing ) + commit_ + + +-- | +constructNewHoodleStateFromHoodle :: Hoodle -> MainCoroutine () +constructNewHoodleStateFromHoodle hdl' = do + callRenderer $ cnstrctRHoodle hdl' >>= return . GotRHoodle + RenderEv (GotRHoodle rhdl) <- waitSomeEvent (\case RenderEv (GotRHoodle _) -> True; _ -> False) + modify (hoodleModeState .~ ViewAppendState rhdl) + + -- | fileNew :: MainCoroutine () fileNew = do - xstate <- get - xstate' <- liftIO $ getFileContent Nothing xstate + getFileContent Nothing + xstate' <- get ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate') xstate'' <- return $ over currentCanvasInfo (const ncvsinfo) xstate' liftIO $ setTitleFromFileName xstate'' @@ -133,17 +199,17 @@ sequence1_ i (a:as) = a >> i >> sequence1_ i as -- | -renderjob :: RHoodle -> FilePath -> IO () -renderjob h ofp = do +renderjob :: RenderCache -> RHoodle -> FilePath -> IO () +renderjob cache h ofp = do let p = maybe (error "renderjob") id $ IM.lookup 0 (view gpages h) let Dim width height = view gdimension p - let rf x = cairoRenderOption (RBkgDrawPDF,DrawFull) x >> return () - withPDFSurface ofp width height $ \s -> renderWith s $ - (sequence1_ showPage . map rf . IM.elems . view gpages ) h + let rf x = cairoRenderOption (RBkgDrawPDF,DrawFull) cache (x,Nothing :: Maybe Xform4Page) >> return () + Cairo.withPDFSurface ofp width height $ \s -> Cairo.renderWith s $ + (sequence1_ Cairo.showPage . map rf . IM.elems . view gpages ) h -- | fileExport :: MainCoroutine () -fileExport = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action +fileExport = fileChooser Gtk.FileChooserActionSave Nothing >>= maybe (return ()) action where action filename = -- this is rather temporary not to make mistake @@ -152,7 +218,8 @@ else do xstate <- get let hdl = getHoodle xstate - liftIO (renderjob hdl filename) + cache = view renderCache xstate + liftIO (renderjob cache hdl filename) -- | fileStartSync :: MainCoroutine () @@ -168,7 +235,7 @@ origfile <- canonicalizePath filename let (filedir,_) = splitFileName origfile print filedir - FS.watchDir wm (decodeString filedir) (const True) $ \ev -> do + _ <- FS.watchDir wm (decodeString filedir) (const True) $ \ev -> do let mchangedfile = case ev of FS.Added fp _ -> Just (encodeString fp) FS.Modified fp _ -> Just (encodeString fp) @@ -192,27 +259,28 @@ -- | need to be merged with ContextMenuEventSVG exportCurrentPageAsSVG :: MainCoroutine () -exportCurrentPageAsSVG = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action +exportCurrentPageAsSVG = fileChooser Gtk.FileChooserActionSave Nothing >>= maybe (return ()) action where action filename = -- this is rather temporary not to make mistake if takeExtension filename /= ".svg" then fileExtensionInvalid (".svg","export") >> exportCurrentPageAsSVG - else do + else do + cache <- view renderCache <$> get cpg <- getCurrentPageCurr let Dim w h = view gdimension cpg - liftIO $ withSVGSurface filename w h $ \s -> renderWith s $ - cairoRenderOption (InBBoxOption Nothing) (InBBox cpg) >> return () + liftIO $ Cairo.withSVGSurface filename w h $ \s -> Cairo.renderWith s $ + cairoRenderOption (InBBoxOption Nothing) cache (InBBox cpg,Nothing :: Maybe Xform4Page) >> return () -- | fileLoad :: FilePath -> MainCoroutine () fileLoad filename = do + getFileContent (Just filename) xstate <- get - xstate' <- liftIO $ getFileContent (Just filename) xstate - ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate') - xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate' + ncvsinfo <- liftIO $ setPage xstate 0 (getCurrentCanvasId xstate) + xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate put . set isSaved True $ xstateNew - let ui = view gtkUIManager xstate + let ui = view gtkUIManager xstateNew liftIO $ toggleSave ui False liftIO $ setTitleFromFileName xstateNew clearUndoHistory @@ -226,14 +294,16 @@ resetHoodleBuffers = do liftIO $ putStrLn "resetHoodleBuffers called" xst <- get - nhdlst <- liftIO $ resetHoodleModeStateBuffers (view hoodleModeState xst) + nhdlst <- liftIO $ resetHoodleModeStateBuffers + (view renderCache xst) + (view hoodleModeState xst) let nxst = set hoodleModeState nhdlst xst put nxst -- | main coroutine for open a file fileOpen :: MainCoroutine () fileOpen = do - mfilename <- fileChooser FileChooserActionOpen Nothing + mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing forM_ mfilename fileLoad -- | main coroutine for save as @@ -250,7 +320,7 @@ defSaveAsAction xstate hdl = do let msuggestedact = view hookSet xstate >>= fileNameSuggestionHook (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact - mr <- fileChooser FileChooserActionSave msuggested + mr <- fileChooser Gtk.FileChooserActionSave msuggested maybe (return ()) (action xstate hdl) mr where action xst' hd filename = if takeExtension filename /= ".hdl" @@ -306,7 +376,7 @@ -- | fileAnnotatePDF :: MainCoroutine () fileAnnotatePDF = - fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action + fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action where warning = do okMessageBox "cannot load the pdf file. Check your hoodle compiled with poppler library" @@ -316,13 +386,20 @@ let doesembed = view (settings.doesEmbedPDF) xstate mhdl <- liftIO $ makeNewHoodleWithPDF doesembed filename flip (maybe warning) mhdl $ \hdl -> do - xstateNew <- return . set (hoodleFileControl.hoodleFileName) Nothing - =<< (liftIO $ constructNewHoodleStateFromHoodle hdl xstate) - commit xstateNew - liftIO $ setTitleFromFileName xstateNew - invalidateAll + constructNewHoodleStateFromHoodle hdl + modify ( hoodleFileControl.hoodleFileName .~ Nothing) + commit_ + setTitleFromFileName_ + canvasZoomUpdateAll + -- invalidateAll +-- | set frame title according to file name +setTitleFromFileName_ :: MainCoroutine () +setTitleFromFileName_ = get >>= liftIO . setTitleFromFileName + + + -- | checkEmbedImageSize :: FilePath -> MainCoroutine (Maybe FilePath) checkEmbedImageSize filename = do @@ -348,7 +425,7 @@ -- | fileLoadPNGorJPG :: MainCoroutine () fileLoadPNGorJPG = do - fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) embedImage + fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) embedImage embedImage :: FilePath -> MainCoroutine () embedImage filename = do @@ -357,67 +434,50 @@ if view (settings.doesEmbedImage) xst then do mf <- checkEmbedImageSize filename - case mf of - Nothing -> liftIO (cnstrctRItem =<< makeNewItemImage True filename) - Just f -> liftIO (cnstrctRItem =<< makeNewItemImage True f) - else - liftIO (cnstrctRItem =<< makeNewItemImage False filename) - insertItemAt Nothing nitm + -- + callRenderer $ case mf of + Nothing -> liftIO (makeNewItemImage True filename) >>= cnstrctRItem >>= return . GotRItem + Just f -> liftIO (makeNewItemImage True f) >>= cnstrctRItem >>= return . GotRItem + RenderEv (GotRItem r) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False ) + return r + else do + callRenderer $ liftIO (makeNewItemImage False filename) >>= cnstrctRItem >>= return . GotRItem + RenderEv (GotRItem r) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False ) + return r -insertItemAt :: Maybe (PageNum,PageCoordinate) - -> RItem - -> MainCoroutine () -insertItemAt mpcoord ritm = do - xst <- get - geometry <- liftIO (getGeometry4CurrCvs xst) - let hdl = getHoodle xst - (pgnum,mpos) = case mpcoord of - Just (PageNum n,pos) -> (n,Just pos) - Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) xst,Nothing) - (ulx,uly) = (bbox_upperleft.getBBox) ritm - nitms = - case mpos of - Nothing -> adjustItemPosition4Paste geometry (PageNum pgnum) [ritm] - Just (PageCoord (nx,ny)) -> - map (changeItemBy (\(x,y)->(x+nx-ulx,y+ny-uly))) [ritm] - - let pg = getPageFromGHoodleMap pgnum hdl - lyr = getCurrentLayer pg - oitms = view gitems lyr - ntpg = makePageSelectMode pg (oitms :- (Hitted nitms) :- Empty) - modeChange ToSelectMode - nxst <- get - thdl <- case view hoodleModeState nxst of - SelectState thdl' -> return thdl' - _ -> (lift . EitherT . return . Left . Other) "insertItemAt" - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - put ( ( set hoodleModeState (SelectState nthdl) - . set isOneTimeSelectMode YesAfterSelect) nxst) - invalidateAll + let cpn = view (currentCanvasInfo . unboxLens currentPageNum) xst + my <- autoPosText + let mpos = (\y->(PageNum cpn,PageCoord (50,y)))<$>my + insertItemAt mpos nitm + -- | fileLoadSVG :: MainCoroutine () fileLoadSVG = do - fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action + fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action where action filename = do xstate <- get liftIO $ putStrLn filename - bstr <- liftIO $ readFile filename + bstr <- liftIO $ B.readFile filename let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate hdl = getHoodle xstate currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage - newitem <- (liftIO . cnstrctRItem . ItemSVG) - (SVG Nothing Nothing bstr (100,100) (Dim 300 300)) + -- + callRenderer $ return . GotRItem =<< (cnstrctRItem . ItemSVG) + (SVG Nothing Nothing bstr (100,100) (Dim 300 300)) + RenderEv (GotRItem newitem) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False ) + -- let otheritems = view gitems currlayer let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) modeChange ToSelectMode nxstate <- get + let cache = view renderCache nxstate thdl <- case view hoodleModeState nxstate of SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "fileLoadSVG" - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum put ( ( set hoodleModeState (SelectState nthdl) . set isOneTimeSelectMode YesAfterSelect) nxstate) invalidateAll @@ -427,7 +487,7 @@ askQuitProgram = do b <- okCancelMessageBox "Current canvas is not saved yet. Will you close hoodle?" case b of - True -> liftIO mainQuit + True -> liftIO Gtk.mainQuit False -> return () -- | @@ -464,6 +524,11 @@ commit (set hoodleModeState (ViewAppendState nhdl) xst) invalidateAll +-- | embed an item from hoodlet using hoodlet identifier +embedHoodlet :: String -> MainCoroutine () +embedHoodlet str = loadHoodlet str >>= mapM_ (insertItemAt Nothing) + +-- | mkRevisionHdlFile :: Hoodle -> IO (String,String) mkRevisionHdlFile hdl = do hdir <- getHomeDirectory @@ -482,11 +547,11 @@ return (md5str,name) -mkRevisionPdfFile :: RHoodle -> String -> IO () -mkRevisionPdfFile hdl fname = do +mkRevisionPdfFile :: RenderCache -> RHoodle -> String -> IO () +mkRevisionPdfFile cache hdl fname = do hdir <- getHomeDirectory tempfile <- mkTmpFile "pdf" - renderjob hdl tempfile + renderjob cache hdl tempfile let nfilename = fname <.> "pdf" vcsdir = hdir ".hoodle.d" "vcs" b <- doesDirectoryExist vcsdir @@ -497,14 +562,15 @@ fileVersionSave :: MainCoroutine () fileVersionSave = do rhdl <- getHoodle <$> get - let hdl = rHoodle2Hoodle rhdl + cache <- view renderCache <$> get + let hdl = rHoodle2Hoodle rhdl rmini <- minibufDialog "Commit Message:" case rmini of Right [] -> return () Right strks' -> do doIOaction $ \_evhandler -> do (md5str,fname) <- mkRevisionHdlFile hdl - mkRevisionPdfFile rhdl fname + mkRevisionPdfFile cache rhdl fname return (UsrEv (GotRevisionInk md5str strks')) r <- waitSomeEvent (\case GotRevisionInk _ _ -> True ; _ -> False ) let GotRevisionInk md5str strks = r @@ -522,7 +588,7 @@ txtstr <- maybe "" id <$> textInputDialog doIOaction $ \_evhandler -> do (md5str,fname) <- mkRevisionHdlFile hdl - mkRevisionPdfFile rhdl fname + mkRevisionPdfFile cache rhdl fname return (UsrEv (GotRevision md5str txtstr)) r <- waitSomeEvent (\case GotRevision _ _ -> True ; _ -> False ) let GotRevision md5str txtstr' = r @@ -541,56 +607,56 @@ showRevisionDialog :: Hoodle -> [Revision] -> MainCoroutine () showRevisionDialog hdl revs = - modify (tempQueue %~ enqueue action) + liftM (view renderCache) get >>= \cache -> + modify (tempQueue %~ enqueue (action cache)) >> waitSomeEvent (\case GotOk -> True ; _ -> False) >> return () where - action = mkIOaction $ \_evhandler -> do - dialog <- dialogNew - vbox <- dialogGetUpper dialog - mapM_ (addOneRevisionBox vbox hdl) revs - _btnOk <- dialogAddButton dialog "Ok" ResponseOk - widgetShowAll dialog - _res <- dialogRun dialog - widgetDestroy dialog + action cache + = mkIOaction $ \_evhandler -> do + dialog <- Gtk.dialogNew + vbox <- Gtk.dialogGetUpper dialog + mapM_ (addOneRevisionBox cache vbox hdl) revs + _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk + Gtk.widgetShowAll dialog + _res <- Gtk.dialogRun dialog + Gtk.widgetDestroy dialog return (UsrEv GotOk) -mkPangoText :: String -> Render () +mkPangoText :: String -> Cairo.Render () mkPangoText str = do let pangordr = do - ctxt <- cairoCreateContext Nothing - layout <- layoutEmpty ctxt - fdesc <- fontDescriptionNew - fontDescriptionSetFamily fdesc "Sans Mono" - fontDescriptionSetSize fdesc 8.0 - layoutSetFontDescription layout (Just fdesc) - layoutSetWidth layout (Just 250) - layoutSetWrap layout WrapAnywhere - layoutSetText layout str - -- (_,reclog) <- layoutGetExtents layout - -- let PangoRectangle x y w h = reclog + ctxt <- Gtk.cairoCreateContext Nothing + layout <- Gtk.layoutEmpty ctxt + fdesc <- Gtk.fontDescriptionNew + Gtk.fontDescriptionSetFamily fdesc "Sans Mono" + Gtk.fontDescriptionSetSize fdesc 8.0 + Gtk.layoutSetFontDescription layout (Just fdesc) + Gtk.layoutSetWidth layout (Just 250) + Gtk.layoutSetWrap layout Gtk.WrapAnywhere + Gtk.layoutSetText layout str return layout - rdr layout = do setSourceRGBA 0 0 0 1 - updateLayout layout - showLayout layout - layout <- liftIO $ pangordr + rdr layout = do Cairo.setSourceRGBA 0 0 0 1 + Gtk.updateLayout layout + Gtk.showLayout layout + layout <- liftIO $ pangordr rdr layout -addOneRevisionBox :: VBox -> Hoodle -> Revision -> IO () -addOneRevisionBox vbox hdl rev = do - cvs <- drawingAreaNew - cvs `on` sizeRequest $ return (Requisition 250 25) - cvs `on` exposeEvent $ tryEvent $ do - drawwdw <- liftIO $ widgetGetDrawWindow cvs - liftIO . renderWithDrawable drawwdw $ do +addOneRevisionBox :: RenderCache -> Gtk.VBox -> Hoodle -> Revision -> IO () +addOneRevisionBox cache vbox hdl rev = do + cvs <- Gtk.drawingAreaNew + cvs `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 250 25) + cvs `Gtk.on` Gtk.exposeEvent $ Gtk.tryEvent $ do + drawwdw <- liftIO $ Gtk.widgetGetDrawWindow cvs + liftIO . Gtk.renderWithDrawable drawwdw $ do case rev of - RevisionInk _ strks -> scale 0.5 0.5 >> mapM_ cairoRender strks + RevisionInk _ strks -> Cairo.scale 0.5 0.5 >> mapM_ (cairoRender cache) strks Revision _ txt -> mkPangoText (B.unpack txt) hdir <- getHomeDirectory let vcsdir = hdir ".hoodle.d" "vcs" - btn <- buttonNewWithLabel "view" - btn `on` buttonPressEvent $ tryEvent $ do + btn <- Gtk.buttonNewWithLabel "view" + btn `Gtk.on` Gtk.buttonPressEvent $ Gtk.tryEvent $ do files <- liftIO $ getDirectoryContents vcsdir let fstrinit = "UUID_" ++ B.unpack (view hoodleID hdl) ++ "_MD5Digest_" ++ B.unpack (view revmd5 rev) @@ -602,10 +668,10 @@ liftIO (createProcess (proc "evince" [vcsdir x])) >> return () _ -> return () - hbox <- hBoxNew False 0 - boxPackStart hbox cvs PackNatural 0 - boxPackStart hbox btn PackGrow 0 - boxPackStart vbox hbox PackNatural 0 + hbox <- Gtk.hBoxNew False 0 + Gtk.boxPackStart hbox cvs Gtk.PackNatural 0 + Gtk.boxPackStart hbox btn Gtk.PackGrow 0 + Gtk.boxPackStart vbox hbox Gtk.PackNatural 0 fileShowRevisions :: MainCoroutine () fileShowRevisions = do @@ -620,6 +686,27 @@ let uuidstr = view ghoodleID hdl okMessageBox (B.unpack uuidstr) + +loadHoodlet :: String -> MainCoroutine (Maybe RItem) +loadHoodlet str = do + homedir <- liftIO getHomeDirectory + let hoodled = homedir ".hoodle.d" + hoodletdir = hoodled "hoodlet" + b' <- liftIO $ doesDirectoryExist hoodletdir + if b' + then do + let fp = hoodletdir str <.> "hdlt" + bstr <- liftIO $ B.readFile fp + case parseOnly Hoodlet.hoodlet bstr of + Left err -> liftIO $ putStrLn err >> return Nothing + Right itm -> do + -- + callRenderer $ cnstrctRItem itm >>= return . GotRItem + RenderEv (GotRItem ritm) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False ) + -- + return (Just ritm) + else return Nothing diff --git a/src/Hoodle/Coroutine/HandwritingRecognition.hs b/src/Hoodle/Coroutine/HandwritingRecognition.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/HandwritingRecognition.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.HandwritingRecognition +-- Copyright : (c) 2014 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.Coroutine.HandwritingRecognition where + +import Control.Lens (view,_1,_2,(%~)) +import Control.Monad ((<=<),guard,when) +import Control.Monad.State (modify) +import Control.Monad.Trans (liftIO) +import Control.Monad.Trans.Either +import Data.Aeson as A +-- import Data.Aeson.Encode +-- import Data.Aeson.Encode.Pretty +import qualified Data.Attoparsec as AP +-- import Data.Attoparsec.Number +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Foldable (mapM_) +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L (lookup) +import Data.Maybe +-- import Data.Scientific +import Data.Strict.Tuple +import qualified Data.Text as T +import Data.Traversable (forM) +import Data.UUID.V4 +import Data.Vector hiding (map,head,null,(++),take,modify,mapM_,zip,forM) +import Graphics.UI.Gtk +import System.Directory +import System.Exit +import System.FilePath +import System.Process +-- +import Control.Monad.Trans.Crtn.Queue +import Data.Hoodle.Simple +-- from this package +-- import Hoodle.Coroutine.Dialog +import Hoodle.Coroutine.Draw (waitSomeEvent) +import Hoodle.Coroutine.Minibuffer +import Hoodle.Type.Coroutine +import Hoodle.Type.Event +import Hoodle.Type.HoodleState +-- +import Prelude hiding (fst,snd,mapM_) + +getArray :: (Monad m) => Value -> EitherT String m (Vector Value) +getArray (Array v) = right v +getArray _ = left "Not an array" + +getArrayVal :: (Monad m) => Int -> Value -> EitherT String m Value +getArrayVal n v = getArray v >>= \vs -> + maybe (left (show n ++ " is out of array")) right (vs !? n) + +handwritingRecognitionDialog :: MainCoroutine (Maybe (Bool,T.Text)) +handwritingRecognitionDialog = do + liftIO $ putStrLn "handwriting recognition test here" + r <- minibufDialog "test handwriting recognition" + case r of + Left err -> liftIO $ putStrLn (show err) >> return Nothing + Right strks -> do + uuid <- liftIO $ nextRandom + tdir <- liftIO getTemporaryDirectory + let bstr = (encode . mkAesonInk) strks + let fp = tdir show uuid <.> "json" + liftIO $ LB.writeFile fp bstr + (excode,gresult,gerror) <- liftIO $ readProcessWithExitCode "curl" ["-X", "POST", "-H", "Content-Type: application/json ", "--data-ascii", "@"++fp, "http://inputtools.google.com/request?itc=en-t-i0-handwrit&app=chext" ] "" + -- let ev0 = AP.parseOnly json (B.pack gresult) + case excode of + ExitSuccess -> do + r_parse <- runEitherT $ do + v0 <- hoistEither (AP.parseOnly json (B.pack gresult)) + getArrayVal 0 v0 >>= \succstr -> + guard (succstr == (String "SUCCESS")) + v4 <-(getArray <=< getArrayVal 1 + <=< getArrayVal 0 <=< getArrayVal 1) v0 + let f (String v) = Just v + f _ = Nothing + (return . mapMaybe f . toList) v4 + + case r_parse of + Left err -> liftIO $ putStrLn err >> return Nothing + Right lst -> showRecogTextDialog lst + _ -> liftIO $ print gerror >> return Nothing + + + +showRecogTextDialog :: [T.Text] -> MainCoroutine (Maybe (Bool,T.Text)) +showRecogTextDialog txts = do + modify (tempQueue %~ enqueue action) + >> waitSomeEvent (\case OkCancel _ -> True + GotRecogResult _ _ -> True + _ -> False) + >>= \case OkCancel _ -> return Nothing + GotRecogResult b txt -> return (Just (b,txt)) + _ -> return Nothing + where + action = mkIOaction $ \evhandler -> do + dialog <- dialogNew + vbox <- dialogGetUpper dialog + let txtlst' = zip [1..] txts + txtlst <- forM txtlst' $ \(n,txt) -> do + let str = T.unpack txt + homedir <- getHomeDirectory + let hoodled = homedir ".hoodle.d" + hoodletdir = hoodled "hoodlet" + b <- doesDirectoryExist hoodletdir + b2 <- if not b + then return False + else doesFileExist (hoodletdir str <.> "hdlt") + return (n,(b2,txt)) + mapM_ (addOneTextBox evhandler dialog vbox) txtlst + _btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel + widgetShowAll dialog + res <- dialogRun dialog + widgetDestroy dialog + case res of + ResponseUser n -> case L.lookup n txtlst of + Nothing -> return (UsrEv (OkCancel False)) + Just (b,txt) -> return (UsrEv (GotRecogResult b txt)) + _ -> return (UsrEv (OkCancel False)) + +addOneTextBox :: (AllEvent -> IO ()) -> Dialog -> VBox -> (Int,(Bool,T.Text)) -> IO () +addOneTextBox _evhandler dialog vbox (n,(b,txt)) = do + btn <- buttonNewWithLabel (T.unpack txt) + when b $ do + widgetModifyBg btn StateNormal (Color 60000 60000 30000) + widgetModifyBg btn StatePrelight (Color 63000 63000 40000) + widgetModifyBg btn StateActive (Color 45000 45000 18000) + btn `on` buttonPressEvent $ tryEvent $ do + liftIO $ dialogResponse dialog (ResponseUser n) + boxPackStart vbox btn PackNatural 0 + +mkAesonInk :: [Stroke] -> Value +mkAesonInk strks = + let strks_value = (Array . fromList . map mkAesonStroke) strks + hm0 = HM.insert "writing_area_width" (Number (fromInteger 500)) + . HM.insert "writing_area_height" (Number (fromInteger 50)) + $ HM.empty + + hm1 = HM.insert "writing_guide" (Object hm0) + . HM.insert "pre_context" (A.String "") + . HM.insert "max_num_results" (Number (fromInteger 10)) + . HM.insert "max_completions" (Number (fromInteger 0)) + . HM.insert "ink" strks_value + $ HM.empty + hm2 = HM.insert "feedback" (A.String "∅[deleted]") + . HM.insert "select_type" (A.String "deleted") + $ HM.empty + hm3 = HM.insert "app_version" (Number 0.4) + . HM.insert "api_level" (A.String "537.36") + . HM.insert "device" "hoodle" + . HM.insert "input_type" (Number (fromInteger 0)) + . HM.insert "options" (A.String "enable_pre_space") + . HM.insert "requests" (Array (fromList [Object hm1, Object hm2])) + $ HM.empty + in Object hm3 + + +mkAesonStroke :: Stroke -> Value +mkAesonStroke Stroke {..} = + let xs = map (Number . fromInteger . (floor :: Double -> Integer) . fst) stroke_data + ys = map (Number . fromInteger . (floor :: Double -> Integer) . snd) stroke_data + in Array (fromList [Array (fromList xs), Array (fromList ys)]) +mkAesonStroke VWStroke {..} = + let xs = map (Number . fromInteger . (floor :: Double -> Integer) . view _1) stroke_vwdata + ys = map (Number . fromInteger . (floor :: Double -> Integer) . view _2) stroke_vwdata + in Array (fromList [Array (fromList xs), Array (fromList ys)]) diff --git a/src/Hoodle/Coroutine/Link.hs b/src/Hoodle/Coroutine/Link.hs --- a/src/Hoodle/Coroutine/Link.hs +++ b/src/Hoodle/Coroutine/Link.hs @@ -1,14 +1,16 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Link --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -18,21 +20,28 @@ module Hoodle.Coroutine.Link where import Control.Applicative +import Control.Concurrent (forkIO) import Control.Lens (at,view,set,(%~)) +import Control.Monad (forever,void) import Control.Monad.State (get,put,modify,liftIO,guard,when) -import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as B import Data.Foldable (forM_) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) import Data.Monoid (mconcat) import Data.UUID.V4 (nextRandom) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import DBus +import DBus.Client import Graphics.UI.Gtk hiding (get,set) import System.FilePath -- from hoodle-platform import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox import Data.Hoodle.Generic -import Data.Hoodle.Simple (SVG(..)) +import Data.Hoodle.Simple -- (Anchor(..),Item(..),SVG(..),pages,layers,items) import Data.Hoodle.Zipper import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type @@ -42,7 +51,8 @@ import Hoodle.Accessor import Hoodle.Coroutine.Dialog import Hoodle.Coroutine.Draw -import Hoodle.Coroutine.File (insertItemAt) +-- import Hoodle.Coroutine.File (insertItemAt) +import Hoodle.Coroutine.Page (changePage) import Hoodle.Coroutine.Select.Clipboard import Hoodle.Coroutine.TextInput import Hoodle.Device @@ -131,8 +141,9 @@ gotLink :: Maybe String -> (Int,Int) -> MainCoroutine () gotLink mstr (x,y) = do xst <- get - liftIO $ print mstr + -- liftIO $ print mstr let cid = getCurrentCanvasId xst + cache = view renderCache xst mr <- runMaybeT $ do str <- (MaybeT . return) mstr let (str1,rem1) = break (== ',') str @@ -143,7 +154,6 @@ mr2 <- runMaybeT $ do str <- (MaybeT . return) mstr (MaybeT . return) (urlParse str) - liftIO $ putStrLn ("mr2= " ++ show mr2) case mr2 of Nothing -> return () Just (FileUrl file) -> do @@ -151,7 +161,10 @@ if ext == ".png" || ext == ".PNG" || ext == ".jpg" || ext == ".JPG" then do let isembedded = view (settings.doesEmbedImage) xst - nitm <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded file) + callRenderer $ return . GotRItem =<< cnstrctRItem =<< + liftIO (makeNewItemImage isembedded file) + RenderEv (GotRItem nitm) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False ) geometry <- liftIO $ getCanvasGeometryCvsId cid xst let ccoord = CvsCoord (fromIntegral x,fromIntegral y) mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord @@ -170,7 +183,7 @@ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms case ulbbox of Middle bbox -> do - svg <- liftIO $ makeSVGFromSelection hititms bbox + svg <- liftIO $ makeSVGFromSelection cache hititms bbox uuidbstr <- liftIO $ B.pack . show <$> nextRandom deleteSelection linkInsert "simple" (uuidbstr,url) url (svg_render svg,bbox) @@ -195,7 +208,7 @@ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms case ulbbox of Middle bbox -> do - svg <- liftIO $ makeSVGFromSelection hititms bbox + svg <- liftIO $ makeSVGFromSelection cache hititms bbox uuid <- liftIO $ nextRandom let uuidbstr' = B.pack (show uuid) deleteSelection @@ -247,8 +260,63 @@ return (UsrEv (AddLink Nothing)) - +-- | +listAnchors :: MainCoroutine () +listAnchors = liftIO . print . getAnchorMap . rHoodle2Hoodle . getHoodle =<< get +getAnchorMap :: Hoodle -> M.Map T.Text (Int, (Double,Double)) +getAnchorMap hdl = + let pgs = view pages hdl + itemsInPage pg = do l <- view layers pg + i <- view items l + return i + anchorsWithPageNum :: [(Int,[Anchor])] + anchorsWithPageNum = zip [0..] + (map (mapMaybe lookupAnchor . itemsInPage) pgs) + anchormap = foldr (\(p,ys) m -> foldr (insertAnchor p) m ys) + M.empty anchorsWithPageNum + in anchormap + where lookupAnchor (ItemAnchor a) = Just a + lookupAnchor _ = Nothing + insertAnchor pgnum (Anchor {..}) = + M.insert (TE.decodeUtf8 anchor_id) (pgnum,anchor_pos) + +-- | +startLinkReceiver :: MainCoroutine () +startLinkReceiver = do + xst <- get + let callback = view callBack xst + liftIO . forkIO $ do + client <- connectSession + requestName client "org.ianwookim" [] + forkIO $ void $ addMatch + client + matchAny { matchInterface = Just "org.ianwookim.hoodle" + , matchMember = Just "link" } + (goToLink callback) + forever getLine + return () + where goToLink callback sig = do + let txts = mapMaybe fromVariant (signalBody sig) :: [T.Text] + case txts of + txt : _ -> do + let r = T.splitOn "," txt + case r of + docid:anchorid:_ -> + (postGUISync . callback . UsrEv . DBusEv . GoToLink) + (docid,anchorid) + _ -> return () + _ -> return () +goToAnchorPos :: T.Text -> T.Text -> MainCoroutine () +goToAnchorPos docid anchorid = do + xst <- get + let rhdl = getHoodle xst + hdl = rHoodle2Hoodle rhdl + when (docid == (TE.decodeUtf8 . view ghoodleID) rhdl) $ do + let anchormap = getAnchorMap hdl + forM_ (M.lookup anchorid anchormap) $ \(pgnum,(x,y))-> do + liftIO $ print (pgnum,(x,y)) + changePage (const pgnum) diff --git a/src/Hoodle/Coroutine/Minibuffer.hs b/src/Hoodle/Coroutine/Minibuffer.hs --- a/src/Hoodle/Coroutine/Minibuffer.hs +++ b/src/Hoodle/Coroutine/Minibuffer.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Minibuffer --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -17,10 +17,11 @@ import Control.Applicative ((<$>),(<*>)) import Control.Lens ((%~),view) import Control.Monad.State (modify,get) +import Control.Monad.Trans (liftIO) import Data.Foldable (Foldable(..),mapM_,forM_,toList) import Data.Sequence (Seq,(|>),empty,singleton,viewl,ViewL(..)) +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk hiding (get,set) -import Graphics.Rendering.Cairo -- import Control.Monad.Trans.Crtn.Queue (enqueue) import Data.Hoodle.Simple @@ -37,20 +38,20 @@ -- import Prelude hiding (length,mapM_) -drawMiniBufBkg :: Render () +drawMiniBufBkg :: Cairo.Render () drawMiniBufBkg = do - setSourceRGBA 0.8 0.8 0.8 1 - rectangle 0 0 500 50 - fill - setSourceRGBA 0.95 0.85 0.5 1 - rectangle 5 2 490 46 - fill - setSourceRGBA 0 0 0 1 - setLineWidth 1.0 - rectangle 5 2 490 46 - stroke + Cairo.setSourceRGBA 0.8 0.8 0.8 1 + Cairo.rectangle 0 0 500 50 + Cairo.fill + Cairo.setSourceRGBA 0.95 0.85 0.5 1 + Cairo.rectangle 5 2 490 46 + Cairo.fill + Cairo.setSourceRGBA 0 0 0 1 + Cairo.setLineWidth 1.0 + Cairo.rectangle 5 2 490 46 + Cairo.stroke -drawMiniBuf :: (Foldable t) => t Stroke -> Render () +drawMiniBuf :: (Foldable t) => t Stroke -> Cairo.Render () drawMiniBuf strks = drawMiniBufBkg >> mapM_ renderStrk strks @@ -125,23 +126,26 @@ minibufInit = waitSomeEvent (\case MiniBuffer (MiniBufferInitialized _ )-> True ; _ -> False) >>= (\case MiniBuffer (MiniBufferInitialized drawwdw) -> do - srcsfc <- liftIO (createImageSurface FormatARGB32 500 50) - tgtsfc <- liftIO (createImageSurface FormatARGB32 500 50) - liftIO $ renderWith srcsfc (drawMiniBuf empty) + srcsfc <- liftIO (Cairo.createImageSurface + Cairo.FormatARGB32 500 50) + tgtsfc <- liftIO (Cairo.createImageSurface + Cairo.FormatARGB32 500 50) + liftIO $ Cairo.renderWith srcsfc (drawMiniBuf empty) liftIO $ invalidateMinibuf drawwdw srcsfc minibufStart drawwdw (srcsfc,tgtsfc) empty _ -> minibufInit) -invalidateMinibuf :: DrawWindow -> Surface -> IO () +invalidateMinibuf :: DrawWindow -> Cairo.Surface -> IO () invalidateMinibuf drawwdw tgtsfc = renderWithDrawable drawwdw $ do - setSourceSurface tgtsfc 0 0 - setOperator OperatorSource - paint + Cairo.setSourceSurface tgtsfc 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint minibufStart :: DrawWindow - -> (Surface,Surface) -- ^ (source surface, target surface) - -> Seq Stroke -> MainCoroutine (Either () [Stroke]) + -> (Cairo.Surface,Cairo.Surface) -- ^ (source, target) + -> Seq Stroke + -> MainCoroutine (Either () [Stroke]) minibufStart drawwdw (srcsfc,tgtsfc) strks = do r <- nextevent case r of @@ -153,11 +157,13 @@ MiniBuffer (MiniBufferPenDown PenButton1 pcoord) -> do ps <- onestroke drawwdw (srcsfc,tgtsfc) (singleton pcoord) let nstrks = strks |> mkstroke ps - liftIO $ renderWith srcsfc (drawMiniBuf nstrks) + liftIO $ Cairo.renderWith srcsfc (drawMiniBuf nstrks) minibufStart drawwdw (srcsfc,tgtsfc) nstrks _ -> minibufStart drawwdw (srcsfc,tgtsfc) strks -onestroke :: DrawWindow -> (Surface,Surface) -> Seq PointerCoord +onestroke :: DrawWindow + -> (Cairo.Surface,Cairo.Surface) -- ^ (source, target) + -> Seq PointerCoord -> MainCoroutine (Seq PointerCoord) onestroke drawwdw (srcsfc,tgtsfc) pcoords = do r <- nextevent @@ -170,20 +176,22 @@ MiniBuffer (MiniBufferPenUp pcoord) -> return (pcoords |> pcoord) _ -> onestroke drawwdw (srcsfc,tgtsfc) pcoords -drawstrokebit :: (Surface,Surface) -> Seq PointerCoord -> IO() +drawstrokebit :: (Cairo.Surface,Cairo.Surface) + -> Seq PointerCoord + -> IO() drawstrokebit (srcsfc,tgtsfc) ps = - renderWith tgtsfc $ do - setSourceSurface srcsfc 0 0 - setOperator OperatorSource - paint + Cairo.renderWith tgtsfc $ do + Cairo.setSourceSurface srcsfc 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint case viewl ps of p :< ps' -> do - setOperator OperatorOver - setSourceRGBA 0.0 0.0 0.0 1.0 - setLineWidth (view penWidth defaultPenWCS) - moveTo (pointerX p) (pointerY p) - mapM_ (uncurry lineTo . ((,)<$>pointerX<*>pointerY)) ps' - stroke + Cairo.setOperator Cairo.OperatorOver + Cairo.setSourceRGBA 0.0 0.0 0.0 1.0 + Cairo.setLineWidth (view penWidth defaultPenWCS) + Cairo.moveTo (pointerX p) (pointerY p) + mapM_ (uncurry Cairo.lineTo . ((,)<$>pointerX<*>pointerY)) ps' + Cairo.stroke _ -> return () mkstroke :: Seq PointerCoord -> Stroke diff --git a/src/Hoodle/Coroutine/Mode.hs b/src/Hoodle/Coroutine/Mode.hs --- a/src/Hoodle/Coroutine/Mode.hs +++ b/src/Hoodle/Coroutine/Mode.hs @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Mode --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -61,9 +61,10 @@ whenselect xstate thdl = do let pages = view gselAll thdl mselect = view gselSelected thdl + cache = view renderCache xstate npages <- maybe (return pages) (\(spgn,spage) -> do - npage <- (liftIO.updatePageBuf.hPage2RPage) spage + npage <- (liftIO.updatePageBuf cache.hPage2RPage) spage return $ M.adjust (const npage) spgn pages ) mselect let nthdl = set gselAll npages . set gselSelected Nothing $ thdl 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 @@ -1,11 +1,15 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Page --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -14,14 +18,29 @@ module Hoodle.Coroutine.Page where -import Control.Lens (view,set,over) +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Lens (view,set,over, (.~), (^.) ) import Control.Monad import Control.Monad.State +import Control.Monad.Trans.Reader (ask) +import qualified Data.Foldable as F +import Data.Function (on) import qualified Data.IntMap as M +import Data.List (sortBy) +import Data.UUID.V4 +import qualified Graphics.Rendering.Cairo as Cairo +import qualified Graphics.UI.Gtk as Gtk +import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Select -import Graphics.Hoodle.Render.Type.Background +import Data.Hoodle.Simple (Dimension(..)) +import Data.Hoodle.Zipper +import Graphics.Hoodle.Render +-- import Graphics.Hoodle.Render.Background +import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Draw @@ -31,6 +50,7 @@ import Hoodle.Type.Alias import Hoodle.Type.Coroutine import Hoodle.Type.Canvas +import Hoodle.Type.Event import Hoodle.Type.PageArrangement import Hoodle.Type.HoodleState import Hoodle.Type.Enum @@ -44,25 +64,26 @@ >> adjustScrollbarWithGeometryCurrent >> invalidateAllInBBox Nothing Efficient where changePageAction xst = unboxBiAct (fsingle xst) (fcont xst) - . view currentCanvasInfo $ xst + . (^. currentCanvasInfo) $ xst fsingle xstate cvsInfo = do let xojst = view hoodleModeState $ xstate - npgnum = modifyfn (view currentPageNum cvsInfo) + npgnum = modifyfn (cvsInfo ^. currentPageNum) cid = view canvasId cvsInfo bsty = view backgroundStyle xstate - (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst + (b,npgnum',_,xojst') <- changePageInHoodleModeState bsty npgnum xojst xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid - xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate' + let xstatefinal = (currentCanvasInfo .~ ncvsInfo) xstate' when b (commit xstatefinal) return xstatefinal fcont xstate cvsInfo = do let xojst = view hoodleModeState xstate - npgnum = modifyfn (view currentPageNum cvsInfo) - cid = view canvasId cvsInfo - bsty = view backgroundStyle xstate - (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst + npgnum = modifyfn (cvsInfo ^. currentPageNum) + cid = cvsInfo ^. canvasId + bsty = xstate ^. backgroundStyle + (b,npgnum',_selectedpage,xojst') + <- changePageInHoodleModeState bsty npgnum xojst xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate' @@ -74,27 +95,29 @@ changePageInHoodleModeState :: BackgroundStyle -> Int -- ^ new page number -> HoodleModeState - -> (Bool,Int,Page EditMode,HoodleModeState) -changePageInHoodleModeState bsty npgnum hdlmodst = + -> MainCoroutine (Bool,Int,Page EditMode,HoodleModeState) +changePageInHoodleModeState bsty npgnum hdlmodst = do let ehdl = hoodleModeStateEither hdlmodst pgs = either (view gpages) (view gselAll) ehdl totnumpages = M.size pgs lpage = maybeError' "changePage" (M.lookup (totnumpages-1) pgs) - (isChanged,npgnum',npage',ehdl') - | npgnum >= totnumpages = - let cbkg = view gbackground lpage - nbkg - | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } - | otherwise = cbkg - npage = set gbackground nbkg - . newSinglePageFromOld $ lpage - npages = M.insert totnumpages npage pgs - in (True,totnumpages,npage, - either (Left . set gpages npages) (Right. set gselAll npages) ehdl ) - | otherwise = let npg = if npgnum < 0 then 0 else npgnum - pg = maybeError' "changePage" (M.lookup npg pgs) - in (False,npg,pg,ehdl) - in (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl') + (isChanged,npgnum',npage',ehdl') <- + if (npgnum >= totnumpages) + then do + let cbkg = view gbackground lpage + nbkg <- newBkg bsty cbkg + npage <- set gbackground nbkg <$> (newPageFromOld lpage) + geometry <- liftIO . getGeometry4CurrCvs =<< get + callRenderer $ updateBkgCache geometry (PageNum (totnumpages-1),npage) >> return GotNone + waitSomeEvent (\case RenderEv GotNone -> True ; _ -> False ) + let npages = M.insert totnumpages npage pgs + return (True,totnumpages,npage, + either (Left . set gpages npages) (Right. set gselAll npages) ehdl ) + else do + let npg = if npgnum < 0 then 0 else npgnum + pg = maybeError' "changePage" (M.lookup npg pgs) + return (False,npg,pg,ehdl) + return (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl') -- | @@ -103,24 +126,30 @@ -> Maybe ZoomMode -> Maybe (PageNum,PageCoordinate) -> MainCoroutine () -canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord - = updateXState zoomUpdateAction - >> adjustScrollbarWithGeometryCvsId cid - >> renderfunc +canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord = do + updateXState zoomUpdateAction + adjustScrollbarWithGeometryCvsId cid + xst <- get + let hdl = getHoodle xst + geometry <- liftIO (getGeometry4CurrCvs xst) + let cpn = view (unboxLens currentPageNum) . getCanvasInfo cid $ xst + let plst = sortBy ( compare `on` (\(n,_) -> abs (n - cpn)) ) . zip [0..] . F.toList $ hdl ^. gpages + forM_ plst $ \(pn,pg) -> callRenderer_ (updateBkgCache geometry (PageNum pn,pg)) + renderfunc where zoomUpdateAction xst = unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst fsingle xstate cinfo = do geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo page <- getCurrentPageCvsId cid - let zmode = maybe (view (viewInfo.zoomMode) cinfo) id mzmode - pdim = PageDimension $ view gdimension page + let zmode = maybe (cinfo ^. viewInfo.zoomMode) id mzmode + pdim = PageDimension $ page ^. gdimension xy = either (const (0,0)) (unPageCoord.snd) (getCvsOriginInPage geometry) cdim = canvasDim geometry narr = makeSingleArrangement zmode pdim cdim xy ncinfobox = CanvasSinglePage - . set (viewInfo.pageArrangement) narr - . set (viewInfo.zoomMode) zmode $ cinfo + . (viewInfo.pageArrangement .~ narr) + . (viewInfo.zoomMode .~ zmode) $ cinfo return . modifyCanvasInfo cid (const ncinfobox) $ xstate fcont xstate cinfo = do geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo @@ -134,8 +163,8 @@ (getCvsOriginInPage geometry) narr = makeContinuousArrangement zmode cdim hdl origcoord ncinfobox = CanvasContPage - . set (viewInfo.pageArrangement) narr - . set (viewInfo.zoomMode) zmode $ cinfo + . (viewInfo.pageArrangement .~ narr) + . (viewInfo.zoomMode .~ zmode) $ cinfo return . modifyCanvasInfo cid (const ncinfobox) $ xstate -- | @@ -179,11 +208,11 @@ where fsingle :: CanvasInfo a -> MainCoroutine () fsingle cinfo = do - let cpn = PageNum (view currentPageNum cinfo) - arr = view (viewInfo.pageArrangement) cinfo - canvas = view drawArea cinfo + let cpn = PageNum (cinfo ^. currentPageNum) + arr = cinfo ^. viewInfo.pageArrangement + canvas = cinfo ^. drawArea geometry <- liftIO $ makeCanvasGeometry cpn arr canvas - let nratio = relZoomRatio geometry rzmode + let nratio = relZoomRatio geometry rzmode pageZoomChange (Zoom nratio) -- | @@ -199,7 +228,7 @@ case view hoodleModeState xstate of ViewAppendState hdl -> do let bsty = view backgroundStyle xstate - hdl' = addNewPageInHoodle bsty dir hdl (view currentPageNum cinfo) + hdl' <- addNewPageInHoodle bsty dir hdl (view currentPageNum cinfo) return =<< liftIO . updatePageAll (ViewAppendState hdl') . set hoodleModeState (ViewAppendState hdl') $ xstate SelectState _ -> do @@ -232,6 +261,66 @@ npagelst = pagesbefore ++ pagesafter nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl return nhdl + + +-- | +addNewPageInHoodle :: BackgroundStyle + -> AddDirection + -> Hoodle EditMode + -> Int + -> MainCoroutine (Hoodle EditMode) +addNewPageInHoodle bsty dir hdl cpn = do + let pagelst = M.elems . view gpages $ hdl + (pagesbefore,cpage:pagesafter) = splitAt cpn pagelst + cbkg = view gbackground cpage + nbkg <- newBkg bsty cbkg + npage <- set gbackground nbkg <$> newPageFromOld cpage + geometry <- liftIO . getGeometry4CurrCvs =<< get + callRenderer_ (updateBkgCache geometry (PageNum cpn,npage)) + let npagelst = case dir of + PageBefore -> pagesbefore ++ (npage : cpage : pagesafter) + PageAfter -> pagesbefore ++ (cpage : npage : pagesafter) + nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl + return nhdl + + +newBkg :: BackgroundStyle -> RBackground -> MainCoroutine RBackground +newBkg bsty bkg = do + let bstystr = convertBackgroundStyleToByteString bsty + case bkg of + RBkgSmpl c _ _ -> RBkgSmpl c bstystr <$> liftIO nextRandom + _ -> RBkgSmpl "white" bstystr <$> liftIO nextRandom + + +-- | +newPageFromOld :: Page EditMode -> MainCoroutine (Page EditMode) +newPageFromOld = + return . ( glayers .~ (fromNonEmptyList (emptyRLayer,[]))) + + +updateBkgCache :: CanvasGeometry -> (PageNum, Page EditMode) -> Renderer () +updateBkgCache geometry (pnum,page) = do + (handler,qvar) <- ask + let dim@(Dim w h) = page ^. gdimension + CvsCoord (x0,y0) = + (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (0,0)) + CvsCoord (x1,y1) = + (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (w,h)) + s = (x1-x0) / w + rbkg = page ^. gbackground + bkg = rbkg2Bkg rbkg + uuid = rbkg_uuid rbkg + case rbkg of + RBkgSmpl {..} -> do liftIO . forkIO $ do + sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor (x1-x0)) (floor (y1-y0)) + Cairo.renderWith sfc $ Cairo.scale s s >> renderBkg (bkg,dim) + handler (uuid, (s,sfc)) + return () + + _ -> F.forM_ (rbkg_popplerpage rbkg) $ \pg -> do + (liftIO . atomically) (sendPDFCommand uuid qvar (RenderPageScaled pg (Dim w h) (Dim (x1-x0) (y1-y0)))) + return () + 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 @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Pen --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -25,17 +25,18 @@ import Data.Sequence hiding (filter) import Data.Maybe import Data.Time.Clock -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Generic (gpages) import Data.Hoodle.Simple (Dimension(..)) import Graphics.Hoodle.Render (renderStrk) -- from this package -import Hoodle.Accessor -import Hoodle.Device +-- import Hoodle.Accessor import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Draw +import Hoodle.Device +import Hoodle.GUI.Reflect import Hoodle.ModelAction.Page import Hoodle.ModelAction.Pen import Hoodle.Type.Canvas @@ -51,29 +52,30 @@ -- import Prelude hiding (mapM_) - - -- | createTempRender :: CanvasGeometry -> a -> MainCoroutine (TempRender a) createTempRender geometry x = do xst <- get let cinfobox = view currentCanvasInfo xst mcvssfc = view (unboxLens mDrawSurface) cinfobox + cache = view renderCache xst let hdl = getHoodle xst let Dim cw ch = unCanvasDimension . canvasDim $ geometry - - srcsfc <- liftIO $ maybe (fst <$> canvasImageSurface Nothing geometry hdl) - (\cvssfc -> do - sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch) - renderWith sfc $ do - setSourceSurface cvssfc 0 0 - setOperator OperatorSource - paint - return sfc) - mcvssfc - liftIO $ renderWith srcsfc $ do + srcsfc <- liftIO $ + maybe (fst <$> canvasImageSurface cache Nothing geometry hdl) + (\cvssfc -> do + sfc <- Cairo.createImageSurface + Cairo.FormatARGB32 (floor cw) (floor ch) + Cairo.renderWith sfc $ do + Cairo.setSourceSurface cvssfc 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint + return sfc) + mcvssfc + liftIO $ Cairo.renderWith srcsfc $ do emphasisCanvasRender ColorRed geometry - tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch) + tgtsfc <- liftIO $ Cairo.createImageSurface + Cairo.FormatARGB32 (floor cw) (floor ch) let trdr = TempRender srcsfc tgtsfc (cw,ch) x return trdr @@ -91,7 +93,8 @@ -- | Common Pen Work starting point commonPenStart :: (forall a. CanvasInfo a -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine () ) - -> CanvasId -> PointerCoord + -> CanvasId + -> PointerCoord -> MainCoroutine () commonPenStart action cid pcoord = do oxstate <- get @@ -116,7 +119,9 @@ action nCvsInfo pgn geometry (x,y) -- | enter pen drawing mode -penStart :: CanvasId -> PointerCoord -> MainCoroutine () +penStart :: CanvasId + -> PointerCoord + -> MainCoroutine () penStart cid pcoord = commonPenStart penAction cid pcoord where penAction :: forall b. CanvasInfo b -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine () penAction _cinfo pnum geometry (x,y) = do @@ -125,11 +130,12 @@ let currhdl = getHoodle xstate pinfo = view penInfo xstate mpage = view (gpages . at (unPageNum pnum)) currhdl + cache = view renderCache xstate forM_ mpage $ \_page -> do trdr <- createTempRender geometry (empty |> (x,y,z)) pdraw <-penProcess cid pnum geometry trdr ((x,y),z) - surfaceFinish (tempSurfaceSrc trdr) - surfaceFinish (tempSurfaceTgt trdr) + Cairo.surfaceFinish (tempSurfaceSrc trdr) + Cairo.surfaceFinish (tempSurfaceTgt trdr) -- case viewl pdraw of EmptyL -> return () @@ -137,7 +143,7 @@ if x1 <= 1e-3 -- this is ad hoc but.. then invalidateAll else do - (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw + (newhdl,bbox) <- liftIO $ addPDraw cache pinfo currhdl pnum pdraw commit . set hoodleModeState (ViewAppendState newhdl) =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate)) let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord @@ -146,7 +152,8 @@ -- | main pen coordinate adding process -- | now being changed -penProcess :: CanvasId -> PageNum +penProcess :: CanvasId + -> PageNum -> CanvasGeometry -> TempRender (Seq (Double,Double,Double)) -> ((Double,Double),Double) @@ -166,7 +173,7 @@ (\(pcoord,(x,y)) -> do let PointerCoord _ _ _ z = pcoord let pinfo = view penInfo xstate - let xformfunc = cairoXform4PageCoordinate geometry pnum + let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum ) tmpstrk = createNewStroke pinfo pdraw renderfunc = do xformfunc @@ -181,21 +188,25 @@ -- | skipIfNotInSamePage :: Monad m => - PageNum -> CanvasGeometry -> PointerCoord - -> m a - -> ((PointerCoord,(Double,Double)) -> m a) - -> m a + PageNum + -> CanvasGeometry + -> PointerCoord + -> m a + -> ((PointerCoord,(Double,Double)) -> m a) + -> m a skipIfNotInSamePage pgn geometry pcoord skipaction ordaction = switchActionEnteringDiffPage pgn geometry pcoord skipaction (\_ _ -> skipaction ) (\_ (_,PageCoord xy)->ordaction (pcoord,xy)) -- | switchActionEnteringDiffPage :: Monad m => - PageNum -> CanvasGeometry -> PointerCoord - -> m a - -> (PageNum -> (PageNum,PageCoordinate) -> m a) - -> (PageNum -> (PageNum,PageCoordinate) -> m a) - -> m a + PageNum + -> CanvasGeometry + -> PointerCoord + -> m a + -> (PageNum -> (PageNum,PageCoordinate) -> m a) + -> (PageNum -> (PageNum,PageCoordinate) -> m a) + -> m a switchActionEnteringDiffPage pgn geometry pcoord skipaction chgaction ordaction = do let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord maybeFlip pagecoord skipaction @@ -204,13 +215,14 @@ else chgaction pgn (cpn,pxy) -- | in page action -penMoveAndUpOnly :: Monad m => UserEvent - -> PageNum - -> CanvasGeometry - -> m a - -> ((PointerCoord,(Double,Double)) -> m a) - -> (PointerCoord -> m a) - -> m a +penMoveAndUpOnly :: Monad m => + UserEvent + -> PageNum + -> CanvasGeometry + -> m a + -> ((PointerCoord,(Double,Double)) -> m a) + -> (PointerCoord -> m a) + -> m a penMoveAndUpOnly r pgn geometry defact moveaction upaction = case r of PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction @@ -218,7 +230,8 @@ _ -> defact -- | -penMoveAndUpInterPage :: Monad m => UserEvent +penMoveAndUpInterPage :: Monad m => + UserEvent -> PageNum -> CanvasGeometry -> m a 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 @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Scroll --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -23,6 +23,8 @@ import Data.Functor.Identity (Identity(..)) import Data.Hoodle.BBox -- from this package +import Hoodle.Coroutine.Draw +import Hoodle.GUI.Reflect import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.Coroutine @@ -30,7 +32,6 @@ import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement import qualified Hoodle.ModelAction.Adjustment as A -import Hoodle.Coroutine.Draw import Hoodle.Accessor import Hoodle.View.Coordinate -- 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 @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Select --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -17,6 +17,7 @@ module Hoodle.Coroutine.Select where -- from other package +import Control.Applicative import Control.Category import Control.Lens (view,set) import Control.Monad @@ -27,7 +28,7 @@ import Data.Sequence (Seq,(|>)) import qualified Data.Sequence as Sq (empty) import Data.Time.Clock -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Cairo.Matrix as Mat -- from hoodle-platform import Data.Hoodle.Select @@ -64,9 +65,9 @@ import Prelude hiding ((.), id) -- | For Selection mode from pen mode with 2nd pen button -dealWithOneTimeSelectMode :: MainCoroutine () -- ^ main action - -> MainCoroutine () -- ^ terminating action - -> MainCoroutine () +dealWithOneTimeSelectMode :: MainCoroutine () -- ^ main action + -> MainCoroutine () -- ^ terminating action + -> MainCoroutine () dealWithOneTimeSelectMode action terminator = do xstate <- get case view isOneTimeSelectMode xstate of @@ -104,7 +105,7 @@ newSelectLasso cinfo pnum geometry itms (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel _ -> return () - surfaceFinish (tempSurfaceSrc tsel) + Cairo.surfaceFinish (tempSurfaceSrc tsel) showContextMenu (pnum,(x,y)) ) (return ()) @@ -160,7 +161,7 @@ (moveact xstate cinfo) (upact xstate cinfo) defact = newSelectRectangle cid pnum geometry itms orig (prev,otime) tempselection - moveact _xstate _cinfo (_pcoord,(x,y)) = do + moveact xstate _cinfo (_pcoord,(x,y)) = do let bbox = BBox orig (x,y) hittestbbox = hltEmbeddedByBBox bbox itms hitteditms = takeHitted hittestbbox @@ -168,17 +169,19 @@ let (fitms,sitms) = separateFS $ getDiffBBox (tempInfo tempselection) hitteditms (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when ((not.null) fitms || (not.null) sitms) $ do - let xformfunc = cairoXform4PageCoordinate geometry pnum + let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum) ulbbox = unUnion . mconcat . fmap (Union .Middle . flip inflate 5 . getBBox) $ fitms + cache = view renderCache xstate + xform = mkXform4Page geometry pnum renderfunc = do xformfunc case ulbbox of - Top -> do - cairoRenderOption (InBBoxOption Nothing) (InBBox page) + Top -> do + cairoRenderOption (InBBoxOption Nothing) cache (InBBox page, Just xform) mapM_ renderSelectedItem hitteditms Middle sbbox -> do let redrawee = filter (do2BBoxIntersect sbbox.getBBox) hitteditms - cairoRenderOption (InBBoxOption (Just sbbox)) (InBBox page) + cairoRenderOption (InBBoxOption (Just sbbox)) cache (InBBox page, Just xform) clipBBox (Just sbbox) mapM_ renderSelectedItem redrawee Bottom -> return () @@ -212,7 +215,6 @@ liftIO $ toggleCutCopyDelete ui (isAnyHitted selectitms) put . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) - -- invalidateAll invalidateAllInBBox Nothing Efficient @@ -223,14 +225,14 @@ -> ((Double,Double),UTCTime) -> Page SelectMode -> MainCoroutine () -startMoveSelect cid pnum geometry ((x,y),ctime) tpage = do - itmimage <- liftIO $ mkItmsNImg geometry tpage +startMoveSelect cid pnum geometry ((x,y),ctime) tpage = do + cache <- view renderCache <$> get + itmimage <- liftIO $ mkItmsNImg cache tpage tsel <- createTempRender geometry itmimage moveSelect cid pnum geometry (x,y) ((x,y),ctime) tsel - surfaceFinish (tempSurfaceSrc tsel) - surfaceFinish (tempSurfaceTgt tsel) - surfaceFinish (imageSurface itmimage) - -- invalidateAll + Cairo.surfaceFinish (tempSurfaceSrc tsel) + Cairo.surfaceFinish (tempSurfaceTgt tsel) + Cairo.surfaceFinish (imageSurface itmimage) invalidateAllInBBox Nothing Efficient -- | @@ -282,12 +284,13 @@ chgaction xstate cinfo oldpgn (newpgn,PageCoord (x,y)) = do let hdlmodst@(SelectState thdl) = view hoodleModeState xstate epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst + cache = view renderCache xstate (xstate1,nthdl1,selecteditms) <- case epage of Right oldtpage -> do let itms = getSelectedItms oldtpage let oldtpage' = deleteSelected oldtpage - nthdl <- liftIO $ updateTempHoodleSelectIO thdl oldtpage' (unPageNum oldpgn) + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl oldtpage' (unPageNum oldpgn) xst <- return . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xstate)) return (xst,nthdl,itms) @@ -300,7 +303,7 @@ alist = olditms :- Hitted newitms :- Empty ntpage = makePageSelectMode page alist coroutineaction = do - nthdl2 <- liftIO $ updateTempHoodleSelectIO nthdl1 ntpage (unPageNum newpgn) + nthdl2 <- liftIO $ updateTempHoodleSelectIO cache nthdl1 ntpage (unPageNum newpgn) let cibox = view currentCanvasInfo xstate1 ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum newpgn))) cibox @@ -322,8 +325,9 @@ pagenum = view currentPageNum cinfo case epage of Right tpage -> do - let newtpage = changeSelectionByOffset offset tpage - newthdl <- liftIO $ updateTempHoodleSelectIO thdl newtpage pagenum + let newtpage = changeSelectionByOffset offset tpage + cache = view renderCache xstate + newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newtpage pagenum commit . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) Left _ -> error "this is impossible, in moveSelect" @@ -332,37 +336,37 @@ -- | prepare for resizing selection -startResizeSelect :: Bool -- ^ doesKeepRatio - -> Handle - -> CanvasId - -> PageNum - -> CanvasGeometry - -> BBox - -> ((Double,Double),UTCTime) - -> Page SelectMode - -> MainCoroutine () +startResizeSelect :: Bool -- ^ doesKeepRatio + -> Handle -- ^ current selection handle + -> CanvasId + -> PageNum + -> CanvasGeometry + -> BBox + -> ((Double,Double),UTCTime) + -> Page SelectMode + -> MainCoroutine () startResizeSelect doesKeepRatio handle cid pnum geometry bbox - ((x,y),ctime) tpage = do - itmimage <- liftIO $ mkItmsNImg geometry tpage + ((x,y),ctime) tpage = do + cache <- view renderCache <$> get + itmimage <- liftIO $ mkItmsNImg cache tpage tsel <- createTempRender geometry itmimage resizeSelect doesKeepRatio handle cid pnum geometry bbox ((x,y),ctime) tsel - surfaceFinish (tempSurfaceSrc tsel) - surfaceFinish (tempSurfaceTgt tsel) - surfaceFinish (imageSurface itmimage) - -- invalidateAll + Cairo.surfaceFinish (tempSurfaceSrc tsel) + Cairo.surfaceFinish (tempSurfaceTgt tsel) + Cairo.surfaceFinish (imageSurface itmimage) invalidateAllInBBox Nothing Efficient -- | -resizeSelect :: Bool -- ^ doesKeepRatio - -> Handle - -> CanvasId - -> PageNum - -> CanvasGeometry - -> BBox - -> ((Double,Double),UTCTime) - -> TempRender ItmsNImg - -> MainCoroutine () +resizeSelect :: Bool -- ^ doesKeepRatio + -> Handle -- ^ current selection handle + -> CanvasId + -> PageNum + -> CanvasGeometry + -> BBox + -> ((Double,Double),UTCTime) + -> TempRender ItmsNImg + -> MainCoroutine () resizeSelect doesKeepRatio handle cid pnum geometry origbbox (prev,otime) tempselection = do xst <- get @@ -425,8 +429,9 @@ case epage of Right tpage -> do let sfunc = scaleFromToBBox origbbox newbbox - let newtpage = changeSelectionBy sfunc tpage - newthdl <- liftIO $ updateTempHoodleSelectIO thdl newtpage pagenum + newtpage = changeSelectionBy sfunc tpage + cache = view renderCache xstate + newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newtpage pagenum commit . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) Left _ -> error "this is impossible, in resizeSelect" @@ -449,7 +454,8 @@ (Hitted . map (changeItemStrokeColor pcolor) . unHitted) alist newlayer = Right alist' newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage - newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n + cache = view renderCache xstate + newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newpage n commit =<< liftIO (updatePageAll (SelectState newthdl) . set hoodleModeState (SelectState newthdl) $ xstate ) -- invalidateAll @@ -462,6 +468,7 @@ let SelectState thdl = view hoodleModeState xstate Just (n,tpage) = view gselSelected thdl slayer = view (glayers.selectedLayer) tpage + cache = view renderCache xstate case unTEitherAlterHitted . view gitems $ slayer of Left _ -> return () Right alist -> do @@ -469,7 +476,7 @@ (Hitted . map (changeItemStrokeWidth pwidth) . unHitted) alist newlayer = Right alist' newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage - newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n + newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newpage n commit =<< liftIO (updatePageAll (SelectState newthdl) . set hoodleModeState (SelectState newthdl) $ xstate ) -- invalidateAll diff --git a/src/Hoodle/Coroutine/Select/Clipboard.hs b/src/Hoodle/Coroutine/Select/Clipboard.hs --- a/src/Hoodle/Coroutine/Select/Clipboard.hs +++ b/src/Hoodle/Coroutine/Select/Clipboard.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Select.Clipboard --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -15,6 +17,7 @@ module Hoodle.Coroutine.Select.Clipboard where -- from other packages +import Control.Applicative import Control.Lens (view,set,(%~)) import Control.Monad.State import Graphics.UI.Gtk hiding (get,set) @@ -54,7 +57,8 @@ Right alist -> do let newlayer = Left . concat . getA $ alist newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage - newthdl <- liftIO $ updateTempHoodleSelectIO thdl newpage n + cache = view renderCache xstate + newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newpage n newxstate <- liftIO $ updatePageAll (SelectState newthdl) . set hoodleModeState (SelectState newthdl) $ xstate @@ -111,7 +115,11 @@ case mitms of Nothing -> return () Just itms -> do - ritms <- liftIO (mapM cnstrctRItem itms) + -- + callRenderer $ GotRItems <$> mapM cnstrctRItem itms + RenderEv (GotRItems ritms) <- + waitSomeEvent (\case RenderEv (GotRItems _) -> True; _ -> False) + -- modeChange ToSelectMode >>updateXState (pasteAction ritms) >> invalidateAll where pasteAction itms xst = forBoth' unboxBiAct (fsimple itms xst) . view currentCanvasInfo $ xst @@ -131,7 +139,8 @@ :- Hitted nclipitms :- Empty ) tpage' = set (glayers.selectedLayer) newlayerselect tpage - thdl' <- liftIO $ updateTempHoodleSelectIO thdl tpage' pagenum + cache = view renderCache xstate + thdl' <- liftIO $ updateTempHoodleSelectIO cache thdl tpage' pagenum xstate' <- liftIO $ updatePageAll (SelectState thdl') . set hoodleModeState (SelectState thdl') $ xstate diff --git a/src/Hoodle/Coroutine/Select/ManipulateImage.hs b/src/Hoodle/Coroutine/Select/ManipulateImage.hs --- a/src/Hoodle/Coroutine/Select/ManipulateImage.hs +++ b/src/Hoodle/Coroutine/Select/ManipulateImage.hs @@ -4,9 +4,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Select.ManipulateImage --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -20,12 +20,13 @@ import Control.Lens (set, view, _2) import Control.Monad (when) import Control.Monad.State (get) +import Control.Monad.Trans (liftIO) import Data.ByteString.Base64 (encode) import Data.Foldable (forM_) import Data.Monoid ((<>)) import Data.Time import qualified Graphics.GD.ByteString as G -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo -- import Data.Hoodle.BBox import Data.Hoodle.Simple @@ -85,17 +86,22 @@ tsel <- createTempRender geometry (p0, BBox (unPageCoord c0) (unPageCoord c0)) ctime <- liftIO $ getCurrentTime nbbox <- newCropRect cid geometry tsel (unPageCoord c0) (unPageCoord c0,ctime) - surfaceFinish (tempSurfaceSrc tsel) - surfaceFinish (tempSurfaceTgt tsel) + Cairo.surfaceFinish (tempSurfaceSrc tsel) + Cairo.surfaceFinish (tempSurfaceTgt tsel) let pnum = (fst . tempInfo) tsel - let img = bbxed_content imgbbx + img = bbxed_content imgbbx obbox = getBBox imgbbx + cache = view renderCache xst when (isBBox2InBBox1 obbox nbbox) $ do mimg' <- liftIO $ createCroppedImage img obbox nbbox forM_ mimg' $ \img' -> do - rimg' <- liftIO $ cnstrctRItem (ItemImage img') + -- + callRenderer $ return . GotRItem =<< cnstrctRItem (ItemImage img') + RenderEv (GotRItem rimg') <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) + -- let ntpage = replaceSelection rimg' tpage - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpage (unPageNum pnum) + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpage (unPageNum pnum) commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst)) invalidateAllInBBox Nothing Efficient return () @@ -154,18 +160,23 @@ hdlmodst = view hoodleModeState xst pnum = (PageNum . forBoth' unboxBiAct (view currentPageNum)) cinfobox epage = forBoth' unboxBiAct (flip getCurrentPageEitherFromHoodleModeState hdlmodst) cinfobox + cache = view renderCache xst case hdlmodst of ViewAppendState _ -> return () SelectState thdl -> do - case epage of + case epage of Left _ -> return () Right tpage -> do let img = bbxed_content imgbbx mimg' <- liftIO (createRotatedImage dir img (getBBox imgbbx)) forM_ mimg' $ \img' -> do - rimg' <- liftIO $ cnstrctRItem (ItemImage img') + -- + callRenderer $ return . GotRItem =<< cnstrctRItem (ItemImage img') + RenderEv (GotRItem rimg') <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) + -- let ntpage = replaceSelection rimg' tpage - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpage (unPageNum pnum) + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpage (unPageNum pnum) commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst)) invalidateAllInBBox Nothing Efficient return () diff --git a/src/Hoodle/Coroutine/TextInput.hs b/src/Hoodle/Coroutine/TextInput.hs --- a/src/Hoodle/Coroutine/TextInput.hs +++ b/src/Hoodle/Coroutine/TextInput.hs @@ -6,9 +6,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.TextInput --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -18,21 +18,27 @@ module Hoodle.Coroutine.TextInput where import Control.Applicative -import Control.Lens (_1,_2,_3,view,set,(%~)) +-- import Control.Concurrent.STM (atomically, newTVar) +import Control.Lens (_1,_2,_3,view,set,(%~),(^.),(.~)) import Control.Monad.State hiding (mapM_, forM_) import Control.Monad.Trans.Either -import Data.Attoparsec +import Control.Monad.Trans.Maybe +-- import Data.Attoparsec +import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as B import Data.Foldable (mapM_, forM_) import Data.List (sortBy) +import qualified Data.Map as M import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO import Data.UUID.V4 (nextRandom) -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Cairo.SVG as RSVG -import Graphics.Rendering.Pango.Cairo -import Graphics.UI.Gtk hiding (get,set) +-- import qualified Graphics.Rendering.Pango.Cairo as Pango +import qualified Graphics.UI.Gtk as Gtk import System.Directory import System.Exit (ExitCode(..)) import System.FilePath @@ -43,26 +49,32 @@ import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox import Data.Hoodle.Generic -import Data.Hoodle.Simple -import Graphics.Hoodle.Render.Item +import Data.Hoodle.Select +import Data.Hoodle.Simple +import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type.HitTest -import Graphics.Hoodle.Render.Type.Hoodle (rHoodle2Hoodle) +import Graphics.Hoodle.Render.Type.Hoodle (rHoodle2Hoodle, rPage2Page) +import Graphics.Hoodle.Render.Type.Item import qualified Text.Hoodle.Parse.Attoparsec as PA -- -import Hoodle.ModelAction.Layer -import Hoodle.ModelAction.Page -import Hoodle.ModelAction.Select +import Hoodle.Accessor import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Dialog import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Mode import Hoodle.Coroutine.Network import Hoodle.Coroutine.Select.Clipboard +import Hoodle.ModelAction.Layer +import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Select +import Hoodle.ModelAction.Select.Transform +import Hoodle.ModelAction.Text import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement import Hoodle.Util -- import Prelude hiding (readFile,mapM_) @@ -72,23 +84,23 @@ textInputDialog :: MainCoroutine (Maybe String) textInputDialog = do doIOaction $ \_evhandler -> do - dialog <- messageDialogNew Nothing [DialogModal] - MessageQuestion ButtonsOkCancel "text input" - vbox <- dialogGetUpper dialog - txtvw <- textViewNew - boxPackStart vbox txtvw PackGrow 0 - widgetShowAll dialog - res <- dialogRun dialog + dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal] + Gtk.MessageQuestion Gtk.ButtonsOkCancel "text input" + vbox <- Gtk.dialogGetUpper dialog + txtvw <- Gtk.textViewNew + Gtk.boxPackStart vbox txtvw Gtk.PackGrow 0 + Gtk.widgetShowAll dialog + res <- Gtk.dialogRun dialog case res of - ResponseOk -> do - buf <- textViewGetBuffer txtvw - (istart,iend) <- (,) <$> textBufferGetStartIter buf - <*> textBufferGetEndIter buf - l <- textBufferGetText buf istart iend True - widgetDestroy dialog + Gtk.ResponseOk -> do + buf <- Gtk.textViewGetBuffer txtvw + (istart,iend) <- (,) <$> Gtk.textBufferGetStartIter buf + <*> Gtk.textBufferGetEndIter buf + l <- Gtk.textBufferGetText buf istart iend True + Gtk.widgetDestroy dialog return (UsrEv (TextInput (Just l))) _ -> do - widgetDestroy dialog + Gtk.widgetDestroy dialog return (UsrEv (TextInput Nothing)) let go = do r <- nextevent case r of @@ -97,42 +109,44 @@ _ -> go go +-- | common dialog with multiline edit input box multiLineDialog :: T.Text -> Either (ActionOrder AllEvent) AllEvent multiLineDialog str = mkIOaction $ \evhandler -> do - dialog <- dialogNew - vbox <- dialogGetUpper dialog - textbuf <- textBufferNew Nothing - textBufferSetByteString textbuf (TE.encodeUtf8 str) - textbuf `on` bufferChanged $ do - (s,e) <- (,) <$> textBufferGetStartIter textbuf <*> textBufferGetEndIter textbuf - contents <- textBufferGetByteString textbuf s e False + dialog <- Gtk.dialogNew + vbox <- Gtk.dialogGetUpper dialog + textbuf <- Gtk.textBufferNew Nothing + Gtk.textBufferSetByteString textbuf (TE.encodeUtf8 str) + textbuf `Gtk.on` Gtk.bufferChanged $ do + (s,e) <- (,) <$> Gtk.textBufferGetStartIter textbuf <*> Gtk.textBufferGetEndIter textbuf + contents <- Gtk.textBufferGetByteString textbuf s e False (evhandler . UsrEv . MultiLine . MultiLineChanged) (TE.decodeUtf8 contents) - textarea <- textViewNewWithBuffer textbuf - vscrbar <- vScrollbarNew =<< textViewGetVadjustment textarea - hscrbar <- hScrollbarNew =<< textViewGetHadjustment textarea - textarea `on` sizeRequest $ return (Requisition 500 600) - fdesc <- fontDescriptionNew - fontDescriptionSetFamily fdesc "Mono" - widgetModifyFont textarea (Just fdesc) + textarea <- Gtk.textViewNewWithBuffer textbuf + vscrbar <- Gtk.vScrollbarNew =<< Gtk.textViewGetVadjustment textarea + hscrbar <- Gtk.hScrollbarNew =<< Gtk.textViewGetHadjustment textarea + textarea `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 500 600) + fdesc <- Gtk.fontDescriptionNew + Gtk.fontDescriptionSetFamily fdesc "Mono" + Gtk.widgetModifyFont textarea (Just fdesc) -- - table <- tableNew 2 2 False - tableAttachDefaults table textarea 0 1 0 1 - tableAttachDefaults table vscrbar 1 2 0 1 - tableAttachDefaults table hscrbar 0 1 1 2 - boxPackStart vbox table PackNatural 0 + table <- Gtk.tableNew 2 2 False + Gtk.tableAttachDefaults table textarea 0 1 0 1 + Gtk.tableAttachDefaults table vscrbar 1 2 0 1 + Gtk.tableAttachDefaults table hscrbar 0 1 1 2 + Gtk.boxPackStart vbox table Gtk.PackNatural 0 -- - _btnOk <- dialogAddButton dialog "Ok" ResponseOk - _btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel - _btnNetwork <- dialogAddButton dialog "Network" (ResponseUser 1) - widgetShowAll dialog - res <- dialogRun dialog - widgetDestroy dialog + _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk + _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel + _btnNetwork <- Gtk.dialogAddButton dialog "Network" (Gtk.ResponseUser 1) + Gtk.widgetShowAll dialog + res <- Gtk.dialogRun dialog + Gtk.widgetDestroy dialog case res of - ResponseOk -> return (UsrEv (OkCancel True)) - ResponseCancel -> return (UsrEv (OkCancel False)) - ResponseUser 1 -> return (UsrEv (NetworkProcess NetworkDialog)) + Gtk.ResponseOk -> return (UsrEv (OkCancel True)) + Gtk.ResponseCancel -> return (UsrEv (OkCancel False)) + Gtk.ResponseUser 1 -> return (UsrEv (NetworkProcess NetworkDialog)) _ -> return (UsrEv (OkCancel False)) +-- | main event loop for multiline edit box multiLineLoop :: T.Text -> MainCoroutine (Maybe T.Text) multiLineLoop txt = do r <- nextevent @@ -146,34 +160,89 @@ _ -> multiLineLoop txt -- | insert text -textInput :: (Double,Double) -> T.Text -> MainCoroutine () -textInput (x0,y0) str = do - modify (tempQueue %~ enqueue (multiLineDialog str)) - multiLineLoop str >>= - mapM_ (\result -> deleteSelection - >> liftIO (makePangoTextSVG (x0,y0) result) - >>= svgInsert (result,"pango")) +textInput :: Maybe (Double,Double) -> T.Text -> MainCoroutine () +textInput mpos str = do + case mpos of + Just (x0,y0) -> do + modify (tempQueue %~ enqueue (multiLineDialog str)) + multiLineLoop str >>= + mapM_ (\result -> deleteSelection + >> liftIO (makePangoTextSVG (x0,y0) result) + >>= svgInsert (result,"pango")) + Nothing -> liftIO $ putStrLn "textInput: not implemented" -- | insert latex -laTeXInput :: (Double,Double) -> T.Text -> MainCoroutine () -laTeXInput (x0,y0) str = do - modify (tempQueue %~ enqueue (multiLineDialog str)) - multiLineLoop str >>= - mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) - >>= \case Right r -> deleteSelection >> svgInsert (result,"latex") r - Left err -> okMessageBox err >> laTeXInput (x0,y0) result - ) +laTeXInput :: Maybe (Double,Double) -> T.Text -> MainCoroutine () +laTeXInput mpos str = do + case mpos of + Just (x0,y0) -> do + modify (tempQueue %~ enqueue (multiLineDialog str)) + multiLineLoop str >>= + mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) >>= \case + Right r -> deleteSelection >> svgInsert (result,"latex") r + Left err -> okMessageBox err >> laTeXInput mpos result + ) + Nothing -> do + modeChange ToViewAppendMode + autoPosText >>= + maybe (laTeXInput (Just (100,100)) str) + (\y'->laTeXInput (Just (100,y')) str) +autoPosText :: MainCoroutine (Maybe Double) +autoPosText = do + cpg <- rPage2Page <$> getCurrentPageCurr + let Dim _pgw pgh = view dimension cpg + mcomponents = do + l <- view layers cpg + i <- view items l + case i of + ItemSVG svg -> + case svg_command svg of + Just "latex" -> do + let (_,y) = svg_pos svg + Dim _ h = svg_dim svg + return (y,y+h) + _ -> [] + ItemImage img -> do + let (_,y) = img_pos img + Dim _ h = img_dim img + return (y,y+h) + + _ -> [] + if null mcomponents + then return Nothing + else do let y0 = (head . sortBy (flip compare) . map snd) mcomponents + if y0 + 10 > pgh then return Nothing else return (Just (y0 + 10)) + + -- | -laTeXInputNetwork :: (Double,Double) -> T.Text -> MainCoroutine () -laTeXInputNetwork (x0,y0) str = - networkTextInput str >>= - mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) - >>= \case Right r -> deleteSelection >> svgInsert (result,"latex") r - Left err -> okMessageBox err >> laTeXInput (x0,y0) result - ) +laTeXInputNetwork :: Maybe (Double,Double) -> T.Text -> MainCoroutine () +laTeXInputNetwork mpos str = + case mpos of + Just (x0,y0) -> do + networkTextInput str >>= + mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) + >>= \case Right r -> deleteSelection >> svgInsert (result,"latex") r + Left err -> okMessageBox err >> laTeXInput mpos result + ) + Nothing -> do + modeChange ToViewAppendMode + autoPosText >>= + maybe (laTeXInputNetwork (Just (100,100)) str) + (\y'->laTeXInputNetwork (Just (100,y')) str) +dbusNetworkInput :: T.Text -> MainCoroutine () +dbusNetworkInput txt = do + modeChange ToViewAppendMode + mpos <- autoPosText + let pos = maybe (100,100) (100,) mpos + rsvg <- liftIO (makeLaTeXSVG pos txt) + case rsvg of + Right r -> deleteSelection >> svgInsert (txt,"latex") r + Left err -> okMessageBox err >> laTeXInput (Just pos) txt + + laTeXHeader :: T.Text laTeXHeader = "\\documentclass{article}\n\ \\\pagestyle{empty}\n\ @@ -194,7 +263,7 @@ B.writeFile (tfilename <.> "tex") (TE.encodeUtf8 txt) r <- runEitherT $ do - check "error during pdflatex" $ do + check "error during xelatex" $ do (ecode,ostr,estr) <- readProcessWithExitCode "xelatex" [tfilename <.> "tex"] "" return (ecode,ostr++estr) check "error during pdfcrop" $ do @@ -219,18 +288,23 @@ hdl = getHoodle xstate currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage - newitem <- (liftIO . cnstrctRItem . ItemSVG) - (SVG (Just (TE.encodeUtf8 txt)) (Just (B.pack cmd)) svgbstr - (x0,y0) (Dim (x1-x0) (y1-y0))) + -- + callRenderer ( (return . GotRItem) =<< + (cnstrctRItem (ItemSVG (SVG (Just (TE.encodeUtf8 txt)) (Just (B.pack cmd)) svgbstr (x0,y0) (Dim (x1-x0) (y1-y0)))))) + + RenderEv (GotRItem newitem) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False ) + -- let otheritems = view gitems currlayer let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) + cache = view renderCache xstate modeChange ToSelectMode nxstate <- get thdl <- case view hoodleModeState nxstate of SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "svgInsert" - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum put (set hoodleModeState (SelectState nthdl) nxstate) commit_ invalidateAll @@ -263,55 +337,58 @@ -> MainCoroutine () linkInsert _typ (uuidbstr,fname) str (svgbstr,BBox (x0,y0) (x1,y1)) = do xstate <- get - let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate - hdl = getHoodle xstate - currpage = getPageFromGHoodleMap pgnum hdl - currlayer = getCurrentLayer currpage + let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate lnk = Link uuidbstr "simple" (B.pack fname) (Just (B.pack str)) Nothing svgbstr (x0,y0) (Dim (x1-x0) (y1-y0)) nlnk <- liftIO $ convertLinkFromSimpleToDocID lnk >>= maybe (return lnk) return - liftIO $ print nlnk - newitem <- (liftIO . cnstrctRItem . ItemLink) nlnk - let otheritems = view gitems currlayer - let ntpg = makePageSelectMode currpage - (otheritems :- (Hitted [newitem]) :- Empty) - modeChange ToSelectMode - nxstate <- get - thdl <- case view hoodleModeState nxstate of - SelectState thdl' -> return thdl' - _ -> (lift . EitherT . return . Left . Other) "linkInsert" - nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate - put nxstate2 - invalidateAll + -- + callRenderer $ return . GotRItem =<< cnstrctRItem (ItemLink nlnk) + RenderEv (GotRItem newitem) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) + -- + insertItemAt (Just (PageNum pgnum, PageCoord (x0,y0))) newitem + +-- | anchor +addAnchor :: MainCoroutine () +addAnchor = do + uuid <- liftIO $ nextRandom + let uuidbstr = B.pack (show uuid) + let anc = Anchor uuidbstr "" (100,100) (Dim 50 50) + -- + callRenderer $ return . GotRItem =<< cnstrctRItem (ItemAnchor anc) + RenderEv (GotRItem nitm) <- + waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False) + -- + insertItemAt Nothing nitm + -- | makePangoTextSVG :: (Double,Double) -> T.Text -> IO (B.ByteString,BBox) makePangoTextSVG (xo,yo) str = do let pangordr = do - ctxt <- cairoCreateContext Nothing - layout <- layoutEmpty ctxt - layoutSetWidth layout (Just 400) - layoutSetWrap layout WrapAnywhere - layoutSetText layout (T.unpack str) -- this is gtk2hs pango limitation - (_,reclog) <- layoutGetExtents layout - let PangoRectangle x y w h = reclog + ctxt <- Gtk.cairoCreateContext Nothing + layout <- Gtk.layoutEmpty ctxt + Gtk.layoutSetWidth layout (Just 400) + Gtk.layoutSetWrap layout Gtk.WrapAnywhere + Gtk.layoutSetText layout (T.unpack str) -- this is gtk2hs pango limitation + (_,reclog) <- Gtk.layoutGetExtents layout + let Gtk.PangoRectangle x y w h = reclog -- 10 is just dirty-fix return (layout,BBox (x,y) (x+w+10,y+h)) - rdr layout = do setSourceRGBA 0 0 0 1 - updateLayout layout - showLayout layout + rdr layout = do Cairo.setSourceRGBA 0 0 0 1 + Gtk.updateLayout layout + Gtk.showLayout layout (layout,(BBox (x0,y0) (x1,y1))) <- pangordr tdir <- getTemporaryDirectory let tfile = tdir "embedded.svg" - withSVGSurface tfile (x1-x0) (y1-y0) $ \s -> renderWith s (rdr layout) + Cairo.withSVGSurface tfile (x1-x0) (y1-y0) $ \s -> + Cairo.renderWith s (rdr layout) bstr <- B.readFile tfile return (bstr,BBox (xo,yo) (xo+x1-x0,yo+y1-y0)) -- | combine all LaTeX texts into a text file combineLaTeXText :: MainCoroutine () combineLaTeXText = do - liftIO $ putStrLn "start combine latex file" hdl <- rHoodle2Hoodle . getHoodle <$> get let mlatex_components = do (pgnum,pg) <- (zip ([1..] :: [Int]) . view pages) hdl @@ -334,5 +411,197 @@ let latex_components = catMaybes mlatex_components sorted = sortBy cfunc latex_components resulttxt = (B.intercalate "%%%%%%%%%%%%\n\n%%%%%%%%%%\n" . map (view _3)) sorted - mfilename <- fileChooser FileChooserActionSave Nothing + mfilename <- fileChooser Gtk.FileChooserActionSave Nothing forM_ mfilename (\filename -> liftIO (B.writeFile filename resulttxt) >> return ()) + + + +insertItemAt :: Maybe (PageNum,PageCoordinate) + -> RItem + -> MainCoroutine () +insertItemAt mpcoord ritm = do + xst <- get + geometry <- liftIO (getGeometry4CurrCvs xst) + let hdl = getHoodle xst + (pgnum,mpos) = case mpcoord of + Just (PageNum n,pos) -> (n,Just pos) + Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) xst,Nothing) + (ulx,uly) = (bbox_upperleft.getBBox) ritm + nitms = + case mpos of + Nothing -> adjustItemPosition4Paste geometry (PageNum pgnum) [ritm] + Just (PageCoord (nx,ny)) -> + map (changeItemBy (\(x,y)->(x+nx-ulx,y+ny-uly))) [ritm] + + let pg = getPageFromGHoodleMap pgnum hdl + lyr = getCurrentLayer pg + oitms = view gitems lyr + ntpg = makePageSelectMode pg (oitms :- (Hitted nitms) :- Empty) + modeChange ToSelectMode + nxst <- get + let cache = view renderCache nxst + thdl <- case view hoodleModeState nxst of + SelectState thdl' -> return thdl' + _ -> (lift . EitherT . return . Left . Other) "insertItemAt" + nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum + put ( ( set hoodleModeState (SelectState nthdl) + . set isOneTimeSelectMode YesAfterSelect) nxst) + invalidateAll + +embedTextSource :: MainCoroutine () +embedTextSource = do + mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing + forM_ mfilename $ \filename -> do + txt <- liftIO $ TIO.readFile filename + xst <- get + let nhdlmodst = case xst ^. hoodleModeState of + ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just txt) $ hdl) + SelectState thdl -> (SelectState . (gselEmbeddedText .~ Just txt) $ thdl) + nxst = (hoodleModeState .~ nhdlmodst) xst + put nxst + commit_ + +-- | +editEmbeddedTextSource :: MainCoroutine () +editEmbeddedTextSource = do + hdl <- getHoodle <$> get + let mtxt = hdl ^. gembeddedtext + forM_ mtxt $ \txt -> do + modify (tempQueue %~ enqueue (multiLineDialog txt)) + multiLineLoop txt >>= \case + Nothing -> return () + Just ntxt -> do + modify $ \xst -> + let nhdlmodst = case xst ^. hoodleModeState of + ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl) + SelectState thdl -> (SelectState . (gselEmbeddedText .~ Just ntxt) $ thdl) + in (hoodleModeState .~ nhdlmodst) xst + commit_ + +-- | +editNetEmbeddedTextSource :: MainCoroutine () +editNetEmbeddedTextSource = do + hdl <- getHoodle <$> get + let mtxt = hdl ^. gembeddedtext + forM_ mtxt $ \txt -> do + -- modify (tempQueue %~ enqueue (multiLineDialog txt)) + networkTextInput txt >>= \case + Nothing -> return () + Just ntxt -> do + modify $ \xst -> + let nhdlmodst = case xst ^. hoodleModeState of + ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl) + SelectState thdl -> (SelectState . (gselEmbeddedText .~ Just ntxt) $ thdl) + in (hoodleModeState .~ nhdlmodst) xst + commit_ + +-- | insert text +textInputFromSource :: (Double,Double) -> MainCoroutine () +textInputFromSource (x0,y0) = do + runMaybeT $ do + txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get + lift $ modify (tempQueue %~ enqueue linePosDialog) + (l1,l2) <- MaybeT linePosLoop + let txt = getLinesFromText (l1,l2) txtsrc + lift $ deleteSelection + liftIO (makePangoTextSVG (x0,y0) txt) + >>= lift . svgInsert ("embedtxt:simple:L" <> T.pack (show l1) <> "," <> T.pack (show l2),"pango") + return () + +-- | common dialog with line position +linePosDialog :: Either (ActionOrder AllEvent) AllEvent +linePosDialog = mkIOaction $ \evhandler -> do + dialog <- Gtk.dialogNew + vbox <- Gtk.dialogGetUpper dialog + + hbox <- Gtk.hBoxNew False 0 + Gtk.boxPackStart vbox hbox Gtk.PackNatural 0 + + line1buf <- Gtk.entryBufferNew Nothing + line1 <- Gtk.entryNewWithBuffer line1buf + Gtk.boxPackStart hbox line1 Gtk.PackNatural 2 + + line2buf <- Gtk.entryBufferNew Nothing + line2 <- Gtk.entryNewWithBuffer line2buf + Gtk.boxPackStart hbox line2 Gtk.PackNatural 2 + -- + _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk + _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel + Gtk.widgetShowAll dialog + res <- Gtk.dialogRun dialog + Gtk.widgetDestroy dialog + case res of + Gtk.ResponseOk -> do + line1str <- B.pack <$> Gtk.get line1buf Gtk.entryBufferText + line2str <- B.pack <$> Gtk.get line2buf Gtk.entryBufferText + let el1l2 = (,) <$> parseOnly decimal line1str + <*> parseOnly decimal line2str + return . UsrEv . LinePosition + . either (const Nothing) (\(l1,l2)->if l1 <= l2 then Just (l1,l2) else Nothing) $ el1l2 + Gtk.ResponseCancel -> return (UsrEv (LinePosition Nothing)) + _ -> return (UsrEv (LinePosition Nothing)) + +-- | main event loop for line position dialog +linePosLoop :: MainCoroutine (Maybe (Int,Int)) +linePosLoop = do + r <- nextevent + case r of + UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> linePosLoop + LinePosition x -> return x + _ -> linePosLoop + +-- | insert text +laTeXInputKeyword :: (Double,Double) -> T.Text -> MaybeT MainCoroutine () +laTeXInputKeyword (x0,y0) keyword = do + txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get + subpart <- (MaybeT . return . M.lookup keyword . getKeywordMap) txtsrc + let subpart' = laTeXHeader <> "\n" <> subpart <> laTeXFooter + liftIO (makeLaTeXSVG (x0,y0) subpart') >>= \case + Right r -> lift $ do + deleteSelection + svgInsert ("embedlatex:keyword:"<>keyword,"latex") r + Left err -> lift $ do + okMessageBox err + return () + +-- | insert text +laTeXInputFromSource :: (Double,Double) -> MainCoroutine () +laTeXInputFromSource (x0,y0) = do + runMaybeT $ do + txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get + lift $ modify (tempQueue %~ enqueue keywordDialog) + keyword <- MaybeT keywordLoop + laTeXInputKeyword (x0,y0) keyword + return () + +-- | common dialog with line position +keywordDialog :: Either (ActionOrder AllEvent) AllEvent +keywordDialog = mkIOaction $ \evhandler -> do + dialog <- Gtk.dialogNew + vbox <- Gtk.dialogGetUpper dialog + hbox <- Gtk.hBoxNew False 0 + Gtk.boxPackStart vbox hbox Gtk.PackNatural 0 + keybuf <- Gtk.entryBufferNew Nothing + key <- Gtk.entryNewWithBuffer keybuf + Gtk.boxPackStart hbox key Gtk.PackNatural 2 + -- + _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk + _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel + Gtk.widgetShowAll dialog + res <- Gtk.dialogRun dialog + Gtk.widgetDestroy dialog + case res of + Gtk.ResponseOk -> do + keystr <- T.pack <$> Gtk.get keybuf Gtk.entryBufferText + (return . UsrEv . Keyword . Just) keystr + Gtk.ResponseCancel -> return (UsrEv (Keyword Nothing)) + _ -> return (UsrEv (Keyword Nothing)) + +-- | main event loop for line position dialog +keywordLoop :: MainCoroutine (Maybe T.Text) +keywordLoop = do + r <- nextevent + case r of + UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> keywordLoop + Keyword x -> return x + _ -> keywordLoop diff --git a/src/Hoodle/Coroutine/VerticalSpace.hs b/src/Hoodle/Coroutine/VerticalSpace.hs --- a/src/Hoodle/Coroutine/VerticalSpace.hs +++ b/src/Hoodle/Coroutine/VerticalSpace.hs @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.VerticalSpace --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -17,10 +17,11 @@ import Control.Lens (view,set,at) import Control.Monad hiding (mapM_) import Control.Monad.State (get) +import Control.Monad.Trans (liftIO) import Data.Foldable import Data.Monoid import Data.Time.Clock -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform import Data.Hoodle.BBox @@ -55,7 +56,8 @@ import Prelude hiding ((.), id, concat,concatMap,mapM_) -- | -splitPageByHLine :: Double -> Page EditMode +splitPageByHLine :: Double + -> Page EditMode -> ([RItem],Page EditMode,SeqZipper RItemHitted) splitPageByHLine y pg = (hitted,set glayers unhitted pg,hltedLayers) where @@ -76,6 +78,7 @@ where verticalSpaceAction _cinfo pnum@(PageNum n) geometry (x,y) = do hdl <- liftM getHoodle get + cache <- view renderCache <$> get cpg <- getCurrentPageCurr let (itms,npg,hltedLayers) = splitPageByHLine y cpg nhdl = set (gpages.at n) (Just npg) hdl @@ -83,18 +86,19 @@ case mbbx of Nothing -> return () Just bbx -> do - (sfcbkg,Dim w h) <- liftIO $ canvasImageSurface Nothing geometry nhdl - sfcitm <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h) - sfctot <- liftIO $ createImageSurface FormatARGB32 (floor w) (floor h) - liftIO $ renderWith sfcitm $ do - identityMatrix - cairoXform4PageCoordinate geometry pnum - mapM_ renderRItem itms + (sfcbkg,Dim w h) <- liftIO $ canvasImageSurface cache Nothing geometry nhdl + sfcitm <- liftIO $ Cairo.createImageSurface + Cairo.FormatARGB32 (floor w) (floor h) + sfctot <- liftIO $ Cairo.createImageSurface + Cairo.FormatARGB32 (floor w) (floor h) + liftIO $ Cairo.renderWith sfcitm $ do + Cairo.identityMatrix + cairoXform4PageCoordinate (mkXform4Page geometry pnum) + mapM_ (renderRItem cache) itms ctime <- liftIO getCurrentTime verticalSpaceProcess cid geometry (bbx,hltedLayers,pnum,cpg) (x,y) (sfcbkg,sfcitm,sfctot) ctime - - liftIO $ mapM_ surfaceFinish [sfcbkg,sfcitm,sfctot] + liftIO $ mapM_ Cairo.surfaceFinish [sfcbkg,sfcitm,sfctot] -- | addNewPageAndMoveBelow :: (PageNum,SeqZipper RItemHitted,BBox) @@ -110,8 +114,8 @@ case view hoodleModeState xstate of ViewAppendState hdl -> do let bsty = view backgroundStyle xstate - hdl' = addNewPageInHoodle bsty PageAfter hdl (unPageNum pnum) - hdl'' = moveBelowToNewPage (pnum,hltedLyrs,bbx) hdl' + hdl' <- addNewPageInHoodle bsty PageAfter hdl (unPageNum pnum) + let hdl'' = moveBelowToNewPage (pnum,hltedLyrs,bbx) hdl' nhdlmodst = ViewAppendState hdl'' return =<< liftIO . updatePageAll nhdlmodst . set hoodleModeState nhdlmodst $ xstate @@ -152,7 +156,8 @@ -> CanvasGeometry -> (BBox,SeqZipper RItemHitted,PageNum,Page EditMode) -> (Double,Double) - -> (Surface,Surface,Surface) + -> (Cairo.Surface,Cairo.Surface,Cairo.Surface) + -- ^ (background, item, total) -> UTCTime -> MainCoroutine () verticalSpaceProcess cid geometry pinfo@(bbx,hltedLayers,pnum@(PageNum n),pg) @@ -212,38 +217,41 @@ | otherwise = GoingUp z = canvas2DesktopRatio geometry drawguide = do - identityMatrix - cairoXform4PageCoordinate geometry pnum - setLineWidth (predefinedLassoWidth*z) + Cairo.identityMatrix + cairoXform4PageCoordinate (mkXform4Page geometry pnum ) + Cairo.setLineWidth (predefinedLassoWidth*z) case mode of - GoingUp -> setSourceRGBA 0.1 0.8 0.1 0.4 - GoingDown -> setSourceRGBA 0.1 0.1 0.8 0.4 - OverPage -> setSourceRGBA 0.8 0.1 0.1 0.4 - moveTo 0 y0 - lineTo w y0 - stroke - moveTo 0 y - lineTo w y - stroke + GoingUp -> Cairo.setSourceRGBA 0.1 0.8 0.1 0.4 + GoingDown -> Cairo.setSourceRGBA 0.1 0.1 0.8 0.4 + OverPage -> Cairo.setSourceRGBA 0.8 0.1 0.1 0.4 + Cairo.moveTo 0 y0 + Cairo.lineTo w y0 + Cairo.stroke + Cairo.moveTo 0 y + Cairo.lineTo w y + Cairo.stroke case mode of - GoingUp -> setSourceRGBA 0.1 0.8 0.1 0.2 >> rectangle 0 y w (y0-y) - GoingDown -> setSourceRGBA 0.1 0.1 0.8 0.2 >> rectangle 0 y0 w (y-y0) - OverPage -> setSourceRGBA 0.8 0.1 0.1 0.2 >> rectangle 0 y0 w (y-y0) - fill - liftIO $ renderWith sfctot $ do - setSourceSurface sfcbkg 0 0 - setOperator OperatorSource - paint - setSourceSurface sfcitm 0 (y_cvs-y0_cvs) - setOperator OperatorOver - paint + GoingUp -> Cairo.setSourceRGBA 0.1 0.8 0.1 0.2 >> + Cairo.rectangle 0 y w (y0-y) + GoingDown -> Cairo.setSourceRGBA 0.1 0.1 0.8 0.2 >> + Cairo.rectangle 0 y0 w (y-y0) + OverPage -> Cairo.setSourceRGBA 0.8 0.1 0.1 0.2 >> + Cairo.rectangle 0 y0 w (y-y0) + Cairo.fill + liftIO $ Cairo.renderWith sfctot $ do + Cairo.setSourceSurface sfcbkg 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint + Cairo.setSourceSurface sfcitm 0 (y_cvs-y0_cvs) + Cairo.setOperator Cairo.OperatorOver + Cairo.paint drawguide let canvas = view drawArea cvsInfo win <- liftIO $ widgetGetDrawWindow canvas liftIO $ renderWithDrawable win $ do - setSourceSurface sfctot 0 0 - setOperator OperatorSource - paint + Cairo.setSourceSurface sfctot 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs ctime) otime 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 @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Window --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -25,6 +25,7 @@ import Hoodle.Accessor import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Page +import Hoodle.GUI.Reflect import Hoodle.ModelAction.Page import Hoodle.ModelAction.Window import Hoodle.Type.Canvas diff --git a/src/Hoodle/GUI.hs b/src/Hoodle/GUI.hs --- a/src/Hoodle/GUI.hs +++ b/src/Hoodle/GUI.hs @@ -31,8 +31,8 @@ -- from this package import Hoodle.Accessor import Hoodle.Config -import Hoodle.Coroutine import Hoodle.Coroutine.Callback +import Hoodle.Coroutine.Default import Hoodle.Device import Hoodle.ModelAction.Window import Hoodle.Script.Hook @@ -40,7 +40,7 @@ import Hoodle.Type.Event import Hoodle.Type.HoodleState -- -import Prelude ((.),($),String,Bool(..),const,error,flip,id,map) -- hiding (catch) +import Prelude ((.),($),String,Bool(..),const,error,flip,id,map) -- | startGUI :: Maybe FilePath -> Maybe Hook -> IO () @@ -55,8 +55,7 @@ xinputbool <- getXInputConfig cfg (usepz,uselyr) <- getWidgetConfig cfg statusbar <- statusbarNew - (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo - (xinputbool,usepz,uselyr) statusbar + (tref,st0,ui,vbox) <- initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr) statusbar setTitleFromFileName st0 -- need for refactoring setToggleUIForFlag "UXINPUTA" (settings.doesUseXInput) st0 @@ -118,7 +117,7 @@ -- -- test end -- - let mainaction = do eventHandler tref (UsrEv Initialized) + let mainaction = do eventHandler tref (UsrEv (Initialized mfname)) mainGUI mainaction `catch` \(_e :: SomeException) -> do homepath <- getEnv "HOME" diff --git a/src/Hoodle/GUI/Menu.hs b/src/Hoodle/GUI/Menu.hs --- a/src/Hoodle/GUI/Menu.hs +++ b/src/Hoodle/GUI/Menu.hs @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.GUI.Menu --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -30,15 +30,9 @@ -- import Paths_hoodle_core --- | - justMenu :: MenuEvent -> Maybe UserEvent justMenu = Just . Menu --- | --- uiDecl :: String --- uiDecl = [verbatim| --- |] iconList :: [ (String,String) ] iconList = [ ("fullscreen.png" , "myfullscreen") @@ -173,35 +167,36 @@ fma <- actionNewAndRegister "FMA" "File" Nothing Nothing Nothing ema <- actionNewAndRegister "EMA" "Edit" Nothing Nothing Nothing vma <- actionNewAndRegister "VMA" "View" Nothing Nothing Nothing - jma <- actionNewAndRegister "JMA" "Page" Nothing Nothing Nothing - tma <- actionNewAndRegister "TMA" "Tools" Nothing Nothing Nothing - oma <- actionNewAndRegister "OMA" "Options" Nothing Nothing Nothing + lma <- actionNewAndRegister "LMA" "Layer" Nothing Nothing Nothing + ima <- actionNewAndRegister "IMA" "Embed" Nothing Nothing Nothing + pma <- actionNewAndRegister "PMA" "Page" Nothing Nothing Nothing + tma <- actionNewAndRegister "TMA" "Tool" Nothing Nothing Nothing + verma <- actionNewAndRegister "VERMA" "Version" Nothing Nothing Nothing + oma <- actionNewAndRegister "OMA" "Option" Nothing Nothing Nothing hma <- actionNewAndRegister "HMA" "Help" Nothing Nothing Nothing - -- file menu + --------------- + -- file menu -- + --------------- newa <- actionNewAndRegister "NEWA" "New" (Just "Just a Stub") (Just stockNew) (justMenu MenuNew) opena <- actionNewAndRegister "OPENA" "Open" (Just "Just a Stub") (Just stockOpen) (justMenu MenuOpen) savea <- actionNewAndRegister "SAVEA" "Save" (Just "Just a Stub") (Just stockSave) (justMenu MenuSave) saveasa <- actionNewAndRegister "SAVEASA" "Save As" (Just "Just a Stub") (Just stockSaveAs) (justMenu MenuSaveAs) + printa <- actionNewAndRegister "PRINTA" "Print" (Just "Just a Stub") Nothing (justMenu MenuPrint) + -- + exporta <- actionNewAndRegister "EXPORTA" "Export to PDF" (Just "Just a Stub") Nothing (justMenu MenuExport) + expsvga <- actionNewAndRegister "EXPSVGA" "Export Current Page to SVG" (Just "Just a Stub") Nothing (justMenu MenuExportPageSVG) + -- + annpdfa <- actionNewAndRegister "ANNPDFA" "Annotate PDF" (Just "Just a Stub") Nothing (justMenu MenuAnnotatePDF) + -- reloada <- actionNewAndRegister "RELOADA" "Reload File" (Just "Just a Stub") Nothing (justMenu MenuReload) recenta <- actionNewAndRegister "RECENTA" "Recent Document" (Just "Just a Stub") Nothing (justMenu MenuRecentDocument) - annpdfa <- actionNewAndRegister "ANNPDFA" "Annotate PDF" (Just "Just a Stub") Nothing (justMenu MenuAnnotatePDF) - ldpnga <- actionNewAndRegister "LDIMGA" "Load PNG or JPG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadPNGorJPG) - ldsvga <- actionNewAndRegister "LDSVGA" "Load SVG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadSVG) - latexa <- actionNewAndRegister "LATEXA" "LaTeX" (Just "Just a Stub") (Just "mylatex") (justMenu MenuLaTeX) - combinelatexa <- actionNewAndRegister "COMBINELATEXA" "Combine LaTeX texts to ..." (Just "Just a Stub") Nothing (justMenu MenuCombineLaTeX) - ldpreimga <- actionNewAndRegister "LDPREIMGA" "Embed Predefined Image File" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage) - ldpreimg2a <- actionNewAndRegister "LDPREIMG2A" "Embed Predefined Image File 2" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage2) - ldpreimg3a <- actionNewAndRegister "LDPREIMG3A" "Embed Predefined Image File 3" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage3) - printa <- actionNewAndRegister "PRINTA" "Print" (Just "Just a Stub") Nothing (justMenu MenuPrint) - exporta <- actionNewAndRegister "EXPORTA" "Export" (Just "Just a Stub") Nothing (justMenu MenuExport) - synca <- actionNewAndRegister "SYNCA" "Start Sync" (Just "Just a Stub") Nothing (justMenu MenuStartSync) - versiona <- actionNewAndRegister "VERSIONA" "Save Version" (Just "Just a Stub") Nothing (justMenu MenuVersionSave) - showreva <- actionNewAndRegister "SHOWREVA" "Show Revisions" (Just "Just a Stub") Nothing (justMenu MenuShowRevisions) - showida <- actionNewAndRegister "SHOWIDA" "Show UUID" (Just "Just a Stub") Nothing (justMenu MenuShowUUID) + -- quita <- actionNewAndRegister "QUITA" "Quit" (Just "Just a Stub") (Just stockQuit) (justMenu MenuQuit) - - -- edit menu + + --------------- + -- edit menu -- + --------------- undoa <- actionNewAndRegister "UNDOA" "Undo" (Just "Just a Stub") (Just stockUndo) (justMenu MenuUndo) redoa <- actionNewAndRegister "REDOA" "Redo" (Just "Just a Stub") (Just stockRedo) (justMenu MenuRedo) cuta <- actionNewAndRegister "CUTA" "Cut" (Just "Just a Stub") (Just stockCut) (justMenu MenuCut) @@ -209,8 +204,11 @@ pastea <- actionNewAndRegister "PASTEA" "Paste" (Just "Just a Stub") (Just stockPaste) (justMenu MenuPaste) deletea <- actionNewAndRegister "DELETEA" "Delete" (Just "Just a Stub") (Just stockDelete) (justMenu MenuDelete) - -- view menu - fscra <- actionNewAndRegister "FSCRA" "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen) + --------------- + -- view menu -- + --------------- + togpanzooma <- actionNewAndRegister "TOGPANZOOMA" "Show/Hide Zoom Widget" (Just "Just a stub") Nothing (justMenu MenuTogglePanZoomWidget) + -- 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) @@ -218,27 +216,63 @@ pgwdtha <- actionNewAndRegister "PGWDTHA" "Page Width" (Just "Page Width") (Just stockZoomFit) (justMenu MenuPageWidth) pgheighta <- actionNewAndRegister "PGHEIGHTA" "Page Height" (Just "Page Height") Nothing (justMenu MenuPageHeight) setzma <- actionNewAndRegister "SETZMA" "Set Zoom" (Just "Set Zoom") (Just stockFind) (justMenu MenuSetZoom) + -- + fscra <- actionNewAndRegister "FSCRA" "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen) + -- fstpagea <- actionNewAndRegister "FSTPAGEA" "First Page" (Just "Just a Stub") (Just stockGotoFirst) (justMenu MenuFirstPage) prvpagea <- actionNewAndRegister "PRVPAGEA" "Previous Page" (Just "Just a Stub") (Just stockGoBack) (justMenu MenuPreviousPage) nxtpagea <- actionNewAndRegister "NXTPAGEA" "Next Page" (Just "Just a Stub") (Just stockGoForward) (justMenu MenuNextPage) lstpagea <- actionNewAndRegister "LSTPAGEA" "Last Page" (Just "Just a Stub") (Just stockGotoLast) (justMenu MenuLastPage) - shwlayera <- actionNewAndRegister "SHWLAYERA" "Show Layer" (Just "Just a Stub") Nothing (justMenu MenuShowLayer) - hidlayera <- actionNewAndRegister "HIDLAYERA" "Hide Layer" (Just "Just a Stub") Nothing (justMenu MenuHideLayer) - hsplita <- actionNewAndRegister "HSPLITA" "Horizontal Split" (Just "horizontal split") Nothing (justMenu MenuHSplit) - vsplita <- actionNewAndRegister "VSPLITA" "Vertical Split" (Just "vertical split") Nothing (justMenu MenuVSplit) - delcvsa <- actionNewAndRegister "DELCVSA" "Delete Current Canvas" (Just "delete current canvas") Nothing (justMenu MenuDelCanvas) + -- + hsplita <- actionNewAndRegister "HSPLITA" "Clone View Horizontally" (Just "horizontal split") Nothing (justMenu MenuHSplit) + vsplita <- actionNewAndRegister "VSPLITA" "Clone View Vertically" (Just "vertical split") Nothing (justMenu MenuVSplit) + delcvsa <- actionNewAndRegister "DELCVSA" "Remove Clone View" (Just "delete current canvas") Nothing (justMenu MenuDelCanvas) - -- page menu - newpgba <- actionNewAndRegister "NEWPGBA" "New Page Before" (Just "Just a Stub") Nothing (justMenu MenuNewPageBefore) - newpgaa <- actionNewAndRegister "NEWPGAA" "New Page After" (Just "Just a Stub") Nothing (justMenu MenuNewPageAfter) - newpgea <- actionNewAndRegister "NEWPGEA" "New Page At End" (Just "Just a Stub") Nothing (justMenu MenuNewPageAtEnd) - delpga <- actionNewAndRegister "DELPGA" "Delete Page" (Just "Just a Stub") Nothing (justMenu MenuDeletePage) - expsvga <- actionNewAndRegister "EXPSVGA" "Export Current Page to SVG" (Just "Just a Stub") Nothing (justMenu MenuExportPageSVG) + + ---------------- + -- layer menu -- + ---------------- + toglayera <- actionNewAndRegister "TOGLAYERA" "Show/Hide Layer Widget" (Just "Just a stub") Nothing (justMenu MenuToggleLayerWidget) + -- newlyra <- actionNewAndRegister "NEWLYRA" "New Layer" (Just "Just a Stub") Nothing (justMenu MenuNewLayer) nextlayera <- actionNewAndRegister "NEXTLAYERA" "Next Layer" (Just "Just a Stub") Nothing (justMenu MenuNextLayer) prevlayera <- actionNewAndRegister "PREVLAYERA" "Prev Layer" (Just "Just a Stub") Nothing (justMenu MenuPrevLayer) gotolayera <- actionNewAndRegister "GOTOLAYERA" "Goto Layer" (Just "Just a Stub") Nothing (justMenu MenuGotoLayer) dellyra <- actionNewAndRegister "DELLYRA" "Delete Layer" (Just "Just a Stub") Nothing (justMenu MenuDeleteLayer) + + -- shwlayera <- actionNewAndRegister "SHWLAYERA" "Show Layer" (Just "Just a Stub") Nothing (justMenu MenuShowLayer) + -- hidlayera <- actionNewAndRegister "HIDLAYERA" "Hide Layer" (Just "Just a Stub") Nothing (justMenu MenuHideLayer) + + + ---------------- + -- image menu -- + ---------------- + + ldpnga <- actionNewAndRegister "LDIMGA" "Load PNG or JPG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadPNGorJPG) + ldsvga <- actionNewAndRegister "LDSVGA" "Load SVG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadSVG) + ldpreimga <- actionNewAndRegister "LDPREIMGA" "Embed Predefined Image File" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage) + ldpreimg2a <- actionNewAndRegister "LDPREIMG2A" "Embed Predefined Image File 2" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage2) + ldpreimg3a <- actionNewAndRegister "LDPREIMG3A" "Embed Predefined Image File 3" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage3) + + texta <- actionNewAndRegister "TEXTA" "Text" (Just "Text") (Just "mytext") (justMenu MenuText) + textsrca <- actionNewAndRegister "TEXTSRCA" "Embed Text Source" (Just "Just a Stub") Nothing (justMenu MenuEmbedTextSource) + editsrca <- actionNewAndRegister "EDITSRCA" "Edit text source" (Just "Just a Stub") Nothing (justMenu MenuEditEmbedTextSource) + editnetsrca <- actionNewAndRegister "EDITNETSRCA" "Network edit text source" (Just "Just a Stub") Nothing (justMenu MenuEditNetEmbedTextSource) + + textfromsrca <- actionNewAndRegister "TEXTFROMSRCA" "Text From Source" (Just "Just a Stub") Nothing (justMenu MenuTextFromSource) + + latexa <- actionNewAndRegister "LATEXA" "LaTeX" (Just "Just a Stub") (Just "mylatex") (justMenu MenuLaTeX) + latexneta <- actionNewAndRegister "LATEXNETA" "LaTeX Network" (Just "Just a Stub") (Just "mylatex") (justMenu MenuLaTeXNetwork) + combinelatexa <- actionNewAndRegister "COMBINELATEXA" "Combine LaTeX texts to ..." (Just "Just a Stub") Nothing (justMenu MenuCombineLaTeX) + latexfromsrca <- actionNewAndRegister "LATEXFROMSRCA" "LaTeX From Source" (Just "Just a Stub") Nothing (justMenu MenuLaTeXFromSource) + + + -- page menu + newpgba <- actionNewAndRegister "NEWPGBA" "New Page Before" (Just "Just a Stub") Nothing (justMenu MenuNewPageBefore) + newpgaa <- actionNewAndRegister "NEWPGAA" "New Page After" (Just "Just a Stub") Nothing (justMenu MenuNewPageAfter) + newpgea <- actionNewAndRegister "NEWPGEA" "New Page At End" (Just "Just a Stub") Nothing (justMenu MenuNewPageAtEnd) + delpga <- actionNewAndRegister "DELPGA" "Delete Page" (Just "Just a Stub") Nothing (justMenu MenuDeletePage) + ppsizea <- actionNewAndRegister "PPSIZEA" "Paper Size" (Just "Just a Stub") Nothing (justMenu MenuPaperSize) ppclra <- actionNewAndRegister "PPCLRA" "Paper Color" (Just "Just a Stub") Nothing (justMenu MenuPaperColor) ppstya <- actionNewAndRegister "PPSTYA" "Paper Style" Nothing Nothing Nothing @@ -250,10 +284,15 @@ setdefppa <- actionNewAndRegister "SETDEFPPA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultPaper) -- tools menu - texta <- actionNewAndRegister "TEXTA" "Text" (Just "Text") (Just "mytext") (justMenu MenuText) linka <- actionNewAndRegister "LINKA" "Add Link" (Just "Add Link") (Just stockIndex) (justMenu MenuAddLink) - shpreca <- actionNewAndRegister "SHPRECA" "Shape Recognizer" (Just "Just a Stub") (Just "myshapes") (justMenu MenuShapeRecognizer) - rulera <- actionNewAndRegister "RULERA" "Ruler" (Just "Just a Stub") (Just "myruler") (justMenu MenuRuler) + anchora <- actionNewAndRegister "ANCHORA" "Add Anchor" (Just "Add Anchor") Nothing (justMenu MenuAddAnchor) + listanchora <- actionNewAndRegister "LISTANCHORA" "List Anchors" (Just "List Anchors") Nothing (justMenu MenuListAnchors) + + -- shpreca <- actionNewAndRegister "SHPRECA" "Shape Recognizer" (Just "Just a Stub") (Just "myshapes") (justMenu MenuShapeRecognizer) + -- rulera <- actionNewAndRegister "RULERA" "Ruler" (Just "Just a Stub") (Just "myruler") (justMenu MenuRuler) + handreca <- actionNewAndRegister "HANDRECA" "Hoodlet load via Handwriting Recognition" (Just "Just a Stub") (Just "myshapes") (justMenu MenuHandwritingRecognitionDialog) + + -- selregna <- actionNewAndRegister "SELREGNA" "Select Region" (Just "Just a Stub") (Just "mylasso") (justMenu MenuSelectRegion) -- selrecta <- actionNewAndRegister "SELRECTA" "Select Rectangle" (Just "Just a Stub") (Just "myrectselect") (justMenu MenuSelectRectangle) -- vertspa <- actionNewAndRegister "VERTSPA" "Vertical Space" (Just "Just a Stub") (Just "mystretch") (justMenu MenuVerticalSpace) @@ -269,8 +308,21 @@ 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 + + + ------------------ + -- version menu -- + ------------------ + + synca <- actionNewAndRegister "SYNCA" "Start Sync" (Just "Just a Stub") Nothing (justMenu MenuStartSync) + versiona <- actionNewAndRegister "VERSIONA" "Save Version" (Just "Just a Stub") Nothing (justMenu MenuVersionSave) + showreva <- actionNewAndRegister "SHOWREVA" "Show Revisions" (Just "Just a Stub") Nothing (justMenu MenuShowRevisions) + showida <- actionNewAndRegister "SHOWIDA" "Show UUID" (Just "Just a Stub") Nothing (justMenu MenuShowUUID) + + + ----------------- + -- option menu -- + ----------------- uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing uxinputa `on` actionToggled $ do eventHandler evar (UsrEv (Menu MenuUseXInput)) @@ -296,9 +348,10 @@ keepratioa <- toggleActionNew "KEEPRATIOA" "Keep Aspect Ratio" (Just "Just a stub") Nothing keepratioa `on` actionToggled $ do eventHandler evar (UsrEv (Menu MenuKeepAspectRatio)) + vcursora <- toggleActionNew "VCURSORA" "Use Variable Cursor" (Just "Just a stub") Nothing + vcursora `on` actionToggled $ do + eventHandler evar (UsrEv (Menu MenuUseVariableCursor)) -- temporary implementation (later will be as submenus with toggle action. appropriate reflection) - togpanzooma <- actionNewAndRegister "TOGPANZOOMA" "Toggle Pan/Zoom Widget" (Just "Just a stub") Nothing (justMenu MenuTogglePanZoomWidget) - toglayera <- actionNewAndRegister "TOGLAYERA" "Toggle Layer Widget" (Just "Just a stub") Nothing (justMenu MenuToggleLayerWidget) togclocka <- actionNewAndRegister "TOGCLOCKA" "Toggle Clock Widget" (Just "Just a stub") Nothing (justMenu MenuToggleClockWidget) dcrdcorea <- actionNewAndRegister "DCRDCOREA" "Discard Core Events" (Just "Just a Stub") Nothing (justMenu MenuDiscardCoreEvents) @@ -332,19 +385,22 @@ agr <- actionGroupNew "AGR" mapM_ (actionGroupAddAction agr) - [fma,ema,vma,jma,tma,oma,hma] + [fma,ema,vma,lma,ima,pma,tma,verma,oma,hma] mapM_ (actionGroupAddAction agr) [ undoa, redoa, cuta, copya, pastea, deletea ] mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing) - [ newa, annpdfa, ldpnga, ldsvga, latexa, combinelatexa, ldpreimga, ldpreimg2a, ldpreimg3a, opena, savea, saveasa + [ newa, annpdfa, opena, savea, saveasa , reloada, recenta, printa, exporta, synca, versiona, showreva, showida, quita , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma - , fstpagea, prvpagea, nxtpagea, lstpagea, shwlayera, hidlayera + , fstpagea, prvpagea, nxtpagea, lstpagea {- , shwlayera, hidlayera -} , hsplita, vsplita, delcvsa , newpgba, newpgaa, newpgea, delpga, expsvga, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra , ppstya , apallpga, embedbkgpdfa, defppa, setdefppa - , texta, linka, shpreca, rulera, clra, clrpcka, penopta + , ldpnga, ldsvga, texta, textsrca, editsrca, editnetsrca, textfromsrca + , latexa, latexneta, combinelatexa, latexfromsrca + , ldpreimga, ldpreimg2a, ldpreimg3a + , linka, anchora, listanchora, {- shpreca, rulera, -} handreca, clra, clrpcka, penopta , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta, relauncha , togpanzooma, toglayera, togclocka @@ -356,7 +412,8 @@ ] mapM_ (actionGroupAddAction agr) - [uxinputa, handa, smthscra, popmenua, ebdimga, ebdpdfa, flwlnka, keepratioa, pressrsensa] + [ uxinputa, handa, smthscra, popmenua, ebdimga, ebdpdfa, flwlnka, keepratioa, pressrsensa + , vcursora ] -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode evar) mpgmodconnid <- actionGroupAddRadioActionsAndGetConnID agr viewmods 0 (assignViewMode evar) -- const (return ())) @@ -373,10 +430,10 @@ [ recenta, printa , cuta, copya, deletea , setzma - , shwlayera, hidlayera + {- , shwlayera, hidlayera -} , newpgea, ppsizea, ppclra , defppa, setdefppa - , shpreca, rulera + -- , shpreca, rulera , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta , dcrdcorea, ersrtipa, pghilta, mltpgvwa diff --git a/src/Hoodle/GUI/Reflect.hs b/src/Hoodle/GUI/Reflect.hs --- a/src/Hoodle/GUI/Reflect.hs +++ b/src/Hoodle/GUI/Reflect.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.GUI.Reflect --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -14,26 +16,50 @@ module Hoodle.GUI.Reflect where -import Control.Lens (view,Simple,Lens) +import Control.Lens (view,Simple,Lens) +import Control.Monad (liftM, when) import qualified Control.Monad.State as St -import Control.Monad.Trans +import Control.Monad.Trans +import Data.Array.MArray +import Data.Foldable (forM_) +import qualified Data.Map as M (lookup) +import Data.Word import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set) -- --- import Control.Monad.Trans.Crtn.Event --- import Control.Monad.Trans.Crtn.Queue --- import Hoodle.GUI.Menu +import Hoodle.Coroutine.Draw import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum -import Hoodle.Type.HoodleState import Hoodle.Type.Event +import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement +import Hoodle.Type.Predefined import Hoodle.Util +import Hoodle.View.Coordinate -- import Debug.Trace +-- | +changeCurrentCanvasId :: CanvasId -> MainCoroutine HoodleState +changeCurrentCanvasId cid = do + xstate1 <- St.get + maybe (return xstate1) + (\xst -> do St.put xst + return xst) + (setCurrentCanvasId cid xstate1) + reflectViewModeUI + St.get +-- | check current canvas id and new active canvas id and invalidate if it's +-- changed. +chkCvsIdNInvalidate :: CanvasId -> MainCoroutine () +chkCvsIdNInvalidate cid = do + currcid <- liftM (getCurrentCanvasId) St.get + when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) + + blockWhile :: (GObjectClass w) => Maybe (ConnectId w) -> IO () -> IO () blockWhile msig act = maybe (return ()) signalBlock msig @@ -65,6 +91,7 @@ reflectPenModeUI :: MainCoroutine () reflectPenModeUI = do reflectUIComponent penModeSignal "PENA" f + reflectCursor where f xst = Just $ hoodleModeStateEither (view hoodleModeState xst) # @@ -76,6 +103,7 @@ reflectPenColorUI :: MainCoroutine () reflectPenColorUI = do reflectUIComponent penColorSignal "BLUEA" f + reflectCursor where f xst = let mcolor = @@ -90,6 +118,7 @@ reflectPenWidthUI :: MainCoroutine () reflectPenWidthUI = do reflectUIComponent penPointSignal "PENVERYFINEA" f + reflectCursor where f xst = case view (penInfo.penType) xst of @@ -128,5 +157,73 @@ where go = do r <- nextevent case r of ActionOrdered -> return () - _ -> (liftIO $ print r) >> go + _ -> go +-- | +reflectCursor :: MainCoroutine () +reflectCursor = do + xst <- St.get + let useVCursor = view (settings.doesUseVariableCursor) xst + let go = do r <- nextevent + case r of + ActionOrdered -> return () + _ -> go + if useVCursor + then + act xst >> go + else do + doIOaction $ \_ -> do + let cinfobox = view currentCanvasInfo xst + canvas = forBoth' unboxBiAct (view drawArea) cinfobox + win <- widgetGetDrawWindow canvas + postGUIAsync (drawWindowSetCursor win Nothing) + return (UsrEv ActionOrdered) + go + where act xst = doIOaction $ \_ -> do + let -- mcur = view cursorInfo xst + cinfobox = view currentCanvasInfo xst + canvas = forBoth' unboxBiAct (view drawArea) cinfobox + cpn = PageNum $ + forBoth' unboxBiAct (view currentPageNum) cinfobox + pinfo = view penInfo xst + pcolor = view (penSet . currPen . penColor) pinfo + pwidth = view (penSet . currPen . penWidth) pinfo + win <- widgetGetDrawWindow canvas + dpy <- widgetGetDisplay canvas + + geometry <- + forBoth' unboxBiAct (\c -> let arr = view (viewInfo.pageArrangement) c + in makeCanvasGeometry cpn arr canvas + ) cinfobox + let p2c = desktop2Canvas geometry . page2Desktop geometry + CvsCoord (x0,_y0) = p2c (cpn, PageCoord (0,0)) + CvsCoord (x1,_y1) = p2c (cpn, PageCoord (pwidth,pwidth)) + cursize = (x1-x0) + (r,g,b,a) = case pcolor of + ColorRGBA r' g' b' a' -> (r',g',b',a') + _ -> maybe (0,0,0,1) id (M.lookup pcolor penColorRGBAmap) + pb <- pixbufNew ColorspaceRgb True 8 maxCursorWidth maxCursorHeight + let numPixels = maxCursorWidth*maxCursorHeight + pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8)) + forM_ [0..numPixels-1] $ \i -> do + let cvt :: Double -> Word8 + cvt x | x < 0.0039 = 0 + | x > 0.996 = 255 + | otherwise = fromIntegral (floor (x*256-1) `mod` 256 :: Int) + if (fromIntegral (i `mod` maxCursorWidth)) < cursize + && (fromIntegral (i `div` maxCursorWidth)) < cursize + then do + writeArray pbData (4*i) (cvt r) + writeArray pbData (4*i+1) (cvt g) + writeArray pbData (4*i+2) (cvt b) + writeArray pbData (4*i+3) (cvt a) + else do + writeArray pbData (4*i) 0 + writeArray pbData (4*i+1) 0 + writeArray pbData (4*i+2) 0 + writeArray pbData (4*i+3) 0 + + postGUIAsync . drawWindowSetCursor win . Just =<< + cursorNewFromPixbuf dpy pb + (floor cursize `div` 2) (floor cursize `div` 2) + return (UsrEv ActionOrdered) diff --git a/src/Hoodle/ModelAction/ContextMenu.hs b/src/Hoodle/ModelAction/ContextMenu.hs --- a/src/Hoodle/ModelAction/ContextMenu.hs +++ b/src/Hoodle/ModelAction/ContextMenu.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.ContextMenu --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -12,48 +14,63 @@ module Hoodle.ModelAction.ContextMenu where +import Control.Concurrent (forkIO, threadDelay) import qualified Data.ByteString.Char8 as B -import Data.UUID.V4 -import Graphics.Rendering.Cairo -import Graphics.UI.Gtk -import System.Directory -import System.FilePath -import System.Process +import Data.Foldable (forM_) +import Data.UUID.V4 +import DBus +import DBus.Client +import qualified Graphics.Rendering.Cairo as Cairo +import Graphics.UI.Gtk +import System.Directory +import System.FilePath +import System.Process -- -import Data.Hoodle.BBox -import Data.Hoodle.Simple -import Graphics.Hoodle.Render -import Graphics.Hoodle.Render.Type.Item +import Data.Hoodle.BBox +import Data.Hoodle.Simple +import Graphics.Hoodle.Render +import Graphics.Hoodle.Render.Type -- import Hoodle.Type.Event import Hoodle.Util -- | -menuOpenALink :: {- (AllEvent -> IO ()) -> -} UrlPath -> IO MenuItem -menuOpenALink {- evhandler -} urlpath = do +menuOpenALink :: UrlPath -> IO MenuItem +menuOpenALink urlpath = do let urlname = case urlpath of FileUrl fp -> fp HttpUrl url -> url menuitemlnk <- menuItemNewWithLabel ("Open "++urlname) - menuitemlnk `on` menuItemActivate $ openLinkAction urlpath + menuitemlnk `on` menuItemActivate $ openLinkAction urlpath Nothing return menuitemlnk -- | -openLinkAction :: UrlPath -> IO () -openLinkAction urlpath = +openLinkAction :: UrlPath + -> Maybe (B.ByteString,B.ByteString) -- ^ (docid,anchorid) + -> IO () +openLinkAction urlpath mid = do + cli <- connectSession case urlpath of FileUrl fp -> do - let cmdargs = [fp] - createProcess (proc "hoodle" cmdargs) + putStrLn "test dbus" + emit cli (signal "/" "org.ianwookim.hoodle" "findWindow") + { signalBody = [ toVariant fp] } return () HttpUrl url -> do let cmdargs = [url] createProcess (proc "xdg-open" cmdargs) return () - - - + forkIO $ do + threadDelay 2000000 + forM_ mid $ \(docid,anchorid) -> do + print (docid,anchorid) + emit cli (signal "/" "org.ianwookim.hoodle" "callLink") + { signalBody = + [ toVariant (B.unpack docid + ++ "," + ++ B.unpack anchorid) ] } + return () -- | menuCreateALink :: (AllEvent -> IO ()) -> [RItem] -> IO (Maybe MenuItem) menuCreateALink evhandler sitems = @@ -66,16 +83,16 @@ -- | -makeSVGFromSelection :: [RItem] -> BBox -> IO SVG -makeSVGFromSelection hititms (BBox (ulx,uly) (lrx,lry)) = do +makeSVGFromSelection :: RenderCache -> [RItem] -> BBox -> IO SVG +makeSVGFromSelection cache hititms (BBox (ulx,uly) (lrx,lry)) = do uuid <- nextRandom tdir <- getTemporaryDirectory let filename = tdir show uuid <.> "svg" (x,y) = (ulx,uly) (w,h) = (lrx-ulx,lry-uly) - withSVGSurface filename w h $ \s -> renderWith s $ do - translate (-ulx) (-uly) - mapM_ renderRItem hititms + Cairo.withSVGSurface filename w h $ \s -> Cairo.renderWith s $ do + Cairo.translate (-ulx) (-uly) + mapM_ (renderRItem cache) hititms bstr <- B.readFile filename let svg = SVG Nothing Nothing bstr (x,y) (Dim w h) svg `seq` removeFile filename diff --git a/src/Hoodle/ModelAction/File.hs b/src/Hoodle/ModelAction/File.hs --- a/src/Hoodle/ModelAction/File.hs +++ b/src/Hoodle/ModelAction/File.hs @@ -5,9 +5,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.File --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -38,15 +38,12 @@ -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Simple -import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Background import Graphics.Hoodle.Render.Type.Background import Graphics.Hoodle.Render.Type.Hoodle import Text.Hoodle.Builder (builder) import qualified Text.Hoodle.Parse.Attoparsec as PA import qualified Text.Hoodle.Migrate.V0_1_1_to_V0_2 as MV -import qualified Text.Xournal.Parse.Conduit as XP -import Text.Hoodle.Migrate.FromXournal -- from this package import Hoodle.Type.HoodleState import Hoodle.Util @@ -61,58 +58,6 @@ then MV.migrate bstr else return (parseOnly PA.hoodle bstr) --- | get file content from xournal file and update xournal state -getFileContent :: Maybe FilePath - -> HoodleState - -> IO HoodleState -getFileContent (Just fname) xstate = do - let ext = takeExtension fname - case ext of - ".hdl" -> do - bstr <- C.readFile fname - r <- checkVersionAndMigrate bstr - case r of - Left err -> putStrLn err >> return xstate - Right h -> do - nxstate <- constructNewHoodleStateFromHoodle h xstate - ctime <- getCurrentTime - return . set (hoodleFileControl.hoodleFileName) (Just fname) - . set (hoodleFileControl.lastSavedTime) (Just ctime) $ nxstate - ".xoj" -> do - XP.parseXojFile fname >>= \x -> case x of - Left str -> do - putStrLn $ "file reading error : " ++ str - return xstate - Right xojcontent -> do - hdlcontent <- mkHoodleFromXournal xojcontent - nxstate <- constructNewHoodleStateFromHoodle hdlcontent xstate - ctime <- getCurrentTime - return . set (hoodleFileControl.hoodleFileName) (Just fname) - . set (hoodleFileControl.lastSavedTime) (Just ctime) $ nxstate - ".pdf" -> do - let doesembed = view (settings.doesEmbedPDF) xstate - mhdl <- makeNewHoodleWithPDF doesembed fname - case mhdl of - Nothing -> getFileContent Nothing xstate - Just hdl -> do - newhdlstate <- constructNewHoodleStateFromHoodle hdl xstate - return . set (hoodleFileControl.hoodleFileName) Nothing $ newhdlstate - _ -> getFileContent Nothing xstate -getFileContent Nothing xstate = do - newhdl <- cnstrctRHoodle =<< defaultHoodle - let newhdlstate = ViewAppendState newhdl - xstate' = set (hoodleFileControl.hoodleFileName) Nothing - . set hoodleModeState newhdlstate - $ xstate - return xstate' - --- | -constructNewHoodleStateFromHoodle :: Hoodle -> HoodleState -> IO HoodleState -constructNewHoodleStateFromHoodle hdl' xstate = do - hdl <- cnstrctRHoodle hdl' - let startinghoodleModeState = ViewAppendState hdl - return $ set hoodleModeState startinghoodleModeState xstate - -- | this is very temporary, need to be changed. findFirstPDFFile :: [(Int,RPage)] -> Maybe C.ByteString findFirstPDFFile xs = let ys = (filter isJust . map f) xs @@ -130,8 +75,8 @@ replacePDFPages :: [(Int,RPage)] -> [(Int,RPage)] replacePDFPages xs = map f xs where f (n,p) = case view gbackground p of - RBkgPDF _ _ pdfn mpdf msfc -> (n, set gbackground (RBkgEmbedPDF pdfn mpdf msfc) p) - _ -> (n,p) + RBkgPDF _ _ pdfn mpdf msfc -> (n, set gbackground (RBkgEmbedPDF pdfn mpdf msfc) p) + _ -> (n,p) -- | embedPDFInHoodle :: RHoodle -> IO RHoodle @@ -266,19 +211,26 @@ loadpng = do img <- loadPngFile filename (w,h) <- imageSize img - let dim | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w) + let dim | w < 612 && h < 792 = Dim (fromIntegral w) (fromIntegral h) + | w < 765 && h < 990 = Dim (fromIntegral w * 72 / 90) + (fromIntegral h * 72 / 90) + | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w) | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 - bstr <- savePngByteString img + -- bstr <- savePngByteString img + bstr <- C.readFile filename let b64str = encode bstr ebdsrc = "data:image/png;base64," <> b64str - return . ItemImage $ Image ebdsrc (100,100) dim + return . ItemImage $ Image ebdsrc (50,100) dim loadjpg = do img <- loadJpegFile filename (w,h) <- imageSize img - let dim | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w) + let dim | w < 612 && h < 792 = Dim (fromIntegral w) (fromIntegral h) + | w < 765 && h < 990 = Dim (fromIntegral w * 72 / 90) + (fromIntegral h * 72 / 90) + | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w) | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 bstr <- savePngByteString img let b64str = encode bstr ebdsrc = "data:image/png;base64," <> b64str - return . ItemImage $ Image ebdsrc (100,100) dim + return . ItemImage $ Image ebdsrc (50,100) dim 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 @@ -4,9 +4,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Page --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -25,8 +25,8 @@ -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Select -import Data.Hoodle.Zipper -import Graphics.Hoodle.Render.Type +-- import Data.Hoodle.Zipper +-- import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Util import Hoodle.Type.Alias @@ -166,34 +166,7 @@ return $ set currentPageNum (unPageNum pnum) . set (viewInfo.pageArrangement) arr $ cinfo --- | -newSinglePageFromOld :: Page EditMode -> Page EditMode -newSinglePageFromOld = set glayers (fromNonEmptyList (emptyRLayer,[])) - -- (NoSelect [emptyRLayer]) - - --- | -addNewPageInHoodle :: BackgroundStyle - -> AddDirection - -> Hoodle EditMode - -> Int - -> Hoodle EditMode -addNewPageInHoodle bsty dir hdl cpn = - let pagelst = M.elems . view gpages $ hdl - (pagesbefore,cpage:pagesafter) = splitAt cpn pagelst - cbkg = view gbackground cpage - nbkg - | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } - | otherwise = cbkg - npage = set gbackground nbkg - . newSinglePageFromOld - $ cpage - npagelst = case dir of - PageBefore -> pagesbefore ++ (npage : cpage : pagesafter) - PageAfter -> pagesbefore ++ (cpage : npage : pagesafter) - nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl - in nhdl -- | need to be refactored into zoomRatioFrmRelToCurr (rename zoomRatioRelPredefined) diff --git a/src/Hoodle/ModelAction/Pen.hs b/src/Hoodle/ModelAction/Pen.hs --- a/src/Hoodle/ModelAction/Pen.hs +++ b/src/Hoodle/ModelAction/Pen.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Pen --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -21,7 +21,7 @@ import qualified Data.IntMap as IM import Data.Sequence hiding (take, drop) import Data.Strict.Tuple hiding (uncurry) -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Generic @@ -36,25 +36,25 @@ import Hoodle.Type.PageArrangement -- -data TempRender a = TempRender { tempSurfaceSrc :: Surface - , tempSurfaceTgt :: Surface +data TempRender a = TempRender { tempSurfaceSrc :: Cairo.Surface + , tempSurfaceTgt :: Cairo.Surface , widthHeight :: (Double,Double) , tempInfo :: a } -- | update the content of temp selection. should not be often updated -updateTempRender :: TempRender a -> Render () -> Bool -> IO () +updateTempRender :: TempRender a -> Cairo.Render () -> Bool -> IO () updateTempRender temprender renderfunc isFullErase = - renderWith (tempSurfaceSrc temprender) $ do + Cairo.renderWith (tempSurfaceSrc temprender) $ do when isFullErase $ do let (cw,ch) = widthHeight temprender - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 cw ch - fill + Cairo.setSourceRGBA 0.5 0.5 0.5 1 + Cairo.rectangle 0 0 cw ch + Cairo.fill renderfunc - +-- | createNewStroke :: PenInfo -> Seq (Double,Double,Double) -> Stroke createNewStroke pinfo pdraw = let ptype = view penType pinfo @@ -80,20 +80,20 @@ -- | -addPDraw :: PenInfo - -> RHoodle - -> PageNum - -> Seq (Double,Double,Double) - -> IO (RHoodle,BBox) - -- ^ new hoodle and bbox in page coordinate -addPDraw pinfo hdl (PageNum pgnum) pdraw = do +addPDraw :: RenderCache + -> PenInfo + -> RHoodle + -> PageNum + -> Seq (Double,Double,Double) + -> IO (RHoodle,BBox) -- ^ new hoodle and bbox in page coordinate +addPDraw cache pinfo hdl (PageNum pgnum) pdraw = do let currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage dim = view gdimension currpage newstroke = createNewStroke pinfo pdraw newstrokebbox = runIdentity (makeBBoxed newstroke) bbox = getBBox newstrokebbox - newlayerbbox <- updateLayerBuf dim (Just bbox) + newlayerbbox <- updateLayerBuf cache dim (Just bbox) . over gitems (++[RItemStroke newstrokebbox]) $ currlayer let newpagebbox = adjustCurrentLayer newlayerbbox currpage diff --git a/src/Hoodle/ModelAction/Select.hs b/src/Hoodle/ModelAction/Select.hs --- a/src/Hoodle/ModelAction/Select.hs +++ b/src/Hoodle/ModelAction/Select.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Select --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -25,7 +25,7 @@ import Data.Sequence (ViewL(..),viewl,Seq) import Data.Strict.Tuple import Data.Time.Clock -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.Rendering.Cairo.Matrix ( invert, transformPoint ) import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform @@ -135,11 +135,14 @@ $ thdl -- | -updateTempHoodleSelectIO :: Hoodle SelectMode -> Page SelectMode -> Int - -> IO (Hoodle SelectMode) -updateTempHoodleSelectIO thdl tpage pagenum = do +updateTempHoodleSelectIO :: RenderCache + -> Hoodle SelectMode + -> Page SelectMode + -> Int + -> IO (Hoodle SelectMode) +updateTempHoodleSelectIO cache thdl tpage pagenum = do let pgs = view gselAll thdl - newpage <- (updatePageBuf.hPage2RPage) tpage + newpage <- (updatePageBuf cache . hPage2RPage) tpage let pgs' = M.adjust (const newpage) pagenum pgs return $ set gselAll pgs' . set gselSelected (Just (pagenum,tpage)) @@ -333,38 +336,41 @@ hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) where BBox (x1,y1) (x2,y2) = getBBox lnk - +hitLassoItem lst (RItemAnchor anc _) = + hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) + && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) + where BBox (x1,y1) (x2,y2) = getBBox anc type TempSelection = TempRender [RItem] data ItmsNImg = ItmsNImg { itmNimg_itms :: [RItem] , itmNimg_mbbx :: Maybe BBox - , imageSurface :: Surface } + , imageSurface :: Cairo.Surface } -- | -mkItmsNImg :: CanvasGeometry -> Page SelectMode -> IO ItmsNImg -mkItmsNImg _geometry tpage = do - let itms = getSelectedItms tpage - drawselection = mapM_ renderRItem itms -- (renderItem.rItem2Item) itms - Dim cw ch = view gdimension tpage - mbbox = case getULBBoxFromSelected tpage of - Middle bbox -> Just bbox - _ -> Nothing - sfc <- createImageSurface FormatARGB32 (floor cw) (floor ch) - renderWith sfc $ do - setSourceRGBA 1 1 1 0 - rectangle 0 0 cw ch - fill - setSourceRGBA 0 0 0 1 - drawselection - return $ ItmsNImg itms mbbox sfc +mkItmsNImg :: RenderCache -> Page SelectMode -> IO ItmsNImg +mkItmsNImg cache tpage = do + let itms = getSelectedItms tpage + drawselection = mapM_ (renderRItem cache) itms + Dim cw ch = view gdimension tpage + mbbox = case getULBBoxFromSelected tpage of + Middle bbox -> Just bbox + _ -> Nothing + sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor cw) (floor ch) + Cairo.renderWith sfc $ do + Cairo.setSourceRGBA 1 1 1 0 + Cairo.rectangle 0 0 cw ch + Cairo.fill + Cairo.setSourceRGBA 0 0 0 1 + drawselection + return $ ItmsNImg itms mbbox sfc -- | drawTempSelectImage :: CanvasGeometry -> TempRender ItmsNImg - -> Matrix -- ^ transformation matrix - -> Render () + -> Cairo.Matrix -- ^ transformation matrix + -> Cairo.Render () drawTempSelectImage geometry tempselection xformmat = do let sfc = imageSurface (tempInfo tempselection) CanvasDimension (Dim cw ch) = canvasDim geometry @@ -375,31 +381,16 @@ newmbbox = case unIntersect (Intersect (Middle newvbbox) `mappend` fromMaybe mbbox) of Middle bbox -> Just bbox _ -> Just newvbbox - setMatrix xformmat + Cairo.setMatrix xformmat clipBBox newmbbox - setSourceSurface sfc 0 0 - setOperator OperatorOver - paint - - - -{- --- | -tempSelected :: TempSelection -> [RItem] -tempSelected = tempInfo --} - -{- -mkTempSelection :: Surface -> (Double,Double) -> [RItem] -> TempSelection -mkTempSelection sfc (w,h) = TempRender sfc (w,h) --} - - + Cairo.setSourceSurface sfc 0 0 + Cairo.setOperator Cairo.OperatorOver + Cairo.paint -- | getNewCoordTime :: ((Double,Double),UTCTime) - -> (Double,Double) - -> IO (Bool,((Double,Double),UTCTime)) + -> (Double,Double) + -> IO (Bool,((Double,Double),UTCTime)) getNewCoordTime (prev,otime) (x,y) = do ntime <- getCurrentTime let dtime = diffUTCTime ntime otime diff --git a/src/Hoodle/ModelAction/Select/Transform.hs b/src/Hoodle/ModelAction/Select/Transform.hs --- a/src/Hoodle/ModelAction/Select/Transform.hs +++ b/src/Hoodle/ModelAction/Select/Transform.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Select.Transform --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -40,7 +40,7 @@ changeItemBy func (RItemImage img sfc) = RItemImage (changeImageBy func img) sfc changeItemBy func (RItemSVG svg rsvg) = RItemSVG (changeSVGBy func svg) rsvg changeItemBy func (RItemLink lnk rsvg) = RItemLink (changeLinkBy func lnk) rsvg - +changeItemBy func (RItemAnchor anc rsvg) = RItemAnchor (changeAnchorBy func anc) rsvg -- | modify stroke using a function @@ -51,16 +51,12 @@ newds = map change ds nstrk = Stroke t c w newds in runIdentity (makeBBoxed nstrk) --- nbbox = bboxFromStroke nstrk --- in BBoxed nstrk nbbox changeStrokeBy func (BBoxed (VWStroke t c ds) _bbox) = let change (x,y,z) = let (nx,ny) = func (x,y) in (nx,ny,z) newds = map change ds nstrk = VWStroke t c newds in runIdentity (makeBBoxed nstrk) --- nbbox = bboxFromStroke nstrk --- in BBoxed nstrk nbbox -- | changeImageBy :: ((Double,Double)->(Double,Double)) -> BBoxed Image -> BBoxed Image @@ -90,6 +86,21 @@ (x2,y2) = func (x+w,y+h) nlnk = LinkDocID i lid loc t c bstr (x1,y1) (Dim (x2-x1) (y2-y1)) in runIdentity (makeBBoxed nlnk) +changeLinkBy func (BBoxed (LinkAnchor i lid loc aid bstr (x,y) (Dim w h)) _bbox) = + let (x1,y1) = func (x,y) + (x2,y2) = func (x+w,y+h) + nlnk = LinkAnchor i lid loc aid bstr (x1,y1) (Dim (x2-x1) (y2-y1)) + in runIdentity (makeBBoxed nlnk) + +-- | +changeAnchorBy :: ((Double,Double) -> (Double,Double)) + -> BBoxed Anchor -> BBoxed Anchor +changeAnchorBy func (BBoxed (Anchor i bstr (x,y) (Dim w h)) _) = + let (x1,y1) = func (x,y) + (x2,y2) = func (x+w,y+h) + nanc = Anchor i bstr (x1,y1) (Dim (x2-x1) (y2-y1)) + in runIdentity (makeBBoxed nanc) + -- | modify the whole selection using a function changeSelectionBy :: ((Double,Double) -> (Double,Double)) diff --git a/src/Hoodle/ModelAction/Text.hs b/src/Hoodle/ModelAction/Text.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/ModelAction/Text.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.ModelAction.File +-- Copyright : (c) 2011-2014 Ian-Woo Kim +-- +-- License : GPL-3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module Hoodle.ModelAction.Text where + +import Control.Applicative +import Data.Attoparsec.Text as A +import Data.Char (isAlphaNum) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +-- +import Debug.Trace + +-- | +getLinesFromText :: (Int,Int) -> T.Text -> T.Text +getLinesFromText (i,e) = T.unlines . Prelude.drop (i-1) . Prelude.take e . T.lines + + +{- +-- | +getKeywordContent :: T.Text -- ^ keyword + -> T.Text -- ^ tex file + -> Maybe T.Text -- ^ subpart +getKeywordContent k txt = M.lookup k (getKeywordMap txt) +-} + +-- | +getKeywordMap :: T.Text -> M.Map T.Text T.Text +getKeywordMap txt = case parseOnly (many keywordContents) txt of + Left err -> trace (show err) $ M.empty + Right lst -> M.fromList lst + + +-- | +keywordBegin :: A.Parser T.Text +keywordBegin = + skipWhile (notInClass "%") *> (try (string "%h%k " *> A.skipSpace + *> A.takeWhile1 isAlphaNum + <* A.skipWhile (not . isEndOfLine) + <* A.endOfLine) + <|> (oneline *> keywordBegin)) + +-- | +keywordEnd :: A.Parser () +keywordEnd = string "%h%k%end" >> skipWhile (notInClass "\r\n") >> endOfLine + + +-- | +oneline :: A.Parser T.Text +oneline = A.takeWhile (not . isEndOfLine) <* endOfLine + +-- | +keywordContents :: A.Parser (T.Text, T.Text) -- ^ (keyword,contents) +keywordContents = do + k <- keywordBegin + txt <- T.unlines <$> manyTill oneline keywordEnd + return (k,txt) + + + + diff --git a/src/Hoodle/ModelAction/Window.hs b/src/Hoodle/ModelAction/Window.hs --- a/src/Hoodle/ModelAction/Window.hs +++ b/src/Hoodle/ModelAction/Window.hs @@ -4,9 +4,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Window --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -42,18 +42,30 @@ getDBUSEvent callback tvar = do client <- connectSession requestName client "org.ianwookim" [] - forkIO $ listen client matchAny { matchInterface = Just "org.ianwookim.hoodle" - , matchMember = Just "filepath" - } - test + forkIO $ void $ addMatch client matchAny { matchInterface = Just "org.ianwookim.hoodle" + , matchMember = Just "filepath" + } + getImage + + forkIO $ void $ addMatch client matchAny { matchInterface = Just "org.ianwookim.hoodle" + , matchMember = Just "latex" + } + getLaTeX forever getLine - where test sig = do - putStrLn "getDBUSEvent" + where getImage sig = do let fps = mapMaybe fromVariant (signalBody sig) :: [T.Text] b <- atomically (readTVar tvar) when ((not.null) fps && b) $ do - postGUISync (callback (UsrEv (ImageFileDropped (T.unpack (head fps))))) + (postGUISync . callback . UsrEv . DBusEv . ImageFileDropped . T.unpack . head) + fps return () + getLaTeX sig = do + let latex = mapMaybe fromVariant (signalBody sig) :: [T.Text] + b <- atomically (readTVar tvar) + when ((not.null) latex && b) $ do + (postGUISync . callback . UsrEv . DBusEv . DBusNetworkInput . head) + latex + return () -- | set frame title according to file name setTitleFromFileName :: HoodleState -> IO () @@ -123,7 +135,6 @@ TouchButton -> liftIO (callback (UsrEv (TouchDown cid p))) _ -> liftIO (callback (UsrEv (PenDown cid pbtn p))) _confevent <- canvas `on` configureEvent $ tryEvent $ do - (w,h) <- eventSize liftIO $ callback (UsrEv (CanvasConfigure cid (fromIntegral w) (fromIntegral h))) _brevent <- canvas `on` buttonReleaseEvent $ tryEvent $ do diff --git a/src/Hoodle/Type/Canvas.hs b/src/Hoodle/Type/Canvas.hs --- a/src/Hoodle/Type/Canvas.hs +++ b/src/Hoodle/Type/Canvas.hs @@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Canvas --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -97,7 +97,7 @@ import Control.Lens (Simple,Lens,view,set,lens) import qualified Data.IntMap as M import Data.Sequence -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk hiding (get,set) -- import Data.Hoodle.Simple (Dimension(..)) @@ -163,13 +163,13 @@ data CanvasInfo (a :: ViewMode) = CanvasInfo { _canvasId :: CanvasId , _drawArea :: DrawingArea - , _mDrawSurface :: Maybe Surface + , _mDrawSurface :: Maybe Cairo.Surface , _scrolledWindow :: ScrolledWindow , _viewInfo :: ViewInfo a , _currentPageNum :: Int , _horizAdjustment :: Adjustment , _vertAdjustment :: Adjustment - , _horizAdjConnId :: Maybe (ConnectId Adjustment) + , _horizAdjConnId :: Maybe (ConnectId Adjustment) , _vertAdjConnId :: Maybe (ConnectId Adjustment) , _canvasWidgets :: CanvasWidgets , _notifiedItem :: Maybe (PageNum,BBox,RItem) @@ -219,7 +219,7 @@ drawArea = lens _drawArea (\f a -> f { _drawArea = a }) -- | -mDrawSurface :: Simple Lens (CanvasInfo a) (Maybe Surface) +mDrawSurface :: Simple Lens (CanvasInfo a) (Maybe Cairo.Surface) mDrawSurface = lens _mDrawSurface (\f a -> f { _mDrawSurface = a }) @@ -271,22 +271,7 @@ CanvasContPage :: CanvasInfo ContinuousPage -> CanvasInfoBox --- test1 :: forall (a :: ViewMode). a -> Bool --- test1 = undefined --- test1 (_ :: SinglePage) = True --- test1 (_ :: ContinuousPage) = False -{- --- | fmap-like operation for box -insideAction4CvsInfoBox :: (forall a. CanvasInfo a -> CanvasInfo a) - -> CanvasInfoBox -> CanvasInfoBox -insideAction4CvsInfoBox f (CanvasSinglePage x) = CanvasSinglePage (f x) -insideAction4CvsInfoBox f (CanvasContPage x) = CanvasContPage (f x) --} - - - - forBoth :: ((CanvasInfo SinglePage -> f (CanvasInfo SinglePage)) -> (CanvasInfo ContinuousPage -> f (CanvasInfo ContinuousPage)) @@ -304,18 +289,6 @@ forBoth' m f = m f f - -{- -bothXform :: (forall a. CanvasInfo a -> CanvasInfo a) - -> ((CanvasInfo SinglePage -> f (CanvasInfo SinglePage)) - -> (CanvasInfo ContinuousPage -> f (CanvasInfo ContinuousPage)) - -> (CanvasInfoBox -> CanvasInfoBox)) - -> CanvasInfoBox -> CanvasInfoBox -bothXform f m = m f f - --} - - -- | single page action and continuous page act unboxBiXform :: (Functor f) => (CanvasInfo SinglePage -> f (CanvasInfo SinglePage)) @@ -332,16 +305,10 @@ unboxBiAct _fsingle fcont (CanvasContPage cinfo) = fcont cinfo -{- --- | apply a funtion to Generic CanvasInfo -unboxAct :: (forall a. CanvasInfo a -> r) -> CanvasInfoBox -> r -unboxAct f (CanvasSinglePage x) = f x -unboxAct f (CanvasContPage x) = f x --} - -- | unboxGet :: (forall a. Simple Lens (CanvasInfo a) b) -> CanvasInfoBox -> b unboxGet f = forBoth' unboxBiAct (view f) + -- | unboxSet :: (forall a. Simple Lens (CanvasInfo a) b) -> b -> CanvasInfoBox -> CanvasInfoBox unboxSet l b (CanvasSinglePage a) = CanvasSinglePage (set l b a) @@ -350,27 +317,6 @@ unboxLens :: (forall a. Simple Lens (CanvasInfo a) b) -> Simple Lens CanvasInfoBox b unboxLens l = lens (unboxGet l) (flip (unboxSet l)) -{- --- | -boxAction :: Monad m => (forall a. CanvasInfo a -> m b) - -> CanvasInfoBox -> m b -boxAction f c = unboxAct f c - -- f (CanvasInfoBox cinfo) = f cinfo --} - - - - - -{- --- | -selectBox :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) - -> (CanvasInfo ContinuousPage -> CanvasInfo ContinuousPage) - -> CanvasInfoBox -> CanvasInfoBox -selectBox fs _fc (CanvasSinglePage cinfo) = CanvasSinglePage (fs cinfo) -selectBox _fs fc (CanvasContPage cinfo)= CanvasContPage (fc cinfo) --} - -- | getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea getDrawAreaFromBox = view (unboxLens drawArea) @@ -502,22 +448,23 @@ (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy) arr' = SingleArrangement cdim pdim (ViewPortBBox nbbox) - maybe (return ()) surfaceFinish $ view mDrawSurface cinfo + maybe (return ()) Cairo.surfaceFinish $ view mDrawSurface cinfo msfc <- fmap Just $ do - sfc <- createImageSurface FormatARGB32 (floor w') (floor h') - renderWith sfc $ do - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 w' h' - fill + sfc <- Cairo.createImageSurface + Cairo.FormatARGB32 (floor w') (floor h') + Cairo.renderWith sfc $ do + Cairo.setSourceRGBA 0.5 0.5 0.5 1 + Cairo.rectangle 0 0 w' h' + Cairo.fill return sfc return $ (set (viewInfo.pageArrangement) arr' . set mDrawSurface msfc) cinfo -- | updateCanvasDimForContSingle :: PageDimension - -> CanvasDimension - -> CanvasInfo ContinuousPage - -> IO (CanvasInfo ContinuousPage) + -> CanvasDimension + -> CanvasInfo ContinuousPage + -> IO (CanvasInfo ContinuousPage) updateCanvasDimForContSingle pdim cdim@(CanvasDimension (Dim w' h')) cinfo = do let zmode = view (viewInfo.zoomMode) cinfo ContinuousArrangement _ ddim func (ViewPortBBox bbox) @@ -526,13 +473,14 @@ (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy) arr' = ContinuousArrangement cdim ddim func (ViewPortBBox nbbox) - maybe (return ()) surfaceFinish $ view mDrawSurface cinfo + maybe (return ()) Cairo.surfaceFinish $ view mDrawSurface cinfo msfc <- fmap Just $ do - sfc <- createImageSurface FormatARGB32 (floor w') (floor h') - renderWith sfc $ do - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 w' h' - fill + sfc <- Cairo.createImageSurface + Cairo.FormatARGB32 (floor w') (floor h') + Cairo.renderWith sfc $ do + Cairo.setSourceRGBA 0.5 0.5 0.5 1 + Cairo.rectangle 0 0 w' h' + Cairo.fill return sfc return $ (set (viewInfo.pageArrangement) arr'.set mDrawSurface msfc) cinfo diff --git a/src/Hoodle/Type/Coroutine.hs b/src/Hoodle/Type/Coroutine.hs --- a/src/Hoodle/Type/Coroutine.hs +++ b/src/Hoodle/Type/Coroutine.hs @@ -7,9 +7,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Coroutine --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -21,13 +21,10 @@ -- from other packages import Control.Applicative import Control.Concurrent -import Control.Lens ((^.),(.~),(%~),view,set) - +import Control.Lens ((^.),(.~),(%~)) import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Either -import Data.Time.Clock -import Data.Time.LocalTime -- from hoodle-platform import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Object @@ -36,10 +33,8 @@ import Control.Monad.Trans.Crtn.Queue import Control.Monad.Trans.Crtn.World -- from this package -import Hoodle.Type.Canvas import Hoodle.Type.Event import Hoodle.Type.HoodleState -import Hoodle.Type.Widget import Hoodle.Util -- @@ -58,37 +53,8 @@ -- | type MainObj = SObjT MainOp (EStT HoodleState WorldObjB) --- | -nextevent :: MainCoroutine UserEvent -nextevent = do Arg DoEvent ev <- request (Res DoEvent ()) - case ev of - SysEv sev -> sysevent sev >> nextevent - UsrEv uev -> return uev -sysevent :: SystemEvent -> MainCoroutine () -sysevent ClockUpdateEvent = do - utctime <- liftIO $ getCurrentTime - zone <- liftIO $ getCurrentTimeZone - let ltime = utcToLocalTime zone utctime - ltimeofday = localTimeOfDay ltime - (h,m,s) :: (Int,Int,Int) = - (,,) <$> (\x->todHour x `mod` 12) <*> todMin <*> (floor . todSec) - $ ltimeofday - -- liftIO $ print (h,m,s) - xst <- get - let cinfo = view currentCanvasInfo xst - cwgts = view (unboxLens canvasWidgets) cinfo - nwgts = set (clockWidgetConfig.clockWidgetTime) (h,m,s) cwgts - ncinfo = set (unboxLens canvasWidgets) nwgts cinfo - put . set currentCanvasInfo ncinfo $ xst - - when (view (widgetConfig.doesUseClockWidget) cwgts) $ do - let cid = getCurrentCanvasId xst - modify (tempQueue %~ enqueue (Right (UsrEv (UpdateCanvasEfficient cid)))) - -- invalidateInBBox Nothing Efficient cid -sysevent ev = liftIO $ print ev - -- | type WorldObj = SObjT (WorldOp AllEvent DriverB) DriverB @@ -142,17 +108,17 @@ -- | type EventVar = MVar (Maybe (Driver ())) - - - -- | maybeError :: String -> Maybe a -> MainCoroutine a maybeError str = maybe (lift . hoistEither . Left . Other $ str) return - -- | doIOaction :: ((AllEvent -> IO ()) -> IO AllEvent) -> MainCoroutine () doIOaction action = modify (tempQueue %~ enqueue (mkIOaction action)) + + + + diff --git a/src/Hoodle/Type/Event.hs b/src/Hoodle/Type/Event.hs --- a/src/Hoodle/Type/Event.hs +++ b/src/Hoodle/Type/Event.hs @@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Event --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -22,11 +22,14 @@ import Data.IORef import qualified Data.Text as T import Data.Time.Clock +import Data.UUID (UUID) +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk hiding (Image) -- from hoodle-platform import Control.Monad.Trans.Crtn.Event import Data.Hoodle.BBox import Data.Hoodle.Simple +import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Device import Hoodle.Type.Enum @@ -37,12 +40,15 @@ data AllEvent = UsrEv UserEvent | SysEv SystemEvent deriving Show +instance Show (Cairo.Surface) where + show _ = "surface" + -- | -data SystemEvent = TestSystemEvent | ClockUpdateEvent +data SystemEvent = TestSystemEvent | ClockUpdateEvent | RenderCacheUpdate (UUID, (Double,Cairo.Surface)) deriving Show -- | -data UserEvent = Initialized +data UserEvent = Initialized (Maybe FilePath) | CanvasConfigure Int Double Double | UpdateCanvas Int | UpdateCanvasEfficient Int @@ -87,15 +93,26 @@ | GotRevisionInk String [Stroke] | ChangeDialog | ActionOrdered + | GotRecogResult Bool T.Text | MiniBuffer MiniBufferEvent | MultiLine MultiLineEvent | NetworkProcess NetworkEvent - | ImageFileDropped FilePath + | DBusEv DBusEvent + | RenderEv RenderEvent + | LinePosition (Maybe (Int,Int)) + | Keyword (Maybe T.Text) deriving Show instance Show (IORef a) where show _ = "IORef" +data RenderEvent = GotRItem RItem + | GotRItems [RItem] + | GotRBackground RBackground + | GotRHoodle RHoodle + | GotNone + deriving Show + -- | data MenuEvent = MenuNew | MenuAnnotatePDF @@ -106,8 +123,15 @@ | MenuRecentDocument | MenuLoadPNGorJPG | MenuLoadSVG + | MenuText + | MenuEmbedTextSource + | MenuEditEmbedTextSource + | MenuEditNetEmbedTextSource + | MenuTextFromSource | MenuLaTeX + | MenuLaTeXNetwork | MenuCombineLaTeX + | MenuLaTeXFromSource | MenuEmbedPredefinedImage | MenuEmbedPredefinedImage2 | MenuEmbedPredefinedImage3 @@ -158,10 +182,12 @@ | MenuEmbedAllPDFBkg | MenuDefaultPaper | MenuSetAsDefaultPaper - | MenuText | MenuAddLink - | MenuShapeRecognizer - | MenuRuler + | MenuAddAnchor + | MenuListAnchors + -- | MenuShapeRecognizer + -- | MenuRuler + | MenuHandwritingRecognitionDialog | MenuSelectRegion | MenuSelectRectangle | MenuVerticalSpace @@ -185,6 +211,7 @@ | MenuEmbedPDF | MenuFollowLinks | MenuKeepAspectRatio + | MenuUseVariableCursor | MenuTogglePanZoomWidget | MenuToggleLayerWidget | MenuToggleClockWidget @@ -205,7 +232,7 @@ | MenuSavePreferences | MenuAbout | MenuDefault - deriving Show -- (Show, Ord, Eq) + deriving Show -- | data ImgType = TypSVG | TypPDF @@ -221,11 +248,16 @@ | CMenuLinkConvert Link | CMenuCreateALink | CMenuAssocWithNewFile + | CMenuMakeLinkToAnchor Anchor | CMenuPangoConvert (Double,Double) T.Text | CMenuLaTeXConvert (Double,Double) T.Text | CMenuLaTeXConvertNetwork (Double,Double) T.Text + | CMenuLaTeXUpdate (Double,Double) T.Text | CMenuCropImage (BBoxed Image) | CMenuRotate RotateDir (BBoxed Image) + | CMenuExport (BBoxed Image) + | CMenuExportHoodlet Item + | CMenuConvertSelection Item | CMenuCustom deriving (Show, Ord, Eq) @@ -254,6 +286,11 @@ instance Show (MVar ()) where show _ = "MVar" + +data DBusEvent = DBusNetworkInput T.Text + | ImageFileDropped FilePath + | GoToLink (T.Text,T.Text) + deriving Show -- | viewModeToUserEvent :: RadioAction -> IO UserEvent diff --git a/src/Hoodle/Type/HoodleState.hs b/src/Hoodle/Type/HoodleState.hs --- a/src/Hoodle/Type/HoodleState.hs +++ b/src/Hoodle/Type/HoodleState.hs @@ -4,9 +4,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.HoodleState --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -46,6 +46,10 @@ , tempLog , tempQueue , statusBar +, renderCache +, pdfRenderQueue +, doesNotInvalidate +-- , cursorInfo -- , hoodleFileName , lastSavedTime @@ -58,6 +62,7 @@ , doesEmbedPDF , doesFollowLinks , doesKeepAspectRatio +, doesUseVariableCursor -- , penModeSignal , pageModeSignal @@ -87,13 +92,19 @@ , showCanvasInfoMapViewPortBBox ) where -import Control.Category +import Control.Applicative hiding (empty) +import Control.Concurrent +import Control.Concurrent.STM import Control.Lens (Simple,Lens,view,set,lens) import Control.Monad.State hiding (get,modify) import Data.Functor.Identity (Identity(..)) +import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as M import Data.Maybe +import Data.Sequence import Data.Time.Clock +import Data.UUID (UUID) +-- import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk hiding (Clipboard, get,set) -- from hoodle-platform import Control.Monad.Trans.Crtn.Event @@ -114,7 +125,7 @@ import Hoodle.Type.PageArrangement import Hoodle.Util -- -import Prelude hiding ((.), id) +-- import Prelude hiding ((.), id) -- | @@ -155,6 +166,9 @@ , _tempQueue :: Queue (Either (ActionOrder AllEvent) AllEvent) , _tempLog :: String -> String , _statusBar :: Maybe Gtk.Statusbar + , _renderCache :: RenderCache + , _pdfRenderQueue :: TVar (Seq (UUID,PDFCommand)) + , _doesNotInvalidate :: Bool -- , _cursorInfo :: Maybe Cursor } @@ -270,6 +284,27 @@ statusBar = lens _statusBar (\f a -> f { _statusBar = a }) -- | +renderCache :: Simple Lens HoodleState RenderCache +renderCache = lens _renderCache (\f a -> f { _renderCache = a }) + +-- | +pdfRenderQueue :: Simple Lens HoodleState (TVar (Seq (UUID, PDFCommand))) +pdfRenderQueue = lens _pdfRenderQueue (\f a -> f { _pdfRenderQueue = a }) + + +-- | +doesNotInvalidate :: Simple Lens HoodleState Bool +doesNotInvalidate = lens _doesNotInvalidate (\f a -> f { _doesNotInvalidate = a }) + + + +{- +-- | +cursorInfo :: Simple Lens HoodleState (Maybe Cursor) +cursorInfo = lens _cursorInfo (\f a -> f { _cursorInfo = a }) +-} + +-- | data HoodleFileControl = HoodleFileControl { _hoodleFileName :: Maybe FilePath , _lastSavedTime :: Maybe UTCTime @@ -320,6 +355,7 @@ , _doesEmbedPDF :: Bool , _doesFollowLinks :: Bool , _doesKeepAspectRatio :: Bool + , _doesUseVariableCursor :: Bool } @@ -355,10 +391,15 @@ doesKeepAspectRatio :: Simple Lens Settings Bool doesKeepAspectRatio = lens _doesKeepAspectRatio (\f a -> f { _doesKeepAspectRatio = a } ) +-- | flag for variable cursor +doesUseVariableCursor :: Simple Lens Settings Bool +doesUseVariableCursor = lens _doesUseVariableCursor (\f a -> f {_doesUseVariableCursor=a}) + -- | default hoodle state emptyHoodleState :: IO HoodleState emptyHoodleState = do hdl <- emptyGHoodle + tvar <- atomically $ newTVar empty return $ HoodleState { _hoodleModeState = ViewAppendState hdl @@ -392,6 +433,10 @@ , _tempQueue = emptyQueue , _tempLog = id , _statusBar = Nothing + , _renderCache = HM.empty + , _pdfRenderQueue = tvar + , _doesNotInvalidate = False + -- , _cursorInfo = Nothing } emptyHoodleFileControl :: HoodleFileControl @@ -422,6 +467,7 @@ , _doesEmbedPDF = True , _doesFollowLinks = True , _doesKeepAspectRatio = False + , _doesUseVariableCursor = False } @@ -469,10 +515,10 @@ in f { _currentCanvas = (cid,a), _cvsInfoMap = cmap' } -- | -resetHoodleModeStateBuffers :: HoodleModeState -> IO HoodleModeState -resetHoodleModeStateBuffers hdlmodestate1 = +resetHoodleModeStateBuffers :: RenderCache -> HoodleModeState -> IO HoodleModeState +resetHoodleModeStateBuffers cache hdlmodestate1 = case hdlmodestate1 of - ViewAppendState hdl -> liftIO . liftM ViewAppendState . updateHoodleBuf $ hdl + ViewAppendState hdl -> liftIO . liftM ViewAppendState . updateHoodleBuf cache $ hdl _ -> return hdlmodestate1 -- | @@ -543,7 +589,6 @@ showCanvasInfoMapViewPortBBox xstate = do let cmap = getCanvasInfoMap xstate print . map (view (unboxLens (viewInfo.pageArrangement.viewPortBBox))) . M.elems $ cmap - diff --git a/src/Hoodle/Type/PageArrangement.hs b/src/Hoodle/Type/PageArrangement.hs --- a/src/Hoodle/Type/PageArrangement.hs +++ b/src/Hoodle/Type/PageArrangement.hs @@ -210,12 +210,16 @@ ------------ -- | -pageDimension :: Simple Lens (PageArrangement SinglePage) PageDimension +pageDimension :: Simple Lens (PageArrangement a) PageDimension pageDimension = lens getter setter - where getter (SingleArrangement _ pdim _) = pdim - getter (ContinuousArrangement _ _ _ _) = error $ "in pageDimension " -- partial - setter (SingleArrangement cdim _ vbbox) pdim = SingleArrangement cdim pdim vbbox - setter (ContinuousArrangement _ _ _ _) _pdim = error $ "in pageDimension " -- partial + where + getter :: PageArrangement a -> PageDimension + getter (SingleArrangement _ pdim _) = pdim + getter (ContinuousArrangement _ _ _ _) = error $ "in pageDimension " -- partial + + setter :: PageArrangement a -> PageDimension -> PageArrangement a + setter (SingleArrangement cdim _ vbbox) pdim = SingleArrangement cdim pdim vbbox + setter (ContinuousArrangement _ _ _ _) _pdim = error $ "in pageDimension " -- partial -- | canvasDimension :: Simple Lens (PageArrangement a) CanvasDimension diff --git a/src/Hoodle/Type/Predefined.hs b/src/Hoodle/Type/Predefined.hs --- a/src/Hoodle/Type/Predefined.hs +++ b/src/Hoodle/Type/Predefined.hs @@ -47,12 +47,18 @@ predefinedLassoDash = ([2,2],4) -- | - predefinedPageSpacing :: Double predefinedPageSpacing = 10 -- | - predefinedZoomStepFactor :: Double predefinedZoomStepFactor = 1.10 + +-- | +maxCursorWidth :: Int +maxCursorWidth = 30 + +-- | +maxCursorHeight :: Int +maxCursorHeight = 30 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 @@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.View.Draw --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim @@ -20,7 +20,6 @@ import Control.Applicative import Control.Monad.Trans import Control.Monad.Trans.Maybe --- import Control.Category ((.)) import Control.Lens (view,set,at) import Control.Monad (when) import Data.Foldable hiding (elem) @@ -28,8 +27,8 @@ import Data.Maybe hiding (fromMaybe) import Data.Monoid import Data.Sequence +import qualified Graphics.Rendering.Cairo as Cairo import Graphics.UI.Gtk hiding (get,set) -import Graphics.Rendering.Cairo -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Generic @@ -37,6 +36,7 @@ import Data.Hoodle.Select import Data.Hoodle.Simple (Dimension(..),Stroke(..)) import Data.Hoodle.Zipper (currIndex,current) +import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Generic import Graphics.Hoodle.Render.Highlight import Graphics.Hoodle.Render.Type @@ -61,24 +61,27 @@ -- | newtype SinglePageDraw a = - SinglePageDraw { unSinglePageDraw :: Bool - -> (DrawingArea, Maybe Surface) - -> (PageNum, Page a) - -> ViewInfo SinglePage - -> Maybe BBox - -> DrawFlag - -> IO (Page a) } + SinglePageDraw + { unSinglePageDraw :: RenderCache + -> Bool -- ^ isCurrentCanvas + -> (DrawingArea, Maybe Cairo.Surface) + -> (PageNum, Page a) + -> ViewInfo SinglePage + -> Maybe BBox + -> DrawFlag + -> IO (Page a) } -- | newtype ContPageDraw a = ContPageDraw - { unContPageDraw :: Bool - -> CanvasInfo ContinuousPage - -> Maybe BBox - -> Hoodle a - -> DrawFlag - -> IO (Hoodle a) } + { unContPageDraw :: RenderCache + -> Bool -- ^ isCurrentCanvas + -> CanvasInfo ContinuousPage + -> Maybe BBox + -> Hoodle a + -> DrawFlag + -> IO (Hoodle a) } -- | type instance DrawingFunction SinglePage = SinglePageDraw @@ -110,35 +113,35 @@ -- | double buffering within two image surfaces virtualDoubleBufferDraw :: (MonadIO m) => - Surface -- source surface - -> Surface -- target surface - -> Render () -- pre-render before source paint - -> Render () -- post-render after source paint + Cairo.Surface -- source surface + -> Cairo.Surface -- target surface + -> Cairo.Render () -- pre-render before source paint + -> Cairo.Render () -- post-render after source paint -> m () virtualDoubleBufferDraw srcsfc tgtsfc pre post = - renderWith tgtsfc $ do + Cairo.renderWith tgtsfc $ do pre - setSourceSurface srcsfc 0 0 - setOperator OperatorSource - paint - setOperator OperatorOver + Cairo.setSourceSurface srcsfc 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint + Cairo.setOperator Cairo.OperatorOver post -- | -doubleBufferFlush :: Surface -> CanvasInfo a -> IO () +doubleBufferFlush :: Cairo.Surface -> CanvasInfo a -> IO () doubleBufferFlush sfc cinfo = do let canvas = view drawArea cinfo win <- widgetGetDrawWindow canvas renderWithDrawable win $ do - setSourceSurface sfc 0 0 - setOperator OperatorSource - paint + Cairo.setSourceSurface sfc 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint -- | common routine for double buffering -doubleBufferDraw :: (DrawWindow, Maybe Surface) - -> CanvasGeometry -> Render () -> Render a +doubleBufferDraw :: (DrawWindow, Maybe Cairo.Surface) + -> CanvasGeometry -> Cairo.Render () -> Cairo.Render a -> IntersectBBox -> IO (Maybe a) doubleBufferDraw (win,msfc) geometry _xform rndr (Intersect ibbox) = do @@ -152,39 +155,52 @@ Nothing -> do renderWithDrawable win $ do clipBBox mbbox' - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 cw ch - fill + Cairo.setSourceRGBA 0.5 0.5 0.5 1 + Cairo.rectangle 0 0 cw ch + Cairo.fill rndr Just sfc -> do - r <- renderWith sfc $ do - -- clipBBox (fmap (flip inflate (-1.0)) mbbox') -- temporary + r <- Cairo.renderWith sfc $ do clipBBox mbbox' - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 cw ch - fill + Cairo.setSourceRGBA 0.5 0.5 0.5 1 + Cairo.rectangle 0 0 cw ch + Cairo.fill clipBBox mbbox' rndr renderWithDrawable win $ do - setSourceSurface sfc 0 0 - setOperator OperatorSource - paint + Cairo.setSourceSurface sfc 0 0 + Cairo.setOperator Cairo.OperatorSource + Cairo.paint return r case ibbox of Top -> Just <$> action Middle _ -> Just <$> action Bottom -> return Nothing + +mkXform4Page :: CanvasGeometry -> PageNum -> Xform4Page +mkXform4Page geometry pnum = + let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0)) + CvsCoord (x1,y1) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (1,1)) + sx = x1-x0 + sy = y1-y0 + in Xform4Page x0 y0 sx sy + + -- | -cairoXform4PageCoordinate :: CanvasGeometry -> PageNum -> Render () -cairoXform4PageCoordinate geometry pnum = do +cairoXform4PageCoordinate :: Xform4Page -> Cairo.Render () +cairoXform4PageCoordinate xform = do + Cairo.translate (transx xform) (transy xform) + Cairo.scale (scalex xform) (scaley xform) + + {- do let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0)) CvsCoord (x1,y1) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (1,1)) sx = x1-x0 sy = y1-y0 - translate x0 y0 - scale sx sy - + Cairo.translate x0 y0 + Cairo.scale sx sy +-} -- | data PressureMode = NoPressure | Pressure @@ -202,104 +218,107 @@ drawCurvebitGen pmode canvas geometry wdth (r,g,b,a) pnum pdraw ((x0,y0),z0) ((x,y),z) = do win <- widgetGetDrawWindow canvas renderWithDrawable win $ do - cairoXform4PageCoordinate geometry pnum - setSourceRGBA r g b a + cairoXform4PageCoordinate (mkXform4Page geometry pnum) + Cairo.setSourceRGBA r g b a case pmode of NoPressure -> do - setLineWidth wdth + Cairo.setLineWidth wdth case viewl pdraw of EmptyL -> return () (xo,yo,_) :< rest -> do - moveTo xo yo - mapM_ (\(x',y',_)-> lineTo x' y') rest - lineTo x y - stroke - -- moveTo x0 y0 - -- lineTo x y + Cairo.moveTo xo yo + mapM_ (\(x',y',_)-> Cairo.lineTo x' y') rest + Cairo.lineTo x y + Cairo.stroke Pressure -> do let wx0 = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z0 wy0 = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z0 wx = 0.5*(fst predefinedPenShapeAspectXY)*wdth*z wy = 0.5*(snd predefinedPenShapeAspectXY)*wdth*z - moveTo (x0-wx0) (y0-wy0) - lineTo (x0+wx0) (y0+wy0) - lineTo (x+wx) (y+wy) - lineTo (x-wx) (y-wy) - fill + Cairo.moveTo (x0-wx0) (y0-wy0) + Cairo.lineTo (x0+wx0) (y0+wy0) + Cairo.lineTo (x+wx) (y+wy) + Cairo.lineTo (x-wx) (y-wy) + Cairo.fill -- | drawFuncGen :: em - -> ((PageNum,Page em) -> Maybe BBox -> DrawFlag -> Render (Page em)) + -> (RenderCache -> (PageNum,Page em) -> Maybe BBox + -> DrawFlag -> Cairo.Render (Page em)) -> DrawingFunction SinglePage em drawFuncGen _typ render = SinglePageDraw func - where func isCurrentCvs (canvas,msfc) (pnum,page) vinfo mbbox flag = do + where func cache isCurrentCvs (canvas,msfc) (pnum,page) vinfo mbbox flag = do let arr = view pageArrangement vinfo geometry <- makeCanvasGeometry pnum arr canvas win <- widgetGetDrawWindow canvas let ibboxnew = getViewableBBox geometry mbbox let mbboxnew = toMaybe ibboxnew - xformfunc = cairoXform4PageCoordinate geometry pnum + xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum) renderfunc = do xformfunc - pg <- render (pnum,page) mbboxnew flag + pg <- render cache (pnum,page) mbboxnew flag -- Start Widget when isCurrentCvs (emphasisCanvasRender ColorBlue geometry) -- End Widget - resetClip + Cairo.resetClip return pg doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew >>= maybe (return page) return -- | -drawFuncSelGen :: ((PageNum,Page SelectMode) -> Maybe BBox -> DrawFlag -> Render ()) - -> ((PageNum,Page SelectMode) -> Maybe BBox -> DrawFlag -> Render ()) +drawFuncSelGen :: (RenderCache -> (PageNum,Page SelectMode) -> Maybe BBox + -> DrawFlag -> Cairo.Render ()) + -> (RenderCache -> (PageNum,Page SelectMode) -> Maybe BBox + -> DrawFlag -> Cairo.Render ()) -> DrawingFunction SinglePage SelectMode -drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\x y f -> rencont x y f >> rensel x y f >> return (snd x)) +drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\c x y f -> rencont c x y f >> rensel c x y f >> return (snd x)) -- | -emphasisCanvasRender :: PenColor -> CanvasGeometry -> Render () +emphasisCanvasRender :: PenColor -> CanvasGeometry -> Cairo.Render () emphasisCanvasRender pcolor geometry = do - identityMatrix + Cairo.identityMatrix let CanvasDimension (Dim cw ch) = canvasDim geometry let (r,g,b,a) = convertPenColorToRGBA pcolor - setSourceRGBA r g b a - setLineWidth 2 - rectangle 0 0 cw ch - stroke + Cairo.setSourceRGBA r g b a + Cairo.setLineWidth 2 + Cairo.rectangle 0 0 cw ch + Cairo.stroke -- | highlight current page -emphasisPageRender :: CanvasGeometry -> (PageNum,Page EditMode) -> Render () +emphasisPageRender :: CanvasGeometry -> (PageNum,Page EditMode) -> Cairo.Render () emphasisPageRender geometry (pn,pg) = do - save - identityMatrix - cairoXform4PageCoordinate geometry pn + Cairo.save + Cairo.identityMatrix + cairoXform4PageCoordinate (mkXform4Page geometry pn) let Dim w h = view gdimension pg - setSourceRGBA 0 0 1.0 1 - setLineWidth 2 - rectangle 0 0 w h - stroke - restore + Cairo.setSourceRGBA 0 0 1.0 1 + Cairo.setLineWidth 2 + Cairo.rectangle 0 0 w h + Cairo.stroke + Cairo.restore -- | highlight notified item (like link) -emphasisNotifiedRender :: CanvasGeometry -> (PageNum,BBox,RItem) -> Render () +emphasisNotifiedRender :: CanvasGeometry -> (PageNum,BBox,RItem) -> Cairo.Render () emphasisNotifiedRender geometry (pn,BBox (x1,y1) (x2,y2),_) = do - save - identityMatrix - cairoXform4PageCoordinate geometry pn - setSourceRGBA 1.0 1.0 0 0.1 - rectangle x1 y1 (x2-x1) (y2-y1) - fill - restore + Cairo.save + Cairo.identityMatrix + cairoXform4PageCoordinate (mkXform4Page geometry pn) + Cairo.setSourceRGBA 1.0 1.0 0 0.1 + Cairo.rectangle x1 y1 (x2-x1) (y2-y1) + Cairo.fill + Cairo.restore -- | -drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page EditMode)) +drawContPageGen :: (RenderCache -> (PageNum,Page EditMode) -> Maybe BBox + -> DrawFlag -> Cairo.Render (Int,Page EditMode)) -> DrawingFunction ContinuousPage EditMode drawContPageGen render = ContPageDraw func - where func :: Bool -> CanvasInfo ContinuousPage ->Maybe BBox -> Hoodle EditMode -> DrawFlag -> IO (Hoodle EditMode) - func isCurrentCvs cinfo mbbox hdl flag = do + where func :: RenderCache -> Bool -> CanvasInfo ContinuousPage + -> Maybe BBox -> Hoodle EditMode -> DrawFlag -> IO (Hoodle EditMode) + func cache isCurrentCvs cinfo mbbox hdl flag = do let arr = view (viewInfo.pageArrangement) cinfo pnum = PageNum . view currentPageNum $ cinfo canvas = view drawArea cinfo @@ -314,12 +333,12 @@ win <- widgetGetDrawWindow canvas let ibboxnew = getViewableBBox geometry mbbox let mbboxnew = toMaybe ibboxnew - xformfunc = cairoXform4PageCoordinate geometry pnum + xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum) onepagerender (pn,pg) = do - identityMatrix - cairoXform4PageCoordinate geometry pn + Cairo.identityMatrix + cairoXform4PageCoordinate (mkXform4Page geometry pn) let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew - render (pn,pg) pgmbbox flag + render cache (pn,pg) pgmbbox flag renderfunc = do xformfunc ndrawpgs <- mapM onepagerender drawpgs @@ -329,21 +348,24 @@ mapM_ (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg mapM_ (emphasisNotifiedRender geometry) (view notifiedItem cinfo) when isCurrentCvs (emphasisCanvasRender ColorRed geometry) - let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew + let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew drawWidgets allWidgets hdl cinfo mbbox_canvas - resetClip + Cairo.resetClip return nhdl doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew >>= maybe (return hdl) return -- | -drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page EditMode)) - -> ((PageNum, Page SelectMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page SelectMode)) - -> DrawingFunction ContinuousPage SelectMode +drawContPageSelGen :: (RenderCache -> (PageNum,Page EditMode) -> Maybe BBox + -> DrawFlag -> Cairo.Render (Int,Page EditMode)) + -> (RenderCache -> (PageNum, Page SelectMode) -> Maybe BBox + -> DrawFlag -> Cairo.Render (Int,Page SelectMode)) + -> DrawingFunction ContinuousPage SelectMode drawContPageSelGen rendergen rendersel = ContPageDraw func - where func :: Bool -> CanvasInfo ContinuousPage ->Maybe BBox -> Hoodle SelectMode ->DrawFlag -> IO (Hoodle SelectMode) - func isCurrentCvs cinfo mbbox thdl flag = do + where func :: RenderCache -> Bool -> CanvasInfo ContinuousPage + -> Maybe BBox -> Hoodle SelectMode ->DrawFlag -> IO (Hoodle SelectMode) + func cache isCurrentCvs cinfo mbbox thdl flag = do let arr = view (viewInfo.pageArrangement) cinfo pnum = PageNum . view currentPageNum $ cinfo mtpage = view gselSelected thdl @@ -360,19 +382,22 @@ win <- widgetGetDrawWindow canvas let ibboxnew = getViewableBBox geometry mbbox mbboxnew = toMaybe ibboxnew - xformfunc = cairoXform4PageCoordinate geometry pnum onepagerender (pn,pg) = do - identityMatrix - cairoXform4PageCoordinate geometry pn - rendergen (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag - selpagerender :: (PageNum, Page SelectMode) -> Render (Int, Page SelectMode) + Cairo.identityMatrix + let xform = mkXform4Page geometry pn + cairoXform4PageCoordinate xform + rendergen cache (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag + selpagerender :: (PageNum, Page SelectMode) + -> Cairo.Render (Int, Page SelectMode) selpagerender (pn,pg) = do - identityMatrix - cairoXform4PageCoordinate geometry pn - rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag - renderfunc :: Render (Hoodle SelectMode) + Cairo.identityMatrix + let xform = mkXform4Page geometry pn + cairoXform4PageCoordinate xform + rendersel cache (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag + renderfunc :: Cairo.Render (Hoodle SelectMode) renderfunc = do - xformfunc + let xform = mkXform4Page geometry pnum + cairoXform4PageCoordinate xform ndrawpgs <- mapM onepagerender drawpgs let npgs = foldr rfunc pgs ndrawpgs where rfunc (k,pg) m = M.adjust (const pg) k m @@ -386,68 +411,83 @@ when isCurrentCvs (emphasisCanvasRender ColorGreen geometry) let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew drawWidgets allWidgets hdl cinfo mbbox_canvas - resetClip + Cairo.resetClip return nthdl2 - doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew + doubleBufferDraw (win,msfc) geometry (cairoXform4PageCoordinate (mkXform4Page geometry pnum)) + renderfunc ibboxnew >>= maybe (return thdl) return -- | -drawSinglePage :: DrawingFunction SinglePage EditMode -drawSinglePage = drawFuncGen EditMode f - where f (_,page) _ Clear = do - pg' <- cairoRenderOption (RBkgDrawPDF,DrawFull) page - return pg' - f(_,page) mbbox BkgEfficient = do - InBBoxBkgBuf pg' <- cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf page) - return pg' - f (_,page) mbbox Efficient = do - InBBox pg' <- cairoRenderOption (InBBoxOption mbbox) (InBBox page) - return pg' +drawSinglePage :: CanvasGeometry -> DrawingFunction SinglePage EditMode +drawSinglePage geometry = drawFuncGen EditMode f + where + f cache (pnum,page) mbbox flag = do + let xform = mkXform4Page geometry pnum + case flag of + Clear -> do (pg',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache (page,Just xform) + return pg' + BkgEfficient -> do (InBBoxBkgBuf pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf page, Just xform) + return pg' + Efficient -> do (InBBox pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBox page, Just xform) + return pg' -- | drawSinglePageSel :: CanvasGeometry -> DrawingFunction SinglePage SelectMode drawSinglePageSel geometry = drawFuncSelGen rendercontent renderselect - where rendercontent (_pnum,tpg) mbbox flag = do + where rendercontent cache (pnum,tpg) mbbox flag = do let pg' = hPage2RPage tpg + xform = mkXform4Page geometry pnum case flag of - Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) pg' >> return () - BkgEfficient -> cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf pg') >> return () - Efficient -> cairoRenderOption (InBBoxOption mbbox) (InBBox pg') >> return () + Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) cache (pg',Just xform) >> return () + BkgEfficient -> cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf pg',Just xform) >> return () + Efficient -> cairoRenderOption (InBBoxOption mbbox) cache (InBBox pg',Just xform) >> return () return () - renderselect (_pnum,tpg) mbbox _flag = do + renderselect _cache (_pnum,tpg) mbbox _flag = do cairoHittedBoxDraw geometry tpg mbbox return () -- | -drawContHoodle :: DrawingFunction ContinuousPage EditMode -drawContHoodle = drawContPageGen f - where f (PageNum n,page) _ Clear = (,) n <$> cairoRenderOption (RBkgDrawPDF,DrawFull) page - f (PageNum n,page) mbbox BkgEfficient = (,) n . unInBBoxBkgBuf <$> cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf page) - f (PageNum n,page) mbbox Efficient = (,) n . unInBBox <$> cairoRenderOption (InBBoxOption mbbox) (InBBox page) +drawContHoodle :: CanvasGeometry -> DrawingFunction ContinuousPage EditMode +drawContHoodle geometry = drawContPageGen f + where + f cache (pnum@(PageNum n),page) mbbox flag = do + let xform = mkXform4Page geometry pnum + case flag of + Clear -> do (p',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache (page, Just xform) + return (n, p') + BkgEfficient -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf page, Just xform) + return (n, unInBBoxBkgBuf p') + Efficient -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBox page, Just xform) + return (n, unInBBox p') -- | -drawContHoodleSel :: CanvasGeometry -> DrawingFunction ContinuousPage SelectMode +drawContHoodleSel :: CanvasGeometry + -> DrawingFunction ContinuousPage SelectMode drawContHoodleSel geometry = drawContPageSelGen renderother renderselect - where renderother (PageNum n,page) mbbox flag = do + where renderother cache (pnum@(PageNum n),page) mbbox flag = do + let xform = mkXform4Page geometry pnum case flag of - Clear -> (,) n <$> cairoRenderOption (RBkgDrawPDF,DrawFull) page - BkgEfficient -> (,) n . unInBBoxBkgBuf <$> cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf page) - Efficient -> (,) n . unInBBox <$> cairoRenderOption (InBBoxOption mbbox) (InBBox page) - renderselect (PageNum n,tpg) mbbox _flag = do + Clear -> (,) n . fst <$> cairoRenderOption (RBkgDrawPDF,DrawFull) cache (page,Just xform) + BkgEfficient -> (,) n . unInBBoxBkgBuf . fst <$> cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf page,Just xform) + Efficient -> (,) n . unInBBox . fst <$> cairoRenderOption (InBBoxOption mbbox) cache (InBBox page,Just xform) + renderselect _cache (PageNum n,tpg) mbbox _flag = do cairoHittedBoxDraw geometry tpg mbbox return (n,tpg) -- | -cairoHittedBoxDraw :: CanvasGeometry->Page SelectMode -> Maybe BBox -> Render () +cairoHittedBoxDraw :: CanvasGeometry + -> Page SelectMode + -> Maybe BBox + -> Cairo.Render () cairoHittedBoxDraw geometry tpg mbbox = do let layers = view glayers tpg slayer = view selectedLayer layers case unTEitherAlterHitted . view gitems $ slayer of Right alist -> do clipBBox mbbox - setSourceRGBA 0.0 0.0 1.0 1.0 + Cairo.setSourceRGBA 0.0 0.0 1.0 1.0 let hititms = concatMap unHitted (getB alist) mapM_ renderSelectedItem hititms let ulbbox = unUnion . mconcat . fmap (Union .Middle . getBBox) @@ -455,48 +495,48 @@ case ulbbox of Middle bbox -> renderSelectHandle geometry bbox _ -> return () - resetClip + Cairo.resetClip Left _ -> return () -- | -renderLasso :: CanvasGeometry -> Seq (Double,Double) -> Render () +renderLasso :: CanvasGeometry -> Seq (Double,Double) -> Cairo.Render () renderLasso geometry lst = do let z = canvas2DesktopRatio geometry - setLineWidth (predefinedLassoWidth*z) - uncurry4 setSourceRGBA predefinedLassoColor + Cairo.setLineWidth (predefinedLassoWidth*z) + uncurry4 Cairo.setSourceRGBA predefinedLassoColor let (dasha,dashb) = predefinedLassoDash adjusteddash = (fmap (*z) dasha,dashb*z) - uncurry setDash adjusteddash + uncurry Cairo.setDash adjusteddash case viewl lst of EmptyL -> return () - x :< xs -> do uncurry moveTo x - mapM_ (uncurry lineTo) xs - stroke + x :< xs -> do uncurry Cairo.moveTo x + mapM_ (uncurry Cairo.lineTo) xs + Cairo.stroke -- | -renderBoxSelection :: BBox -> Render () +renderBoxSelection :: BBox -> Cairo.Render () renderBoxSelection bbox = do - setLineWidth predefinedLassoWidth - uncurry4 setSourceRGBA predefinedLassoColor - uncurry setDash predefinedLassoDash + Cairo.setLineWidth predefinedLassoWidth + uncurry4 Cairo.setSourceRGBA predefinedLassoColor + uncurry Cairo.setDash predefinedLassoDash let (x1,y1) = bbox_upperleft bbox (x2,y2) = bbox_lowerright bbox - rectangle x1 y1 (x2-x1) (y2-y1) - stroke + Cairo.rectangle x1 y1 (x2-x1) (y2-y1) + Cairo.stroke -- | -renderSelectedStroke :: BBoxed Stroke -> Render () +renderSelectedStroke :: BBoxed Stroke -> Cairo.Render () renderSelectedStroke str = do - setLineWidth 1.5 - setSourceRGBA 0 0 1 1 + Cairo.setLineWidth 1.5 + Cairo.setSourceRGBA 0 0 1 1 renderStrkHltd str -- | -renderSelectedItem :: RItem -> Render () +renderSelectedItem :: RItem -> Cairo.Render () renderSelectedItem itm = do - setLineWidth 1.5 - setSourceRGBA 0 0 1 1 + Cairo.setLineWidth 1.5 + Cairo.setSourceRGBA 0 0 1 1 renderRItemHltd itm -- | @@ -506,54 +546,52 @@ DeskCoord (tx2,_) = canvas2Desktop geometry (CvsCoord (1,0)) in tx2-tx1 - -- | -renderSelectHandle :: CanvasGeometry -> BBox -> Render () +renderSelectHandle :: CanvasGeometry -> BBox -> Cairo.Render () renderSelectHandle geometry bbox = do let z = canvas2DesktopRatio geometry - setLineWidth (predefinedLassoWidth*z) - uncurry4 setSourceRGBA predefinedLassoColor + Cairo.setLineWidth (predefinedLassoWidth*z) + uncurry4 Cairo.setSourceRGBA predefinedLassoColor let (dasha,dashb) = predefinedLassoDash adjusteddash = (fmap (*z) dasha,dashb*z) - uncurry setDash adjusteddash + uncurry Cairo.setDash adjusteddash let (x1,y1) = bbox_upperleft bbox (x2,y2) = bbox_lowerright bbox hsize = predefinedLassoHandleSize*z - rectangle x1 y1 (x2-x1) (y2-y1) - stroke - setSourceRGBA 1 0 0 0.8 - rectangle (x1-hsize) (y1-hsize) (2*hsize) (2*hsize) - fill - setSourceRGBA 1 0 0 0.8 - rectangle (x1-hsize) (y2-hsize) (2*hsize) (2*hsize) - fill - setSourceRGBA 1 0 0 0.8 - rectangle (x2-hsize) (y1-hsize) (2*hsize) (2*hsize) - fill - setSourceRGBA 1 0 0 0.8 - rectangle (x2-hsize) (y2-hsize) (2*hsize) (2*hsize) - fill - setSourceRGBA 0.5 0 0.2 0.8 - rectangle (x1-hsize*0.6) (0.5*(y1+y2)-hsize*0.6) (1.2*hsize) (1.2*hsize) - fill - setSourceRGBA 0.5 0 0.2 0.8 - rectangle (x2-hsize*0.6) (0.5*(y1+y2)-hsize*0.6) (1.2*hsize) (1.2*hsize) - fill - setSourceRGBA 0.5 0 0.2 0.8 - rectangle (0.5*(x1+x2)-hsize*0.6) (y1-hsize*0.6) (1.2*hsize) (1.2*hsize) - fill - setSourceRGBA 0.5 0 0.2 0.8 - rectangle (0.5*(x1+x2)-hsize*0.6) (y2-hsize*0.6) (1.2*hsize) (1.2*hsize) - fill - - + Cairo.rectangle x1 y1 (x2-x1) (y2-y1) + Cairo.stroke + Cairo.setSourceRGBA 1 0 0 0.8 + Cairo.rectangle (x1-hsize) (y1-hsize) (2*hsize) (2*hsize) + Cairo.fill + Cairo.setSourceRGBA 1 0 0 0.8 + Cairo.rectangle (x1-hsize) (y2-hsize) (2*hsize) (2*hsize) + Cairo.fill + Cairo.setSourceRGBA 1 0 0 0.8 + Cairo.rectangle (x2-hsize) (y1-hsize) (2*hsize) (2*hsize) + Cairo.fill + Cairo.setSourceRGBA 1 0 0 0.8 + Cairo.rectangle (x2-hsize) (y2-hsize) (2*hsize) (2*hsize) + Cairo.fill + Cairo.setSourceRGBA 0.5 0 0.2 0.8 + Cairo.rectangle (x1-hsize*0.6) (0.5*(y1+y2)-hsize*0.6) (1.2*hsize) (1.2*hsize) + Cairo.fill + Cairo.setSourceRGBA 0.5 0 0.2 0.8 + Cairo.rectangle (x2-hsize*0.6) (0.5*(y1+y2)-hsize*0.6) (1.2*hsize) (1.2*hsize) + Cairo.fill + Cairo.setSourceRGBA 0.5 0 0.2 0.8 + Cairo.rectangle (0.5*(x1+x2)-hsize*0.6) (y1-hsize*0.6) (1.2*hsize) (1.2*hsize) + Cairo.fill + Cairo.setSourceRGBA 0.5 0 0.2 0.8 + Cairo.rectangle (0.5*(x1+x2)-hsize*0.6) (y2-hsize*0.6) (1.2*hsize) (1.2*hsize) + Cairo.fill -- | -canvasImageSurface :: Maybe Double -- ^ multiply +canvasImageSurface :: RenderCache + -> Maybe Double -- ^ multiply -> CanvasGeometry -> Hoodle EditMode - -> IO (Surface,Dimension) -canvasImageSurface mmulti geometry hdl = do + -> IO (Cairo.Surface,Dimension) +canvasImageSurface cache mmulti geometry hdl = do let ViewPortBBox bbx_desk = getCanvasViewPort geometry nbbx_desk = case mmulti of Nothing -> bbx_desk @@ -569,23 +607,23 @@ drawpgs = (catMaybes . map f . getPagesInRange geometry nvport) hdl where f k = maybe Nothing (\a -> Just (k,a)) . M.lookup (unPageNum k) $ pgs onepagerender (pn,pg) = do - identityMatrix + Cairo.identityMatrix case mmulti of Nothing -> return () Just z -> do let (ws_cvs,hs_cvs) = (w_cvs/(2*z+1),h_cvs/(2*z+1)) - translate (z*ws_cvs) (z*hs_cvs) - cairoXform4PageCoordinate geometry pn - cairoRenderOption (InBBoxOption Nothing) (InBBox pg) + Cairo.translate (z*ws_cvs) (z*hs_cvs) + let xform = mkXform4Page geometry pn + cairoXform4PageCoordinate xform + cairoRenderOption (InBBoxOption Nothing) cache (InBBox pg,Nothing :: Maybe Xform4Page) -- Just xform renderfunc = do - setSourceRGBA 0.5 0.5 0.5 1 - rectangle 0 0 w_cvs h_cvs - fill - + Cairo.setSourceRGBA 0.5 0.5 0.5 1 + Cairo.rectangle 0 0 w_cvs h_cvs + Cairo.fill mapM_ onepagerender drawpgs print (Prelude.length drawpgs) - sfc <- createImageSurface FormatARGB32 (floor w_cvs) (floor h_cvs) - renderWith sfc renderfunc + sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor w_cvs) (floor h_cvs) + Cairo.renderWith sfc renderfunc return (sfc, Dim w_cvs h_cvs) --------------------------------------------------- @@ -593,8 +631,11 @@ --------------------------------------------------- -- | -drawWidgets :: [WidgetItem] -> Hoodle EditMode - -> CanvasInfo a -> Maybe BBox -> Render () +drawWidgets :: [WidgetItem] + -> Hoodle EditMode + -> CanvasInfo a + -> Maybe BBox + -> Cairo.Render () drawWidgets witms hdl cinfo mbbox = do when (PanZoomWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUsePanZoomWidget) cinfo) $ renderPanZoomWidget (view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) cinfo) @@ -612,44 +653,44 @@ --------------------- -- | -renderPanZoomWidget :: Bool -> Maybe BBox -> CanvasCoordinate -> Render () +renderPanZoomWidget :: Bool -> Maybe BBox -> CanvasCoordinate -> Cairo.Render () renderPanZoomWidget b mbbox (CvsCoord (x,y)) = do - identityMatrix - clipBBox mbbox - setSourceRGBA 0.5 0.5 0.2 0.3 - rectangle x y 100 100 - fill - setSourceRGBA 0.2 0.2 0.7 0.5 - rectangle (x+10) (y+10) 40 80 - fill - setSourceRGBA 0.2 0.7 0.2 0.5 - rectangle (x+50) (y+10) 40 80 - fill - setSourceRGBA 0.7 0.2 0.2 (if b then 1.0 else 0.5) - rectangle (x+30) (y+30) 40 40 - fill - setSourceRGBA 0.5 0.5 0.5 0.5 - rectangle x y 10 10 - fill - setSourceRGBA 0 0 0 0.7 - setLineWidth 1 - moveTo x y - lineTo (x+10) (y+10) - stroke - moveTo x (y+10) - lineTo (x+10) y - stroke - resetClip + Cairo.identityMatrix + clipBBox mbbox + Cairo.setSourceRGBA 0.5 0.5 0.2 0.3 + Cairo.rectangle x y 100 100 + Cairo.fill + Cairo.setSourceRGBA 0.2 0.2 0.7 0.5 + Cairo.rectangle (x+10) (y+10) 40 80 + Cairo.fill + Cairo.setSourceRGBA 0.2 0.7 0.2 0.5 + Cairo.rectangle (x+50) (y+10) 40 80 + Cairo.fill + Cairo.setSourceRGBA 0.7 0.2 0.2 (if b then 1.0 else 0.5) + Cairo.rectangle (x+30) (y+30) 40 40 + Cairo.fill + Cairo.setSourceRGBA 0.5 0.5 0.5 0.5 + Cairo.rectangle x y 10 10 + Cairo.fill + Cairo.setSourceRGBA 0 0 0 0.7 + Cairo.setLineWidth 1 + Cairo.moveTo x y + Cairo.lineTo (x+10) (y+10) + Cairo.stroke + Cairo.moveTo x (y+10) + Cairo.lineTo (x+10) y + Cairo.stroke + Cairo.resetClip ------------------ -- Layer Widget -- ------------------ drawLayerWidget :: Hoodle EditMode - -> CanvasInfo a - -> Maybe BBox - -> CanvasCoordinate - -> Render () + -> CanvasInfo a + -> Maybe BBox + -> CanvasCoordinate + -> Cairo.Render () drawLayerWidget hdl cinfo mbbox cvscoord = do let cpn = view currentPageNum cinfo lc = view (canvasWidgets.layerWidgetConfig) cinfo @@ -665,117 +706,122 @@ lift $ renderLayerContent mbbox (view gdimension pg) sfc cvscoord return () -renderLayerContent :: Maybe BBox -> Dimension -> Surface -> CanvasCoordinate -> Render () +renderLayerContent :: Maybe BBox + -> Dimension + -> Cairo.Surface + -> CanvasCoordinate + -> Cairo.Render () renderLayerContent mbbox (Dim w h) sfc (CvsCoord (x,y)) = do - identityMatrix + Cairo.identityMatrix clipBBox mbbox let sx = 200 / w - rectangle (x+100) y 200 (h*200/w) - setLineWidth 0.5 - setSourceRGBA 0 0 0 1 - stroke - translate (x+100) (y) - scale sx sx - setSourceSurface sfc 0 0 - paint + Cairo.rectangle (x+100) y 200 (h*200/w) + Cairo.setLineWidth 0.5 + Cairo.setSourceRGBA 0 0 0 1 + Cairo.stroke + Cairo.translate (x+100) (y) + Cairo.scale sx sx + Cairo.setSourceSurface sfc 0 0 + Cairo.paint -- | -renderLayerWidget :: String -> Maybe BBox -> CanvasCoordinate -> Render () +renderLayerWidget :: String -> Maybe BBox -> CanvasCoordinate -> Cairo.Render () renderLayerWidget str mbbox (CvsCoord (x,y)) = do - identityMatrix + Cairo.identityMatrix clipBBox mbbox - setSourceRGBA 0.5 0.5 0.2 0.3 - rectangle x y 100 100 - fill - rectangle x y 10 10 - fill - setSourceRGBA 0 0 0 0.7 - setLineWidth 1 - moveTo x y - lineTo (x+10) (y+10) - stroke - moveTo x (y+10) - lineTo (x+10) y - stroke + Cairo.setSourceRGBA 0.5 0.5 0.2 0.3 + Cairo.rectangle x y 100 100 + Cairo.fill + Cairo.rectangle x y 10 10 + Cairo.fill + Cairo.setSourceRGBA 0 0 0 0.7 + Cairo.setLineWidth 1 + Cairo.moveTo x y + Cairo.lineTo (x+10) (y+10) + Cairo.stroke + Cairo.moveTo x (y+10) + Cairo.lineTo (x+10) y + Cairo.stroke -- upper right - setSourceRGBA 0 0 0 0.4 - moveTo (x+80) y - lineTo (x+100) y - lineTo (x+100) (y+20) - fill + Cairo.setSourceRGBA 0 0 0 0.4 + Cairo.moveTo (x+80) y + Cairo.lineTo (x+100) y + Cairo.lineTo (x+100) (y+20) + Cairo.fill -- lower left - setSourceRGBA 0 0 0 0.1 - moveTo x (y+80) - lineTo x (y+100) - lineTo (x+20) (y+100) - fill + Cairo.setSourceRGBA 0 0 0 0.1 + Cairo.moveTo x (y+80) + Cairo.lineTo x (y+100) + Cairo.lineTo (x+20) (y+100) + Cairo.fill -- middle right - setSourceRGBA 0 0 0 0.3 - moveTo (x+90) (y+40) - lineTo (x+100) (y+50) - lineTo (x+90) (y+60) - fill + Cairo.setSourceRGBA 0 0 0 0.3 + Cairo.moveTo (x+90) (y+40) + Cairo.lineTo (x+100) (y+50) + Cairo.lineTo (x+90) (y+60) + Cairo.fill -- - identityMatrix + Cairo.identityMatrix l1 <- createLayout "layer" updateLayout l1 (_,reclog) <- liftIO $ layoutGetExtents l1 let PangoRectangle _ _ w1 h1 = reclog - moveTo (x+15) y + Cairo.moveTo (x+15) y let sx1 = 50 / w1 sy1 = 20 / h1 - scale sx1 sy1 + Cairo.scale sx1 sy1 layoutPath l1 - setSourceRGBA 0 0 0 0.4 - fill + Cairo.setSourceRGBA 0 0 0 0.4 + Cairo.fill -- - identityMatrix + Cairo.identityMatrix l <- createLayout str updateLayout l (_,reclog2) <- liftIO $ layoutGetExtents l let PangoRectangle _ _ w h = reclog2 - moveTo (x+30) (y+20) + Cairo.moveTo (x+30) (y+20) let sx = 40 / w sy = 60 / h - scale sx sy + Cairo.scale sx sy layoutPath l - setSourceRGBA 0 0 0 0.4 - fill + Cairo.setSourceRGBA 0 0 0 0.4 + Cairo.fill ------------------ -- Clock Widget -- ------------------ -renderClockWidget :: Maybe BBox -> ClockWidgetConfig -> Render () +renderClockWidget :: Maybe BBox -> ClockWidgetConfig -> Cairo.Render () renderClockWidget mbbox cfg = do let CvsCoord (x,y) = view clockWidgetPosition cfg (h,m,s) = view clockWidgetTime cfg div2rad :: Int -> Int -> Double div2rad n theta = fromIntegral theta/fromIntegral n * 2.0*pi - identityMatrix + Cairo.identityMatrix clipBBox mbbox - setSourceRGBA 0.5 0.5 0.2 0.3 - arc x y 50 0.0 (2.0*pi) - fill + Cairo.setSourceRGBA 0.5 0.5 0.2 0.3 + Cairo.arc x y 50 0.0 (2.0*pi) + Cairo.fill -- - setSourceRGBA 1 0 0 0.7 - setLineWidth 0.5 - moveTo x y - lineTo (x+45*sin (div2rad 60 s)) (y-45*cos (div2rad 60 s)) - stroke + Cairo.setSourceRGBA 1 0 0 0.7 + Cairo.setLineWidth 0.5 + Cairo.moveTo x y + Cairo.lineTo (x+45*sin (div2rad 60 s)) (y-45*cos (div2rad 60 s)) + Cairo.stroke -- - setSourceRGBA 0 0 0 1 - setLineWidth 1.0 - moveTo x y - lineTo (x+50*sin (div2rad 60 m)) (y-50*cos (div2rad 60 m)) - stroke + Cairo.setSourceRGBA 0 0 0 1 + Cairo.setLineWidth 1.0 + Cairo.moveTo x y + Cairo.lineTo (x+50*sin (div2rad 60 m)) (y-50*cos (div2rad 60 m)) + Cairo.stroke -- - setSourceRGBA 0 0 0 1 - setLineWidth 2.0 - moveTo x y - lineTo (x+30*sin (div2rad 12 h + div2rad 720 m)) (y-30*cos (div2rad 12 h + div2rad 720 m)) - stroke + Cairo.setSourceRGBA 0 0 0 1 + Cairo.setLineWidth 2.0 + Cairo.moveTo x y + Cairo.lineTo (x+30*sin (div2rad 12 h + div2rad 720 m)) + (y-30*cos (div2rad 12 h + div2rad 720 m)) + Cairo.stroke -- - resetClip + Cairo.resetClip diff --git a/src/Hoodle/Widget/Clock.hs b/src/Hoodle/Widget/Clock.hs --- a/src/Hoodle/Widget/Clock.hs +++ b/src/Hoodle/Widget/Clock.hs @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Widget.Clock --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -19,7 +19,7 @@ import Data.Functor.Identity (Identity(..)) import Data.List (delete) import Data.Time -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo -- import Data.Hoodle.BBox import Data.Hoodle.Simple @@ -65,21 +65,23 @@ startClockWidget (cid,cinfo,geometry) (Move (oxy,owxy)) = do xst <- get let hdl = getHoodle xst - (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface Nothing geometry hdl) + cache = view renderCache xst + (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface cache Nothing geometry hdl) -- need to draw other widgets here let otherwidgets = delete ClockWidget allWidgets - liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) + liftIO $ Cairo.renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) -- end : need to draw other widgets here ^^^ - tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc) + tgtsfc <- liftIO $ Cairo.createImageSurface + Cairo.FormatARGB32 (floor wsfc) (floor hsfc) ctime <- liftIO getCurrentTime manipulateCW cid geometry (srcsfc,tgtsfc) owxy oxy ctime - liftIO $ surfaceFinish srcsfc - liftIO $ surfaceFinish tgtsfc + liftIO $ Cairo.surfaceFinish srcsfc + liftIO $ Cairo.surfaceFinish tgtsfc -- | main event loop for clock widget manipulateCW :: CanvasId -> CanvasGeometry - -> (Surface,Surface) + -> (Cairo.Surface,Cairo.Surface) -> CanvasCoordinate -> CanvasCoordinate -> UTCTime @@ -98,7 +100,7 @@ moveClockWidget :: CanvasId -> CanvasGeometry - -> (Surface,Surface) + -> (Cairo.Surface,Cairo.Surface) -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord diff --git a/src/Hoodle/Widget/Dispatch.hs b/src/Hoodle/Widget/Dispatch.hs --- a/src/Hoodle/Widget/Dispatch.hs +++ b/src/Hoodle/Widget/Dispatch.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | --- Module : Hoodle.Coroutine.Default --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Module : Hoodle.Widget.Dispatch +-- Copyright : (c) 2011-2014 Ian-Woo Kim -- -- License : GPL-3 -- Maintainer : Ian-Woo Kim @@ -69,9 +71,15 @@ guard (isPointInBBox bbox (x,y)) case ritem of RItemLink lnkbbx _ -> do - forM_ ((urlParse . B.unpack . link_location . bbxed_content) lnkbbx) - (liftIO . openLinkAction) - liftIO $ putStrLn "I am in" + let lnk = bbxed_content lnkbbx + loc = link_location lnk + mid = case lnk of + LinkAnchor {..} -> Just (link_linkeddocid,link_anchorid) + _ -> Nothing + + forM_ + ((urlParse . B.unpack) loc) + (\url -> liftIO (openLinkAction url mid)) MaybeT (return (Just ())) _ -> MaybeT (return Nothing)) case m of diff --git a/src/Hoodle/Widget/Layer.hs b/src/Hoodle/Widget/Layer.hs --- a/src/Hoodle/Widget/Layer.hs +++ b/src/Hoodle/Widget/Layer.hs @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Widget.Layer --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -20,7 +20,7 @@ import Data.List (delete) import Data.Sequence import Data.Time -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo -- import Data.Hoodle.BBox import Data.Hoodle.Simple @@ -73,12 +73,14 @@ startLayerWidget (cid,cinfo,geometry) (Move (oxy,owxy)) = do xst <- get let hdl = getHoodle xst - (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface Nothing geometry hdl) + cache = view renderCache xst + (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface cache Nothing geometry hdl) -- need to draw other widgets here let otherwidgets = delete LayerWidget allWidgets - liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) + liftIO $ Cairo.renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) -- end : need to draw other widgets here ^^^ - tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc) + tgtsfc <- liftIO $ Cairo.createImageSurface + Cairo.FormatARGB32 (floor wsfc) (floor hsfc) ctime <- liftIO getCurrentTime let CvsCoord (x0,y0) = owxy CvsCoord (x,y) = oxy @@ -87,13 +89,13 @@ | hitLassoPoint (fromList [(x0,y0+80),(x0,y0+100),(x0+20,y0+100)]) (x,y) = gotoPrevLayer | otherwise = manipulateLW cid geometry (srcsfc,tgtsfc) owxy oxy ctime act - liftIO $ surfaceFinish srcsfc - liftIO $ surfaceFinish tgtsfc + liftIO $ Cairo.surfaceFinish srcsfc + liftIO $ Cairo.surfaceFinish tgtsfc -- | main event loop for layer widget manipulateLW :: CanvasId -> CanvasGeometry - -> (Surface,Surface) + -> (Cairo.Surface,Cairo.Surface) -> CanvasCoordinate -> CanvasCoordinate -> UTCTime @@ -112,7 +114,7 @@ moveLayerWidget :: CanvasId -> CanvasGeometry - -> (Surface,Surface) + -> (Cairo.Surface,Cairo.Surface) -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord diff --git a/src/Hoodle/Widget/PanZoom.hs b/src/Hoodle/Widget/PanZoom.hs --- a/src/Hoodle/Widget/PanZoom.hs +++ b/src/Hoodle/Widget/PanZoom.hs @@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Widget.PanZoom --- Copyright : (c) 2013 Ian-Woo Kim +-- Copyright : (c) 2013, 2014 Ian-Woo Kim -- --- License : BSD3 +-- License : GPL-3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC @@ -15,12 +15,12 @@ module Hoodle.Widget.PanZoom where -- from other packages -import Control.Lens (view,set,over) +import Control.Lens (view,set,over,(.~)) import Control.Monad.Identity import Control.Monad.State import Data.List (delete) import Data.Time.Clock -import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo as Cairo import System.Process -- from hoodle-platform import Data.Hoodle.BBox @@ -82,26 +82,30 @@ -> Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate)) -> MainCoroutine () startPanZoomWidget tchmode (cid,cinfo,geometry) mmode = do + modify (doesNotInvalidate .~ True) xst <- get let hdl = getHoodle xst + cache = view renderCache xst case mmode of Nothing -> togglePanZoom cid Just (mode,(oxy,owxy)) -> do (srcsfc,Dim wsfc hsfc) <- case mode of - Moving -> liftIO (canvasImageSurface Nothing geometry hdl) - Zooming -> liftIO (canvasImageSurface (Just 1) geometry hdl) - Panning _ -> liftIO (canvasImageSurface (Just 1) geometry hdl) + Moving -> liftIO (canvasImageSurface cache Nothing geometry hdl) + Zooming -> liftIO (canvasImageSurface cache (Just 1) geometry hdl) + Panning _ -> liftIO (canvasImageSurface cache (Just 1) geometry hdl) -- need to draw other widgets here let otherwidgets = delete PanZoomWidget allWidgets - liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) + liftIO $ Cairo.renderWith + srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) -- end : need to draw other widgets here ^^^ - tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc) + tgtsfc <- liftIO $ Cairo.createImageSurface + Cairo.FormatARGB32 (floor wsfc) (floor hsfc) ctime <- liftIO getCurrentTime manipulatePZW (tchmode,mode) cid geometry (srcsfc,tgtsfc) owxy oxy ctime - liftIO $ surfaceFinish srcsfc - liftIO $ surfaceFinish tgtsfc - - + liftIO $ Cairo.surfaceFinish srcsfc + liftIO $ Cairo.surfaceFinish tgtsfc + modify (doesNotInvalidate .~ False) + invalidateAll -- | @@ -144,7 +148,7 @@ manipulatePZW :: (PanZoomTouch,PanZoomMode) -> CanvasId -> CanvasGeometry - -> (Surface,Surface) -- ^ (Source Surface, Target Surface) + -> (Cairo.Surface,Cairo.Surface) -- ^ (Source, Target) -> CanvasCoordinate -- ^ original widget position -> CanvasCoordinate -- ^ where pen pressed -> UTCTime @@ -161,12 +165,12 @@ TouchUp _ pcoord -> if (tchmode /= TouchMode) then again otime else do b <- liftM (view (settings.doesUseTouch)) get when b $ upact pcoord - _ -> again otime -- manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy otime + _ -> again otime where again t = manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy t moveact pcoord = processWithDefTimeInterval - again -- (manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy) + again (\ctime -> movingRender mode cid geometry (srcsfc,tgtsfc) owxy oxy pcoord >> manipulatePZW fullmode cid geometry (srcsfc,tgtsfc) owxy oxy ctime) otime @@ -202,9 +206,10 @@ -- | -movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry -> (Surface,Surface) - -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord - -> MainCoroutine () +movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry + -> (Cairo.Surface,Cairo.Surface) + -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord + -> MainCoroutine () movingRender mode cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord xst <- get @@ -234,8 +239,8 @@ (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y)) isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox virtualDoubleBufferDraw srcsfc tgtsfc - (save >> scale z z >> translate xtrans ytrans) - (restore >> renderPanZoomWidget isTouchZoom Nothing pos) + (Cairo.save >> Cairo.scale z z >> Cairo.translate xtrans ytrans) + (Cairo.restore >> renderPanZoomWidget isTouchZoom Nothing pos) Panning b -> do let cinfobox = getCanvasInfo cid xst CanvasDimension cdim = canvasDim geometry @@ -255,8 +260,8 @@ isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox put (setCanvasInfo (cid,ncinfobox) xst) virtualDoubleBufferDraw srcsfc tgtsfc - (save >> translate xtrans ytrans) - (restore >> renderPanZoomWidget isTouchZoom Nothing nwpos) + (Cairo.save >> Cairo.translate xtrans ytrans) + (Cairo.restore >> renderPanZoomWidget isTouchZoom Nothing nwpos) -- xst2 <- get let cinfobox = getCanvasInfo cid xst2