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.10
+Version: 0.11
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
@@ -22,11 +22,6 @@
type: git
location: http://www.github.com/wavewave/hoodle-core
--- Flag Poppler
--- Description: Enable poppler support
--- Default: False
-
-
Library
hs-source-dirs: src
ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans
@@ -46,10 +41,9 @@
transformers == 0.3.*,
transformers-free == 1.0.*,
hoodle-types >= 0.2,
- -- hoodle-common >= 0.1,
hoodle-parser >= 0.2,
xournal-parser >= 0.5.0.1,
- hoodle-render >= 0.3,
+ hoodle-render >= 0.3.1,
hoodle-builder >= 0.2,
containers >= 0.4,
template-haskell == 2.*,
@@ -70,13 +64,6 @@
monad-loops >= 0.3,
network,
poppler >= 0.12.2.2
-
--- if flag(poppler)
--- Build-Depends:
--- else
--- Build-Depends:
-
-
Exposed-Modules:
Hoodle.Accessor
Hoodle.Config
@@ -87,7 +74,6 @@
Hoodle.Coroutine.Default
Hoodle.Coroutine.Draw
Hoodle.Coroutine.Eraser
- -- Hoodle.Coroutine.EventConnect
Hoodle.Coroutine.File
Hoodle.Coroutine.Highlighter
Hoodle.Coroutine.Layer
@@ -98,7 +84,6 @@
Hoodle.Coroutine.Scroll
Hoodle.Coroutine.Select
Hoodle.Coroutine.Select.Clipboard
- -- Hoodle.Coroutine.Select.Transform
Hoodle.Coroutine.TextInput
Hoodle.Coroutine.VerticalSpace
Hoodle.Coroutine.Window
@@ -108,9 +93,9 @@
Hoodle.GUI.Reflect
Hoodle.ModelAction.Adjustment
Hoodle.ModelAction.Clipboard
+ Hoodle.ModelAction.ContextMenu
Hoodle.ModelAction.Eraser
Hoodle.ModelAction.File
- -- Hoodle.ModelAction.Item
Hoodle.ModelAction.Layer
Hoodle.ModelAction.Page
Hoodle.ModelAction.Pen
@@ -127,13 +112,13 @@
Hoodle.Type.Coroutine
Hoodle.Type.Enum
Hoodle.Type.Event
+ Hoodle.Type.HoodleState
Hoodle.Type.PageArrangement
Hoodle.Type.Predefined
Hoodle.Type.Undo
Hoodle.Type.Window
- Hoodle.Type.HoodleState
+ Hoodle.Type.Widget
Hoodle.Util
- -- Hoodle.Util.Process
Hoodle.View.Coordinate
Hoodle.View.Draw
Hoodle.Widget.PanZoom
@@ -147,5 +132,3 @@
csrc/template-hsc-gtk2hs.h
cc-options: -Wno-pointer-to-int-cast
--- if flag(poppler)
--- cpp-options: -DPOPPLER
diff --git a/resource/menu.xml b/resource/menu.xml
--- a/resource/menu.xml
+++ b/resource/menu.xml
@@ -145,6 +145,7 @@
+
diff --git a/src/Hoodle/Config.hs b/src/Hoodle/Config.hs
--- a/src/Hoodle/Config.hs
+++ b/src/Hoodle/Config.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Config
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Callback
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
@@ -13,12 +13,7 @@
module Hoodle.Coroutine.Callback where
import Control.Concurrent
-import Control.Exception
--- import Data.Time
--- import System.Directory
--- import System.Environment
--- import System.FilePath
--- import System.Locale
+import Control.Exception (SomeException(..),ErrorCall,PatternMatchFail,catch)
import System.IO
import System.Exit
--
@@ -27,12 +22,10 @@
--
import Hoodle.Util
--
-import Prelude 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
-
- -- `catches` [Handler errorcall, Handler patternerr]
allexceptionproc :: SomeException -> IO ()
allexceptionproc e = do errorlog (show e)
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
@@ -23,6 +23,7 @@
import qualified Data.ByteString.Char8 as B
import qualified Data.IntMap as IM
import Data.Monoid
+import Data.UUID.V4
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk hiding (get,set)
import System.Directory
@@ -34,7 +35,7 @@
import Data.Hoodle.BBox
import Data.Hoodle.Generic
import Data.Hoodle.Select
-import Data.Hoodle.Simple (Item(..),Link(..),hoodleID)
+import Data.Hoodle.Simple (SVG(..),Item(..),Link(..),hoodleID)
import Graphics.Hoodle.Render
import Graphics.Hoodle.Render.Item
import Graphics.Hoodle.Render.Type
@@ -47,6 +48,8 @@
import Hoodle.Coroutine.File
import Hoodle.Coroutine.Scroll
import Hoodle.Coroutine.Select.Clipboard
+import Hoodle.Coroutine.TextInput
+import Hoodle.ModelAction.ContextMenu
import Hoodle.ModelAction.Page
import Hoodle.ModelAction.Select
import Hoodle.ModelAction.Select.Transform
@@ -55,28 +58,23 @@
import Hoodle.Type.Event
import Hoodle.Type.HoodleState
import Hoodle.Type.PageArrangement
+import Hoodle.Util
--
import Prelude hiding ((.),id)
processContextMenu :: ContextMenuEvent -> MainCoroutine ()
processContextMenu (CMenuSaveSelectionAs ityp) = do
- xstate <- get
- case view hoodleModeState xstate of
- SelectState thdl -> do
- liftIO $ putStrLn "SelectState"
- case view gselSelected thdl of
- Nothing -> return ()
- Just (_,tpg) -> do
- let hititms = getSelectedItms tpg
- ulbbox = unUnion . mconcat . fmap (Union . Middle . getBBox)
- $ hititms
- case ulbbox of
- Middle bbox ->
- case ityp of
- SVG -> exportCurrentSelectionAsSVG hititms bbox
- PDF -> exportCurrentSelectionAsPDF hititms bbox
- _ -> return ()
- _ -> return ()
+ xst <- get
+ case getSelectedItmsFromHoodleState xst of
+ Nothing -> return ()
+ Just hititms ->
+ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms
+ in case ulbbox of
+ Middle bbox ->
+ case ityp of
+ TypSVG -> exportCurrentSelectionAsSVG hititms bbox
+ TypPDF -> exportCurrentSelectionAsPDF hititms bbox
+ _ -> return ()
processContextMenu CMenuCut = cutSelection
processContextMenu CMenuCopy = copySelection
processContextMenu CMenuDelete = deleteSelection
@@ -123,7 +121,25 @@
commit . set hoodleModeState (SelectState nthdl)
=<< (liftIO (updatePageAll (SelectState nthdl) xst))
invalidateAll
-
+processContextMenu CMenuCreateALink = do
+ liftIO $ putStrLn "create a link called"
+ mfilename <- fileChooser FileChooserActionOpen Nothing
+ case mfilename of
+ Nothing -> return ()
+ Just fname -> do
+ xst <- get
+ case getSelectedItmsFromHoodleState xst of
+ Nothing -> return ()
+ Just hititms ->
+ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms
+ in case ulbbox of
+ Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do
+ svg <- liftIO $ makeSVGFromSelection hititms bbox
+ uuid <- liftIO $ nextRandom
+ let uuidbstr = B.pack (show uuid)
+ deleteSelection
+ linkInsert "simple" (uuidbstr,fname) fname (svg_render svg,bbox)
+ _ -> return ()
processContextMenu CMenuCustom =
either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get
where action thdl = do
@@ -192,9 +208,9 @@
menuitem4 <- menuItemNewWithLabel "Copy"
menuitem5 <- menuItemNewWithLabel "Delete"
menuitem1 `on` menuItemActivate $
- evhandler (GotContextMenuSignal (CMenuSaveSelectionAs SVG))
+ evhandler (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG))
menuitem2 `on` menuItemActivate $
- evhandler (GotContextMenuSignal (CMenuSaveSelectionAs PDF))
+ evhandler (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF))
menuitem3 `on` menuItemActivate $
evhandler (GotContextMenuSignal (CMenuCut))
menuitem4 `on` menuItemActivate $
@@ -206,33 +222,39 @@
menuAttach menu menuitem3 1 2 0 1
menuAttach menu menuitem4 1 2 1 2
menuAttach menu menuitem5 1 2 2 3
+
+ maybe (return ()) (\mi -> menuAttach menu mi 1 2 4 5) =<< menuCreateALink evhandler sitms
+
case sitms of
sitm : [] -> do
case sitm of
RItemLink lnkbbx _msfc -> do
let lnk = bbxed_content lnkbbx
- let fp = (B.unpack . link_location) lnk
- cmdargs = [fp]
- menuitemlnk <- menuItemNewWithLabel ("Open "++fp)
- menuitemlnk `on` menuItemActivate $ do
- createProcess (proc "hoodle" cmdargs)
- return ()
- menuAttach menu menuitemlnk 0 1 3 4
+ maybe (return ())
+ (\urlpath -> do
+ milnk <- menuOpenALink evhandler urlpath
+ menuAttach menu milnk 0 1 3 4
+ )
+ (urlParse ((B.unpack . link_location) lnk))
case lnk of
- Link i _typ file txt cmd rdr pos dim -> do
- b <- doesFileExist (B.unpack file)
- when b $ do
- bstr <- B.readFile (B.unpack file)
- case parseOnly PA.hoodle bstr of
- Left str -> print str
- Right hdl -> do
- let uuid = view hoodleID hdl
- link = LinkDocID i uuid file txt cmd rdr pos dim
-
- menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid)
- menuitemcvt `on` menuItemActivate $ do
- evhandler (GotContextMenuSignal (CMenuLinkConvert link))
- menuAttach menu menuitemcvt 0 1 4 5
+ Link i _typ lstr txt cmd rdr pos dim -> do
+ case urlParse (B.unpack lstr) of
+ Nothing -> return ()
+ Just (HttpUrl url) -> return ()
+ Just (FileUrl file) -> do
+ b <- doesFileExist file
+ when b $ do
+ bstr <- B.readFile file
+ case parseOnly PA.hoodle bstr of
+ Left str -> print str
+ Right hdl -> do
+ let uuid = view hoodleID hdl
+ link = LinkDocID i uuid (B.pack file) txt cmd rdr pos dim
+
+ menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid)
+ menuitemcvt `on` menuItemActivate $ do
+ evhandler (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 ()
@@ -249,11 +271,8 @@
menuitemcvt `on` menuItemActivate $ do
evhandler (GotContextMenuSignal (CMenuLinkConvert link))
menuAttach menu menuitemcvt 0 1 4 5
-
-
-
-
_ -> return ()
+
_ -> return ()
case (customContextMenuTitle =<< view hookSet xstate) of
Nothing -> return ()
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
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Default
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
@@ -84,8 +84,9 @@
-> Maybe Hook
-> Int -- ^ maxundo
-> Bool -- ^ xinputbool
+ -> Statusbar -- ^ status bar
-> IO (EventVar,HoodleState,UIManager,VBox)
-initCoroutine devlst window mfname mhook maxundo xinputbool = do
+initCoroutine devlst window mfname mhook maxundo xinputbool stbar = do
evar <- newEmptyMVar
putMVar evar Nothing
st0new <- set deviceList devlst
@@ -107,6 +108,7 @@
. set frameState wconf'
. set rootWindow cvs
. set uiComponentSignalHandler uicompsighdlr
+ . set statusBar (Just stbar)
$ st4
st6 <- getFileContent mfname st5
@@ -128,11 +130,17 @@
initialize :: MyEvent -> MainCoroutine ()
initialize ev = do
case ev of
- Initialized -> do return ()
- -- additional initialization goes here
+ Initialized -> do -- additional initialization goes here
viewModeChange ToContSinglePage
-- pageZoomChange (Zoom 0.3)
pageZoomChange FitWidth
+ xst <- get
+ let Just sbar = view statusBar xst
+ cxtid <- liftIO $ statusbarGetContextId sbar "test"
+ liftIO $ statusbarPush sbar cxtid "Hello there"
+ let ui = view gtkUIManager xst
+ liftIO $ toggleSave ui False
+ put (set isSaved True xst)
_ -> do ev' <- nextevent
initialize ev'
@@ -353,6 +361,7 @@
modify (set hoodleModeState (ViewAppendState nhdl))
invalidateAll
menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground
+menuEventProcess MenuWidgetToggle = togglePanZoom
menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m
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
@@ -64,7 +64,7 @@
-- import Hoodle.Type.Alias
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
-import Hoodle.Type.Event hiding (SVG)
+import Hoodle.Type.Event hiding (TypSVG)
import Hoodle.Type.HoodleState
import Hoodle.Type.PageArrangement
import Hoodle.View.Draw
@@ -254,8 +254,9 @@
xstate' <- liftIO $ getFileContent (Just filename) xstate
ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate')
xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate'
- put . set isSaved True
- $ xstateNew
+ put . set isSaved True $ xstateNew
+ let ui = view gtkUIManager xstate
+ liftIO $ toggleSave ui False
liftIO $ setTitleFromFileName xstateNew
clearUndoHistory
modeChange ToViewAppendMode
diff --git a/src/Hoodle/Coroutine/Highlighter.hs b/src/Hoodle/Coroutine/Highlighter.hs
--- a/src/Hoodle/Coroutine/Highlighter.hs
+++ b/src/Hoodle/Coroutine/Highlighter.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Highlighter
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Coroutine/Layer.hs b/src/Hoodle/Coroutine/Layer.hs
--- a/src/Hoodle/Coroutine/Layer.hs
+++ b/src/Hoodle/Coroutine/Layer.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Layer
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -20,10 +20,9 @@
import Control.Applicative
import Control.Lens (view,(%~))
import Control.Monad.State
-
import Control.Monad.Trans.Maybe
import qualified Data.ByteString.Char8 as B
-
+import Data.Monoid (mconcat)
import Data.UUID.V4 (nextRandom)
import Graphics.UI.Gtk hiding (get,set)
import System.FilePath
@@ -31,6 +30,7 @@
import Control.Monad.Trans.Crtn.Event
import Control.Monad.Trans.Crtn.Queue
import Data.Hoodle.BBox
+import Data.Hoodle.Simple (SVG(..))
import Graphics.Hoodle.Render.Item
import Graphics.Hoodle.Render.Type
import Graphics.Hoodle.Render.Type.HitTest
@@ -39,8 +39,11 @@
import Hoodle.Accessor
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.File
+import Hoodle.Coroutine.Select.Clipboard
import Hoodle.Coroutine.TextInput
import Hoodle.Device
+import Hoodle.ModelAction.ContextMenu
+import Hoodle.ModelAction.Select
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
import Hoodle.Type.Event
@@ -52,6 +55,22 @@
--
import Prelude hiding (mapM_, mapM)
+makeTextSVGFromStringAt :: String
+ -> CanvasId
+ -> HoodleState
+ -> CanvasCoordinate
+ -> IO (B.ByteString, BBox)
+makeTextSVGFromStringAt str cid xst ccoord = do
+ rdr <- makePangoTextSVG str
+ geometry <- getCanvasGeometryCvsId cid xst
+ let mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord
+ return $ case mpgcoord of
+ Nothing -> rdr
+ Just (_,PageCoord (x',y')) ->
+ let bbox' = moveBBoxULCornerTo (x',y') (snd rdr)
+ in (fst rdr,bbox')
+
+-- |
notifyLink :: CanvasId -> PointerCoord -> MainCoroutine ()
notifyLink cid pcoord = do
xst <- get
@@ -81,6 +100,7 @@
gotLink :: Maybe String -> (Int,Int) -> MainCoroutine ()
gotLink mstr (x,y) = do
xst <- get
+ liftIO $ print mstr
let cid = getCurrentCanvasId xst
mr <- runMaybeT $ do
str <- (MaybeT . return) mstr
@@ -92,10 +112,10 @@
mr2 <- runMaybeT $ do
str <- (MaybeT . return) mstr
(MaybeT . return) (urlParse str)
+ liftIO $ putStrLn ("mr2= " ++ show mr2)
case mr2 of
- Nothing -> liftIO $ putStrLn "nothing"
+ Nothing -> return ()
Just (FileUrl file) -> do
- liftIO $ print file
let ext = takeExtension file
if ext == ".png" || ext == ".PNG" || ext == ".jpg" || ext == ".JPG"
then do
@@ -103,44 +123,54 @@
nitm <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded file)
geometry <- liftIO $ getCanvasGeometryCvsId cid xst
let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
- mpgcoord = (desktop2Page geometry . canvas2Desktop geometry)
- ccoord
-
- insertItemAt mpgcoord nitm
-
-
-{- let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord
- rdr' = case mpgcoord of
- Nothing -> rdr
- Just (_,PageCoord (x',y')) ->
- let bbox' = moveBBoxULCornerTo (x',y') (snd rdr)
- in (fst rdr,bbox')
-
- liftIO $ print mpgcoord
- liftIO $ print (snd rdr')
- linkInsert "simple" (uuidbstr,fp) fn rdr' -}
-
-
- else return ()
-
-
-
-
+ insertItemAt mpgcoord nitm
+ else return ()
+ Just (HttpUrl url) -> do
+ case getSelectedItmsFromHoodleState xst of
+ Nothing -> do
+ liftIO $ print "here"
+ uuidbstr <- liftIO $ B.pack . show <$> nextRandom
+ rdrbbx <- liftIO $ makeTextSVGFromStringAt url cid xst
+ (CvsCoord (fromIntegral x,fromIntegral y))
+ linkInsert "simple" (uuidbstr,url) url rdrbbx
+ Just hititms -> do
+ b <- okCancelMessageBox ("replace selected item with link to " ++ url ++ "?")
+ when b $ do
+ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms
+ case ulbbox of
+ Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do
+ svg <- liftIO $ makeSVGFromSelection hititms bbox
+ uuidbstr <- liftIO $ B.pack . show <$> nextRandom
+ deleteSelection
+ linkInsert "simple" (uuidbstr,url) url (svg_render svg,bbox)
+ _ -> return ()
Just (uuidbstr,fp) -> do
let fn = takeFileName fp
- rdr <- liftIO (makePangoTextSVG fn)
- geometry <- liftIO $ getCanvasGeometryCvsId cid xst
- let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
- mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord
- rdr' = case mpgcoord of
- Nothing -> rdr
- Just (_,PageCoord (x',y')) ->
- let bbox' = moveBBoxULCornerTo (x',y') (snd rdr)
- in (fst rdr,bbox')
- liftIO $ print mpgcoord
- liftIO $ print (snd rdr')
- linkInsert "simple" (uuidbstr,fp) fn rdr'
+ case getSelectedItmsFromHoodleState xst of
+ Nothing -> do
+ rdr <- liftIO (makePangoTextSVG fn)
+ geometry <- liftIO $ getCanvasGeometryCvsId cid xst
+ let ccoord = CvsCoord (fromIntegral x,fromIntegral y)
+ mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord
+ rdr' = case mpgcoord of
+ Nothing -> rdr
+ Just (_,PageCoord (x',y')) ->
+ let bbox' = moveBBoxULCornerTo (x',y') (snd rdr)
+ in (fst rdr,bbox')
+ linkInsert "simple" (uuidbstr,fp) fn rdr'
+ Just hititms -> do
+ b <- okCancelMessageBox ("replace selected item with link to " ++ fn ++ "?")
+ when b $ do
+ let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms
+ case ulbbox of
+ Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do
+ svg <- liftIO $ makeSVGFromSelection hititms bbox
+ uuid <- liftIO $ nextRandom
+ let uuidbstr = B.pack (show uuid)
+ deleteSelection
+ linkInsert "simple" (uuidbstr,fp) fn (svg_render svg,bbox)
+ _ -> return ()
liftIO $ putStrLn "gotLink"
liftIO $ print mstr
liftIO $ print (x,y)
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
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Page
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Pen
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Scroll
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Select
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
@@ -495,7 +495,7 @@
hittestlasso1 = hltFilteredBy (hitLassoItem (nlasso |> orig)) itms
selectitms1 = fmapAL unNotHitted id hittestlasso1
selecteditms1 = (concatMap unHitted . getB) selectitms1
- hittestlasso2 = flip hltFilteredBy itms $
+ hittestlasso2 = takeLastFromHitted . flip hltFilteredBy itms $
\itm-> (not.isStrkInRItem) itm
&& isPointInBBox (getBBox itm) (x,y)
selectitms2 = fmapAL unNotHitted id hittestlasso2
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,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Select.Clipboard
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -42,7 +42,7 @@
import Hoodle.Coroutine.Mode
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
-import Hoodle.Type.Event hiding (SVG)
+import Hoodle.Type.Event
import Hoodle.Type.HoodleState
--
import Prelude hiding (readFile)
@@ -118,7 +118,6 @@
hdl = getHoodle xstate
currpage = getPageFromGHoodleMap pgnum hdl
currlayer = getCurrentLayer currpage
-
newitem <- (liftIO . cnstrctRItem . ItemLink)
(Link uuidbstr typ (B.pack fname)
(Just (B.pack str)) Nothing svgbstr
@@ -147,7 +146,8 @@
layoutSetText layout str
(_,reclog) <- layoutGetExtents layout
let PangoRectangle x y w h = reclog
- return (layout,BBox (x,y) (x+w,y+h))
+ -- 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
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,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Coroutine.Window
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Device.hsc b/src/Hoodle/Device.hsc
--- a/src/Hoodle/Device.hsc
+++ b/src/Hoodle/Device.hsc
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Device
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/GUI.hs b/src/Hoodle/GUI.hs
--- a/src/Hoodle/GUI.hs
+++ b/src/Hoodle/GUI.hs
@@ -14,7 +14,7 @@
module Hoodle.GUI where
-import Control.Exception
+import Control.Exception (SomeException(..),catch)
import Control.Lens (view)
import Control.Monad
import Control.Monad.Trans
@@ -38,7 +38,7 @@
import Hoodle.Type.Event
import Hoodle.Type.HoodleState
--
-import Prelude hiding (catch)
+import Prelude ((.),($),String,Bool(..),const,error,flip,id,map) -- hiding (catch)
-- |
startGUI :: Maybe FilePath -> Maybe Hook -> IO ()
@@ -51,7 +51,8 @@
maxundo <- getMaxUndo cfg >>=
\mmax -> maybe (return 50) (return . id) mmax
xinputbool <- getXInputConfig cfg
- (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo xinputbool
+ statusbar <- statusbarNew
+ (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo xinputbool statusbar
setTitleFromFileName st0
-- need for refactoring
setToggleUIForFlag "UXINPUTA" (settings.doesUseXInput) st0
@@ -74,7 +75,6 @@
ebox <- eventBoxNew
label <- labelNew (Just "drag me")
containerAdd ebox label
-
dragSourceSet ebox [Button1] [ActionCopy]
dragSourceSetIconStock ebox stockIndex
dragSourceAddTextTargets ebox
@@ -88,6 +88,7 @@
readIORef ref
maybe (return ()) (selectionDataSetText >=> const (return ())) minfo
--
+ --
hbox <- hBoxNew False 0
boxPackStart hbox toolbar1 PackGrow 0
boxPackStart hbox ebox PackNatural 0
@@ -95,7 +96,8 @@
boxPackStart vbox menubar PackNatural 0
boxPackStart vbox hbox PackNatural 0
boxPackStart vbox toolbar2 PackNatural 0
- boxPackEnd vbox (view rootWindow st0) PackGrow 0
+ boxPackEnd vbox statusbar PackNatural 0
+ boxPackStart vbox (view rootWindow st0) PackGrow 0
window `on` deleteEvent $ do
liftIO $ eventHandler tref (Menu MenuQuit)
return True
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
@@ -281,6 +281,9 @@
ebdpdfa <- toggleActionNew "EBDPDFA" "Embed PDF" (Just "Just a stub") Nothing
ebdpdfa `on` actionToggled $ do
eventHandler evar (Menu MenuEmbedPDF)
+ -- temporary implementation (later will be as submenus with toggle action. appropriate reflection)
+ widgettogglea <- actionNewAndRegister "WIDGETTOGGLEA" "Toggle Pan/Zoom Widget" (Just "Just a stub") Nothing (justMenu MenuWidgetToggle)
+
dcrdcorea <- actionNewAndRegister "DCRDCOREA" "Discard Core Events" (Just "Just a Stub") Nothing (justMenu MenuDiscardCoreEvents)
ersrtipa <- actionNewAndRegister "ERSRTIPA" "Eraser Tip" (Just "Just a Stub") Nothing (justMenu MenuEraserTip)
pressrsensa <- toggleActionNew "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing
@@ -322,10 +325,11 @@
, hsplita, vsplita, delcvsa
, newpgba, newpgaa, newpgea, delpga, expsvga, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra
, ppstya
- , apallpga, embedbkgpdfa, {- ldbkga, bkgscrshta, -} defppa, setdefppa
+ , apallpga, embedbkgpdfa, defppa, setdefppa
, texta, linka, shpreca, rulera, clra, clrpcka, penopta
, erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta
, setdefopta, relauncha
+ , widgettogglea
, dcrdcorea, ersrtipa, pghilta, mltpgvwa
, mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea
, lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa
@@ -352,14 +356,11 @@
let disabledActions =
- [ recenta, printa {- , exporta-}
- , cuta, copya, {- pastea, -} deletea
- {- , fscra -}
+ [ recenta, printa
+ , cuta, copya, deletea
, setzma
, shwlayera, hidlayera
- , newpgea, {- delpga, -} ppsizea, ppclra
- {- , ppstya, apallpga -}
- {- , ldbkga, bkgscrshta, -}
+ , newpgea, ppsizea, ppclra
, defppa, setdefppa
, shpreca, rulera
, erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta
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
@@ -118,9 +118,7 @@
Just pma <- liftIO $ actionGroupGetAction (head agr) name
let wpma = castToRadioAction pma
update xst wpma mconnid
- where -- (#) :: a -> (a -> b) -> b
- -- (#) = flip ($)
- update xst wpma mconnid = do
+ where update xst wpma mconnid = do
(f xst) #
(maybe (return ()) $ \v -> do
let action = Left . ActionOrder $
diff --git a/src/Hoodle/ModelAction/ContextMenu.hs b/src/Hoodle/ModelAction/ContextMenu.hs
new file mode 100644
--- /dev/null
+++ b/src/Hoodle/ModelAction/ContextMenu.hs
@@ -0,0 +1,80 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hoodle.ModelAction.ContextMenu
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
+--
+-- License : BSD3
+-- Maintainer : Ian-Woo Kim
+-- Stability : experimental
+-- Portability : GHC
+--
+-----------------------------------------------------------------------------
+
+module Hoodle.ModelAction.ContextMenu where
+
+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 Control.Monad.Trans.Crtn.Driver
+import Data.Hoodle.BBox
+import Data.Hoodle.Simple
+import Graphics.Hoodle.Render
+import Graphics.Hoodle.Render.Type.Item
+--
+import Hoodle.Type.Event
+import Hoodle.Util
+
+-- |
+menuOpenALink :: (MyEvent -> IO ()) -> UrlPath -> IO MenuItem
+menuOpenALink evhandler urlpath = do
+ let urlname = case urlpath of
+ FileUrl fp -> fp
+ HttpUrl url -> url
+ menuitemlnk <- menuItemNewWithLabel ("Open "++urlname)
+ menuitemlnk `on` menuItemActivate $ do
+ case urlpath of
+ FileUrl fp -> do
+ let cmdargs = [fp]
+ createProcess (proc "hoodle" cmdargs)
+ return ()
+ HttpUrl url -> do
+ let cmdargs = [url]
+ createProcess (proc "xdg-open" cmdargs)
+ return ()
+ return menuitemlnk
+
+
+
+
+-- |
+menuCreateALink :: (MyEvent -> IO ()) -> [RItem] -> IO (Maybe MenuItem)
+menuCreateALink evhandler sitems =
+ if (length . filter isLinkInRItem) sitems > 0
+ then return Nothing
+ else do mi <- menuItemNewWithLabel "Create a link to..."
+ mi `on` menuItemActivate $
+ evhandler (GotContextMenuSignal CMenuCreateALink)
+ return (Just mi)
+
+
+-- |
+makeSVGFromSelection :: [RItem] -> BBox -> IO SVG
+makeSVGFromSelection 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
+ bstr <- B.readFile filename
+ let svg = SVG Nothing Nothing bstr (x,y) (Dim w h)
+ svg `seq` removeFile filename
+ return svg
+
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
@@ -181,7 +181,6 @@
return (Just nhdl)
-- |
-
createPage :: Bool -- ^ does embed pdf?
-> Dimension
-> C.ByteString
@@ -197,8 +196,9 @@
= BackgroundEmbedPdf "embedpdf" n
in Page dim bkg [emptyLayer]
--- |
+
+-- | this function must be moved to GUI.Reflect
toggleSave :: UIManager -> Bool -> IO ()
toggleSave ui b = do
agr <- uiManagerGetActionGroups ui >>= \x ->
diff --git a/src/Hoodle/Script.hs b/src/Hoodle/Script.hs
--- a/src/Hoodle/Script.hs
+++ b/src/Hoodle/Script.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Script
--- Copyright : (c) 2012 Ian-Woo Kim
+-- Copyright : (c) 2012, 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Script/Coroutine.hs b/src/Hoodle/Script/Coroutine.hs
--- a/src/Hoodle/Script/Coroutine.hs
+++ b/src/Hoodle/Script/Coroutine.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Script.Coroutine
--- Copyright : (c) 2012 Ian-Woo Kim
+-- Copyright : (c) 2012, 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Type.hs b/src/Hoodle/Type.hs
--- a/src/Hoodle/Type.hs
+++ b/src/Hoodle/Type.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Type/Alias.hs b/src/Hoodle/Type/Alias.hs
--- a/src/Hoodle/Type/Alias.hs
+++ b/src/Hoodle/Type/Alias.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.Alias
--- Copyright : (c) 2012 Ian-Woo Kim
+-- Copyright : (c) 2012, 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -69,6 +69,8 @@
, xfrmViewInfo
, getDrawAreaFromBox
, unboxGet
+, unboxSet
+, unboxLens
, fmap4CvsInfoBox
, insideAction4CvsInfoBox
, insideAction4CvsInfoBoxF
@@ -93,6 +95,7 @@
--
import Hoodle.Type.Enum
import Hoodle.Type.PageArrangement
+import Hoodle.Type.Widget
--
@@ -143,10 +146,6 @@
pageArrangement :: Simple Lens (ViewInfo a) (PageArrangement a)
pageArrangement = lens _pageArrangement (\f a -> f { _pageArrangement = a })
--- |
-data CanvasWidgets =
- CanvasWidgets { _testWidgetPosition :: CanvasCoordinate
- }
-- |
@@ -164,14 +163,6 @@
, _canvasWidgets :: CanvasWidgets
}
--- | default hoodle widgets
-defaultCanvasWidgets :: CanvasWidgets
-defaultCanvasWidgets =
- CanvasWidgets
- { _testWidgetPosition = CvsCoord (100,100)
- }
-
-
-- |
xfrmCvsInfo :: (ViewMode a, ViewMode b) =>
(ViewInfo a -> ViewInfo b)
@@ -257,9 +248,6 @@
canvasWidgets :: Simple Lens (CanvasInfo a) CanvasWidgets
canvasWidgets = lens _canvasWidgets (\f a -> f { _canvasWidgets = a } )
--- |
-testWidgetPosition :: Simple Lens CanvasWidgets CanvasCoordinate
-testWidgetPosition = lens _testWidgetPosition (\f a -> f { _testWidgetPosition = a} )
-- |
@@ -298,7 +286,13 @@
unboxGet f x = fmap4CvsInfoBox (view f) x
+-- |
+unboxSet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> CanvasInfoBox -> b -> CanvasInfoBox
+unboxSet l (CanvasSinglePage a) b = CanvasSinglePage (set l b a)
+unboxSet l (CanvasContPage a) b = CanvasContPage (set l b a)
+unboxLens :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> Simple Lens CanvasInfoBox b
+unboxLens l = lens (unboxGet l) (unboxSet l)
-- |
boxAction :: Monad m => (forall a. ViewMode a => CanvasInfo a -> m b)
@@ -370,9 +364,6 @@
currVerticalSpace = lens _currVerticalSpace
(\f a -> f { _currVerticalSpace = a } )
-
-
-
-- |
data PenInfo = PenInfo { _penType :: PenType
@@ -393,10 +384,6 @@
variableWidthPen :: Simple Lens PenInfo Bool
variableWidthPen = lens _variableWidthPen (\f a -> f { _variableWidthPen = a } )
-
-
-
-
-- |
currentTool :: Simple Lens PenInfo WidthColorStyle
currentTool = lens chooser setter
@@ -405,8 +392,6 @@
HighlighterWork -> _currHighlighter . _penSet $ pinfo
EraserWork -> _currEraser . _penSet $ pinfo
VerticalSpaceWork -> NoWidthColorStyle
-
- -- TextWork -> _currText . _penSet $ pinfo
setter pinfo wcs =
let pset = _penSet pinfo
psetnew = case _penType pinfo of
@@ -414,7 +399,6 @@
HighlighterWork -> pset { _currHighlighter = wcs }
EraserWork -> pset { _currEraser = wcs }
VerticalSpaceWork -> pset
- -- TextWork -> pset { _currText = wcs }
in pinfo { _penSet = psetnew }
-- |
@@ -446,16 +430,6 @@
, _variableWidthPen = False
}
-
-
-
-
-
--- makeLenses ''PenDraw
--- makeLenses ''PenInfo
--- makeLenses ''PenHighlighterEraserSet
--- makeLenses ''WidthColorStyle
-
-- |
updateCanvasDimForSingle :: CanvasDimension
-> CanvasInfo SinglePage
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,7 +7,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.Coroutine
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -147,6 +147,7 @@
| MenuUsePopUpMenu
| MenuEmbedImage
| MenuEmbedPDF
+ | MenuWidgetToggle
| MenuDiscardCoreEvents
| MenuEraserTip
| MenuPressureSensitivity
@@ -167,7 +168,7 @@
deriving (Show, Ord, Eq)
-- |
-data ImgType = SVG | PDF
+data ImgType = TypSVG | TypPDF
deriving (Show, Ord, Eq)
-- |
@@ -180,6 +181,7 @@
| CMenuRotateCCW
| CMenuAutosavePage
| CMenuLinkConvert Link
+ | CMenuCreateALink
| CMenuCustom
deriving (Show, Ord, Eq)
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
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.HoodleState
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
@@ -44,6 +44,7 @@
, hookSet
, tempLog
, tempQueue
+, statusBar
--
, hoodleFileName
--
@@ -74,8 +75,6 @@
, updateFromCanvasInfoAsCurrentCanvas
, setCanvasId
, modifyCanvasInfo
--- , modifyCurrentCanvasInfo
--- , modifyCurrCvsInfoM
, hoodleModeStateEither
, getCurrentPageFromHoodleModeState
, getCurrentPageDimFromHoodleModeState
@@ -95,7 +94,6 @@
import Control.Monad.Trans.Crtn.Queue
import Data.Hoodle.Generic
import Data.Hoodle.Select
--- import Data.Hoodle.Map
import Graphics.Hoodle.Render
import Graphics.Hoodle.Render.Type
-- from this package
@@ -112,9 +110,6 @@
--
import Prelude hiding ((.), id)
-
--- type HoodleModeStateIO = StateT HoodleState IO
-
-- |
data HoodleModeState = ViewAppendState { unView :: RHoodle }
@@ -149,12 +144,11 @@
, _settings :: Settings
, _uiComponentSignalHandler :: UIComponentSignalHandler
, _isOneTimeSelectMode :: IsOneTimeSelectMode
- -- , _pageModeSignal :: Maybe (ConnectId RadioAction)
- -- , _penModeSignal :: Maybe (ConnectId RadioAction)
, _lastTimeCanvasConfigure :: Maybe UTCTime
, _hookSet :: Maybe Hook
, _tempQueue :: Queue (Either (ActionOrder MyEvent) MyEvent)
, _tempLog :: String -> String
+ , _statusBar :: Maybe Statusbar
}
@@ -264,6 +258,9 @@
tempLog :: Simple Lens HoodleState (String -> String)
tempLog = lens _tempLog (\f a -> f { _tempLog = a } )
+-- |
+statusBar :: Simple Lens HoodleState (Maybe Statusbar)
+statusBar = lens _statusBar (\f a -> f { _statusBar = a })
-- |
data HoodleFileControl =
@@ -328,7 +325,6 @@
doesEmbedPDF :: Simple Lens Settings Bool
doesEmbedPDF = lens _doesEmbedPDF (\f a -> f { _doesEmbedPDF = a } )
-
-- | default hoodle state
emptyHoodleState :: IO HoodleState
emptyHoodleState = do
@@ -365,6 +361,7 @@
, _hookSet = Nothing
, _tempQueue = emptyQueue
, _tempLog = id
+ , _statusBar = Nothing
}
emptyHoodleFileControl :: HoodleFileControl
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
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.PageArrangement
--- Copyright : (c) 2012 Ian-Woo Kim
+-- Copyright : (c) 2012, 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.Predefined
--- Copyright : (c) 2012 Ian-Woo Kim
+-- Copyright : (c) 2012, 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Type/Undo.hs b/src/Hoodle/Type/Undo.hs
--- a/src/Hoodle/Type/Undo.hs
+++ b/src/Hoodle/Type/Undo.hs
@@ -1,14 +1,15 @@
-
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.Undo
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
-- Stability : experimental
-- Portability : GHC
--
+-----------------------------------------------------------------------------
+
module Hoodle.Type.Undo where
import Data.Hoodle.Zipper
diff --git a/src/Hoodle/Type/Widget.hs b/src/Hoodle/Type/Widget.hs
new file mode 100644
--- /dev/null
+++ b/src/Hoodle/Type/Widget.hs
@@ -0,0 +1,53 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Hoodle.Type.Widget
+-- Copyright : (c) 2013 Ian-Woo Kim
+--
+-- License : BSD3
+-- Maintainer : Ian-Woo Kim
+-- Stability : experimental
+-- Portability : GHC
+--
+-- Types for Widgets
+--
+-----------------------------------------------------------------------------
+
+module Hoodle.Type.Widget where
+
+import Control.Lens (Simple,Lens,lens)
+--
+import Hoodle.Type.PageArrangement
+
+-- |
+data CanvasWidgets =
+ CanvasWidgets { _testWidgetPosition :: CanvasCoordinate
+ , _widgetConfig :: WidgetConfig
+ }
+
+-- |
+testWidgetPosition :: Simple Lens CanvasWidgets CanvasCoordinate
+testWidgetPosition = lens _testWidgetPosition (\f a -> f { _testWidgetPosition = a} )
+
+-- | default hoodle widgets
+defaultCanvasWidgets :: CanvasWidgets
+defaultCanvasWidgets =
+ CanvasWidgets
+ { _testWidgetPosition = CvsCoord (100,100)
+ , _widgetConfig = defaultWidgetConfig
+ }
+
+
+data WidgetConfig = WidgetConfig { _doesUsePanZoom :: Bool }
+
+-- | flag for pan zoom widget
+doesUsePanZoom :: Simple Lens WidgetConfig Bool
+doesUsePanZoom = lens _doesUsePanZoom (\f a -> f {_doesUsePanZoom = a})
+
+-- | default widget configuration
+defaultWidgetConfig :: WidgetConfig
+defaultWidgetConfig = WidgetConfig { _doesUsePanZoom = True }
+
+
+-- | widget config lens
+widgetConfig :: Simple Lens CanvasWidgets WidgetConfig
+widgetConfig = lens _widgetConfig (\f a -> f { _widgetConfig =a } )
diff --git a/src/Hoodle/Type/Window.hs b/src/Hoodle/Type/Window.hs
--- a/src/Hoodle/Type/Window.hs
+++ b/src/Hoodle/Type/Window.hs
@@ -1,7 +1,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.Type.Window
--- Copyright : (c) 2011, 2012 Ian-Woo Kim
+-- Copyright : (c) 2011-2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
diff --git a/src/Hoodle/Util.hs b/src/Hoodle/Util.hs
--- a/src/Hoodle/Util.hs
+++ b/src/Hoodle/Util.hs
@@ -29,7 +29,8 @@
import System.Locale
--
import Data.Hoodle.Simple
-
+--
+import Debug.Trace
-- for test
@@ -103,19 +104,31 @@
-data UrlPath = FileUrl FilePath
+data UrlPath = FileUrl FilePath | HttpUrl String
+ deriving (Show,Eq)
+data T = N | F | H | HS deriving (Show,Eq)
+
-- |
urlParse :: String -> Maybe UrlPath
urlParse str =
if length str < 7
then Just (FileUrl str)
else
- let p = string "file://" *> manyTill anyChar (satisfy (inClass "\r\n"))
+ let p = do b <- (try (string "file://" *> return F)
+ <|> try (string "http://" *> return H)
+ <|> try (string "https://" *> return HS)
+ <|> (return N) )
+ rem <- manyTill anyChar ((satisfy (inClass "\r\n") *> return ()) <|> endOfInput)
+ return (b,rem)
r = parseOnly p (B.pack str)
in case r of
- Left _ -> Just (FileUrl str)
- Right f -> Just (FileUrl (unEscapeString f))
+ Left _ -> Nothing -- Just (FileUrl str)
+ Right (b,f) -> case b of
+ N -> Just (FileUrl f)
+ F -> Just (FileUrl (unEscapeString f))
+ H -> Just (HttpUrl ("http://" ++ f))
+ HS -> Just (HttpUrl ("https://" ++ f))
{-
diff --git a/src/Hoodle/View/Coordinate.hs b/src/Hoodle/View/Coordinate.hs
--- a/src/Hoodle/View/Coordinate.hs
+++ b/src/Hoodle/View/Coordinate.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Hoodle.View.Coordinate
--- Copyright : (c) 2012,2013 Ian-Woo Kim
+-- Copyright : (c) 2012, 2013 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim
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
@@ -39,12 +39,13 @@
import Graphics.Hoodle.Render.Type.HitTest
import Graphics.Hoodle.Render.Util
-- from this package
-import Hoodle.Type.Canvas
import Hoodle.Type.Alias
-import Hoodle.Util
+import Hoodle.Type.Canvas
import Hoodle.Type.PageArrangement
-import Hoodle.Type.Predefined
import Hoodle.Type.Enum
+import Hoodle.Type.Predefined
+import Hoodle.Type.Widget
+import Hoodle.Util
import Hoodle.View.Coordinate
--
import Prelude hiding ((.),id,mapM_,concatMap,foldr)
@@ -108,6 +109,33 @@
let ViewPortBBox vportbbox = getCanvasViewPort geometry
in (fromMaybe mbbox :: IntersectBBox) `mappend` (Intersect (Middle vportbbox))
+-- | 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
+ -> m ()
+virtualDoubleBufferDraw sfc sfc2 pre post =
+ renderWith sfc2 $ do
+ pre
+ setSourceSurface sfc 0 0
+ setOperator OperatorSource
+ paint
+ setOperator OperatorOver
+ post
+
+doubleBufferFlush :: ViewMode a => 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
+
+
+
-- | common routine for double buffering
doubleBufferDraw :: (DrawWindow, Maybe Surface)
-> CanvasGeometry -> Render () -> Render a
@@ -128,7 +156,6 @@
rectangle 0 0 cw ch
fill
rndr
- -- return ()
Just sfc -> do
r <- renderWith sfc $ do
clipBBox (fmap (flip inflate (-1.0)) mbbox')
@@ -142,11 +169,10 @@
setOperator OperatorSource
paint
return r
- -- return ()
case ibbox of
- Top -> Just <$> action -- >> return Nothing
- Middle _ -> Just <$> action -- >> return Nothing
- Bottom -> return Nothing
+ Top -> Just <$> action
+ Middle _ -> Just <$> action
+ Bottom -> return Nothing
-- |
cairoXform4PageCoordinate :: CanvasGeometry -> PageNum -> Render ()
@@ -207,7 +233,6 @@
xformfunc = cairoXform4PageCoordinate geometry pnum
renderfunc = do
xformfunc
- -- clipBBox (fmap (flip inflate 1) mbboxnew) -- ad hoc ?
pg <- render (pnum,page) mbboxnew flag
-- Start Widget
when isCurrentCvs (emphasisCanvasRender ColorBlue geometry)
@@ -276,22 +301,18 @@
identityMatrix
cairoXform4PageCoordinate geometry pn
let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew
- -- clipBBox (fmap (flip inflate 1) pgmbbox) -- ad hoc
render (pn,pg) pgmbbox flag
renderfunc = do
xformfunc
- -- mapM_ onepagerender drawpgs
ndrawpgs <- mapM onepagerender drawpgs
let npgs = foldr rfunc pgs ndrawpgs
where rfunc (k,pg) m = M.adjust (const pg) k m
let nhdl = set gpages npgs hdl
maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg
- -- Start Widget
when isCurrentCvs (emphasisCanvasRender ColorRed geometry)
- -- widget test
let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew
- renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo) -- (CvsCoord (100,100))
- -- End Widget
+ when (view (canvasWidgets.widgetConfig.doesUsePanZoom) cinfo) $
+ renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)
resetClip
return nhdl
doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew
@@ -343,12 +364,10 @@
lift (selpagerender (PageNum n,tpage))
let nthdl2 = set gselSelected r nthdl
maybe (return ()) (\cpg->emphasisPageRender geometry (pnum,cpg)) mcpg
- -- Start Widget
when isCurrentCvs (emphasisCanvasRender ColorGreen geometry)
- -- widget test
let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew
- renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)
- -- End Widget
+ when (view (canvasWidgets.widgetConfig.doesUsePanZoom) cinfo) $
+ renderPanZoomWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)
resetClip
return nthdl2
doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew
@@ -525,6 +544,17 @@
setSourceRGBA 0.7 0.2 0.2 0.5
rectangle (x+30) (y+30) 40 40
fill
+ setSourceRGBA 0.5 0.5 0.5 0.5
+ rectangle (x+90) y 10 10
+ fill
+ setSourceRGBA 0 0 0 0.7
+ setLineWidth 1
+ moveTo (x+90) y
+ lineTo (x+100) (y+10)
+ stroke
+ moveTo (x+90) (y+10)
+ lineTo (x+100) y
+ stroke
resetClip
@@ -544,12 +574,10 @@
nbbx_cvs =
xformBBox ( unCvsCoord . desktop2Canvas geometry . DeskCoord ) nbbx_desk
nvport = ViewPortBBox nbbx_desk
- -- Dim _w_desk _h_desk = bboxToDim nbbx_desk
Dim w_cvs h_cvs = bboxToDim nbbx_cvs
let pgs = view gpages hdl
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
case mmulti of
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
@@ -8,52 +8,42 @@
-- Stability : experimental
-- Portability : GHC
--
+-- Pan-Zoom widget drawing and action
+--
-----------------------------------------------------------------------------
module Hoodle.Widget.PanZoom where
-- from other packages
-import Control.Category
-import Control.Lens (view,set)
+import Control.Lens (view,set,over)
import Control.Monad.Identity
import Control.Monad.State
import Data.Time.Clock
import Graphics.Rendering.Cairo
-import Graphics.UI.Gtk hiding (get,set)
--- import Graphics.UI.Gtk hiding (get,set)
--- import qualified Graphics.UI.Gtk as Gtk (get)
+-- import Graphics.UI.Gtk hiding (get,set)
-- from hoodle-platform
import Data.Hoodle.BBox
-
import Data.Hoodle.Simple
-
-
-
import Graphics.Hoodle.Render.Util.HitTest
---
+-- from this package
import Hoodle.Accessor
import Hoodle.Coroutine.Draw
import Hoodle.Coroutine.Page
import Hoodle.Coroutine.Pen
import Hoodle.Coroutine.Scroll
-
import Hoodle.Device
import Hoodle.ModelAction.Page
-
-
import Hoodle.Type.Canvas
import Hoodle.Type.Coroutine
import Hoodle.Type.Event
import Hoodle.Type.HoodleState
import Hoodle.Type.PageArrangement
-
+import Hoodle.Type.Widget
import Hoodle.View.Coordinate
import Hoodle.View.Draw
--
-import Prelude hiding ((.),id)
-
-data WidgetMode = Moving | Zooming | Panning Bool
+data PanZoomMode = Moving | Zooming | Panning Bool
widgetCheckPen :: CanvasId -> PointerCoord
-> MainCoroutine ()
@@ -61,7 +51,8 @@
widgetCheckPen cid pcoord act = do
xst <- get
let cinfobox = getCanvasInfo cid xst
- boxAction (f xst) cinfobox
+ b = view (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) cinfobox
+ if b then boxAction (f xst) cinfobox else act
where
f xst cinfo = do
let cvs = view drawArea cinfo
@@ -73,36 +64,37 @@
obbox = BBox (x0,y0) (x0+100,y0+100)
pbbox1 = BBox (x0+10,y0+10) (x0+50,y0+90)
pbbox2 = BBox (x0+50,y0+10) (x0+90,y0+90)
+ pbbox3 = BBox (x0+90,y0) (x0+100,y0+10)
zbbox = BBox (x0+30,y0+30) (x0+70,y0+70)
-
-
if (isPointInBBox obbox (x,y))
then do
- let mode | isPointInBBox zbbox (x,y) = Zooming
- | isPointInBBox pbbox1 (x,y) = Panning False
- | isPointInBBox pbbox2 (x,y) = Panning True
- | otherwise = Moving
+ let mmode | isPointInBBox zbbox (x,y) = Just Zooming
+ | isPointInBBox pbbox1 (x,y) = Just (Panning False)
+ | isPointInBBox pbbox2 (x,y) = Just (Panning True)
+ | isPointInBBox pbbox3 (x,y) = Nothing
+ | otherwise = Just Moving
let hdl = getHoodle xst
- (sfc,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)
- sfc2 <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)
- ctime <- liftIO getCurrentTime
- startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime
- liftIO $ surfaceFinish sfc
- liftIO $ surfaceFinish sfc2
- else do
- act
-
+ case mmode of
+ Nothing -> togglePanZoom
+ Just mode -> do
+ (sfc,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)
+ sfc2 <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)
+ ctime <- liftIO getCurrentTime
+ startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime
+ liftIO $ surfaceFinish sfc
+ liftIO $ surfaceFinish sfc2
+ else act
+-- |
findZoomXform :: Dimension
-> ((Double,Double),(Double,Double),(Double,Double))
-> (Double,(Double,Double))
findZoomXform (Dim w h) ((xo,yo),(x0,y0),(x,y)) =
- let tx = x - x0 -- if x0 > xo then x - x0 else x0 - x
- ty = y - y0 -- if y0 > yo then y - y0 else y0 - y
+ let tx = x - x0
+ ty = y - y0
ztx = 1 + tx / 200
zty = 1 + ty / 200
zx | ztx > 2 = 2
@@ -133,9 +125,8 @@
| otherwise = ty
in ((dx-w),(dy-h))
-
-- |
-startWidgetAction :: WidgetMode
+startWidgetAction :: PanZoomMode
-> CanvasId
-> CanvasGeometry
-> (Surface,Surface)
@@ -161,7 +152,6 @@
ccoord@(CvsCoord (xo,yo)) = CvsCoord (xw+50,yw+50)
(z,(_,_)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))
nratio = zoomRatioFrmRelToCurr geometry z
-
mpnpgxy = (desktop2Page geometry . canvas2Desktop geometry) ccoord
canvasZoomUpdateGenRenderCvsId (return ()) cid (Just (Zoom nratio)) Nothing
case mpnpgxy of
@@ -184,8 +174,8 @@
invalidate cid
_ -> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy otime
-
-movingRender :: WidgetMode -> CanvasId -> CanvasGeometry -> (Surface,Surface)
+-- |
+movingRender :: PanZoomMode -> CanvasId -> CanvasGeometry -> (Surface,Surface)
-> CanvasCoordinate -> CanvasCoordinate -> PointerCoord
-> MainCoroutine ()
movingRender mode cid geometry (sfc,sfc2) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do
@@ -201,34 +191,22 @@
nposy | yw+y-y0 < -50 = -50
| yw+y-y0 > ch-50 = ch-50
| otherwise = yw+y-y0
- nwpos = CvsCoord (nposx,nposy) -- (xw+x-x0,yw+y-y0)
+ nwpos = CvsCoord (nposx,nposy)
changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a
changeact cinfo =
set (canvasWidgets.testWidgetPosition) nwpos $ cinfo
ncinfobox = selectBox changeact changeact cinfobox
put (setCanvasInfo (cid,ncinfobox) xst)
- renderWith sfc2 $ do
- setSourceSurface sfc 0 0
- setOperator OperatorSource
- paint
- setOperator OperatorOver
- renderPanZoomWidget Nothing nwpos
+ virtualDoubleBufferDraw sfc sfc2 (return ()) (renderPanZoomWidget Nothing nwpos)
Zooming -> do
let cinfobox = getCanvasInfo cid xst
let pos = runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox )
let (xo,yo) = (xw+50,yw+50)
CanvasDimension cdim = canvasDim geometry
(z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))
- renderWith sfc2 $ do
- save
- scale z z
- translate xtrans ytrans
- setSourceSurface sfc 0 0
- setOperator OperatorSource
- paint
- setOperator OperatorOver
- restore
- renderPanZoomWidget Nothing pos
+ virtualDoubleBufferDraw sfc sfc2
+ (save >> scale z z >> translate xtrans ytrans)
+ (restore >> renderPanZoomWidget Nothing pos)
Panning b -> do
let cinfobox = getCanvasInfo cid xst
CanvasDimension cdim = canvasDim geometry
@@ -244,32 +222,23 @@
then CvsCoord (nposx,nposy)
else
runIdentity (boxAction (return . view (canvasWidgets.testWidgetPosition)) cinfobox)
- changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a
- changeact cinfo =
- set (canvasWidgets.testWidgetPosition) nwpos $ cinfo
- ncinfobox = selectBox changeact changeact cinfobox
+ -- changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a
+ -- changeact cinfo =
+ -- set (canvasWidgets.testWidgetPosition) nwpos $ cinfo
+ -- selectBox changeact changeact cinfobox
+ ncinfobox = set (unboxLens (canvasWidgets.testWidgetPosition)) nwpos cinfobox
put (setCanvasInfo (cid,ncinfobox) xst)
-
- renderWith sfc2 $ do
- save
- translate xtrans ytrans
- setSourceSurface sfc 0 0
- setOperator OperatorSource
- paint
- setOperator OperatorOver
- restore
- renderPanZoomWidget Nothing nwpos
+ virtualDoubleBufferDraw sfc sfc2
+ (save >> translate xtrans ytrans)
+ (restore >> renderPanZoomWidget Nothing nwpos)
--
xst2 <- get
let cinfobox = getCanvasInfo cid xst2
- drawact :: (ViewMode a) => CanvasInfo a -> IO ()
- drawact cinfo = do
- let canvas = view drawArea cinfo
- win <- widgetGetDrawWindow canvas
- renderWithDrawable win $ do
- setSourceSurface sfc2 0 0
- setOperator OperatorSource
- paint
- liftIO $ boxAction drawact cinfobox
+ liftIO $ boxAction (doubleBufferFlush sfc2) cinfobox
-
+
+-- |
+togglePanZoom :: MainCoroutine ()
+togglePanZoom = do
+ modify (over (currentCanvasInfo . unboxLens (canvasWidgets.widgetConfig.doesUsePanZoom)) not)
+ invalidateAll