hoodle-core 0.9.0.0 → 0.10
raw patch · 49 files changed
+2560/−1173 lines, 49 filesdep +monad-loopsdep +networkdep +uuiddep −TypeComposedep ~coroutine-objectdep ~hoodle-builderdep ~hoodle-parser
Dependencies added: monad-loops, network, uuid
Dependencies removed: TypeCompose
Dependency ranges changed: coroutine-object, hoodle-builder, hoodle-parser, hoodle-render, hoodle-types
Files
- hoodle-core.cabal +34/−20
- resource/menu.xml +13/−4
- src/Hoodle/Accessor.hs +10/−56
- src/Hoodle/Coroutine.hs +1/−3
- src/Hoodle/Coroutine/Commit.hs +2/−3
- src/Hoodle/Coroutine/ContextMenu.hs +116/−37
- src/Hoodle/Coroutine/Default.hs +62/−72
- src/Hoodle/Coroutine/Draw.hs +28/−16
- src/Hoodle/Coroutine/Eraser.hs +13/−19
- src/Hoodle/Coroutine/EventConnect.hs +0/−78
- src/Hoodle/Coroutine/File.hs +198/−90
- src/Hoodle/Coroutine/Layer.hs +18/−37
- src/Hoodle/Coroutine/Link.hs +194/−0
- src/Hoodle/Coroutine/Mode.hs +21/−17
- src/Hoodle/Coroutine/Page.hs +14/−13
- src/Hoodle/Coroutine/Pen.hs +54/−21
- src/Hoodle/Coroutine/Scroll.hs +27/−25
- src/Hoodle/Coroutine/Select.hs +36/−60
- src/Hoodle/Coroutine/Select/Clipboard.hs +2/−1
- src/Hoodle/Coroutine/TextInput.hs +68/−53
- src/Hoodle/Coroutine/VerticalSpace.hs +253/−0
- src/Hoodle/Coroutine/Window.hs +1/−8
- src/Hoodle/GUI.hs +39/−28
- src/Hoodle/GUI/Menu.hs +121/−33
- src/Hoodle/GUI/Reflect.hs +137/−0
- src/Hoodle/ModelAction/Adjustment.hs +0/−1
- src/Hoodle/ModelAction/Clipboard.hs +2/−2
- src/Hoodle/ModelAction/Eraser.hs +1/−1
- src/Hoodle/ModelAction/File.hs +114/−43
- src/Hoodle/ModelAction/Layer.hs +10/−19
- src/Hoodle/ModelAction/Page.hs +18/−12
- src/Hoodle/ModelAction/Pen.hs +7/−9
- src/Hoodle/ModelAction/Select.hs +22/−91
- src/Hoodle/ModelAction/Select/Transform.hs +123/−0
- src/Hoodle/ModelAction/Window.hs +27/−6
- src/Hoodle/Script/Coroutine.hs +21/−10
- src/Hoodle/Script/Hook.hs +11/−2
- src/Hoodle/Type/Canvas.hs +47/−12
- src/Hoodle/Type/Clipboard.hs +5/−23
- src/Hoodle/Type/Coroutine.hs +1/−1
- src/Hoodle/Type/Enum.hs +26/−6
- src/Hoodle/Type/Event.hs +19/−11
- src/Hoodle/Type/HoodleState.hs +164/−106
- src/Hoodle/Type/PageArrangement.hs +32/−66
- src/Hoodle/Type/Predefined.hs +7/−3
- src/Hoodle/Util.hs +31/−2
- src/Hoodle/View/Coordinate.hs +13/−11
- src/Hoodle/View/Draw.hs +122/−42
- src/Hoodle/Widget/PanZoom.hs +275/−0
hoodle-core.cabal view
@@ -1,5 +1,5 @@ Name: hoodle-core-Version: 0.9.0.0+Version: 0.10 Synopsis: Core library for hoodle Description: Hoodle is a pen notetaking program written in haskell. hoodle-core is the core library written in haskell and @@ -10,7 +10,7 @@ Author: Ian-Woo Kim Maintainer: Ian-Woo Kim <ianwookim@gmail.com> Category: Application-Tested-with: GHC == 7.4 +Tested-with: GHC == 7.4, GHC == 7.6 Build-Type: Custom Cabal-Version: >= 1.8 data-files: template/*.html.st@@ -22,9 +22,9 @@ type: git location: http://www.github.com/wavewave/hoodle-core -Flag Poppler- Description: Enable poppler support- Default: False+-- Flag Poppler+-- Description: Enable poppler support+-- Default: False Library@@ -42,14 +42,15 @@ pango == 0.12.*, gd >= 3000.7, attoparsec == 0.10.*,- coroutine-object >= 0.2.0, + coroutine-object >= 0.2, transformers == 0.3.*, transformers-free == 1.0.*,- hoodle-types >= 0.1.1,- hoodle-parser >= 0.1.1,+ hoodle-types >= 0.2,+ -- hoodle-common >= 0.1, + hoodle-parser >= 0.2, xournal-parser >= 0.5.0.1,- hoodle-render >= 0.2.1,- hoodle-builder >= 0.1.1,+ hoodle-render >= 0.3,+ hoodle-builder >= 0.2, containers >= 0.4, template-haskell == 2.*, bytestring >= 0.9, @@ -60,17 +61,22 @@ process >= 1.1, configurator == 0.2.*, time >= 1.2, - TypeCompose == 0.9.*, Diff == 0.1.*, dyre >= 0.8.11, cereal == 0.3.5.*, base64-bytestring >= 0.1, - old-locale >= 1.0 - if flag(poppler) - Build-Depends: poppler >= 0.12.2.2 - else - Build-Depends:+ old-locale >= 1.0, + uuid >= 1.2.7, + monad-loops >= 0.3, + network, + poppler >= 0.12.2.2+ +-- if flag(poppler) +-- Build-Depends: +-- else +-- Build-Depends: + Exposed-Modules: Hoodle.Accessor Hoodle.Config@@ -81,29 +87,35 @@ Hoodle.Coroutine.Default Hoodle.Coroutine.Draw Hoodle.Coroutine.Eraser- Hoodle.Coroutine.EventConnect+ -- Hoodle.Coroutine.EventConnect Hoodle.Coroutine.File Hoodle.Coroutine.Highlighter Hoodle.Coroutine.Layer+ Hoodle.Coroutine.Link Hoodle.Coroutine.Mode Hoodle.Coroutine.Page Hoodle.Coroutine.Pen Hoodle.Coroutine.Scroll Hoodle.Coroutine.Select Hoodle.Coroutine.Select.Clipboard+ -- Hoodle.Coroutine.Select.Transform Hoodle.Coroutine.TextInput+ Hoodle.Coroutine.VerticalSpace Hoodle.Coroutine.Window Hoodle.Device Hoodle.GUI Hoodle.GUI.Menu+ Hoodle.GUI.Reflect Hoodle.ModelAction.Adjustment Hoodle.ModelAction.Clipboard Hoodle.ModelAction.Eraser Hoodle.ModelAction.File+ -- Hoodle.ModelAction.Item Hoodle.ModelAction.Layer Hoodle.ModelAction.Page Hoodle.ModelAction.Pen Hoodle.ModelAction.Select+ Hoodle.ModelAction.Select.Transform Hoodle.ModelAction.Window Hoodle.Script Hoodle.Script.Coroutine@@ -121,9 +133,10 @@ Hoodle.Type.Window Hoodle.Type.HoodleState Hoodle.Util- -- Hoodle.Util.Verbatim + -- Hoodle.Util.Process Hoodle.View.Coordinate Hoodle.View.Draw+ Hoodle.Widget.PanZoom Other-Modules: Paths_hoodle_core c-sources: @@ -133,5 +146,6 @@ csrc/c_initdevice.h csrc/template-hsc-gtk2hs.h cc-options: -Wno-pointer-to-int-cast- if flag(poppler)- cpp-options: -DPOPPLER++-- if flag(poppler)+-- cpp-options: -DPOPPLER
@@ -13,6 +13,8 @@ <menuitem action="LDIMGA" /> <menuitem action="LDSVGA" /> <menuitem action="LDPREIMGA" /> + <menuitem action="LDPREIMG2A" />+ <menuitem action="LDPREIMG3A" /> <menuitem action="LATEXA" /> <separator /> <menuitem action="PRINTA" /> @@ -83,8 +85,9 @@ </menu> <menuitem action="APALLPGA" /> <separator />- <menuitem action="LDBKGA" />- <menuitem action="BKGSCRSHTA" />+ <menuitem action="EMBEDBKGPDFA" />+ <!-- <menuitem action="LDBKGA" /> -->+ <!-- <menuitem action="BKGSCRSHTA" /> --> <separator /> <menuitem action="DEFPPA" /> <menuitem action="SETDEFPPA" /> @@ -95,6 +98,7 @@ <menuitem action="HIGHLTA" /> <separator /> <menuitem action="TEXTA" /> + <menuitem action="LINKA" /> <menuitem action="SHPRECA" /> <menuitem action="RULERA" /> <separator />@@ -140,6 +144,7 @@ <menuitem action="SMTHSCRA" /> <menuitem action="POPMENUA" /> <menuitem action="EBDIMGA" />+ <menuitem action="EBDPDFA" /> <menuitem action="DCRDCOREA" /> <menuitem action="ERSRTIPA" /> <menuitem action="PRESSRSENSA" /> @@ -186,6 +191,8 @@ <toolitem action="PGWDTHA" /> <toolitem action="SETZMA" /> <toolitem action="FSCRA" />+ <separator /> + <toolitem action="LINKA" /> </toolbar> <toolbar name="toolbar2" > <toolitem action="PENA" />@@ -201,11 +208,12 @@ <toolitem action="SELREGNA" /> <toolitem action="SELRECTA" /> <toolitem action="VERTSPA" /> - <toolitem action="HANDA" /> + <toolitem action="HANDA" /> <separator /> <toolitem action="PENFINEA" /> <toolitem action="PENMEDIUMA" /> <toolitem action="PENTHICKA" /> + <!-- <toolitem action="NOWIDTH" /> --> <separator /> <toolitem action="CLRPCKA" /> <toolitem action="BLACKA" /> @@ -218,6 +226,7 @@ <toolitem action="MAGENTAA" /> <toolitem action="ORANGEA" /> <toolitem action="YELLOWA" /> - <toolitem action="WHITEA" /> + <toolitem action="WHITEA" /> + <!-- <toolitem action="NOCOLOR" /> --> </toolbar> </ui>
src/Hoodle/Accessor.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Accessor --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,32 +15,27 @@ module Hoodle.Accessor where import Control.Applicative-import Control.Category-import Control.Lens+import Control.Lens (Simple,Lens,view,set) import Control.Monad hiding (mapM_, forM_) import qualified Control.Monad.State as St hiding (mapM_, forM_) import Control.Monad.Trans import Data.Foldable import qualified Data.IntMap as M import Graphics.UI.Gtk hiding (get,set)-import qualified Graphics.UI.Gtk as Gtk (set) -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Select import Graphics.Hoodle.Render.Type -- from this package+-- import Hoodle.GUI.Menu+import Hoodle.GUI.Reflect import Hoodle.ModelAction.Layer import Hoodle.Type import Hoodle.Type.Alias import Hoodle.View.Coordinate import Hoodle.Type.PageArrangement ---import Prelude hiding ((.),id,mapM_)---- | -waitSomeEvent :: (MyEvent -> Bool) -> MainCoroutine MyEvent -waitSomeEvent p = do r <- nextevent- if p r then return r else waitSomeEvent p +import Prelude hiding (mapM_) -- | update state updateXState :: (HoodleState -> MainCoroutine HoodleState) -> MainCoroutine ()@@ -85,11 +80,7 @@ -- | rItmsInCurrLyr :: MainCoroutine [RItem] -rItmsInCurrLyr = do - page <- getCurrentPageCurr- let (mcurrlayer, _currpage) = getCurrentLayerOrSet page- currlayer = maybe (error "rItmsInCurrLyr") id mcurrlayer- (return . view gitems) currlayer+rItmsInCurrLyr = return . view gitems . getCurrentLayer =<< getCurrentPageCurr -- | otherCanvas :: HoodleState -> [Int] @@ -103,11 +94,8 @@ (\xst -> do St.put xst return xst) (setCurrentCanvasId cid xstate1)- xst <- St.get- let cinfo = view currentCanvasInfo xst - ui = view gtkUIManager xst - reflectUI ui cinfo- return xst+ reflectViewModeUI+ St.get -- | apply an action to all canvases applyActionToAllCVS :: (CanvasId -> MainCoroutine ()) -> MainCoroutine () @@ -117,23 +105,8 @@ keys = M.keys cinfoMap forM_ keys action --- | reflect UI for current canvas info -reflectUI :: UIManager -> CanvasInfoBox -> MainCoroutine ()-reflectUI ui cinfobox = do - xstate <- St.get- let mconnid = view pageModeSignal xstate- liftIO $ maybe (return ()) signalBlock mconnid - agr <- liftIO $ uiManagerGetActionGroups ui- Just ra1 <- liftIO $ actionGroupGetAction (head agr) "ONEPAGEA"- selectBoxAction (fsingle ra1) (fcont ra1) cinfobox - liftIO $ maybe (return ()) signalUnblock mconnid - return ()- where fsingle ra1 _cinfo = do- let wra1 = castToRadioAction ra1 - liftIO $ Gtk.set wra1 [radioActionCurrentValue := 1 ] - fcont ra1 _cinfo = do- liftIO $ Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 0 ] - ++ -- | printViewPortBBox :: CanvasId -> MainCoroutine () printViewPortBBox cid = do @@ -239,24 +212,5 @@ toggleActionSetActive togglea b return b -{---- | -getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox] -getAllStrokeBBoxInCurrentPage = do - page <- getCurrentPageCurr- return [ s | l <- toList (view glayers page)- , s <- (catMaybes . map findStrkInRItem . view gitems) l ]- --}--{---- | -getAllStrokeBBoxInCurrentLayer :: MainCoroutine [StrokeBBox] -getAllStrokeBBoxInCurrentLayer = do - page <- getCurrentPageCurr- let (mcurrlayer, _currpage) = getCurrentLayerOrSet page- currlayer = maybe (error "getAllStrokeBBoxInCurrentLayer") id mcurrlayer- (return . catMaybes . map findStrkInRItem . view gitems) currlayer--}
src/Hoodle/Coroutine.hs view
@@ -12,14 +12,12 @@ -- module Hoodle.Coroutine -( module Hoodle.Coroutine.EventConnect-, module Hoodle.Coroutine.Default+( module Hoodle.Coroutine.Default , module Hoodle.Coroutine.Pen , module Hoodle.Coroutine.Eraser , module Hoodle.Coroutine.Highlighter ) where -import Hoodle.Coroutine.EventConnect import Hoodle.Coroutine.Default import Hoodle.Coroutine.Pen import Hoodle.Coroutine.Eraser
src/Hoodle/Coroutine/Commit.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Commit --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,8 +12,7 @@ module Hoodle.Coroutine.Commit where --- import Data.Label-import Control.Lens+import Control.Lens (view,set) import Control.Monad.Trans import Control.Monad.State -- from this package
src/Hoodle/Coroutine/ContextMenu.hs view
@@ -17,40 +17,40 @@ -- from other packages import Control.Applicative import Control.Category-import Control.Lens--- import Control.Monad.Trans.Maybe +import Control.Lens (view,set,(%~)) import Control.Monad.State--- import Data.ByteString.Char8 as B (pack)--- import qualified Data.ByteString.Lazy as L+import Data.Attoparsec +import qualified Data.ByteString.Char8 as B import qualified Data.IntMap as IM import Data.Monoid import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set)--- import System.Directory+import System.Directory import System.FilePath+import System.Process -- from hoodle-platform import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox--- import Data.Hoodle.Generic--- import Data.Hoodle.Simple hiding (SVG)+import Data.Hoodle.Generic import Data.Hoodle.Select+import Data.Hoodle.Simple (Item(..),Link(..),hoodleID) import Graphics.Hoodle.Render--- import Graphics.Hoodle.Render.Generic--- import Graphics.Hoodle.Render.Item+import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type--- import Graphics.Hoodle.Render.Type.HitTest --- import Text.Hoodle.Builder +import Graphics.Hoodle.Render.Type.HitTest+import qualified Text.Hoodle.Parse.Attoparsec as PA -- from this package import Hoodle.Accessor+import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Draw import Hoodle.Coroutine.File import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.Select.Clipboard import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select+import Hoodle.ModelAction.Select.Transform import Hoodle.Script.Hook--- import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Event import Hoodle.Type.HoodleState@@ -81,7 +81,6 @@ processContextMenu CMenuCopy = copySelection processContextMenu CMenuDelete = deleteSelection processContextMenu (CMenuCanvasView cid pnum _x _y) = do - -- liftIO $ print (cid,pnum,x,y) xstate <- get let cmap = view cvsInfoMap xstate let mcinfobox = IM.lookup cid cmap @@ -92,24 +91,52 @@ put $ set cvsInfoMap (IM.adjust (const cinfobox') cid cmap) xstate adjustScrollbarWithGeometryCvsId cid invalidateAll -processContextMenu CMenuCustom = do +processContextMenu CMenuRotateCW = return () -- rotateSelection CW+processContextMenu CMenuRotateCCW = return () -- rotateSelection CCW+processContextMenu CMenuAutosavePage = do xst <- get - case view hoodleModeState xst of - SelectState thdl -> do - liftIO $ putStrLn "SelectState"- case view gselSelected thdl of - Nothing -> return () - Just (_,tpg) -> do - let hititms = (map rItem2Item . getSelectedItms) tpg - maybe (return ()) liftIO $ do - hset <- view hookSet xst - customContextMenuHook hset <*> pure hititms - _ -> return () - -+ pg <- getCurrentPageCurr + maybe (return ()) liftIO $ do + hset <- view hookSet xst+ customAutosavePage hset <*> pure pg +processContextMenu (CMenuLinkConvert nlnk) = + either (const (return ())) action + . hoodleModeStateEither + . view hoodleModeState =<< get + where action thdl = do + xst <- get + case view gselSelected thdl of + Nothing -> return () + Just (n,tpg) -> do + let activelayer = rItmsInActiveLyr tpg+ buf = view (glayers.selectedLayer.gbuffer) tpg+ ntpg <- case activelayer of + Left _ -> return tpg + Right (a :- _b :- as ) -> liftIO $ do+ let nitm = ItemLink nlnk+ nritm <- cnstrctRItem nitm+ 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+ commit . set hoodleModeState (SelectState nthdl)+ =<< (liftIO (updatePageAll (SelectState nthdl) xst))+ invalidateAll +processContextMenu CMenuCustom = + either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get + where action thdl = do + xst <- get + case view gselSelected thdl of + Nothing -> return () + Just (_,tpg) -> do + let hititms = (map rItem2Item . getSelectedItms) tpg + maybe (return ()) liftIO $ do + hset <- view hookSet xst + customContextMenuHook hset <*> pure hititms -+-- | exportCurrentSelectionAsSVG :: [RItem] -> BBox -> MainCoroutine () exportCurrentSelectionAsSVG hititms bbox@(BBox (ulx,uly) (lrx,lry)) = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action @@ -120,7 +147,6 @@ then fileExtensionInvalid (".svg","export") >> exportCurrentSelectionAsSVG hititms bbox else do - -- liftIO $ print "exportCurrentSelectionAsSVG executed" liftIO $ withSVGSurface filename (lrx-ulx) (lry-uly) $ \s -> renderWith s $ do translate (-ulx) (-uly) mapM_ renderRItem hititms@@ -136,7 +162,6 @@ then fileExtensionInvalid (".svg","export") >> exportCurrentSelectionAsPDF hititms bbox else do - -- liftIO $ print "exportCurrentSelectionAsPDF executed" liftIO $ withPDFSurface filename (lrx-ulx) (lry-uly) $ \s -> renderWith s $ do translate (-ulx) (-uly) mapM_ renderRItem hititms@@ -145,13 +170,13 @@ showContextMenu :: (PageNum,(Double,Double)) -> MainCoroutine () showContextMenu (pnum,(x,y)) = do xstate <- get- when (view doesUsePopUpMenu xstate) $ do + when (view (settings.doesUsePopUpMenu) xstate) $ do let cids = IM.keys . view cvsInfoMap $ xstate cid = fst . view currentCanvas $ xstate mselitms = do lst <- getSelectedItmsFromHoodleState xstate if null lst then Nothing else Just lst modify (tempQueue %~ enqueue (action xstate mselitms cid cids)) - >> waitSomeEvent (==ContextMenuCreated) + >> waitSomeEvent (\e->case e of ContextMenuCreated -> True ; _ -> False) >> return () where action xstate msitms cid cids = Left . ActionOrder $ @@ -160,13 +185,12 @@ menuSetTitle menu "MyMenu" case msitms of Nothing -> return ()- Just _ -> do + Just sitms -> do menuitem1 <- menuItemNewWithLabel "Make SVG" menuitem2 <- menuItemNewWithLabel "Make PDF" menuitem3 <- menuItemNewWithLabel "Cut" menuitem4 <- menuItemNewWithLabel "Copy" menuitem5 <- menuItemNewWithLabel "Delete"- menuitem1 `on` menuItemActivate $ evhandler (GotContextMenuSignal (CMenuSaveSelectionAs SVG)) menuitem2 `on` menuItemActivate $ @@ -177,18 +201,73 @@ evhandler (GotContextMenuSignal (CMenuCopy)) menuitem5 `on` menuItemActivate $ evhandler (GotContextMenuSignal (CMenuDelete)) - menuAttach menu menuitem1 0 1 0 1 - menuAttach menu menuitem2 0 1 1 2+ menuAttach menu menuitem1 0 1 1 2 + menuAttach menu menuitem2 0 1 2 3 menuAttach menu menuitem3 1 2 0 1 menuAttach menu menuitem4 1 2 1 2 menuAttach menu menuitem5 1 2 2 3 + 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 + 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 + 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 $ do+ evhandler (GotContextMenuSignal (CMenuLinkConvert link))+ menuAttach menu menuitemcvt 0 1 4 5 + ++++ _ -> return () + _ -> return () case (customContextMenuTitle =<< view hookSet xstate) of Nothing -> return () Just ttl -> do custommenu <- menuItemNewWithLabel ttl custommenu `on` menuItemActivate $ evhandler (GotContextMenuSignal (CMenuCustom))- menuAttach menu custommenu 1 2 3 4 + menuAttach menu custommenu 0 1 0 1 + + menuitem8 <- menuItemNewWithLabel "Autosave This Page Image"+ menuitem8 `on` menuItemActivate $ + evhandler (GotContextMenuSignal (CMenuAutosavePage))+ menuAttach menu menuitem8 1 2 3 4 + runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0 widgetShowAll menu menuPopup menu Nothing
src/Hoodle/Coroutine/Default.hs view
@@ -17,23 +17,22 @@ import Control.Applicative ((<$>)) import Control.Category import Control.Concurrent -import Control.Lens+import Control.Lens (view,set,at,(.~),(%~)) import Control.Monad.Reader import Control.Monad.State +import qualified Data.ByteString.Char8 as B import qualified Data.IntMap as M--- import Data.IntMap.Lens +import Data.IORef import Data.Maybe import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform--- import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Driver--- import Control.Monad.Trans.Crtn.EventHandler import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Object import Control.Monad.Trans.Crtn.Logger.Simple import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.Select-import Data.Hoodle.Simple (Dimension(..), bkg_style)+import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic import Graphics.Hoodle.Render.Type.Background -- from this package@@ -46,6 +45,7 @@ import Hoodle.Coroutine.File import Hoodle.Coroutine.Highlighter import Hoodle.Coroutine.Layer +import Hoodle.Coroutine.Link import Hoodle.Coroutine.Page import Hoodle.Coroutine.Pen import Hoodle.Coroutine.Scroll@@ -53,17 +53,19 @@ import Hoodle.Coroutine.Select.Clipboard import Hoodle.Coroutine.TextInput import Hoodle.Coroutine.Mode+import Hoodle.Coroutine.VerticalSpace import Hoodle.Coroutine.Window import Hoodle.Device import Hoodle.GUI.Menu+import Hoodle.GUI.Reflect import Hoodle.ModelAction.File-import Hoodle.ModelAction.Layer + import Hoodle.ModelAction.Page import Hoodle.ModelAction.Window import Hoodle.Script import Hoodle.Script.Hook import Hoodle.Type.Canvas-import Hoodle.Type.Clipboard+ import Hoodle.Type.Coroutine import Hoodle.Type.Enum import Hoodle.Type.Event@@ -71,6 +73,7 @@ import Hoodle.Type.Undo import Hoodle.Type.Window import Hoodle.Type.HoodleState+import Hoodle.Widget.PanZoom -- import Prelude hiding ((.), id) @@ -85,11 +88,11 @@ initCoroutine devlst window mfname mhook maxundo xinputbool = do evar <- newEmptyMVar putMVar evar Nothing - let st0new = set deviceList devlst + st0new <- set deviceList devlst . set rootOfRootWindow window . set callBack (eventHandler evar) - $ emptyHoodleState - ui <- getMenuUI evar + <$> emptyHoodleState + (ui,uicompsighdlr) <- getMenuUI evar let st1 = set gtkUIManager ui st0new initcvs = defaultCvsInfoSinglePage { _canvasId = 1 } initcvsbox = CanvasSinglePage initcvs@@ -98,11 +101,12 @@ $ st1 { _cvsInfoMap = M.empty } (st3,cvs,_wconf) <- constructFrame st2 (view frameState st2) (st4,wconf') <- eventConnect st3 (view frameState st3)- let st5 = set doesUseXInput xinputbool + let st5 = set (settings.doesUseXInput) xinputbool . set hookSet mhook . set undoTable (emptyUndo maxundo) . set frameState wconf' . set rootWindow cvs + . set uiComponentSignalHandler uicompsighdlr $ st4 st6 <- getFileContent mfname st5@@ -120,31 +124,15 @@ return (evar,startingXstate,ui,vbox) --- | -initViewModeIOAction :: MainCoroutine HoodleState-initViewModeIOAction = do - oxstate <- get- let ui = view gtkUIManager oxstate- agr <- liftIO $ uiManagerGetActionGroups ui - Just ra <- liftIO $ actionGroupGetAction (head agr) "CONTA"- let wra = castToRadioAction ra - connid <- liftIO $ wra `on` radioActionChanged $ \x -> do - y <- viewModeToMyEvent x - view callBack oxstate y - return () - let xstate = set pageModeSignal (Just connid) oxstate- put xstate - return xstate - -- | initialization according to the setting initialize :: MyEvent -> MainCoroutine () initialize ev = do - liftIO $ putStrLn $ show ev case ev of Initialized -> do return () -- additional initialization goes here viewModeChange ToContSinglePage- pageZoomChange (Zoom 0.3) + -- pageZoomChange (Zoom 0.3) + pageZoomChange FitWidth _ -> do ev' <- nextevent initialize ev' @@ -153,7 +141,11 @@ guiProcess ev = do initialize ev changePage (const 0)- xstate <- initViewModeIOAction + xstate <- get + reflectViewModeUI+ reflectPenModeUI+ reflectPenColorUI + reflectPenWidthUI let cinfoMap = getCanvasInfoMap xstate assocs = M.toList cinfoMap f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox@@ -175,18 +167,21 @@ r1 <- nextevent case r1 of PenDown cid pbtn pcoord -> do - ptype <- getPenType - case (ptype,pbtn) of - (PenWork,PenButton1) -> penStart cid pcoord - (PenWork,PenButton2) -> eraserStart cid pcoord - (PenWork,PenButton3) -> do - updateXState (return . set isOneTimeSelectMode YesBeforeSelect)- modeChange ToSelectMode- selectLassoStart cid pcoord- (PenWork,EraserButton) -> eraserStart cid pcoord- (EraserWork,_) -> eraserStart cid pcoord - (HighlighterWork,_) -> highlighterStart cid pcoord- -- _ -> return () + widgetCheckPen cid pcoord $ do + ptype <- getPenType + case (ptype,pbtn) of + (PenWork,PenButton1) -> penStart cid pcoord+ (PenWork,PenButton2) -> eraserStart cid pcoord + (PenWork,PenButton3) -> do + updateXState (return . set isOneTimeSelectMode YesBeforeSelect)+ modeChange ToSelectMode+ selectLassoStart cid pcoord+ (PenWork,EraserButton) -> eraserStart cid pcoord+ (EraserWork,_) -> eraserStart cid pcoord + (HighlighterWork,_) -> highlighterStart cid pcoord+ (VerticalSpaceWork,PenButton1) -> verticalSpaceStart cid pcoord + (VerticalSpaceWork,_) -> return () + PenMove cid pcoord -> notifyLink cid pcoord _ -> defaultEventProcess r1 -- |@@ -200,18 +195,13 @@ SelectRectangleWork -> selectRectStart cid pcoord SelectRegionWork -> selectLassoStart cid pcoord _ -> return ()+ PenMove cid pcoord -> notifyLink cid pcoord PenColorChanged c -> do modify (penInfo.currentTool.penColor .~ c) selectPenColorChanged c PenWidthChanged v -> do w <- flip int2Point v . view (penInfo.penType) <$> get modify (penInfo.currentTool.penWidth .~ w) selectPenWidthChanged w -{- st <- get - let ptype = view (penInfo.penType) st- let w = int2Point ptype v- selectPenWidthChanged w- let stNew = set (penInfo.currentTool.penWidth) w st - put stNew -} _ -> defaultEventProcess r1 @@ -232,19 +222,9 @@ defaultEventProcess (AssignPenMode t) = case t of Left pm -> do - -- xst <- get - -- let cvs = unboxGet drawArea . snd. view currentCanvas $ xst - -- win <- liftIO $ widgetGetDrawWindow cvs - -- cursor <- liftIO $ cursorNew BlankCursor - -- liftIO $ drawWindowSetCursor win (Just cursor) modify (penInfo.penType .~ pm) modeChange ToViewAppendMode Right sm -> do - -- xst <- get - -- let cvs = unboxGet drawArea . snd. view currentCanvas $ xst - -- win <- liftIO $ widgetGetDrawWindow cvs - -- cursor <- cursorNew Dot - -- liftIO $ drawWindowSetCursor win Nothing modify (selectInfo.selectType .~ sm) modeChange ToSelectMode defaultEventProcess (PenColorChanged c) = @@ -261,11 +241,10 @@ let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate pgs = view gpages hdl - (_,cpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)+ cpage = getPageFromGHoodleMap pgnum hdl cbkg = view gbackground cpage nbkg - | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg - in bkg2RBkg bkg { bkg_style = convertBackgroundStyleToByteString bsty } + | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } | otherwise = cbkg npage = set gbackground nbkg cpage npgs = set (at pgnum) (Just npage) pgs @@ -274,12 +253,19 @@ modify (set hoodleModeState (ViewAppendState nhdl)) invalidateAll defaultEventProcess (GotContextMenuSignal ctxtmenu) = processContextMenu ctxtmenu+defaultEventProcess (GetHoodleFileInfo ref) = do + xst <- get+ let hdl = getHoodle xst + uuid = B.unpack (view ghoodleID hdl)+ case view (hoodleFileControl.hoodleFileName) xst of + Nothing -> liftIO $ writeIORef ref Nothing+ Just fp -> liftIO $ writeIORef ref (Just (uuid ++ "," ++ fp))+defaultEventProcess (GotLink mstr (x,y)) = gotLink mstr (x,y) defaultEventProcess ev = -- for debugging- do liftIO $ putStrLn "--- no default ---"- liftIO $ print ev - liftIO $ putStrLn "------------------"- return () -+ do liftIO $ putStrLn "--- no default ---"+ liftIO $ print ev + liftIO $ putStrLn "------------------"+ return () -- | menuEventProcess :: MenuEvent -> MainCoroutine () @@ -331,21 +317,25 @@ menuEventProcess MenuDeleteLayer = deleteCurrentLayer menuEventProcess MenuUseXInput = do xstate <- get - b <- updateFlagFromToggleUI "UXINPUTA" doesUseXInput + b <- updateFlagFromToggleUI "UXINPUTA" (settings.doesUseXInput) 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-menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" doesSmoothScroll >> return ()-menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" doesUsePopUpMenu >> return ()-menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" doesEmbedImage >> return ()+menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" (settings.doesSmoothScroll) >> return ()+menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" (settings.doesUsePopUpMenu) >> return ()+menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" (settings.doesEmbedImage) >> return ()+menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return () menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return () menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess MenuColorPicker = colorPick menuEventProcess MenuFullScreen = fullScreen menuEventProcess MenuText = textInput +menuEventProcess MenuAddLink = addLink menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage +menuEventProcess MenuEmbedPredefinedImage2 = embedPredefinedImage2 +menuEventProcess MenuEmbedPredefinedImage3 = embedPredefinedImage3 menuEventProcess MenuApplyToAllPages = do xstate <- get let bsty = view backgroundStyle xstate @@ -354,8 +344,7 @@ changeBkg cpage = let cbkg = view gbackground cpage nbkg - | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg - in bkg2RBkg bkg { bkg_style = convertBackgroundStyleToByteString bsty } + | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } | otherwise = cbkg in set gbackground nbkg cpage npgs = fmap changeBkg pgs @@ -363,6 +352,7 @@ modeChange ToViewAppendMode modify (set hoodleModeState (ViewAppendState nhdl)) invalidateAll +menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m
src/Hoodle/Coroutine/Draw.hs view
@@ -16,9 +16,8 @@ -- from other packages import Control.Applicative -import Control.Category import qualified Data.IntMap as M-import Control.Lens+import Control.Lens (view,set) import Control.Monad import Control.Monad.Trans import Control.Monad.State@@ -36,8 +35,8 @@ import Hoodle.Type.HoodleState import Hoodle.View.Draw -- -import Prelude hiding ((.),id) + -- | data DrawingFunctionSet = DrawingFunctionSet { singleEditDraw :: DrawingFunction SinglePage EditMode@@ -103,35 +102,26 @@ -> DrawFlag -> CanvasId -> MainCoroutine () invalidateInBBox mbbox flag cid = do + xst <- get + geometry <- liftIO $ getCanvasGeometryCvsId cid xst invalidateGeneral cid mbbox flag - drawSinglePage drawSinglePageSel drawContHoodle drawContHoodleSel--+ drawSinglePage (drawSinglePageSel geometry) drawContHoodle (drawContHoodleSel geometry) -- | invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate -> DrawFlag -> MainCoroutine () invalidateAllInBBox mbbox flag = applyActionToAllCVS (invalidateInBBox mbbox flag)-{- do - xstate <- get- let cinfoMap = getCanvasInfoMap xstate- keys = M.keys cinfoMap - forM_ keys (invalidateInBBox mbbox flag)--} -- | - invalidateAll :: MainCoroutine () invalidateAll = invalidateAllInBBox Nothing Clear -- | Invalidate Current canvas- invalidateCurrent :: MainCoroutine () invalidateCurrent = invalidate . getCurrentCanvasId =<< get -- | Drawing temporary gadgets- invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine () invalidateTemp cid tempsurface rndr = do xst <- get @@ -148,7 +138,26 @@ paint xformfunc rndr - +{- +-- | Drawing temporary gadgets more generally+invalidateTempGen :: CanvasId -> Surface -> Render () -> Render () + -> MainCoroutine ()+invalidateTempGen cid tempsurface xformfunc rndr = do + xst <- get + selectBoxAction (fsingle xst) (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+ liftIO $ renderWithDrawable win $ do + xformfunc + setSourceSurface tempsurface 0 0 + setOperator OperatorSource + paint + rndr +-}+ -- | Drawing temporary gadgets with coordinate based on base page invalidateTempBasePage :: CanvasId -> Surface -> PageNum -> Render () @@ -186,3 +195,6 @@ currcid <- liftM (getCurrentCanvasId) get when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) +-- ++
src/Hoodle/Coroutine/Eraser.hs view
@@ -12,13 +12,11 @@ module Hoodle.Coroutine.Eraser where -import Control.Category--- import Data.Label import qualified Data.IntMap as IM-import Control.Lens-import Control.Monad.State +import Control.Lens (view,set,over)+import Control.Monad.State import qualified Control.Monad.State as St-import Graphics.UI.Gtk hiding (get,set,disconnect)+-- import Graphics.UI.Gtk hiding (get,set,disconnect) -- import Data.Hoodle.Generic import Data.Hoodle.BBox@@ -34,7 +32,6 @@ import Hoodle.Device import Hoodle.View.Coordinate import Hoodle.View.Draw-import Hoodle.Coroutine.EventConnect import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Commit import Hoodle.Accessor@@ -43,27 +40,25 @@ import Hoodle.ModelAction.Layer import Hoodle.Coroutine.Pen ---import Prelude hiding ((.), id) -- | eraserStart :: CanvasId -> PointerCoord -> MainCoroutine () eraserStart cid = commonPenStart eraserAction cid - where eraserAction _cinfo pnum geometry (cidup,cidmove) (x,y) = do + where eraserAction _cinfo pnum geometry (x,y) = do itms <- rItmsInCurrLyr- eraserProcess cid pnum geometry cidup cidmove itms (x,y)+ eraserProcess cid pnum geometry itms (x,y) -- | eraserProcess :: CanvasId -> PageNum -> CanvasGeometry- -> ConnectId DrawingArea -> ConnectId DrawingArea - -> [RItem] -- [StrokeBBox] + -> [RItem] -> (Double,Double) -> MainCoroutine () -eraserProcess cid pnum geometry connidmove connidup itms (x0,y0) = do +eraserProcess cid pnum geometry itms (x0,y0) = do r <- nextevent xst <- get boxAction (f r xst) . getCanvasInfo cid $ xst @@ -71,8 +66,8 @@ f :: (ViewMode a) => MyEvent -> HoodleState -> CanvasInfo a -> MainCoroutine () f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cvsInfo) upact- defact = eraserProcess cid pnum geometry connidup connidmove itms (x0,y0)- upact _ = disconnect [connidmove,connidup] >> invalidateAll+ defact = eraserProcess cid pnum geometry itms (x0,y0)+ upact _ = invalidateAll moveact xstate cvsInfo (_pcoord,(x,y)) = do let line = ((x0,y0),(x,y)) hittestbbox = hltHittedByLineRough line itms@@ -84,19 +79,18 @@ let currhdl = unView . view hoodleModeState $ xstate dim = view gdimension page pgnum = view currentPageNum cvsInfo- (mcurrlayer, currpage) = getCurrentLayerOrSet page- currlayer = maybe (error "eraserProcess") id mcurrlayer+ currlayer = getCurrentLayer page let (newitms,maybebbox1) = St.runState (eraseHitted hittestitem) Nothing maybebbox = fmap (flip inflate 2.0) maybebbox1 newlayerbbox <- liftIO . updateLayerBuf dim maybebbox . set gitems newitms $ currlayer - let newpagebbox = adjustCurrentLayer newlayerbbox currpage + let newpagebbox = adjustCurrentLayer newlayerbbox page newhdlbbox = over gpages (IM.adjust (const newpagebbox) pgnum) currhdl newhdlmodst = ViewAppendState newhdlbbox commit . set hoodleModeState newhdlmodst =<< (liftIO (updatePageAll newhdlmodst xstate)) invalidateInBBox Nothing Efficient cid nitms <- rItmsInCurrLyr- eraserProcess cid pnum geometry connidup connidmove nitms (x,y)- else eraserProcess cid pnum geometry connidmove connidup itms (x,y) + eraserProcess cid pnum geometry nitms (x,y)+ else eraserProcess cid pnum geometry itms (x,y)
− src/Hoodle/Coroutine/EventConnect.hs
@@ -1,78 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Hoodle.Coroutine.EventConnect --- Copyright : (c) 2011, 2012 Ian-Woo Kim------ License : BSD3--- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>--- Stability : experimental--- Portability : GHC-----------------------------------------------------------------------------------module Hoodle.Coroutine.EventConnect where--import Graphics.UI.Gtk hiding (get,set,disconnect)--- import qualified Control.Monad.State as St-import Control.Applicative-import Control.Monad.Trans-import Control.Category-import Control.Lens-import Control.Monad.State --- -import Control.Monad.Trans.Crtn.Event-import Control.Monad.Trans.Crtn.Queue --- -import Hoodle.Type.Event-import Hoodle.Type.Canvas-import Hoodle.Type.HoodleState-import Hoodle.Device-import Hoodle.Type.Coroutine--- -import Prelude hiding ((.), id)---- |-disconnect :: (WidgetClass w) => [ConnectId w] -> MainCoroutine () -disconnect is = modify (tempQueue %~ enqueue action) >> go - where - go = do r <- nextevent - case r of- EventDisconnected -> return ()- _ -> go - action = Left . ActionOrder $ - \_ -> mapM_ signalDisconnect is >> return EventDisconnected--- liftIO . signalDisconnect---- |-connectPenUp :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea) -connectPenUp cinfo = do - let cid = view canvasId cinfo- canvas = view drawArea cinfo - connPenUp canvas cid ---- |-connectPenMove :: CanvasInfo a -> MainCoroutine (ConnectId DrawingArea) -connectPenMove cinfo = do - let cid = view canvasId cinfo- canvas = view drawArea cinfo - connPenMove canvas cid ---- |--connPenMove :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w) -connPenMove c cid = do - callbk <- view callBack <$> get- dev <- view deviceList <$> get- liftIO (c `on` motionNotifyEvent $ tryEvent $ do - (_,p) <- getPointer dev- liftIO (callbk (PenMove cid p)))---- | - -connPenUp :: (WidgetClass w) => w -> CanvasId -> MainCoroutine (ConnectId w)-connPenUp c cid = do - callbk <- view callBack <$> get- dev <- view deviceList <$> get- liftIO (c `on` buttonReleaseEvent $ tryEvent $ do - (_,p) <- getPointer dev- liftIO (callbk (PenMove cid p)))
src/Hoodle/Coroutine/File.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.File --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,32 +17,31 @@ module Hoodle.Coroutine.File where -- from other packages-import Control.Category-import Control.Lens-import Control.Monad.State+import Control.Lens (view,set,over,(%~))+import Control.Monad.Loops+import Control.Monad.State hiding (mapM) import Control.Monad.Trans.Either import Data.ByteString (readFile) import Data.ByteString.Base64 import Data.ByteString.Char8 as B (pack) import qualified Data.ByteString.Lazy as L+import Data.Maybe import qualified Data.IntMap as IM import Graphics.GD.ByteString import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set) import System.Directory--- import System.Environment import System.Exit import System.FilePath import System.Process --- import System.IO (writeFile) -- from hoodle-platform import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue +import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Simple import Data.Hoodle.Select--- import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Generic import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type@@ -56,22 +57,35 @@ import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select+import Hoodle.ModelAction.Select.Transform import Hoodle.ModelAction.Window import qualified Hoodle.Script.Coroutine as S import Hoodle.Script.Hook+-- import Hoodle.Type.Alias import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Event hiding (SVG) import Hoodle.Type.HoodleState-import Hoodle.Util+import Hoodle.Type.PageArrangement+import Hoodle.View.Draw ---import Prelude hiding ((.),id,readFile)+import Prelude hiding (readFile,concat,mapM) +-- | +waitSomeEvent :: (MyEvent -> Bool) -> MainCoroutine MyEvent +waitSomeEvent p = do + r <- nextevent+ case r of + UpdateCanvas cid -> -- this is temporary+ invalidateInBBox Nothing Efficient cid >> waitSomeEvent p + _ -> if p r then return r else waitSomeEvent p ++ -- | okMessageBox :: String -> MainCoroutine () okMessageBox msg = modify (tempQueue %~ enqueue action) - >> waitSomeEvent (==GotOk) + >> waitSomeEvent (\x->case x of GotOk -> True ; _ -> False) >> return () where action = Left . ActionOrder $ @@ -85,10 +99,12 @@ -- | okCancelMessageBox :: String -> MainCoroutine Bool okCancelMessageBox msg = modify (tempQueue %~ enqueue action) - >> waitSomeEvent p >>= return . p + >> waitSomeEvent p >>= return . q where - p (OkCancel b) = b -- True + p (OkCancel _) = True p _ = False + q (OkCancel b) = b + q _ = False action = Left . ActionOrder $ \_evhandler -> do dialog <- messageDialogNew Nothing [DialogModal]@@ -104,20 +120,29 @@ fileChooser :: FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath) fileChooser choosertyp mfname = do mrecentfolder <- S.recentFolderHook - modify (tempQueue %~ enqueue (action mrecentfolder)) >> go + xst <- get + let rtrwin = view rootOfRootWindow xst + liftIO $ widgetQueueDraw rtrwin + + modify (tempQueue %~ enqueue (action rtrwin mrecentfolder)) >> go where go = do r <- nextevent case r of FileChosen b -> return b + UpdateCanvas cid -> -- this is temporary+ invalidateInBBox Nothing Efficient cid >> go _ -> go - action mrf = Left . ActionOrder $ \_evhandler -> do - dialog <- fileChooserDialogNew Nothing Nothing choosertyp + action win mrf = Left . ActionOrder $ \_evhandler -> do + dialog <- fileChooserDialogNew Nothing (Just win) choosertyp [ ("OK", ResponseOk) , ("Cancel", ResponseCancel) ] case mrf of Just rf -> fileChooserSetCurrentFolder dialog rf Nothing -> getCurrentDirectory >>= fileChooserSetCurrentFolder dialog maybe (return ()) (fileChooserSetCurrentName dialog) mfname + -- !!!!!! really hackish solution !!!!!!+ whileM_ (liftM (>0) eventsPending) (mainIterationDo False)+ res <- dialogRun dialog mr <- case res of ResponseDeleteEvent -> return Nothing@@ -139,9 +164,15 @@ False -> return () else action ---+-- | +askIfOverwrite :: FilePath -> MainCoroutine () -> MainCoroutine () +askIfOverwrite fp action = do + b <- liftIO $ doesFileExist fp + if b + then do + r <- okCancelMessageBox ("Overwrite " ++ fp ++ "???") + if r then action else return () + else action -- | fileNew :: MainCoroutine () @@ -158,7 +189,7 @@ fileSave :: MainCoroutine () fileSave = do xstate <- get - case view currFileName xstate of+ case view (hoodleFileControl.hoodleFileName) xstate of Nothing -> fileSaveAs Just filename -> do -- this is rather temporary not to make mistake @@ -184,11 +215,9 @@ renderjob h ofp = do let p = maybe (error "renderjob") id $ IM.lookup 0 (view gpages h) let Dim width height = view gdimension p - let rf :: InBBox RPage -> Render ()- rf x = cairoRenderOption (InBBoxOption Nothing) x >> return () + let rf x = cairoRenderOption (RBkgDrawPDF,DrawFull) x >> return () withPDFSurface ofp width height $ \s -> renderWith s $ - -- (sequence1_ showPage . map renderPage . hoodle_pages) h - (sequence1_ showPage . map (rf . InBBox) . IM.elems . view gpages ) h + (sequence1_ showPage . map rf . IM.elems . view gpages ) h -- | fileExport :: MainCoroutine ()@@ -200,7 +229,7 @@ then fileExtensionInvalid (".pdf","export") >> fileExport else do xstate <- get - let hdl = getHoodle xstate -- (rHoodle2Hoodle . getHoodle) xstate + let hdl = getHoodle xstate liftIO (renderjob hdl filename) @@ -234,10 +263,7 @@ invalidateAll applyActionToAllCVS adjustScrollbarWithGeometryCvsId --- let hdlmodst = view hoodleModeState xstate1--- hdlmodst' <- liftIO $ resetHoodleModeStateBuffers hdlmodst --- let xstate' = set hoodleModeState hdlmodst' xstate1-+-- | resetHoodleBuffers :: MainCoroutine () resetHoodleBuffers = do liftIO $ putStrLn "resetHoodleBuffers called"@@ -246,9 +272,6 @@ let nxst = set hoodleModeState nhdlst xst put nxst --- -- | main coroutine for open a file fileOpen :: MainCoroutine () fileOpen = do @@ -277,34 +300,35 @@ if takeExtension filename /= ".hdl" then fileExtensionInvalid (".hdl","save") else do - let ntitle = B.pack . snd . splitFileName $ filename - (hdlmodst',hdl') = case view hoodleModeState xst' of- ViewAppendState hdlmap -> - if view gtitle hdlmap == "untitled"- then ( ViewAppendState . set gtitle ntitle- $ hdlmap- , (set title ntitle hd))- else (ViewAppendState hdlmap,hd)- SelectState thdl -> - if view gselTitle thdl == "untitled"- then ( SelectState $ set gselTitle ntitle thdl - , set title ntitle hd) - else (SelectState thdl,hd)- xstateNew = set currFileName (Just filename) - . set hoodleModeState hdlmodst' $ xst'- liftIO . L.writeFile filename . builder $ hdl'- put . set isSaved True $ xstateNew - let ui = view gtkUIManager xstateNew- liftIO $ toggleSave ui False- liftIO $ setTitleFromFileName xstateNew - S.afterSaveHook filename hdl'+ askIfOverwrite filename $ do + let ntitle = B.pack . snd . splitFileName $ filename + (hdlmodst',hdl') = case view hoodleModeState xst' of+ ViewAppendState hdlmap -> + if view gtitle hdlmap == "untitled"+ then ( ViewAppendState . set gtitle ntitle+ $ hdlmap+ , (set title ntitle hd))+ else (ViewAppendState hdlmap,hd)+ SelectState thdl -> + if view gselTitle thdl == "untitled"+ then ( SelectState $ set gselTitle ntitle thdl + , set title ntitle hd) + else (SelectState thdl,hd)+ xstateNew = set (hoodleFileControl.hoodleFileName) (Just filename) + . set hoodleModeState hdlmodst' $ xst'+ liftIO . L.writeFile filename . builder $ hdl'+ put . set isSaved True $ xstateNew + let ui = view gtkUIManager xstateNew+ liftIO $ toggleSave ui False+ liftIO $ setTitleFromFileName xstateNew + S.afterSaveHook filename hdl' -- | main coroutine for open a file fileReload :: MainCoroutine () fileReload = do xstate <- get- case view currFileName xstate of + case view (hoodleFileControl.hoodleFileName) xstate of Nothing -> return () Just filename -> do if not (view isSaved xstate) @@ -329,13 +353,14 @@ fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action where warning = do - okMessageBox "cannot load the pdf file. Check your hoodle compiled with poppler library"+ okMessageBox "cannot load the pdf file. Check your hoodle compiled with poppler library" invalidateAll action filename = do xstate <- get - mhdl <- liftIO $ makeNewHoodleWithPDF filename + let doesembed = view (settings.doesEmbedPDF) xstate+ mhdl <- liftIO $ makeNewHoodleWithPDF doesembed filename flip (maybe warning) mhdl $ \hdl -> do - xstateNew <- return . set currFileName Nothing + xstateNew <- return . set (hoodleFileControl.hoodleFileName) Nothing =<< (liftIO $ constructNewHoodleStateFromHoodle hdl xstate) commit xstateNew liftIO $ setTitleFromFileName xstateNew @@ -348,29 +373,41 @@ fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action where action filename = do - xstate <- get - liftIO $ putStrLn filename - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate- hdl = getHoodle xstate - (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)- currlayer = maybeError' "something wrong in addPDraw" mcurrlayer - isembedded = view doesEmbedImage xstate - newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) - - 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) "fileLoadPNGorJPG"- nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate- put nxstate2- invalidateAll -+ xst <- get + let isembedded = view (settings.doesEmbedImage) xst + nitm <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) + insertItemAt Nothing nitm +insertItemAt :: Maybe (PageNum,PageCoordinate) + -> RItem + -> MainCoroutine () +insertItemAt mpcoord ritm = do + xst <- get + let hdl = getHoodle xst + (pgnum,mpos) = case mpcoord of + Just (PageNum n,pos) -> (n,Just pos)+ Nothing -> ((unboxGet currentPageNum.view currentCanvasInfo) xst,Nothing)+ (ulx,uly) = (bbox_upperleft.getBBox) ritm+ nitm = case mpos of + Nothing -> ritm + Just (PageCoord (nx,ny)) -> + 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 [nitm]) :- 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 + let nxst2 = set hoodleModeState (SelectState nthdl) nxst+ put nxst2+ invalidateAll + -- | makeNewItemImage :: Bool -- ^ isEmbedded? -> FilePath @@ -393,7 +430,7 @@ bstr <- savePngByteString img let b64str = encode bstr ebdsrc = "data:image/png;base64," <> b64str- return . ItemImage $ Image ebdsrc (100,100) dim -- (Dim 300 300)+ return . ItemImage $ Image ebdsrc (100,100) dim loadjpg = do img <- loadJpegFile filename (w,h) <- imageSize img @@ -402,7 +439,7 @@ bstr <- savePngByteString img let b64str = encode bstr ebdsrc = "data:image/png;base64," <> b64str- return . ItemImage $ Image ebdsrc (100,100) dim -- (Dim 300 300) + return . ItemImage $ Image ebdsrc (100,100) dim -- | fileLoadSVG :: MainCoroutine ()@@ -415,8 +452,8 @@ bstr <- liftIO $ readFile filename let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate - (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)- currlayer = maybeError' "something wrong in addPDraw" mcurrlayer + currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage newitem <- (liftIO . cnstrctRItem . ItemSVG) (SVG Nothing Nothing bstr (100,100) (Dim 300 300)) let otheritems = view gitems currlayer @@ -448,15 +485,12 @@ dialog <- messageDialogNew Nothing [DialogModal] MessageQuestion ButtonsOkCancel "latex input" vbox <- dialogGetUpper dialog- -- entry <- entryNew - -- boxPackStart vbox entry PackGrow 0 txtvw <- textViewNew boxPackStart vbox txtvw PackGrow 0 widgetShowAll dialog res <- dialogRun dialog case res of ResponseOk -> do - -- l <- entryGetText entry buf <- textViewGetBuffer txtvw istart <- textBufferGetStartIter buf iend <- textBufferGetEndIter buf@@ -480,8 +514,8 @@ xstate <- get let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate - (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)- currlayer = maybeError' "something wrong in addPDraw" mcurrlayer + currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage newitem <- (liftIO . cnstrctRItem . ItemSVG) (SVG (Just latex) Nothing svg (100,100) (Dim 300 50)) let otheritems = view gitems currlayer @@ -518,8 +552,8 @@ xstate <- get let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate - (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)- currlayer = maybeError' "something wrong in addPDraw" mcurrlayer + currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage isembedded = True newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) @@ -531,6 +565,80 @@ SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "embedPredefinedImage" nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate+ let nxstate2 = set isOneTimeSelectMode YesAfterSelect + . set hoodleModeState (SelectState nthdl) + $ nxstate put nxstate2 invalidateAll + +-- | this is temporary. I will remove it+embedPredefinedImage2 :: MainCoroutine () +embedPredefinedImage2 = do + liftIO $ putStrLn "embedPredefinedImage2"+ mpredefined <- S.embedPredefinedImage2Hook + liftIO $ print mpredefined+ case mpredefined of + Nothing -> return () + Just filename -> do + xstate <- get + let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ hdl = getHoodle xstate + currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage+ isembedded = True+ newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) ++ 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) "embedPredefinedImage2"+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set isOneTimeSelectMode YesAfterSelect + . set hoodleModeState (SelectState nthdl) + $ nxstate+ put nxstate2+ invalidateAll + +-- | this is temporary. I will remove it+embedPredefinedImage3 :: MainCoroutine () +embedPredefinedImage3 = do + liftIO $ putStrLn "embedPredefinedImage3"+ mpredefined <- S.embedPredefinedImage3Hook + liftIO $ print mpredefined+ case mpredefined of + Nothing -> return () + Just filename -> do + xstate <- get + let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ hdl = getHoodle xstate + currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage+ isembedded = True+ newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) ++ 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) "embedPredefinedImage3"+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set isOneTimeSelectMode YesAfterSelect + . set hoodleModeState (SelectState nthdl) + $ nxstate+ put nxstate2+ invalidateAll + +-- | +embedAllPDFBackground :: MainCoroutine () +embedAllPDFBackground = do + xst <- get + let hdl = getHoodle xst+ nhdl <- liftIO . embedPDFInHoodle $ hdl+ modeChange ToViewAppendMode+ commit (set hoodleModeState (ViewAppendState nhdl) xst)+ invalidateAll
src/Hoodle/Coroutine/Layer.hs view
@@ -16,7 +16,6 @@ import Control.Monad.State import qualified Data.IntMap as M-import Control.Compose import Control.Category -- import Data.Label import Control.Lens (view,set)@@ -57,63 +56,46 @@ makeNewLayer :: MainCoroutine () makeNewLayer = layerAction newlayeraction >>= commit where newlayeraction hdlmodst cpn page = do - let (_,currpage) = getCurrentLayerOrSet page- Select (O (Just lyrzipper)) = view glayers currpage - -- emptylyr <- liftIO ( emptyRLayer) - let emptylyr = emptyRLayer - let nlyrzipper = appendGoLast lyrzipper emptylyr - npage = set glayers (Select (O (Just nlyrzipper))) currpage+ let lyrzipper = view glayers page + emptylyr = emptyRLayer + nlyrzipper = appendGoLast lyrzipper emptylyr + npage = set glayers nlyrzipper page return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst gotoNextLayer :: MainCoroutine () gotoNextLayer = layerAction nextlayeraction >>= put where nextlayeraction hdlmodst cpn page = do - let (_,currpage) = getCurrentLayerOrSet page- Select (O (Just lyrzipper)) = view glayers currpage - let mlyrzipper = moveRight lyrzipper - - npage = maybe currpage (\x-> set glayers (Select (O (Just x))) currpage) mlyrzipper- case mlyrzipper of - Nothing -> liftIO $ putStrLn "Nothing"- Just _ -> liftIO $ putStrLn "Just"+ let lyrzipper = view glayers page + mlyrzipper = moveRight lyrzipper + npage = maybe page (\x-> set glayers x page) mlyrzipper return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst gotoPrevLayer :: MainCoroutine () gotoPrevLayer = layerAction prevlayeraction >>= put where prevlayeraction hdlmodst cpn page = do - let (_,currpage) = getCurrentLayerOrSet page- Select (O (Just lyrzipper)) = view glayers currpage - let mlyrzipper = moveLeft lyrzipper - npage = maybe currpage (\x -> set glayers (Select (O (Just x))) currpage) mlyrzipper- case mlyrzipper of - Nothing -> liftIO $ putStrLn "Nothing"- Just _ -> liftIO $ putStrLn "Just"+ let lyrzipper = view glayers page + mlyrzipper = moveLeft lyrzipper + npage = maybe page (\x -> set glayers x page) mlyrzipper return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst gotoLayerAt :: Int -> MainCoroutine () gotoLayerAt n = layerAction gotoaction >>= put where gotoaction hdlmodst cpn page = do - let (_,currpage) = getCurrentLayerOrSet page- Select (O (Just lyrzipper)) = view glayers currpage - let mlyrzipper = moveTo n lyrzipper - npage = maybe currpage (\x -> set glayers (Select (O (Just x))) currpage) mlyrzipper+ let lyrzipper = view glayers page + mlyrzipper = moveTo n lyrzipper + npage = maybe page (\x -> set glayers x page) mlyrzipper return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst deleteCurrentLayer :: MainCoroutine () deleteCurrentLayer = layerAction deletelayeraction >>= commit where deletelayeraction hdlmodst cpn page = do - let (mcurrlayer,currpage) = getCurrentLayerOrSet page- flip (maybe (return hdlmodst)) mcurrlayer $ - const $ do - let Select (O (Just lyrzipper)) = view glayers currpage - mlyrzipper = deleteCurrent lyrzipper - npage = maybe currpage - (\x -> set glayers (Select (O (Just x))) currpage) - mlyrzipper- return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst + let lyrzipper = view glayers page + mlyrzipper = deleteCurrent lyrzipper + npage = maybe page (\x -> set glayers x page) mlyrzipper+ return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst startGotoLayerAt :: MainCoroutine () startGotoLayerAt = @@ -124,8 +106,7 @@ let hdlmodst = view hoodleModeState xstate let epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst page = either id (hPage2RPage) epage - (_,currpage) = getCurrentLayerOrSet page- Select (O (Just lyrzipper)) = view glayers currpage+ lyrzipper = view glayers page cidx = currIndex lyrzipper len = lengthSZ lyrzipper lref <- liftIO $ newIORef cidx
+ src/Hoodle/Coroutine/Link.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Link+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Link where++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.UUID.V4 (nextRandom)+import Graphics.UI.Gtk hiding (get,set) +import System.FilePath +-- from hoodle-platform+import Control.Monad.Trans.Crtn.Event +import Control.Monad.Trans.Crtn.Queue +import Data.Hoodle.BBox+import Graphics.Hoodle.Render.Item +import Graphics.Hoodle.Render.Type +import Graphics.Hoodle.Render.Type.HitTest +import Graphics.Hoodle.Render.Util.HitTest +-- from this package+import Hoodle.Accessor+import Hoodle.Coroutine.Draw+import Hoodle.Coroutine.File +import Hoodle.Coroutine.TextInput +import Hoodle.Device +import Hoodle.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.Event+import Hoodle.Type.HoodleState+import Hoodle.Type.PageArrangement+import Hoodle.Util +import Hoodle.View.Coordinate+import Hoodle.View.Draw+--+import Prelude hiding (mapM_, mapM)++notifyLink :: CanvasId -> PointerCoord -> MainCoroutine () +notifyLink cid pcoord = do + xst <- get + (boxAction f . getCanvasInfo cid) xst + where + f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine () + f cvsInfo = do + let cpn = PageNum . view currentPageNum $ cvsInfo+ arr = view (viewInfo.pageArrangement) cvsInfo + canvas = view drawArea cvsInfo+ geometry <- liftIO $ makeCanvasGeometry cpn arr canvas+ case (desktop2Page geometry . device2Desktop geometry) pcoord of+ Nothing -> return () + Just (pnum,PageCoord (x,y)) -> do + itms <- rItmsInCurrLyr + let lnks = filter isLinkInRItem itms + hlnks = hltFilteredBy (\itm->isPointInBBox (getBBox itm) (x,y)) lnks+ hitted = takeHitted hlnks + when ((not.null) hitted) $ do + let lnk = head hitted + bbx = getBBox lnk+ bbx_desk = xformBBox (unDeskCoord . page2Desktop geometry+ . (pnum,) . PageCoord) bbx+ invalidateInBBox (Just bbx_desk) Efficient cid ++-- | got a link address (or embedded image) from drag and drop +gotLink :: Maybe String -> (Int,Int) -> MainCoroutine () +gotLink mstr (x,y) = do + xst <- get + let cid = getCurrentCanvasId xst+ mr <- runMaybeT $ do + str <- (MaybeT . return) mstr + let (str1,rem1) = break (== ',') str + guard ((not.null) rem1)+ return (B.pack str1,tail rem1) + case mr of + Nothing -> do + mr2 <- runMaybeT $ do + str <- (MaybeT . return) mstr + (MaybeT . return) (urlParse str)+ case mr2 of + Nothing -> liftIO $ putStrLn "nothing" + Just (FileUrl file) -> do + liftIO $ print file + let ext = takeExtension file + if ext == ".png" || ext == ".PNG" || ext == ".jpg" || ext == ".JPG" + then do + let isembedded = view (settings.doesEmbedImage) xst + 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 () ++ + + + 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' + liftIO $ putStrLn "gotLink"+ liftIO $ print mstr + liftIO $ print (x,y)++-- | +addLink :: MainCoroutine ()+addLink = do + mfilename <- fileChooser FileChooserActionOpen Nothing + modify (tempQueue %~ enqueue (action mfilename)) + minput <- go+ case minput of + Nothing -> return () + Just (str,fname) -> do + uuid <- liftIO $ nextRandom+ let uuidbstr = B.pack (show uuid)+ rdr <- liftIO (makePangoTextSVG str) + linkInsert "simple" (uuidbstr,fname) str rdr + where + go = do r <- nextevent+ case r of + AddLink minput -> return minput + UpdateCanvas cid -> -- this is temporary + (invalidateInBBox Nothing Efficient cid) >> go + _ -> go + action mfn = Left . ActionOrder $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal]+ MessageQuestion ButtonsOkCancel "add link" + vbox <- dialogGetUpper dialog+ txtvw <- textViewNew+ boxPackStart vbox txtvw PackGrow 0 + widgetShowAll dialog+ res <- dialogRun dialog + case res of + ResponseOk -> do + buf <- textViewGetBuffer txtvw + (istart,iend) <- (,) <$> textBufferGetStartIter buf+ <*> textBufferGetEndIter buf+ l <- textBufferGetText buf istart iend True+ widgetDestroy dialog+ return (AddLink ((l,) <$> mfn))+ _ -> do + widgetDestroy dialog+ return (AddLink Nothing)++ + ++++
src/Hoodle/Coroutine/Mode.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Mode --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,15 +15,11 @@ module Hoodle.Coroutine.Mode where import Control.Applicative-import Control.Category-import Control.Lens+import Control.Lens (view,set,over) import Control.Monad.State --- import Control.Monad.Trans import qualified Data.IntMap as M-import Graphics.UI.Gtk hiding (get,set) -- (adjustmentGetValue)+import Graphics.UI.Gtk (adjustmentGetValue) -- from hoodle-platform--- import Control.Monad.Trans.Crtn.Event --- import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Select@@ -33,22 +29,26 @@ import Hoodle.Accessor import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Scroll+import Hoodle.GUI.Reflect import Hoodle.Type.Alias 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.View.Coordinate ---import Prelude hiding ((.),id, mapM_, mapM)+import Prelude hiding (mapM_, mapM) modeChange :: MyEvent -> MainCoroutine () -modeChange command = case command of - ToViewAppendMode -> updateXState select2edit >> invalidateAll - ToSelectMode -> updateXState edit2select >> invalidateAll - _ -> return ()+modeChange command = do + case command of + ToViewAppendMode -> updateXState select2edit >> invalidateAll + ToSelectMode -> updateXState edit2select >> invalidateAll + _ -> return ()+ reflectPenModeUI+ reflectPenColorUI+ reflectPenWidthUI where select2edit xst = either (noaction xst) (whenselect xst) . hoodleModeStateEither . view hoodleModeState $ xst edit2select xst = @@ -64,12 +64,14 @@ npage <- (liftIO.updatePageBuf.hPage2RPage) spage return $ M.adjust (const npage) spgn pages ) mselect+ let nthdl = set gselAll npages . set gselSelected Nothing $ thdl return . flip (set hoodleModeState) xstate - . ViewAppendState . GHoodle (view gselTitle thdl) $ npages + . ViewAppendState . gSelect2GHoodle $ nthdl whenedit :: HoodleState -> Hoodle EditMode -> MainCoroutine HoodleState - whenedit xstate hdl = return . flip (set hoodleModeState) xstate - . SelectState - $ GSelect (view gtitle hdl) (view gpages hdl) Nothing+ whenedit xstate hdl = do + return . flip (set hoodleModeState) xstate + . SelectState + . gHoodle2GSelect $ hdl -- | viewModeChange :: MyEvent -> MainCoroutine () @@ -110,6 +112,7 @@ (view vertAdjustment cinfo) (view horizAdjConnId cinfo) (view vertAdjConnId cinfo)+ (view canvasWidgets cinfo) return $ set currentCanvasInfo (CanvasSinglePage ncinfo) xstate ------------------------------------- whensing xstate cinfo = do @@ -135,6 +138,7 @@ vadj (view horizAdjConnId cinfo) (view vertAdjConnId cinfo)+ (view canvasWidgets cinfo) ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos)) ncinfo = over currentPageNum (const (unPageNum ncpn)) ncinfotemp return . over currentCanvasInfo (const (CanvasContPage ncinfo)) $ xstate
src/Hoodle/Coroutine/Page.hs view
@@ -14,15 +14,13 @@ module Hoodle.Coroutine.Page where -import Control.Category-import Control.Lens+import Control.Lens (view,set,over) import Control.Monad import Control.Monad.State import qualified Data.IntMap as M -- from hoodle-platform import Data.Hoodle.Generic import Data.Hoodle.Select-import qualified Data.Hoodle.Simple as S import Graphics.Hoodle.Render.Type.Background -- from this package import Hoodle.Accessor@@ -40,13 +38,12 @@ import Hoodle.View.Coordinate import Hoodle.View.Draw -- -import Prelude hiding ((.), id) -- | change page of current canvas using a modify function changePage :: (Int -> Int) -> MainCoroutine () changePage modifyfn = updateXState changePageAction >> adjustScrollbarWithGeometryCurrent- >> invalidateAll -- invalidateCurrent+ >> invalidateAll where changePageAction xst = selectBoxAction (fsingle xst) (fcont xst) . view currentCanvasInfo $ xst fsingle xstate cvsInfo = do @@ -88,8 +85,7 @@ | npgnum >= totnumpages = let cbkg = view gbackground lpage nbkg - | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg - in bkg2RBkg bkg { S.bkg_style = convertBackgroundStyleToByteString bsty } + | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } | otherwise = cbkg npage = set gbackground nbkg . newSinglePageFromOld $ lpage@@ -101,12 +97,14 @@ in (False,npg,pg,ehdl) in (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl') + -- | canvasZoomUpdateGenRenderCvsId :: MainCoroutine () -> CanvasId -> Maybe ZoomMode + -> Maybe (PageNum,PageCoordinate) -> MainCoroutine ()-canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode +canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord = updateXState zoomUpdateAction >> adjustScrollbarWithGeometryCvsId cid >> renderfunc@@ -131,8 +129,10 @@ cpn = PageNum $ view currentPageNum cinfo cdim = canvasDim geometry hdl = getHoodle xstate - origcoord = either (const (cpn,PageCoord (0,0))) id - (getCvsOriginInPage geometry)+ origcoord = case mcoord of+ Just coord -> coord + Nothing -> either (const (cpn,PageCoord (0,0))) id + (getCvsOriginInPage geometry) narr = makeContinuousArrangement zmode cdim hdl origcoord ncinfobox = CanvasContPage . set (viewInfo.pageArrangement) narr@@ -143,7 +143,8 @@ canvasZoomUpdateCvsId :: CanvasId -> Maybe ZoomMode -> MainCoroutine ()-canvasZoomUpdateCvsId = canvasZoomUpdateGenRenderCvsId invalidateAll+canvasZoomUpdateCvsId cid mzmode = + canvasZoomUpdateGenRenderCvsId invalidateAll cid mzmode Nothing -- | canvasZoomUpdateBufAll :: MainCoroutine () @@ -152,8 +153,8 @@ mapM_ updatefunc klst where updatefunc cid - = canvasZoomUpdateGenRenderCvsId (invalidateInBBox Nothing Efficient cid) cid Nothing- -- canvasZoomUpdateGenRenderCvsId (invalidateWithBuf cid) cid Nothing+ = canvasZoomUpdateGenRenderCvsId (invalidateInBBox Nothing Efficient cid) cid Nothing Nothing + -- | canvasZoomUpdateAll :: MainCoroutine ()
src/Hoodle/Coroutine/Pen.hs view
@@ -23,7 +23,8 @@ import Data.Sequence hiding (filter) -- import qualified Data.Map as M import Data.Maybe -import Graphics.UI.Gtk hiding (get,set,disconnect)+import Data.Time.Clock +-- import Graphics.UI.Gtk hiding (get,set,disconnect) -- from hoodle-platform import Data.Hoodle.Predefined import Data.Hoodle.BBox@@ -32,7 +33,6 @@ import Hoodle.Device import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Draw-import Hoodle.Coroutine.EventConnect import Hoodle.ModelAction.Page import Hoodle.ModelAction.Pen import Hoodle.Type.Canvas@@ -40,6 +40,7 @@ import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.PageArrangement+import Hoodle.Type.Predefined import Hoodle.Type.HoodleState import Hoodle.Util import Hoodle.View.Coordinate@@ -61,7 +62,6 @@ -- | Common Pen Work starting point commonPenStart :: (forall a. ViewMode a => CanvasInfo a -> PageNum -> CanvasGeometry - -> (ConnectId DrawingArea, ConnectId DrawingArea) -> (Double,Double) -> MainCoroutine () ) -> CanvasId -> PointerCoord -> MainCoroutine ()@@ -85,36 +85,45 @@ -- temporary dirty fix return (set currentPageNum (unPageNum pgn) cvsInfo ) else return cvsInfo - connidup <- connectPenUp nCvsInfo - connidmove <- connectPenMove nCvsInfo- action nCvsInfo pgn geometry (connidup,connidmove) (x,y) + action nCvsInfo pgn geometry (x,y) -- | enter pen drawing mode penStart :: CanvasId -> PointerCoord -> MainCoroutine () penStart cid pcoord = commonPenStart penAction cid pcoord- where penAction :: forall b. (ViewMode b) => CanvasInfo b -> PageNum -> CanvasGeometry -> (ConnectId DrawingArea, ConnectId DrawingArea) -> (Double,Double) -> MainCoroutine ()- penAction _cinfo pnum geometry (cidmove,cidup) (x,y) = do + where penAction :: forall b. (ViewMode b) => CanvasInfo b -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine ()+ penAction _cinfo pnum geometry (x,y) = do xstate <- get let PointerCoord _ _ _ z = pcoord let currhdl = unView . view hoodleModeState $ xstate pinfo = view penInfo xstate- pdraw <-penProcess cid pnum geometry cidmove cidup (empty |> (x,y,z)) ((x,y),z) - (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw- commit . set hoodleModeState (ViewAppendState newhdl) - =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate))- let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord- nbbox = xformBBox f bbox - invalidateAllInBBox (Just nbbox) BkgEfficient -- Efficient+ pdraw <-penProcess cid pnum geometry (empty |> (x,y,z)) ((x,y),z) + case viewl pdraw of + EmptyL -> return ()+ (x1,_y1,_z1) :< _rest -> do + if x1 <= 1e-3 -- this is ad hoc but.. + then do + liftIO $ putStrLn " horizontal line cured !" + invalidateAll+ else do + (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw+ commit . set hoodleModeState (ViewAppendState newhdl) + =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate))+ let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord+ nbbox = xformBBox f bbox + invalidateAllInBBox (Just nbbox) BkgEfficient + + ++ -- | main pen coordinate adding process -- | now being changed penProcess :: CanvasId -> PageNum -> CanvasGeometry- -> ConnectId DrawingArea -> ConnectId DrawingArea -> Seq (Double,Double,Double) -> ((Double,Double),Double) -> MainCoroutine (Seq (Double,Double,Double))-penProcess cid pnum geometry connidmove connidup pdraw ((x0,y0),z0) = do +penProcess cid pnum geometry pdraw ((x0,y0),z0) = do r <- nextevent xst <- get boxAction (fsingle r xst) . getCanvasInfo cid $ xst@@ -124,7 +133,7 @@ -> MainCoroutine (Seq (Double,Double,Double)) fsingle r xstate cvsInfo = penMoveAndUpOnly r pnum geometry - (penProcess cid pnum geometry connidmove connidup pdraw ((x0,y0),z0))+ (penProcess cid pnum geometry pdraw ((x0,y0),z0)) (\(pcoord,(x,y)) -> do let PointerCoord _ _ _ z = pcoord let canvas = view drawArea cvsInfo@@ -142,8 +151,8 @@ False -> NoPressure liftIO $ drawCurvebitGen pressureType (canvas,msfc) geometry pwidth pcolRGBA pnum ((x0,y0),z0) ((x,y),z)- penProcess cid pnum geometry connidmove connidup (pdraw |> (x,y,z)) ((x,y),z) )- (\_ -> disconnect [connidmove,connidup] >> return pdraw )+ penProcess cid pnum geometry (pdraw |> (x,y,z)) ((x,y),z) )+ (\_ -> return pdraw ) -- | skipIfNotInSamePage :: Monad m => @@ -180,7 +189,7 @@ -> m a penMoveAndUpOnly r pgn geometry defact moveaction upaction = case r of - PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction + PenMove _ pcoord -> skipIfNotInSamePage pgn geometry pcoord defact moveaction PenUp _ pcoord -> upaction pcoord _ -> defact @@ -199,6 +208,30 @@ PenUp _ pcoord -> upaction pcoord _ -> defact +++-- | process action when last time was before time diff limit, otherwise+-- just do default action.+processWithTimeInterval :: (Monad m, MonadIO m) => + NominalDiffTime -- ^ time diff+ -> (UTCTime -> m a) -- ^ not larger than time diff bound+ -> (UTCTime -> m a) -- ^ larger than time diff bound + -> UTCTime -- ^ last updated time+ -> m a+processWithTimeInterval tdiffbound defact updateact otime = do + ctime <- liftIO getCurrentTime + let dtime = diffUTCTime ctime otime + if dtime > tdiffbound then updateact ctime else defact otime ++-- |+processWithDefTimeInterval :: (Monad m, MonadIO m) => + (UTCTime -> m a) -- ^ not larger than time diff bound+ -> (UTCTime -> m a) -- ^ larger than time diff bound + -> UTCTime -- ^ last updated time+ -> m a+processWithDefTimeInterval = processWithTimeInterval dtime_bound ++
src/Hoodle/Coroutine/Scroll.hs view
@@ -14,13 +14,10 @@ module Hoodle.Coroutine.Scroll where -import Control.Category--- import Control.Concurrent-import Control.Lens+import Control.Lens (view,over) import Control.Monad import Control.Monad.State import Control.Monad.Trans.Either--- import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform import Control.Monad.Trans.Crtn import Data.Hoodle.BBox@@ -36,9 +33,28 @@ import Hoodle.View.Coordinate import Hoodle.View.Draw ---import Prelude hiding ((.), id) -- | +moveViewPortBy :: MainCoroutine ()->CanvasId-> ((Double,Double)->(Double,Double))+ -> MainCoroutine () +moveViewPortBy rndr cid f = + updateXState (return . act) >> adjustScrollbarWithGeometryCvsId cid >> rndr + where + act xst = let cinfobox = getCanvasInfo cid xst + ncinfobox = selectBox moveact moveact cinfobox + in setCanvasInfo (cid,ncinfobox) xst+ moveact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a + moveact cinfo = + let BBox (x0,y0) _ = + (unViewPortBBox . view (viewInfo.pageArrangement.viewPortBBox)) cinfo+ DesktopDimension ddim = + view (viewInfo.pageArrangement.desktopDimension) cinfo+ in over (viewInfo.pageArrangement.viewPortBBox) + (xformViewPortFitInSize ddim (moveBBoxULCornerTo (f (x0,y0)))) + cinfo+++-- | adjustScrollbarWithGeometryCvsId :: CanvasId -> MainCoroutine () adjustScrollbarWithGeometryCvsId cid = do xstate <- get@@ -64,27 +80,14 @@ -- | hscrollBarMoved :: CanvasId -> Double -> MainCoroutine () hscrollBarMoved cid v = - changeCurrentCanvasId cid - >> updateXState (return . hscrollmoveAction) - >> invalidate cid - where hscrollmoveAction = over currentCanvasInfo (selectBox fsimple fsimple)- fsimple cinfo = - let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cinfo- in over (viewInfo.pageArrangement.viewPortBBox) (apply (moveBBoxULCornerTo (v,snd vm_orig))) $ cinfo-+ changeCurrentCanvasId cid+ >> moveViewPortBy (invalidate cid) cid (\(_,y)->(v,y)) -- | vscrollBarMoved :: CanvasId -> Double -> MainCoroutine () -vscrollBarMoved cid v = - chkCvsIdNInvalidate cid - >> updateXState (return . vscrollmoveAction) - >> invalidate cid- -- invalidateInBBox Nothing Efficient cid - where vscrollmoveAction = over currentCanvasInfo (selectBox fsimple fsimple)- fsimple cinfo = - let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cinfo- in over (viewInfo.pageArrangement.viewPortBBox) (apply (moveBBoxULCornerTo (fst vm_orig,v))) $ cinfo-+vscrollBarMoved cid v = chkCvsIdNInvalidate cid + >> moveViewPortBy (invalidate cid) cid (\(x,_)->(x,v))+ -- | vscrollStart :: CanvasId -> Double -> MainCoroutine () vscrollStart cid v = do @@ -119,7 +122,7 @@ smoothScroll :: CanvasId -> CanvasGeometry -> Double -> Double -> MainCoroutine () smoothScroll cid geometry v0 v = do xst <- get - let b = view doesSmoothScroll xst + let b = view (settings.doesSmoothScroll) xst let diff = (v - v0) lst' | (diff < 20 && diff > -20) = [v] | (diff < 5 &&diff > -5) = []@@ -132,7 +135,6 @@ updateXState $ return . over currentCanvasInfo (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v')) invalidateInBBox Nothing Efficient cid - -- liftIO $ threadDelay (floor (100 * abs diff)) where scrollmovecanvas vv cvsInfo = let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo in over (viewInfo.pageArrangement.viewPortBBox)
src/Hoodle/Coroutine/Select.hs view
@@ -27,7 +27,6 @@ import Data.Time.Clock import Graphics.Rendering.Cairo import qualified Graphics.Rendering.Cairo.Matrix as Mat-import Graphics.UI.Gtk hiding (get,set,disconnect) -- from hoodle-platform import Data.Hoodle.Select import Data.Hoodle.Simple (Dimension(..))@@ -44,12 +43,12 @@ import Hoodle.Coroutine.Commit import Hoodle.Coroutine.ContextMenu import Hoodle.Coroutine.Draw-import Hoodle.Coroutine.EventConnect import Hoodle.Coroutine.Mode import Hoodle.Coroutine.Pen import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select+import Hoodle.ModelAction.Select.Transform import Hoodle.Type.Alias import Hoodle.Type.Canvas import Hoodle.Type.Coroutine@@ -66,16 +65,12 @@ createTempSelectRender :: PageNum -> CanvasGeometry -> Page EditMode -> a -> MainCoroutine (TempSelectRender a) -createTempSelectRender pnum geometry page x = do +createTempSelectRender _pnum geometry _page x = do + xst <- get+ let hdl = getHoodle xst let Dim cw ch = unCanvasDimension . canvasDim $ geometry- xformfunc = cairoXform4PageCoordinate geometry pnum - renderfunc = do - xformfunc - cairoRenderOption (InBBoxOption Nothing) (InBBox page) - return ()- tempsurface <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch) + (tempsurface,_) <- liftIO $ canvasImageSurface Nothing geometry hdl let tempselection = TempSelectRender tempsurface (cw,ch) x- liftIO $ updateTempSelection tempselection renderfunc True return tempselection @@ -100,30 +95,30 @@ -- (dev note: need to be refactored with selectLassoStart) selectRectStart :: CanvasId -> PointerCoord -> MainCoroutine () selectRectStart cid = commonPenStart rectaction cid- where rectaction cinfo pnum geometry (cidup,cidmove) (x,y) = do+ where rectaction cinfo pnum geometry (x,y) = do itms <- rItmsInCurrLyr ctime <- liftIO $ getCurrentTime let newSelectAction page = dealWithOneTimeSelectMode (do tsel <- createTempSelectRender pnum geometry page [] - newSelectRectangle cid pnum geometry cidmove cidup itms + newSelectRectangle cid pnum geometry itms (x,y) ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) showContextMenu (pnum,(x,y)) )- (disconnect [cidmove,cidup]) + (return ()) let action (Right tpage) | hitInHandle tpage (x,y) = case getULBBoxFromSelected tpage of Middle bbox -> maybe (return ()) (\handle -> startResizeSelect - handle cid pnum geometry cidmove cidup + handle cid pnum geometry bbox ((x,y),ctime) tpage) (checkIfHandleGrasped bbox (x,y)) _ -> return () action (Right tpage) | hitInSelection tpage (x,y) = do- startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage+ startMoveSelect cid pnum geometry ((x,y),ctime) tpage action (Right tpage) | otherwise = newSelectAction (hPage2RPage tpage) action (Left page) = newSelectAction page xstate <- get @@ -135,13 +130,12 @@ newSelectRectangle :: CanvasId -> PageNum -> CanvasGeometry- -> ConnectId DrawingArea -> ConnectId DrawingArea -> [RItem] -> (Double,Double) -> ((Double,Double),UTCTime) -> TempSelection -> MainCoroutine () -newSelectRectangle cid pnum geometry connidmove connidup itms orig +newSelectRectangle cid pnum geometry itms orig (prev,otime) tempselection = do r <- nextevent xst <- get @@ -149,7 +143,7 @@ where fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo)- defact = newSelectRectangle cid pnum geometry connidmove connidup itms orig + defact = newSelectRectangle cid pnum geometry itms orig (prev,otime) tempselection moveact _xstate _cinfo (_pcoord,(x,y)) = do let bbox = BBox orig (x,y)@@ -178,7 +172,7 @@ when willUpdate $ invalidateTemp cid (tempSurface tempselection) (renderBoxSelection bbox) - newSelectRectangle cid pnum geometry connidmove connidup itms orig + newSelectRectangle cid pnum geometry itms orig (ncoord,ntime) tempselection { tempSelectInfo = hitteditms } upact xstate cinfo pcoord = do @@ -203,7 +197,6 @@ liftIO $ toggleCutCopyDelete ui (isAnyHitted selectitms) put . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate))- disconnect [connidmove, connidup] invalidateAll @@ -211,17 +204,15 @@ startMoveSelect :: CanvasId -> PageNum -> CanvasGeometry - -> ConnectId DrawingArea- -> ConnectId DrawingArea -> ((Double,Double),UTCTime) -> Page SelectMode -> MainCoroutine () -startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage = do +startMoveSelect cid pnum geometry ((x,y),ctime) tpage = do itmimage <- liftIO $ mkItmsNImg geometry tpage tsel <- createTempSelectRender pnum geometry (hPage2RPage tpage) itmimage - moveSelect cid pnum geometry cidmove cidup (x,y) ((x,y),ctime) tsel + moveSelect cid pnum geometry (x,y) ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) surfaceFinish (imageSurface itmimage) invalidateAll @@ -230,13 +221,11 @@ moveSelect :: CanvasId -> PageNum -- ^ starting pagenum -> CanvasGeometry- -> ConnectId DrawingArea - -> ConnectId DrawingArea -> (Double,Double) -> ((Double,Double),UTCTime) -> TempSelectRender ItmsNImg -> MainCoroutine ()-moveSelect cid pnum geometry connidmove connidup orig@(x0,y0) +moveSelect cid pnum geometry orig@(x0,y0) (prev,otime) tempselection = do xst <- get r <- nextevent @@ -244,7 +233,7 @@ where fsingle r xstate cinfo = penMoveAndUpInterPage r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) - defact = moveSelect cid pnum geometry connidmove connidup orig (prev,otime) + defact = moveSelect cid pnum geometry orig (prev,otime) tempselection moveact _xstate _cinfo oldpgn pcpair@(newpgn,PageCoord (px,py)) = do let (x,y) @@ -267,8 +256,7 @@ xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 invalidateTempBasePage cid (tempSurface tempselection) pnum (drawTempSelectImage geometry tempselection xformmat) - moveSelect cid pnum geometry connidmove connidup orig (ncoord,ntime) - tempselection+ moveSelect cid pnum geometry orig (ncoord,ntime) tempselection upact :: (ViewMode a) => HoodleState -> CanvasInfo a -> PointerCoord -> MainCoroutine () upact xst cinfo pcoord = switchActionEnteringDiffPage pnum geometry pcoord (return ()) @@ -290,12 +278,11 @@ Left _ -> error "this is impossible, in moveSelect" let maction = do page <- M.lookup (unPageNum newpgn) (view gselAll nthdl1)- let (mcurrlayer,npage) = getCurrentLayerOrSet page- currlayer <- mcurrlayer + let currlayer = getCurrentLayer page let olditms = view gitems currlayer let newitms = map (changeItemBy (offsetFunc (x-x0,y-y0))) selecteditms alist = olditms :- Hitted newitms :- Empty - ntpage = makePageSelectMode npage alist + ntpage = makePageSelectMode page alist coroutineaction = do nthdl2 <- liftIO $ updateTempHoodleSelectIO nthdl1 ntpage (unPageNum newpgn) let cibox = view currentCanvasInfo xstate1 @@ -308,7 +295,6 @@ return coroutineaction xstate2 <- maybe (return xstate1) id maction commit xstate2- disconnect [connidmove, connidup] invalidateAll ---- ordaction xstate cinfo _pgn (_cpn,PageCoord (x,y)) = do @@ -323,7 +309,6 @@ commit . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) Left _ -> error "this is impossible, in moveSelect" - disconnect [connidmove, connidup] invalidateAll @@ -332,19 +317,17 @@ -> CanvasId -> PageNum -> CanvasGeometry - -> ConnectId DrawingArea- -> ConnectId DrawingArea -> BBox -> ((Double,Double),UTCTime) -> Page SelectMode -> MainCoroutine () -startResizeSelect handle cid pnum geometry cidmove cidup bbox +startResizeSelect handle cid pnum geometry bbox ((x,y),ctime) tpage = do itmimage <- liftIO $ mkItmsNImg geometry tpage tsel <- createTempSelectRender pnum geometry (hPage2RPage tpage) itmimage - resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel + resizeSelect handle cid pnum geometry bbox ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) surfaceFinish (imageSurface itmimage) invalidateAll @@ -354,20 +337,18 @@ -> CanvasId -> PageNum -> CanvasGeometry- -> ConnectId DrawingArea - -> ConnectId DrawingArea -> BBox -> ((Double,Double),UTCTime) -> TempSelectRender ItmsNImg -> MainCoroutine ()-resizeSelect handle cid pnum geometry connidmove connidup origbbox +resizeSelect handle cid pnum geometry origbbox (prev,otime) tempselection = do xst <- get r <- nextevent boxAction (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo)- defact = resizeSelect handle cid pnum geometry connidmove connidup + defact = resizeSelect handle cid pnum geometry origbbox (prev,otime) tempselection moveact _xstate _cinfo (_pcoord,(x,y)) = do (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) @@ -385,7 +366,7 @@ invalidateTemp cid (tempSurface tempselection) (drawTempSelectImage geometry tempselection xformmat)- resizeSelect handle cid pnum geometry connidmove connidup + resizeSelect handle cid pnum geometry origbbox (ncoord,ntime) tempselection upact xstate cinfo pcoord = do let (_,(x,y)) = runIdentity $ @@ -403,7 +384,6 @@ commit . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate)) Left _ -> error "this is impossible, in resizeSelect" - disconnect [connidmove, connidup] invalidateAll return () @@ -451,26 +431,26 @@ -- selected selection. selectLassoStart :: CanvasId -> PointerCoord -> MainCoroutine () selectLassoStart cid = commonPenStart lassoAction cid - where lassoAction cinfo pnum geometry (cidup,cidmove) (x,y) = do + where lassoAction cinfo pnum geometry (x,y) = do itms <- rItmsInCurrLyr ctime <- liftIO $ getCurrentTime let newSelectAction page = dealWithOneTimeSelectMode (do tsel <- createTempSelectRender pnum geometry page [] - newSelectLasso cinfo pnum geometry cidmove cidup itms + newSelectLasso cinfo pnum geometry itms (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel surfaceFinish (tempSurface tsel) showContextMenu (pnum,(x,y)) )- (disconnect [cidmove, cidup] )+ (return ()) let action (Right tpage) | hitInSelection tpage (x,y) = - startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage+ startMoveSelect cid pnum geometry ((x,y),ctime) tpage action (Right tpage) | hitInHandle tpage (x,y) = case getULBBoxFromSelected tpage of Middle bbox -> maybe (return ()) (\handle -> startResizeSelect - handle cid pnum geometry cidmove cidup + handle cid pnum geometry bbox ((x,y),ctime) tpage) (checkIfHandleGrasped bbox (x,y)) _ -> return () @@ -485,26 +465,24 @@ newSelectLasso :: (ViewMode a) => CanvasInfo a -> PageNum -> CanvasGeometry- -> ConnectId DrawingArea -> ConnectId DrawingArea -> [RItem] -> (Double,Double) -> ((Double,Double),UTCTime) -> Seq (Double,Double) -> TempSelection -> MainCoroutine ()-newSelectLasso cvsInfo pnum geometry cidmove cidup itms orig (prev,otime) lasso tsel = nextevent >>= flip fsingle cvsInfo +newSelectLasso cvsInfo pnum geometry itms orig (prev,otime) lasso tsel = nextevent >>= flip fsingle cvsInfo where fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact (moveact cinfo) (upact cinfo)- defact = newSelectLasso cvsInfo pnum geometry cidmove cidup itms orig + defact = newSelectLasso cvsInfo pnum geometry itms orig (prev,otime) lasso tsel moveact cinfo (_pcoord,(x,y)) = do let nlasso = lasso |> (x,y) (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do - invalidateTemp (view canvasId cinfo) (tempSurface tsel) (renderLasso nlasso) - newSelectLasso cinfo pnum geometry cidmove cidup itms orig - (ncoord,ntime) nlasso tsel+ invalidateTemp (view canvasId cinfo) (tempSurface tsel) (renderLasso geometry nlasso) + newSelectLasso cinfo pnum geometry itms orig (ncoord,ntime) nlasso tsel upact cinfo pcoord = do xstate <- get let (_,(x,y)) = runIdentity $ @@ -527,10 +505,9 @@ SelectState thdl = view hoodleModeState xstate newpage = case epage of Left pagebbox -> - let (mcurrlayer,npagebbox) = getCurrentLayerOrSet pagebbox- currlayer = maybe (error "newSelectLasso") id mcurrlayer + let currlayer= getCurrentLayer pagebbox newlayer = GLayer (view gbuffer currlayer) (TEitherAlterHitted (Right selectitms))- tpg = mkHPage npagebbox + tpg = mkHPage pagebbox npg = set (glayers.selectedLayer) newlayer tpg in npg Right tpage -> @@ -543,7 +520,6 @@ liftIO $ toggleCutCopyDelete ui (isAnyHitted selectitms) put . set hoodleModeState (SelectState newthdl) =<< (liftIO (updatePageAll (SelectState newthdl) xstate))- disconnect [cidmove, cidup] invalidateAll
src/Hoodle/Coroutine/Select/Clipboard.hs view
@@ -15,7 +15,7 @@ module Hoodle.Coroutine.Select.Clipboard where -- from other packages-import Control.Lens+import Control.Lens (view,set,(%~)) import Control.Monad.State import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform @@ -34,6 +34,7 @@ import Hoodle.Coroutine.Mode import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select+import Hoodle.ModelAction.Select.Transform import Hoodle.ModelAction.Clipboard import Hoodle.Type.Canvas import Hoodle.Type.Coroutine
src/Hoodle/Coroutine/TextInput.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TupleSections #-} ----------------------------------------------------------------------------- -- |@@ -15,9 +15,8 @@ module Hoodle.Coroutine.TextInput where import Control.Applicative-import Control.Lens+import Control.Lens (view,set,(%~)) import Control.Monad.State --- import Control.Monad.Trans import Control.Monad.Trans.Either import Graphics.Rendering.Cairo import Graphics.Rendering.Pango.Cairo@@ -26,43 +25,36 @@ import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue -import Data.ByteString (readFile)-import qualified Data.ByteString.Char8 as B (pack)+import qualified Data.ByteString.Char8 as B import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Simple import Graphics.Hoodle.Render.Item --- import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Type.HitTest import System.Directory --- import System.Environment--- import System.Exit import System.FilePath --- import System.Process ----- import Hoodle.Accessor import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select import Hoodle.Coroutine.Draw + import Hoodle.Coroutine.Mode import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Event hiding (SVG) import Hoodle.Type.HoodleState -import Hoodle.Util -- import Prelude hiding (readFile) -+-- | textInput :: MainCoroutine () textInput = do - liftIO $ putStrLn "textInput" modify (tempQueue %~ enqueue action) minput <- go case minput of Nothing -> return () - Just str -> makePangoTextSVGInsert str + Just str -> liftIO (makePangoTextSVG str) >>= svgInsert str where go = do r <- nextevent case r of @@ -89,58 +81,81 @@ widgetDestroy dialog return (TextInput Nothing) -makePangoTextSVGInsert :: String -> MainCoroutine () -makePangoTextSVGInsert str = do +-- |+svgInsert :: String -> (B.ByteString,BBox) -> MainCoroutine () +svgInsert str (svgbstr,BBox (x0,y0) (x1,y1)) = do xstate <- get - liftIO $ putStrLn str let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate - (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)- currlayer = maybeError' "something wrong in addPDraw" mcurrlayer - pangordr = do - ctxt <- cairoCreateContext Nothing - layout <- layoutEmpty ctxt - layoutSetWidth layout (Just 300)- layoutSetWrap layout WrapAnywhere - layoutSetText layout str - (_,reclog) <- layoutGetExtents layout - let PangoRectangle x y w h = reclog - return (layout,BBox (x,y) (x+w,y+h)) - rdr layout = do setSourceRGBA 0 0 0 1- -- layout <- createLayout str- -- liftIO $ layoutSetWidth layout (Just 300)- -- liftIO $ layoutSetWrap layout WrapAnywhere - updateLayout layout - showLayout layout - (layout,BBox (x0,y0) (x1,y1)) <- liftIO pangordr - - tdir <- liftIO $ getTemporaryDirectory - let tfile = tdir </> "embedded.svg"- liftIO $ withSVGSurface tfile (x1-x0) (y1-y0) $ \s -> renderWith s (rdr layout)- svg <- liftIO $ readFile tfile + currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage+ newitem <- (liftIO . cnstrctRItem . ItemSVG) - (SVG (Just (B.pack str)) Nothing svg (100,100) (Dim (x1-x0) (y1-y0))) + (SVG (Just (B.pack str)) Nothing svgbstr + (100,100) (Dim (x1-x0) (y1-y0))) let otheritems = view gitems currlayer - let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) + 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) "makePangoTextSVGInsert"+ _ -> (lift . EitherT . return . Left . Other) "svgInsert" nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate put nxstate2 invalidateAll + +-- | +linkInsert :: B.ByteString + -> (B.ByteString,FilePath)+ -> String + -> (B.ByteString,BBox) + -> MainCoroutine ()+linkInsert typ (uuidbstr,fname) str (svgbstr,BBox (x0,y0) (x1,y1)) = do + xstate <- get + let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ 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 + (x0,y0) (Dim (x1-x0) (y1-y0))) + 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 +-- |+makePangoTextSVG :: String -> IO (B.ByteString,BBox) +makePangoTextSVG str = do + let pangordr = do + ctxt <- cairoCreateContext Nothing + layout <- layoutEmpty ctxt + layoutSetWidth layout (Just 400)+ layoutSetWrap layout WrapAnywhere + layoutSetText layout str + (_,reclog) <- layoutGetExtents layout + let PangoRectangle x y w h = reclog + return (layout,BBox (x,y) (x+w,y+h)) + rdr layout = do setSourceRGBA 0 0 0 1+ updateLayout layout + 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)+ bstr <- B.readFile tfile + return (bstr,BBox (x0,y0) (x1,y1)) -{- tdir <- getTemporaryDirectory- writeFile (tdir </> "latextest.tex") l - let cmd = "lasem-render-0.6 " ++ (tdir </> "latextest.tex") ++ " -f svg -o " ++ (tdir </> "latextest.svg" )- print cmd - excode <- system cmd - case excode of - ExitSuccess -> do - svg <- readFile (tdir </> "latextest.svg")- return (LaTeXInput (Just (B.pack l,svg)))- _ -> return (LaTeXInput Nothing) -}
+ src/Hoodle/Coroutine/VerticalSpace.hs view
@@ -0,0 +1,253 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.VerticalSpace+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.VerticalSpace where++import Control.Applicative+import Control.Category+import Control.Lens (view,set,at)+import Control.Monad hiding (mapM_)+import Control.Monad.State (get)+import Data.Foldable +import Data.Monoid+import Data.Time.Clock+import Graphics.Rendering.Cairo +import Graphics.UI.Gtk hiding (get,set) +-- from hoodle-platform+import Data.Hoodle.BBox+import Data.Hoodle.Generic+import Data.Hoodle.Simple (Dimension(..))+import Data.Hoodle.Zipper (SeqZipper,toSeq) +import Graphics.Hoodle.Render+import Graphics.Hoodle.Render.Type.HitTest+import Graphics.Hoodle.Render.Type.Hoodle+import Graphics.Hoodle.Render.Type.Item +import Graphics.Hoodle.Render.Util.HitTest+-- from this package+import Hoodle.Accessor+import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.Draw+import Hoodle.Coroutine.Page+import Hoodle.Coroutine.Pen +import Hoodle.Device+import Hoodle.ModelAction.Page +import Hoodle.ModelAction.Select.Transform+import Hoodle.Type.Alias +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.Type.Predefined +import Hoodle.View.Coordinate+import Hoodle.View.Draw+--+import Prelude hiding ((.), id, concat,concatMap,mapM_)++-- | +splitPageByHLine :: Double -> Page EditMode + -> ([RItem],Page EditMode,SeqZipper RItemHitted) +splitPageByHLine y pg = (hitted,set glayers unhitted pg,hltedLayers)+ where + alllyrs = view glayers pg+ findHittedItmsInALyr = hltFilteredBy (bboxabove . getBBox) . view gitems+ hltedLayers = fmap findHittedItmsInALyr alllyrs + unhitted = fmap (\lyr -> (\x->set gitems x lyr) . concatMap unNotHitted + . getA . findHittedItmsInALyr $ lyr) alllyrs+ hitted = (concat + . fmap (concatMap unHitted . getB . findHittedItmsInALyr)+ . toSeq + ) alllyrs+ bboxabove (BBox (_,y0) _) = y0 > y ++-- |+verticalSpaceStart :: CanvasId -> PointerCoord -> MainCoroutine () +verticalSpaceStart cid = commonPenStart verticalSpaceAction cid + where + verticalSpaceAction _cinfo pnum@(PageNum n) geometry (x,y) = do + hdl <- liftM getHoodle get + cpg <- getCurrentPageCurr + let (itms,npg,hltedLayers) = splitPageByHLine y cpg + nhdl = set (gpages.at n) (Just npg) hdl + mbbx = (toMaybe . mconcat . fmap (Union . Middle . getBBox)) itms + 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+ ctime <- liftIO getCurrentTime + verticalSpaceProcess cid geometry (bbx,hltedLayers,pnum,cpg) (x,y) + (sfcbkg,sfcitm,sfctot) ctime ++ liftIO $ mapM_ surfaceFinish [sfcbkg,sfcitm,sfctot]++-- |+addNewPageAndMoveBelow :: (PageNum,SeqZipper RItemHitted,BBox) + -> MainCoroutine () +addNewPageAndMoveBelow (pnum,hltedLyrs,bbx) = + updateXState npgBfrAct + >> commit_ + >> canvasZoomUpdateAll >> invalidateAll+ where+ npgBfrAct xst = boxAction (fsimple xst) . view currentCanvasInfo $ xst+ fsimple :: (ViewMode a) => HoodleState -> CanvasInfo a + -> MainCoroutine HoodleState+ fsimple xstate _cinfo = do + 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' + nhdlmodst = ViewAppendState hdl''+ return =<< liftIO . updatePageAll nhdlmodst+ . set hoodleModeState nhdlmodst $ xstate + SelectState _ -> do + liftIO $ putStrLn " not implemented yet"+ return xstate+ +-- | +moveBelowToNewPage :: (PageNum,SeqZipper RItemHitted,BBox) + -> Hoodle EditMode+ -> Hoodle EditMode+moveBelowToNewPage (PageNum n,hltedLayers,BBox (_,y0) _) hdl = + let mpg = view (gpages.at n) hdl + mpg2 = view (gpages.at (n+1)) hdl + in case (,) <$> mpg <*> mpg2 of + Nothing -> hdl + Just (pg,pg2) -> + let nhlyrs = -- 10 is just a predefined number + fmap (fmapAL id + (fmap (changeItemBy (\(x',y')->(x',y'+10-y0)))))+ hltedLayers+ nlyrs = fmap ((\x -> set gitems x emptyRLayer) + . concatMap unNotHitted + . getA ) nhlyrs + npg = set glayers nlyrs pg + nnlyrs = fmap ((\x -> set gitems x emptyRLayer)+ . concatMap unHitted+ . getB ) nhlyrs+ npg2 = set glayers nnlyrs pg2+ + nhdl = ( set (gpages.at (n+1)) (Just npg2)+ . set (gpages.at n) (Just npg) ) hdl + in nhdl +++-- |+verticalSpaceProcess :: CanvasId+ -> CanvasGeometry+ -> (BBox,SeqZipper RItemHitted,PageNum,Page EditMode)+ -> (Double,Double)+ -> (Surface,Surface,Surface)+ -> UTCTime+ -> MainCoroutine () +verticalSpaceProcess cid geometry pinfo@(bbx,hltedLayers,pnum@(PageNum n),pg) + (x0,y0) sfcs@(sfcbkg,sfcitm,sfctot) otime = do + r <- nextevent + xst <- get+ boxAction (f r xst) . getCanvasInfo cid $ xst + where + Dim w h = view gdimension pg + CvsCoord (_,y0_cvs) = + (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x0,y0))+ + f :: (ViewMode a) => MyEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()+ f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact + (moveact xstate cvsInfo) upact+ ------------------------------------------------------------- + defact = verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs otime+ ------------------------------------------------------------- + upact pcoord = do + let mpgcoord = (desktop2Page geometry . device2Desktop geometry) pcoord+ case mpgcoord of + Nothing -> invalidateAll + Just (cpn,PageCoord (_,y)) -> + if cpn /= pnum + then invalidateAll + else do + -- add space within this page+ let BBox _ (_,by1) = bbx+ if by1 + y - y0 < h + then do + xst <- get + let hdl = getHoodle xst + let nhlyrs = + fmap (fmapAL id + (fmap (changeItemBy (\(x',y')->(x',y'+y-y0)))))+ hltedLayers+ nlyrs = fmap + ((\is -> set gitems is emptyRLayer) + . concat+ . interleave unNotHitted unHitted) + nhlyrs + npg = set glayers nlyrs pg + nhdl = set (gpages.at n) (Just npg) hdl + commit (set hoodleModeState (ViewAppendState nhdl) xst)+ invalidateAll + else do + addNewPageAndMoveBelow (pnum,hltedLayers,bbx)+ -------------------------------------------------------------+ moveact _xstate cvsInfo (_,(x,y)) = + processWithDefTimeInterval + (verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs)+ (\ctime -> do + let CvsCoord (_,y_cvs) = + (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x,y))+ BBox _ (_,by1) = bbx + mode | by1 + y - y0 > h = OverPage+ | y > y0 = GoingDown+ | otherwise = GoingUp + z = canvas2DesktopRatio geometry + drawguide = do + identityMatrix + cairoXform4PageCoordinate geometry pnum + 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 + 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+ drawguide + let canvas = view drawArea cvsInfo + win <- liftIO $ widgetGetDrawWindow canvas+ liftIO $ renderWithDrawable win $ do + setSourceSurface sfctot 0 0 + setOperator OperatorSource + paint + verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs ctime)+ otime ++ +
src/Hoodle/Coroutine/Window.hs view
@@ -14,12 +14,9 @@ module Hoodle.Coroutine.Window where -import Control.Category-import Control.Lens+import Control.Lens (view,set,over) import Control.Monad.State import qualified Data.IntMap as M-import Data.Maybe--- import Data.Time.Clock import Graphics.UI.Gtk hiding (get,set) -- import Data.Hoodle.Generic@@ -35,12 +32,9 @@ import Hoodle.Type.Event import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement--- import Hoodle.Type.Predefined import Hoodle.Type.Window--- import Hoodle.Util import Hoodle.View.Draw ---import Prelude hiding ((.),id) -- | canvas configure with general zoom update func canvasConfigureGenUpdate :: MainCoroutine () @@ -92,7 +86,6 @@ put xstate3 liftIO $ boxPackEnd rtcntr win PackGrow 0 liftIO $ widgetShowAll rtcntr - -- liftIO $ widgetShowAll win liftIO $ widgetQueueDraw rtrwin (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3) xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4
src/Hoodle/GUI.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.GUI --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,20 +14,18 @@ module Hoodle.GUI where -import Control.Category import Control.Exception-import Control.Lens+import Control.Lens (view)+import Control.Monad import Control.Monad.Trans import qualified Data.IntMap as M+import Data.IORef import Data.Maybe--- import Data.Time import Graphics.UI.Gtk hiding (get,set) import System.Directory import System.Environment import System.FilePath import System.IO--- --- import Control.Monad.Trans.Crtn.EventHandler -- from this package import Hoodle.Accessor import Hoodle.Config @@ -40,7 +38,7 @@ import Hoodle.Type.Event import Hoodle.Type.HoodleState ---import Prelude hiding ((.),id,catch)+import Prelude hiding (catch) -- | startGUI :: Maybe FilePath -> Maybe Hook -> IO () @@ -56,38 +54,53 @@ (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo xinputbool setTitleFromFileName st0 -- need for refactoring- setToggleUIForFlag "UXINPUTA" doesUseXInput st0 - setToggleUIForFlag "POPMENUA" doesUsePopUpMenu st0 - setToggleUIForFlag "EBDIMGA" doesEmbedImage st0 + setToggleUIForFlag "UXINPUTA" (settings.doesUseXInput) st0 + setToggleUIForFlag "POPMENUA" (settings.doesUsePopUpMenu) st0 + setToggleUIForFlag "EBDIMGA" (settings.doesEmbedImage) st0 + setToggleUIForFlag "EBDPDFA" (settings.doesEmbedPDF) st0 -- let canvases = map (getDrawAreaFromBox) . M.elems . getCanvasInfoMap $ st0 if xinputbool then mapM_ (flip widgetSetExtensionEvents [ExtensionEventsAll]) canvases else mapM_ (flip widgetSetExtensionEvents [ExtensionEventsNone]) canvases- - maybeMenubar <- uiManagerGetWidget ui "/ui/menubar"- let menubar = case maybeMenubar of - Just x -> x - Nothing -> error "cannot get menubar from string"+ -- + menubar <- uiManagerGetWidget ui "/ui/menubar" + >>= maybe (error "GUI.hs:no menubar") return + toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1" + >>= maybe (error "GUI.hs:no toolbar1") return + toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2"+ >>= maybe (error "GUI.hs:no toolbar2") return + -- + ebox <- eventBoxNew+ label <- labelNew (Just "drag me")+ containerAdd ebox label - maybeToolbar1 <- uiManagerGetWidget ui "/ui/toolbar1"- let toolbar1 = case maybeToolbar1 of - Just x -> x - Nothing -> error "cannot get toolbar from string"- maybeToolbar2 <- uiManagerGetWidget ui "/ui/toolbar2"- let toolbar2 = case maybeToolbar2 of - Just x -> x - Nothing -> error "cannot get toolbar from string" + dragSourceSet ebox [Button1] [ActionCopy]+ dragSourceSetIconStock ebox stockIndex+ dragSourceAddTextTargets ebox+ ebox `on` dragBegin $ \_dc -> do + liftIO $ putStrLn "dragging"+ ebox `on` dragDataGet $ \_dc _iid _ts -> do + -- very dirty solution but.. + minfo <- liftIO $ do + ref <- newIORef (Nothing :: Maybe String)+ view callBack st0 (GetHoodleFileInfo ref) + readIORef ref+ maybe (return ()) (selectionDataSetText >=> const (return ())) minfo+ --+ hbox <- hBoxNew False 0 + boxPackStart hbox toolbar1 PackGrow 0+ boxPackStart hbox ebox PackNatural 0 containerAdd window vbox boxPackStart vbox menubar PackNatural 0 - boxPackStart vbox toolbar1 PackNatural 0- boxPackStart vbox toolbar2 PackNatural 0 + boxPackStart vbox hbox PackNatural 0+ boxPackStart vbox toolbar2 PackNatural 0 boxPackEnd vbox (view rootWindow st0) PackGrow 0 - -- cursorDot <- cursorNew BlankCursor window `on` deleteEvent $ do liftIO $ eventHandler tref (Menu MenuQuit) return True widgetShowAll window+ -- let mainaction = do eventHandler tref Initialized mainGUI mainaction `catch` \(_e :: SomeException) -> do @@ -98,7 +111,5 @@ hPutStrLn outh "error occured" hClose outh return ()--
src/Hoodle/GUI/Menu.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.GUI.Menu --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -17,22 +17,17 @@ module Hoodle.GUI.Menu where -- from other packages-import Control.Category-import Data.Maybe+import Control.Lens (set)+import Control.Monad import Graphics.UI.Gtk hiding (set,get) import qualified Graphics.UI.Gtk as Gtk (set) import System.FilePath-import System.IO -- from hoodle-platform --- import Control.Monad.Trans.Crtn.EventHandler import Data.Hoodle.Predefined -- from this package import Hoodle.Coroutine.Callback import Hoodle.Type-import Hoodle.Type.Clipboard--- import Hoodle.Util.Verbatim ---import Prelude hiding ((.),id) import Paths_hoodle_core -- | @@ -90,6 +85,7 @@ , RadioActionEntry "PENVERYTHICKA" "Very Thick" Nothing Nothing Nothing 4 , RadioActionEntry "PENULTRATHICKA" "Ultra Thick" Nothing Nothing Nothing 5 , RadioActionEntry "PENMEDIUMA" "Medium" (Just "mymedium") Nothing Nothing 2 +-- , RadioActionEntry "NOWIDTH" "Unknown" Nothing Nothing Nothing 999 ] -- | @@ -119,6 +115,7 @@ , RadioActionEntry "YELLOWA" "Yellow" (Just "myyellow") Nothing Nothing 9 , RadioActionEntry "WHITEA" "White" (Just "mywhite") Nothing Nothing 10 , RadioActionEntry "BLACKA" "Black" (Just "myblack") Nothing Nothing 0 +--- , RadioActionEntry "NOCOLOR" "Unknown" Nothing Nothing Nothing 999 ] -- | @@ -162,7 +159,7 @@ -- | -getMenuUI :: EventVar -> IO UIManager+getMenuUI :: EventVar -> IO (UIManager,UIComponentSignalHandler) getMenuUI evar = do let actionNewAndRegister = actionNewAndRegisterRef evar -- icons @@ -190,8 +187,8 @@ ldsvga <- actionNewAndRegister "LDSVGA" "Load SVG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadSVG) latexa <- actionNewAndRegister "LATEXA" "LaTeX" (Just "Just a Stub") Nothing (justMenu MenuLaTeX) 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) quita <- actionNewAndRegister "QUITA" "Quit" (Just "Just a Stub") (Just stockQuit) (justMenu MenuQuit)@@ -240,13 +237,15 @@ ppclra <- actionNewAndRegister "PPCLRA" "Paper Color" (Just "Just a Stub") Nothing (justMenu MenuPaperColor) ppstya <- actionNewAndRegister "PPSTYA" "Paper Style" Nothing Nothing Nothing apallpga<- actionNewAndRegister "APALLPGA" "Apply To All Pages" (Just "Just a Stub") Nothing (justMenu MenuApplyToAllPages)- ldbkga <- actionNewAndRegister "LDBKGA" "Load Background" (Just "Just a Stub") Nothing (justMenu MenuLoadBackground)- bkgscrshta <- actionNewAndRegister "BKGSCRSHTA" "Background Screenshot" (Just "Just a Stub") Nothing (justMenu MenuBackgroundScreenshot)+ embedbkgpdfa <- actionNewAndRegister "EMBEDBKGPDFA" "Embed All PDF backgroound" (Just "Just a Stub") Nothing (justMenu MenuEmbedAllPDFBkg)+ -- ldbkga <- actionNewAndRegister "LDBKGA" "Load Background" (Just "Just a Stub") Nothing (justMenu MenuLoadBackground)+ -- bkgscrshta <- actionNewAndRegister "BKGSCRSHTA" "Background Screenshot" (Just "Just a Stub") Nothing (justMenu MenuBackgroundScreenshot) defppa <- actionNewAndRegister "DEFPPA" "Default Paper" (Just "Just a Stub") Nothing (justMenu MenuDefaultPaper) 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) -- selregna <- actionNewAndRegister "SELREGNA" "Select Region" (Just "Just a Stub") (Just "mylasso") (justMenu MenuSelectRegion)@@ -279,6 +278,9 @@ ebdimga <- toggleActionNew "EBDIMGA" "Embed PNG/JPG Image" (Just "Just a stub") Nothing ebdimga `on` actionToggled $ do eventHandler evar (Menu MenuEmbedImage)+ ebdpdfa <- toggleActionNew "EBDPDFA" "Embed PDF" (Just "Just a stub") Nothing+ ebdpdfa `on` actionToggled $ do + eventHandler evar (Menu MenuEmbedPDF) 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 @@ -314,14 +316,14 @@ mapM_ (actionGroupAddAction agr) [ undoa, redoa, cuta, copya, pastea, deletea ] mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing) - [ newa, annpdfa, ldpnga, ldsvga, latexa, ldpreimga, opena, savea, saveasa, reloada, recenta, printa, exporta, quita+ [ newa, annpdfa, ldpnga, ldsvga, latexa, ldpreimga, ldpreimg2a, ldpreimg3a, opena, savea, saveasa, reloada, recenta, printa, exporta, quita , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma , fstpagea, prvpagea, nxtpagea, lstpagea, shwlayera, hidlayera , hsplita, vsplita, delcvsa , newpgba, newpgaa, newpgea, delpga, expsvga, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra- , ppstya {- , bkgplaina, bkglineda, bkgruleda, bkggrapha -}- , apallpga, ldbkga, bkgscrshta, defppa, setdefppa- , texta, shpreca, rulera, clra, clrpcka, penopta + , ppstya + , apallpga, embedbkgpdfa, {- ldbkga, bkgscrshta, -} defppa, setdefppa+ , texta, linka, shpreca, rulera, clra, clrpcka, penopta , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta, relauncha , dcrdcorea, ersrtipa, pghilta, mltpgvwa@@ -335,12 +337,17 @@ actionGroupAddAction agr smthscra actionGroupAddAction agr popmenua actionGroupAddAction agr ebdimga+ actionGroupAddAction agr ebdpdfa actionGroupAddAction agr pressrsensa -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode evar)- actionGroupAddRadioActions agr viewmods 0 (const (return ()))- actionGroupAddRadioActions agr pointmods 0 (assignPoint evar)- actionGroupAddRadioActions agr penmods 0 (assignPenMode evar)- actionGroupAddRadioActions agr colormods 0 (assignColor evar) + mpgmodconnid <- + actionGroupAddRadioActionsAndGetConnID agr viewmods 0 (assignViewMode evar) -- const (return ()))+ _mpointconnid <- + actionGroupAddRadioActionsAndGetConnID agr pointmods 0 (assignPoint evar)+ mpenmodconnid <- + actionGroupAddRadioActionsAndGetConnID agr penmods 0 (assignPenMode evar)+ _mcolorconnid <- + actionGroupAddRadioActionsAndGetConnID agr colormods 0 (assignColor evar) actionGroupAddRadioActions agr bkgstyles 2 (assignBkgStyle evar) @@ -352,7 +359,8 @@ , shwlayera, hidlayera , newpgea, {- delpga, -} ppsizea, ppclra {- , ppstya, apallpga -} - , ldbkga, bkgscrshta, defppa, setdefppa+ {- , ldbkga, bkgscrshta, -}+ , defppa, setdefppa , shpreca, rulera , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta@@ -378,26 +386,56 @@ uiDecl <- readFile (resDir </> "menu.xml") uiManagerAddUiFromString ui uiDecl uiManagerInsertActionGroup ui agr 0 - -- Just ra1 <- actionGroupGetAction agr "ONEPAGEA"- -- Gtk.set (castToRadioAction ra1) [radioActionCurrentValue := 1] Just ra2 <- actionGroupGetAction agr "PENFINEA" Gtk.set (castToRadioAction ra2) [radioActionCurrentValue := 2] Just ra3 <- actionGroupGetAction agr "SELREGNA" actionSetSensitive ra3 True Just ra4 <- actionGroupGetAction agr "VERTSPA"- actionSetSensitive ra4 False+ actionSetSensitive ra4 True Just ra5 <- actionGroupGetAction agr "HANDA" actionSetSensitive ra5 False Just ra6 <- actionGroupGetAction agr "CONTA" actionSetSensitive ra6 True+ Just _ra7 <- actionGroupGetAction agr "PENA"+ actionSetSensitive ra6 True Just toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1" toolbarSetStyle (castToToolbar toolbar1) ToolbarIcons toolbarSetIconSize (castToToolbar toolbar1) IconSizeSmallToolbar Just toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2" toolbarSetStyle (castToToolbar toolbar2) ToolbarIcons toolbarSetIconSize (castToToolbar toolbar2) IconSizeSmallToolbar - return ui + + + let uicomponentsignalhandler = set penModeSignal mpenmodconnid + . set pageModeSignal mpgmodconnid + $ defaultUIComponentSignalHandler + return (ui,uicomponentsignalhandler) ++-- |+actionGroupAddRadioActionsAndGetConnID :: ActionGroup + -> [RadioActionEntry]+ -> Int + -> (RadioAction -> IO ()) + -> IO (Maybe (ConnectId RadioAction))+actionGroupAddRadioActionsAndGetConnID self entries _value onChange = do + mgroup <- foldM + (\mgroup (n,RadioActionEntry name label stockId accelerator tooltip value) -> do+ action <- radioActionNew name label tooltip stockId value+ case mgroup of + Nothing -> return () + Just gr -> radioActionSetGroup action gr+ when (n==value) (toggleActionSetActive action True)+ actionGroupAddActionWithAccel self action accelerator+ return (Just action))+ Nothing (zip [0..] entries)+ case mgroup of + Nothing -> return Nothing + Just gr -> do + connid <- (gr `on` radioActionChanged) onChange+ return (Just connid)++ -- | assignViewMode :: EventVar -> RadioAction -> IO () assignViewMode evar a = viewModeToMyEvent a >>= eventHandler evar@@ -438,11 +476,22 @@ -- int2PenType 3 = Left TextWork int2PenType 4 = Right SelectRegionWork int2PenType 5 = Right SelectRectangleWork-int2PenType 6 = Right SelectVerticalSpaceWork+int2PenType 6 = Left VerticalSpaceWork int2PenType 7 = Right SelectHandToolWork int2PenType _ = error "No such pentype" -- | +penType2Int :: Either PenType SelectType -> Int +penType2Int (Left PenWork) = 0+penType2Int (Left EraserWork) = 1+penType2Int (Left HighlighterWork) = 2 +penType2Int (Left VerticalSpaceWork) = 6+penType2Int (Right SelectRegionWork) = 4 +penType2Int (Right SelectRectangleWork) = 5 +penType2Int (Right SelectHandToolWork) = 7 +++-- | int2Point :: PenType -> Int -> Double int2Point PenWork 0 = predefined_veryfine int2Point PenWork 1 = predefined_fine@@ -462,15 +511,39 @@ int2Point EraserWork 3 = predefined_eraser_thick int2Point EraserWork 4 = predefined_eraser_verythick int2Point EraserWork 5 = predefined_eraser_ultrathick--- int2Point TextWork 0 = predefined_veryfine--- int2Point TextWork 1 = predefined_fine--- int2Point TextWork 2 = predefined_medium--- int2Point TextWork 3 = predefined_thick--- int2Point TextWork 4 = predefined_verythick--- int2Point TextWork 5 = predefined_ultrathick int2Point _ _ = error "No such point" +similarTo :: Double -> Double -> Bool+similarTo v w = (v < w + eps) && (v > w - eps) + where eps = 1e-2+ -- | +point2Int :: PenType -> Double -> Int +point2Int PenWork v + | v `similarTo` predefined_veryfine = 0+ | v `similarTo` predefined_fine = 1+ | v `similarTo` predefined_medium = 2+ | v `similarTo` predefined_thick = 3 + | v `similarTo` predefined_verythick = 4+ | v `similarTo` predefined_ultrathick = 5+point2Int HighlighterWork v + | v `similarTo` predefined_highlighter_fine = 1+ | v `similarTo` predefined_highlighter_veryfine = 0+ | v `similarTo` predefined_highlighter_medium = 2+ | v `similarTo` predefined_highlighter_thick = 3 + | v `similarTo` predefined_highlighter_verythick = 4+ | v `similarTo` predefined_highlighter_ultrathick = 5 +point2Int EraserWork v+ | v `similarTo` predefined_eraser_veryfine = 0+ | v `similarTo` predefined_eraser_fine = 1+ | v `similarTo` predefined_eraser_medium = 2+ | v `similarTo` predefined_eraser_thick = 3 + | v `similarTo` predefined_eraser_verythick = 4+ | v `similarTo` predefined_eraser_ultrathick = 5 +point2Int _ _ = 0 -- for the time being +++-- | int2Color :: Int -> PenColor int2Color 0 = ColorBlack int2Color 1 = ColorBlue@@ -484,6 +557,21 @@ int2Color 9 = ColorYellow int2Color 10 = ColorWhite int2Color _ = error "No such color"+++color2Int :: PenColor -> Int +color2Int ColorBlack = 0+color2Int ColorBlue = 1+color2Int ColorRed = 2+color2Int ColorGreen = 3+color2Int ColorGray = 4+color2Int ColorLightBlue = 5+color2Int ColorLightGreen = 6+color2Int ColorMagenta = 7 +color2Int ColorOrange = 8 +color2Int ColorYellow = 9+color2Int ColorWhite = 10+color2Int _ = 0 -- just for the time being int2BkgStyle :: Int -> BackgroundStyle
+ src/Hoodle/GUI/Reflect.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.GUI.Reflect+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.GUI.Reflect where++import Control.Lens (view,Simple,Lens,(%~))+import qualified Control.Monad.State as St+import Control.Monad.Trans +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.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum +import Hoodle.Type.HoodleState+import Hoodle.Type.Event+import Hoodle.Util +-- +import Debug.Trace+++blockWhile :: (GObjectClass w) => Maybe (ConnectId w) -> IO () -> IO ()+blockWhile msig act = + maybe (return ()) signalBlock msig+ >> act + >> maybe (return ()) signalUnblock msig+ ++-- | reflect view mode UI for current canvas info +reflectViewModeUI :: MainCoroutine ()+reflectViewModeUI = do + xstate <- St.get+ let cinfobox = view currentCanvasInfo xstate + ui = view gtkUIManager xstate + let mconnid = view (uiComponentSignalHandler.pageModeSignal) xstate+ agr <- liftIO $ uiManagerGetActionGroups ui+ ra1 <- maybe (error "reflectUI") return =<< + liftIO (actionGroupGetAction (head agr) "ONEPAGEA")+ let wra1 = castToRadioAction ra1 + selectBoxAction (pgmodupdate_s mconnid wra1) + (pgmodupdate_c mconnid wra1) cinfobox + return ()+ where pgmodupdate_s mconnid wra1 _cinfo = do+ liftIO $ blockWhile mconnid $+ Gtk.set wra1 [radioActionCurrentValue := 1 ] + pgmodupdate_c mconnid wra1 _cinfo = do+ liftIO $ blockWhile mconnid $ + Gtk.set wra1 [radioActionCurrentValue := 0 ] ++-- | +reflectPenModeUI :: MainCoroutine ()+reflectPenModeUI = do + reflectUIComponent penModeSignal "PENA" f+ where + f xst = Just $+ hoodleModeStateEither (view hoodleModeState xst) # + either (\_ -> (penType2Int. Left .view (penInfo.penType)) xst)+ (\_ -> (penType2Int. Right .view (selectInfo.selectType)) xst)+++-- | +reflectPenColorUI :: MainCoroutine () +reflectPenColorUI = do + reflectUIComponent penColorSignal "BLUEA" f+ where + f xst = + let mcolor = + case view (penInfo.penType) xst of + PenWork -> Just (view (penInfo.penSet.currPen.penColor) xst)+ HighlighterWork -> Just (view (penInfo.penSet.currHighlighter.penColor) xst)+ _ -> Nothing + in fmap color2Int mcolor + ++-- | +reflectPenWidthUI :: MainCoroutine () +reflectPenWidthUI = do + reflectUIComponent penPointSignal "PENVERYFINEA" f+ where + f xst = + case view (penInfo.penType) xst of + PenWork -> (Just . point2Int PenWork + . view (penInfo.penSet.currPen.penWidth)) xst+ HighlighterWork -> + let x = (Just . point2Int HighlighterWork + . view (penInfo.penSet.currHighlighter.penWidth)) xst+ y = view (penInfo.penSet.currHighlighter.penWidth) xst+ in trace (" x= " ++ show x ++ " y = " ++ show y ) x + EraserWork -> (Just . point2Int EraserWork + . view (penInfo.penSet.currEraser.penWidth)) xst+ _ -> Nothing ++-- | +reflectUIComponent :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction))+ -> String + -> (HoodleState -> Maybe Int) + -> MainCoroutine ()+reflectUIComponent lnz name f = do + xst <- St.get + let ui = view gtkUIManager xst + mconnid = view (uiComponentSignalHandler.lnz) xst + agr <- liftIO $ uiManagerGetActionGroups ui + 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 + (f xst) # + (maybe (return ()) $ \v -> do+ let action = Left . ActionOrder $ + \_evhandler -> do + blockWhile mconnid + (Gtk.set wpma [radioActionCurrentValue := v ] )+ return ActionOrdered+ St.modify (tempQueue %~ enqueue action)+ go)+ where go = do r <- nextevent+ case r of+ ActionOrdered -> return ()+ _ -> (liftIO $ print r) >> go +
src/Hoodle/ModelAction/Adjustment.hs view
@@ -38,7 +38,6 @@ adjustmentSetUpper vadj h adjustmentSetValue hadj x0 adjustmentSetValue vadj y0- print (xsize,ysize) adjustmentSetPageSize hadj xsize -- (min xsize w) adjustmentSetPageSize vadj ysize -- (min ysize h) adjustmentSetPageIncrement hadj (xsize*0.9)
src/Hoodle/ModelAction/Clipboard.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Clipboard --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,7 +15,7 @@ module Hoodle.ModelAction.Clipboard where -- from other package-import Control.Lens +import Control.Lens (view) import Control.Monad.Trans import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C8
src/Hoodle/ModelAction/Eraser.hs view
@@ -19,7 +19,7 @@ import Graphics.Hoodle.Render.Util.HitTest -- |-eraseHitted :: (BBoxable a) => +eraseHitted :: (GetBBoxable a) => AlterList (NotHitted a) (AlterList (NotHitted a) (Hitted a)) -> State (Maybe BBox) [a] eraseHitted Empty = error "something wrong in eraseHitted"
src/Hoodle/ModelAction/File.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE OverloadedStrings, CPP, GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.File --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,33 +17,48 @@ module Hoodle.ModelAction.File where -- from other package-import Control.Category-import Control.Lens-import Control.Monad+import Control.Applicative+import Control.Lens (view,set) import Data.Attoparsec -import qualified Data.ByteString as B import Data.Maybe import Graphics.UI.Gtk hiding (get,set)-#ifdef POPPLER+import Data.ByteString.Base64 import qualified Data.ByteString.Char8 as C+import qualified Data.IntMap as IM+import Data.Monoid ((<>)) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage import Graphics.Hoodle.Render.Background-#endif+import System.Directory (canonicalizePath) import System.FilePath (takeExtension)+import System.Process -- from hoodle-platform +import Data.Hoodle.Generic import Data.Hoodle.Simple import Graphics.Hoodle.Render+import Graphics.Hoodle.Render.Type.Background +import Graphics.Hoodle.Render.Type.Hoodle 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.Translate.FromXournal+import Text.Hoodle.Migrate.FromXournal -- from this package import Hoodle.Type.HoodleState -- -import Prelude hiding ((.),id)+-- import Prelude hiding ((.),id) --- | get file content from xournal file and update xournal state +-- | check hoodle version and migrate if necessary +checkVersionAndMigrate :: C.ByteString -> IO (Either String Hoodle) +checkVersionAndMigrate bstr = do + case parseOnly PA.checkHoodleVersion bstr of + Left str -> error str + Right v -> do + if ( v <= "0.1.1" ) + 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 @@ -49,39 +66,37 @@ let ext = takeExtension fname case ext of ".hdl" -> do - bstr <- B.readFile fname- let r = parse PA.hoodle bstr+ bstr <- C.readFile fname+ r <- checkVersionAndMigrate bstr case r of - Done _ h -> constructNewHoodleStateFromHoodle h xstate - >>= return . set currFileName (Just fname)- _ -> print r >> return xstate + Left err -> putStrLn err >> return xstate + Right h -> constructNewHoodleStateFromHoodle h xstate + >>= return . set (hoodleFileControl.hoodleFileName) (Just fname) ".xoj" -> do XP.parseXojFile fname >>= \x -> case x of Left str -> do putStrLn $ "file reading error : " ++ str return xstate Right xojcontent -> do - let hdlcontent = mkHoodleFromXournal xojcontent + hdlcontent <- mkHoodleFromXournal xojcontent nxstate <- constructNewHoodleStateFromHoodle hdlcontent xstate - return $ set currFileName (Just fname) nxstate + return $ set (hoodleFileControl.hoodleFileName) (Just fname) nxstate ".pdf" -> do - mhdl <- makeNewHoodleWithPDF fname + 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 currFileName Nothing $ newhdlstate + return . set (hoodleFileControl.hoodleFileName) Nothing $ newhdlstate _ -> getFileContent Nothing xstate getFileContent Nothing xstate = do - newhdl <- cnstrctRHoodle defaultHoodle + newhdl <- cnstrctRHoodle =<< defaultHoodle let newhdlstate = ViewAppendState newhdl - xstate' = set currFileName Nothing + xstate' = set (hoodleFileControl.hoodleFileName) Nothing . set hoodleModeState newhdlstate $ xstate return xstate' - - - -- | constructNewHoodleStateFromHoodle :: Hoodle -> HoodleState -> IO HoodleState @@ -90,11 +105,58 @@ 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 + in if null ys then Nothing else head ys + where f (_,p) = case view gbackground p of + RBkgPDF _ fi _ _ _ -> Just fi+ _ -> Nothing + +findAllPDFPages :: [(Int,RPage)] -> [Int]+findAllPDFPages = catMaybes . map f+ where f (n,p) = case view gbackground p of + RBkgPDF _ _ _ _ _ -> Just n+ _ -> Nothing ++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) + -- | -makeNewHoodleWithPDF :: FilePath -> IO (Maybe Hoodle)-makeNewHoodleWithPDF fp = do -#ifdef POPPLER- let fname = C.pack fp +embedPDFInHoodle :: RHoodle -> IO RHoodle+embedPDFInHoodle hdl = do + let pgs = (IM.toAscList . view gpages) hdl + mfn = findFirstPDFFile pgs+ allpdfpg = findAllPDFPages pgs + + case mfn of + Nothing -> return hdl + Just fn -> do + let fnstr = C.unpack fn + pglst = map show allpdfpg + cmdargs = [fnstr, "cat"] ++ pglst ++ ["output", "-"]+ print cmdargs + (_,Just hout,_,_) <- createProcess (proc "pdftk" cmdargs) { std_out = CreatePipe } + bstr <- C.hGetContents hout+ let ebdsrc = makeEmbeddedPdfSrcString bstr + npgs = (IM.fromAscList . replacePDFPages) pgs + (return . set gembeddedpdf (Just ebdsrc) . set gpages npgs) hdl++++makeEmbeddedPdfSrcString :: C.ByteString -> C.ByteString +makeEmbeddedPdfSrcString = ("data:application/x-pdf;base64," <>) . encode++-- | +makeNewHoodleWithPDF :: Bool -- ^ doesEmbedPDF+ -> FilePath -- ^ pdf file+ -> IO (Maybe Hoodle) +makeNewHoodleWithPDF doesembed fp = do + canonicalfp <- canonicalizePath fp + let fname = C.pack canonicalfp mdoc <- popplerGetDocFromFile fname case mdoc of Nothing -> do @@ -107,24 +169,33 @@ pg <- Poppler.documentGetPage doc (i-1) (w,h) <- PopplerPage.pageGetSize pg let dim = Dim w h - return (createPage dim fname i) + return (createPage doesembed dim fname i) pgs <- mapM createPageAct [1..n]- let hdl = set title fname - . set pages pgs- $ emptyHoodle- return (Just hdl)-#else- return Nothing-#endif+ hdl <- set title fname . set pages pgs <$> emptyHoodle+ nhdl <- if doesembed + then do + bstr <- C.readFile canonicalfp + let ebdsrc = makeEmbeddedPdfSrcString bstr + return (set embeddedPdf (Just ebdsrc) hdl)+ else return hdl + return (Just nhdl) -- | -createPage :: Dimension -> B.ByteString -> Int -> Page-createPage dim fn n - | n == 1 = let bkg = BackgroundPdf "pdf" (Just "absolute") (Just fn ) n - in Page dim bkg [emptyLayer]- | otherwise = let bkg = BackgroundPdf "pdf" Nothing Nothing n - in Page dim bkg [emptyLayer]+createPage :: Bool -- ^ does embed pdf?+ -> Dimension + -> C.ByteString + -> Int + -> Page+createPage doesembed dim fn n =+ let bkg + | not doesembed && n == 1 + = BackgroundPdf "pdf" (Just "absolute") (Just fn ) n + | not doesembed && n /= 1 + = BackgroundPdf "pdf" Nothing Nothing n + | otherwise -- doesembed + = BackgroundEmbedPdf "embedpdf" n + in Page dim bkg [emptyLayer] -- |
src/Hoodle/ModelAction/Layer.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Layer --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,8 +14,7 @@ -- from other packages import Control.Category-import Control.Compose-import Control.Lens (view,set)+import Control.Lens (view,over) import Data.IORef import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (get)@@ -29,25 +28,17 @@ -- import Prelude hiding ((.),id) --- | -getCurrentLayerOrSet :: Page EditMode -> (Maybe RLayer, Page EditMode)-getCurrentLayerOrSet pg = - let olayers = view glayers pg- nlayers = case olayers of - NoSelect _ -> selectFirst olayers- Select _ -> olayers - in case nlayers of- NoSelect _ -> (Nothing, set glayers nlayers pg)- Select osz -> (return . current =<< unO osz, set glayers nlayers pg) +-- |+getCurrentLayer :: Page EditMode -> RLayer+getCurrentLayer = current . view glayers +++ -- | adjustCurrentLayer :: RLayer -> Page EditMode -> Page EditMode-adjustCurrentLayer nlayer pg = - let (molayer,pg') = getCurrentLayerOrSet pg- in maybe (set glayers (Select .O . Just . singletonSZ $ nlayer) pg')- (const $ let layerzipper = maybe (error "adjustCurrentLayer") id . unO . zipper . view glayers $ pg'- in set glayers (Select . O . Just . replace nlayer $ layerzipper) pg' )- molayer +adjustCurrentLayer nlayer = over glayers (replace nlayer)+ -- | layerChooseDialog :: IORef Int -> Int -> Int -> IO Dialog
src/Hoodle/ModelAction/Page.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Page --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,8 +15,7 @@ module Hoodle.ModelAction.Page where import Control.Applicative-import Control.Category-import Control.Lens+import Control.Lens (view,set) import Control.Monad (liftM) -- import Control.Monad.Trans.Either import qualified Data.IntMap as M@@ -26,7 +25,7 @@ -- import Control.Monad.Trans.Crtn import Data.Hoodle.Generic import Data.Hoodle.Select-import qualified Data.Hoodle.Simple as S+import Data.Hoodle.Zipper import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Util@@ -38,7 +37,7 @@ import Hoodle.Type.Predefined import Hoodle.View.Coordinate -- -import Prelude hiding ((.),id,mapM)+import Prelude hiding (mapM) -- |@@ -128,8 +127,9 @@ updatePage :: HoodleModeState -> CanvasInfoBox -> IO CanvasInfoBox updatePage (ViewAppendState hdl) c = updateCvsInfoFrmHoodle hdl c updatePage (SelectState thdl) c = do - let hdl = GHoodle (view gselTitle thdl) (view gselAll thdl)+ let hdl = gSelect2GHoodle thdl updateCvsInfoFrmHoodle hdl c+ -- GHoodle (view gselTitle thdl) (view gselAll thdl) -- | setPage :: HoodleState -> PageNum -> CanvasId -> IO CanvasInfoBox@@ -169,7 +169,7 @@ -- | newSinglePageFromOld :: Page EditMode -> Page EditMode -newSinglePageFromOld = set glayers (fromList [emptyRLayer])+newSinglePageFromOld = set glayers (fromNonEmptyList (emptyRLayer,[])) -- (NoSelect [emptyRLayer]) @@ -179,14 +179,13 @@ -> AddDirection -> Hoodle EditMode -> Int - -> Hoodle EditMode -- IO (Hoodle EditMode)+ -> 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 = let bkg = rbkg2Bkg cbkg - in bkg2RBkg bkg { S.bkg_style = convertBackgroundStyleToByteString bsty } + | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty } | otherwise = cbkg npage = set gbackground nbkg . newSinglePageFromOld @@ -195,9 +194,10 @@ PageBefore -> pagesbefore ++ (npage : cpage : pagesafter) PageAfter -> pagesbefore ++ (cpage : npage : pagesafter) nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl- in nhdl -- return nhdl+ in nhdl --- | ++-- | need to be refactored into zoomRatioFrmRelToCurr (rename zoomRatioRelPredefined) relZoomRatio :: CanvasGeometry -> ZoomModeRel -> Double relZoomRatio geometry rzmode = let CvsCoord (cx0,_cy0) = desktop2Canvas geometry (DeskCoord (0,0))@@ -207,3 +207,9 @@ ZoomOut -> 1.0/predefinedZoomStepFactor in (cx1-cx0) * scalefactor +-- |+zoomRatioFrmRelToCurr :: CanvasGeometry -> Double -> Double +zoomRatioFrmRelToCurr geometry z = + let CvsCoord (cx0,_cy0) = desktop2Canvas geometry (DeskCoord (0,0))+ CvsCoord (cx1,_cy1) = desktop2Canvas geometry (DeskCoord (1,1))+ in (cx1-cx0) * z
src/Hoodle/ModelAction/Pen.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Pen --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,11 +14,10 @@ module Hoodle.ModelAction.Pen where -import Control.Category-import Control.Lens+import Control.Lens (view,set,over)+import Control.Monad.Identity (runIdentity) import Data.Foldable import qualified Data.IntMap as IM-import Data.Maybe -- import qualified Data.Map as M import Data.Sequence hiding (take, drop) import Data.Strict.Tuple hiding (uncurry)@@ -35,7 +34,6 @@ import Hoodle.Type.Enum import Hoodle.Type.PageArrangement ---import Prelude hiding ((.), id) -- | addPDraw :: PenInfo @@ -50,9 +48,9 @@ pcolname = convertPenColorToByteString pcolor pwidth = view (currentTool.penWidth) pinfo pvwpen = view variableWidthPen pinfo- (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)+ currpage = getPageFromGHoodleMap pgnum hdl+ currlayer = getCurrentLayer currpage dim = view gdimension currpage- currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer ptool = case ptype of PenWork -> "pen" HighlighterWork -> "highlighter"@@ -69,8 +67,8 @@ , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw } - newstrokebbox = mkStrokeBBox newstroke- bbox = strkbbx_bbx newstrokebbox+ newstrokebbox = runIdentity (makeBBoxed newstroke)+ bbox = getBBox newstrokebbox newlayerbbox <- updateLayerBuf dim (Just bbox) . over gitems (++[RItemStroke newstrokebbox]) $ currlayer
src/Hoodle/ModelAction/Select.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Select --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,8 +15,7 @@ module Hoodle.ModelAction.Select where -- from other package-import Control.Category-import Control.Lens+import Control.Lens (view,set) import Control.Monad import Data.Algorithm.Diff import Data.Foldable (foldl')@@ -41,17 +40,16 @@ import Graphics.Hoodle.Render.Util.HitTest -- from this package import Hoodle.ModelAction.Layer+import Hoodle.ModelAction.Select.Transform import Hoodle.Type.Alias import Hoodle.Type.Enum import Hoodle.Type.HoodleState import Hoodle.Type.Predefined import Hoodle.Type.PageArrangement-import Hoodle.Util+ import Hoodle.View.Coordinate -- -import Prelude hiding ((.),id) - -- | data Handle = HandleTL | HandleTR @@ -87,53 +85,9 @@ where coordtrans (x,y) = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (x,y)) --- | -changeItemBy :: ((Double,Double)->(Double,Double)) -> RItem -> RItem-changeItemBy func (RItemStroke strk) = RItemStroke (changeStrokeBy func strk)-changeItemBy func (RItemImage img sfc) = RItemImage (changeImageBy func img) sfc-changeItemBy func (RItemSVG svg rsvg) = RItemSVG (changeSVGBy func svg) rsvg- ----- | modify stroke using a function-changeStrokeBy :: ((Double,Double)->(Double,Double)) -> StrokeBBox -> StrokeBBox-changeStrokeBy func (StrokeBBox (Stroke t c w ds) _bbox) = - let change ( x :!: y ) = let (nx,ny) = func (x,y) - in nx :!: ny- newds = map change ds - nstrk = Stroke t c w newds - nbbox = bboxFromStroke nstrk - in StrokeBBox nstrk nbbox-changeStrokeBy func (StrokeBBox (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 - nbbox = bboxFromStroke nstrk - in StrokeBBox nstrk nbbox---- | -changeImageBy :: ((Double,Double)->(Double,Double)) -> ImageBBox -> ImageBBox-changeImageBy func (ImageBBox (Image bstr (x,y) (Dim w h)) _bbox) = - let (x1,y1) = func (x,y) - (x2,y2) = func (x+w,y+h)- nimg = Image bstr (x1,y1) (Dim (x2-x1) (y2-y1))- in mkImageBBox nimg ---- | -changeSVGBy :: ((Double,Double)->(Double,Double)) -> SVGBBox -> SVGBBox-changeSVGBy func (SVGBBox (SVG t c bstr (x,y) (Dim w h)) _bbox) = - let (x1,y1) = func (x,y) - (x2,y2) = func (x+w,y+h)- nsvg = SVG t c bstr (x1,y1) (Dim (x2-x1) (y2-y1))- in mkSVGBBox nsvg - -- nbbox = bboxFromImage nimg -- in ImageBBox nimg nbbox --- |-rItmsInActiveLyr :: Page SelectMode -> Either [RItem] (TAlterHitted RItem)-rItmsInActiveLyr = unTEitherAlterHitted.view (glayers.selectedLayer.gitems) -- | getSelectedItms :: Page SelectMode -> [RItem]@@ -150,10 +104,9 @@ -> TAlterHitted RItem -- ^ current selection layer (active layer will be replaced) -> Page SelectMode -- ^ resultant select mode page makePageSelectMode page alist = - let (mcurrlayer,npage) = getCurrentLayerOrSet page- clyr = maybeError' "makePageSelectMode" mcurrlayer + let clyr = getCurrentLayer page nlyr= GLayer (view gbuffer clyr) (TEitherAlterHitted (Right alist))- in set (glayers.selectedLayer) nlyr (mkHPage npage) + in set (glayers.selectedLayer) nlyr (mkHPage page) -- | get unselected part of page and make an ordinary page@@ -169,33 +122,8 @@ in set (glayers.selectedLayer) layer' tpage --- | modify the whole selection using a function-changeSelectionBy :: ((Double,Double) -> (Double,Double))- -> Page SelectMode -> Page SelectMode-changeSelectionBy func tpage = - let activelayer = rItmsInActiveLyr tpage- buf = view (glayers.selectedLayer.gbuffer) tpage- in case activelayer of - Left _ -> tpage - Right alist -> - let alist' =fmapAL id - (Hitted . map (changeItemBy func) . unHitted) - alist - layer' = GLayer buf . TEitherAlterHitted . Right $ alist'- in set (glayers.selectedLayer) layer' tpage - ---- | special case of offset modification-changeSelectionByOffset :: (Double,Double) -> Page SelectMode -> Page SelectMode-changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy))- -- |-offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) -offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy)----- | updateTempHoodleSelect :: Hoodle SelectMode -> Page SelectMode -> Int -> Hoodle SelectMode updateTempHoodleSelect thdl tpage pagenum = @@ -217,8 +145,8 @@ $ thdl -- | -calculateWholeBBox :: [StrokeBBox] -> Maybe BBox -calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. strkbbx_bbx ) +calculateWholeBBox :: [BBoxed Stroke] -> Maybe BBox +calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. getBBox ) -- | hitInSelection :: Page SelectMode -> (Double,Double) -> Bool @@ -272,20 +200,20 @@ actionSetSensitive pastea b -- |-changeStrokeColor :: PenColor -> StrokeBBox -> StrokeBBox+changeStrokeColor :: PenColor -> BBoxed Stroke -> BBoxed Stroke changeStrokeColor pcolor str = let Just cname = Map.lookup pcolor penColorNameMap - strsmpl = strkbbx_strk str - in str { strkbbx_strk = set color cname strsmpl } + strsmpl = bbxed_content str + in str { bbxed_content = set color cname strsmpl } -- |-changeStrokeWidth :: Double -> StrokeBBox -> StrokeBBox+changeStrokeWidth :: Double -> BBoxed Stroke -> BBoxed Stroke changeStrokeWidth pwidth str = - let nstrsmpl = case strkbbx_strk str of + let nstrsmpl = case bbxed_content str of Stroke t c _w d -> Stroke t c pwidth d VWStroke t c d -> Stroke t c pwidth (map (\(x,y,_z) -> (x:!:y)) d) -- Img b w h -> Img b w h- in str { strkbbx_strk = nstrsmpl } + in str { bbxed_content = nstrsmpl } -- | changeItemStrokeWidth :: Double -> RItem -> RItem @@ -302,7 +230,7 @@ -- | newtype CmpBBox a = CmpBBox { unCmpBBox :: a } -- deriving Show-instance (BBoxable a) => Eq (CmpBBox a) where+instance (GetBBoxable a) => Eq (CmpBBox a) where CmpBBox s1 == CmpBBox s2 = getBBox s1 == getBBox s2 -- |@@ -318,7 +246,7 @@ f (B,_x) (fs,ss) = (fs,ss) -- |-getDiffBBox :: (BBoxable a) => [a] -> [a] -> [(DI,a)]+getDiffBBox :: (GetBBoxable a) => [a] -> [a] -> [(DI,a)] getDiffBBox lst1 lst2 = let nlst1 = fmap CmpBBox lst1 nlst2 = fmap CmpBBox lst2 @@ -386,8 +314,8 @@ hitLassoPoint lst = odd . mappingDegree lst -- | -hitLassoStroke :: Seq (Double,Double) -> StrokeBBox -> Bool -hitLassoStroke lst = all (hitLassoPoint lst) . getXYtuples . strkbbx_strk+hitLassoStroke :: Seq (Double,Double) -> BBoxed Stroke -> Bool +hitLassoStroke lst = all (hitLassoPoint lst) . getXYtuples . bbxed_content -- | hitLassoItem :: Seq (Double,Double) -> RItem -> Bool @@ -400,7 +328,10 @@ hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) where BBox (x1,y1) (x2,y2) = getBBox svg-+hitLassoItem lst (RItemLink lnk _) = + hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2)+ && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2)+ where BBox (x1,y1) (x2,y2) = getBBox lnk data TempSelectRender a = TempSelectRender { tempSurface :: Surface
+ src/Hoodle/ModelAction/Select/Transform.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.ModelAction.Select.Transform +-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.ModelAction.Select.Transform where++-- from other package+import Control.Category+import Control.Lens (view,set)+import Control.Monad.Identity (runIdentity)+import Data.Strict.Tuple+-- from hoodle-platform+import Data.Hoodle.Generic+import Data.Hoodle.BBox+import Data.Hoodle.Simple hiding (Page,Hoodle)+import Graphics.Hoodle.Render.Type+import Graphics.Hoodle.Render.Type.HitTest+-- from this package+import Hoodle.Type.Alias+-- +import Prelude hiding ((.),id)++-- |+rItmsInActiveLyr :: Page SelectMode -> Either [RItem] (TAlterHitted RItem)+rItmsInActiveLyr = unTEitherAlterHitted.view (glayers.selectedLayer.gitems)++-- | +changeItemBy :: ((Double,Double)->(Double,Double)) -> RItem -> RItem+changeItemBy func (RItemStroke strk) = RItemStroke (changeStrokeBy func strk)+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+ +++-- | modify stroke using a function+changeStrokeBy :: ((Double,Double)->(Double,Double)) -> BBoxed Stroke -> BBoxed Stroke+changeStrokeBy func (BBoxed (Stroke t c w ds) _bbox) = + let change ( x :!: y ) = let (nx,ny) = func (x,y) + in nx :!: ny+ 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+changeImageBy func (BBoxed (Image bstr (x,y) (Dim w h)) _bbox) = + let (x1,y1) = func (x,y) + (x2,y2) = func (x+w,y+h)+ nimg = Image bstr (x1,y1) (Dim (x2-x1) (y2-y1))+ in runIdentity (makeBBoxed nimg)++-- | +changeSVGBy :: ((Double,Double)->(Double,Double)) -> BBoxed SVG -> BBoxed SVG+changeSVGBy func (BBoxed (SVG t c bstr (x,y) (Dim w h)) _bbox) = + let (x1,y1) = func (x,y) + (x2,y2) = func (x+w,y+h)+ nsvg = SVG t c bstr (x1,y1) (Dim (x2-x1) (y2-y1))+ in runIdentity (makeBBoxed nsvg)+ +-- | +changeLinkBy :: ((Double,Double)->(Double,Double)) -> BBoxed Link -> BBoxed Link+changeLinkBy func (BBoxed (Link i typ loc t c bstr (x,y) (Dim w h)) _bbox) = + let (x1,y1) = func (x,y) + (x2,y2) = func (x+w,y+h)+ nlnk = Link i typ loc t c bstr (x1,y1) (Dim (x2-x1) (y2-y1))+ in runIdentity (makeBBoxed nlnk) +changeLinkBy func (BBoxed (LinkDocID i lid loc t c bstr (x,y) (Dim w h)) _bbox) = + let (x1,y1) = func (x,y) + (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) ++++++-- | modify the whole selection using a function+changeSelectionBy :: ((Double,Double) -> (Double,Double))+ -> Page SelectMode -> Page SelectMode+changeSelectionBy func tpage = + let activelayer = rItmsInActiveLyr tpage+ buf = view (glayers.selectedLayer.gbuffer) tpage+ in case activelayer of + Left _ -> tpage + Right alist -> + let alist' =fmapAL id + (Hitted . map (changeItemBy func) . unHitted) + alist + layer' = GLayer buf . TEitherAlterHitted . Right $ alist'+ in set (glayers.selectedLayer) layer' tpage ++ ++-- | special case of offset modification+changeSelectionByOffset :: (Double,Double) -> Page SelectMode -> Page SelectMode+changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy))++-- |+offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) +offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy)++
src/Hoodle/ModelAction/Window.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.ModelAction.Window --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,8 +15,7 @@ module Hoodle.ModelAction.Window where -- from other packages-import Control.Category-import Control.Lens+import Control.Lens (view) import Control.Monad.Trans import qualified Data.IntMap as M import Graphics.UI.Gtk hiding (get,set)@@ -31,14 +30,14 @@ import Hoodle.Type.HoodleState import Hoodle.Util -- -import Prelude hiding ((.),id) + -- | set frame title according to file name setTitleFromFileName :: HoodleState -> IO () setTitleFromFileName xstate = do - case view currFileName xstate of+ case view (hoodleFileControl.hoodleFileName) xstate of Nothing -> Gtk.set (view rootOfRootWindow xstate) [ windowTitle := "untitled" ] Just filename -> Gtk.set (view rootOfRootWindow xstate) @@ -67,7 +66,7 @@ scrolledWindowSetHAdjustment scrwin hadj scrolledWindowSetVAdjustment scrwin vadj -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic - return $ CanvasInfo cid canvas Nothing scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing+ return $ CanvasInfo cid canvas Nothing scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing defaultCanvasWidgets -- | only connect events @@ -98,6 +97,28 @@ liftIO (callback (PenUp cid p)) _exposeev <- canvas `on` exposeEvent $ tryEvent $ do liftIO $ callback (UpdateCanvas cid) + canvas `on` motionNotifyEvent $ tryEvent $ do + (_,p) <- getPointer dev+ liftIO $ callback (PenMove cid p)++ -- drag and drop setting+ dragDestSet canvas [DestDefaultMotion, DestDefaultDrop] [ActionCopy]+ dragDestAddTextTargets canvas+ canvas `on` dragDataReceived $ \_dc pos _i _ts -> do + s <- selectionDataGetText + liftIO $ callback (GotLink s pos)+ + {-+ liftIO . putStrLn $ case s of + Nothing -> "didn't understand the drop"+ Just s -> "understood. here it is : <" ++ s ++ ">" ++ " and pos is <" ++ show pos ++ ">" + -}+ {- + dragSourceSet canvas [Button1] [ActionCopy]+ dragSourceAddTextTargets canvas+ canvas `on` dragBegin $ \dc -> do + liftIO $ putStrLn "dragging"+ -} {- canvas `on` enterNotifyEvent $ tryEvent $ do
src/Hoodle/Script/Coroutine.hs view
@@ -14,8 +14,7 @@ module Hoodle.Script.Coroutine where -import Control.Lens--- import Control.Monad +import Control.Lens (view) import Control.Monad.State import Control.Monad.Trans.Maybe -- from hoodle-platform@@ -26,14 +25,6 @@ import Hoodle.Type.HoodleState -- -{---- |-runHookIO2 :: (Hook -> f) -> MainCoroutine ()-runHookIO2 a b = - liftM (H.afterSaveHook <=< view hookSet) get - >>= maybe (return ()) (\hk->liftIO (hk a b)) --}- -- | afterSaveHook :: FilePath -> Hoodle -> MainCoroutine () afterSaveHook fp hdl = do @@ -74,3 +65,23 @@ rfilename <- hoist (H.embedPredefinedImageHook hset) liftIO rfilename return r + +-- | temporary+embedPredefinedImage2Hook :: MainCoroutine (Maybe FilePath) +embedPredefinedImage2Hook = do + xstate <- get + (r :: Maybe FilePath) <- runMaybeT $ do + hset <- hoist (view hookSet xstate)+ rfilename <- hoist (H.embedPredefinedImage2Hook hset)+ liftIO rfilename + return r + +-- | temporary+embedPredefinedImage3Hook :: MainCoroutine (Maybe FilePath) +embedPredefinedImage3Hook = do + xstate <- get + (r :: Maybe FilePath) <- runMaybeT $ do + hset <- hoist (view hookSet xstate)+ rfilename <- hoist (H.embedPredefinedImage3Hook hset)+ liftIO rfilename + return r
src/Hoodle/Script/Hook.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Script.Hook--- Copyright : (c) 2012 Ian-Woo Kim+-- Copyright : (c) 2012, 2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,8 +12,9 @@ module Hoodle.Script.Hook where --- import System.FilePath import Data.Hoodle.Simple +import Graphics.Hoodle.Render.Type.Hoodle+-- -- | data Hook = Hook { saveAsHook :: Maybe (Hoodle -> IO ())@@ -22,9 +23,13 @@ , afterUpdateClipboardHook :: Maybe ([Item] -> IO ()) , customContextMenuTitle :: Maybe String , customContextMenuHook :: Maybe ([Item] -> IO ())+ , customAutosavePage :: Maybe (RPage -> IO ()) , fileNameSuggestionHook :: Maybe (IO String) , recentFolderHook :: Maybe (IO FilePath) , embedPredefinedImageHook :: Maybe (IO FilePath) + , embedPredefinedImage2Hook :: Maybe (IO FilePath)+ , embedPredefinedImage3Hook :: Maybe (IO FilePath)+ , lookupPathFromId :: Maybe (String -> IO (Maybe FilePath)) } @@ -35,7 +40,11 @@ , afterUpdateClipboardHook = Nothing , customContextMenuTitle = Nothing , customContextMenuHook = Nothing + , customAutosavePage = Nothing , fileNameSuggestionHook = Nothing , recentFolderHook = Nothing , embedPredefinedImageHook = Nothing + , embedPredefinedImage2Hook = Nothing+ , embedPredefinedImage3Hook = Nothing + , lookupPathFromId = Nothing }
src/Hoodle/Type/Canvas.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Canvas --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -23,13 +23,13 @@ , CanvasInfo (..) , CanvasInfoBox (..) , CanvasInfoMap--- , PenType (..) , WidthColorStyle , PenHighlighterEraserSet , PenInfo -- * default constructor , defaultViewInfoSinglePage , defaultCvsInfoSinglePage+, defaultCanvasWidgets , defaultPenWCS , defaultEraserWCS , defaultTextWCS@@ -51,6 +51,8 @@ , horizAdjConnId , vertAdjConnId , adjustments +, canvasWidgets+, testWidgetPosition , currentTool , penWidth , penColor@@ -58,6 +60,7 @@ , currHighlighter , currEraser , currText+, currVerticalSpace , penType , penSet , variableWidthPen@@ -72,17 +75,13 @@ , boxAction , selectBoxAction , selectBox--- , pageArrEitherFromCanvasInfoBox--- , viewModeBranch -- * others--- , getPage , updateCanvasDimForSingle , updateCanvasDimForContSingle ) where import Control.Applicative ((<*>),(<$>))-import Control.Category-import Control.Lens+import Control.Lens (Simple,Lens,view,set,lens) import qualified Data.IntMap as M import Data.Sequence import Graphics.Rendering.Cairo@@ -95,8 +94,8 @@ import Hoodle.Type.Enum import Hoodle.Type.PageArrangement ---import Prelude hiding ((.), id) + -- | type CanvasId = Int @@ -144,6 +143,12 @@ pageArrangement :: Simple Lens (ViewInfo a) (PageArrangement a) pageArrangement = lens _pageArrangement (\f a -> f { _pageArrangement = a }) +-- | +data CanvasWidgets = + CanvasWidgets { _testWidgetPosition :: CanvasCoordinate+ } ++ -- | data CanvasInfo a = (ViewMode a) => CanvasInfo { _canvasId :: CanvasId@@ -156,8 +161,17 @@ , _vertAdjustment :: Adjustment , _horizAdjConnId :: Maybe (ConnectId Adjustment) , _vertAdjConnId :: Maybe (ConnectId Adjustment)+ , _canvasWidgets :: CanvasWidgets } +-- | default hoodle widgets+defaultCanvasWidgets :: CanvasWidgets+defaultCanvasWidgets = + CanvasWidgets+ { _testWidgetPosition = CvsCoord (100,100)+ } ++ -- | xfrmCvsInfo :: (ViewMode a, ViewMode b) => (ViewInfo a -> ViewInfo b) @@ -173,6 +187,7 @@ , _vertAdjustment = _vertAdjustment , _horizAdjConnId = _horizAdjConnId , _vertAdjConnId = _vertAdjConnId + , _canvasWidgets = _canvasWidgets } -- | @@ -188,6 +203,7 @@ , _vertAdjustment = error "vadjust" , _horizAdjConnId = Nothing , _vertAdjConnId = Nothing+ , _canvasWidgets = defaultCanvasWidgets } -- | @@ -237,9 +253,15 @@ where getter = (,) <$> view horizAdjustment <*> view vertAdjustment setter f (h,v) = set horizAdjustment h . set vertAdjustment v $ f - {- Lens $ (,) <$> (fst `for` horizAdjustment)- <*> (snd `for` vertAdjustment) -}+-- | +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} )++ -- | data CanvasInfoBox = CanvasSinglePage (CanvasInfo SinglePage) | CanvasContPage (CanvasInfo ContinuousPage)@@ -305,6 +327,7 @@ -- | data WidthColorStyle = WidthColorStyle { _penWidth :: Double , _penColor :: PenColor } + | NoWidthColorStyle deriving (Show) -- | lens for penWidth@@ -321,7 +344,9 @@ { _currPen :: WidthColorStyle , _currHighlighter :: WidthColorStyle , _currEraser :: WidthColorStyle - , _currText :: WidthColorStyle}+ , _currText :: WidthColorStyle+ , _currVerticalSpace :: WidthColorStyle + } deriving (Show) -- | lens for currPen@@ -340,9 +365,14 @@ currText :: Simple Lens PenHighlighterEraserSet WidthColorStyle currText = lens _currText (\f a -> f { _currText = a } ) +-- | lens for currText+currVerticalSpace :: Simple Lens PenHighlighterEraserSet WidthColorStyle+currVerticalSpace = lens _currVerticalSpace + (\f a -> f { _currVerticalSpace = a } ) + -- | data PenInfo = PenInfo { _penType :: PenType@@ -374,6 +404,8 @@ PenWork -> _currPen . _penSet $ pinfo HighlighterWork -> _currHighlighter . _penSet $ pinfo EraserWork -> _currEraser . _penSet $ pinfo+ VerticalSpaceWork -> NoWidthColorStyle+ -- TextWork -> _currText . _penSet $ pinfo setter pinfo wcs = let pset = _penSet pinfo@@ -381,6 +413,7 @@ PenWork -> pset { _currPen = wcs } HighlighterWork -> pset { _currHighlighter = wcs } EraserWork -> pset { _currEraser = wcs }+ VerticalSpaceWork -> pset -- TextWork -> pset { _currText = wcs } in pinfo { _penSet = psetnew } @@ -407,7 +440,9 @@ , _penSet = PenHighlighterEraserSet { _currPen = defaultPenWCS , _currHighlighter = defaultHighligherWCS , _currEraser = defaultEraserWCS- , _currText = defaultTextWCS }+ , _currText = defaultTextWCS + , _currVerticalSpace = NoWidthColorStyle + } , _variableWidthPen = False }
src/Hoodle/Type/Clipboard.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Clipboard --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,15 +14,13 @@ module Hoodle.Type.Clipboard where -import Control.Category-import Control.Lens -- from hoodle-platform import Data.Hoodle.BBox+import Data.Hoodle.Simple ---import Prelude hiding ((.), id) -- |-newtype Clipboard = Clipboard { unClipboard :: [StrokeBBox] }+newtype Clipboard = Clipboard { unClipboard :: [BBoxed Stroke] } -- | emptyClipboard :: Clipboard@@ -33,27 +31,11 @@ isEmpty = null . unClipboard -- |-getClipContents :: Clipboard -> [StrokeBBox] +getClipContents :: Clipboard -> [BBoxed Stroke] getClipContents = unClipboard -- |-replaceClipContents :: [StrokeBBox] -> Clipboard -> Clipboard+replaceClipContents :: [BBoxed Stroke] -> Clipboard -> Clipboard replaceClipContents strs _ = Clipboard strs --- |-data SelectType = SelectRegionWork - | SelectRectangleWork - | SelectVerticalSpaceWork- | SelectHandToolWork - deriving (Show,Eq,Ord) --- |-data SelectInfo = SelectInfo { _selectType :: SelectType- }- deriving (Show) ---selectType :: Simple Lens SelectInfo SelectType -selectType = lens _selectType (\f a -> f { _selectType = a })---- makeLenses ''SelectInfo
src/Hoodle/Type/Coroutine.hs view
@@ -21,7 +21,7 @@ -- from other packages import Control.Applicative import Control.Concurrent-import Control.Lens +import Control.Lens ((^.),(.~)) -- import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State
src/Hoodle/Type/Enum.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Enum --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,10 +14,10 @@ module Hoodle.Type.Enum where +import Control.Lens (Simple,Lens,lens) import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import Data.Maybe --- import Numeric (showHex) -- import Data.Hoodle.Predefined @@ -27,19 +27,18 @@ deriving (Show,Eq,Ord,Enum) -- | relative zoom mode - data ZoomModeRel = ZoomIn | ZoomOut deriving (Show,Eq,Ord,Enum) --- | +-- | pen tool type data PenType = PenWork | HighlighterWork | EraserWork + | VerticalSpaceWork deriving (Show,Eq,Ord) --- TextWork --- | +-- | predefined pen colors data PenColor = ColorBlack | ColorBlue | ColorRed@@ -54,12 +53,33 @@ | ColorRGBA Double Double Double Double deriving (Show,Eq,Ord) +-- | predefined background styles data BackgroundStyle = BkgStylePlain | BkgStyleLined | BkgStyleRuled | BkgStyleGraph deriving (Show,Eq,Ord) ++-- | mode for vertical space adding +data VerticalSpaceMode = GoingUp | GoingDown | OverPage ++-- | select tool type+data SelectType = SelectRegionWork + | SelectRectangleWork + | SelectHandToolWork + deriving (Show,Eq,Ord) ++-- |+data SelectInfo = SelectInfo { _selectType :: SelectType+ }+ deriving (Show) +++selectType :: Simple Lens SelectInfo SelectType +selectType = lens _selectType (\f a -> f { _selectType = a })++-- | penColorNameMap :: M.Map PenColor B.ByteString penColorNameMap = M.fromList [ (ColorBlack, "black") , (ColorBlue , "blue")
src/Hoodle/Type/Event.hs view
@@ -12,15 +12,14 @@ module Hoodle.Type.Event where -import Data.ByteString -- from other package+import Data.ByteString +import Data.IORef import Graphics.UI.Gtk -- from hoodle-platform--- import Data.Hoodle.BBox import Data.Hoodle.Simple -- from this package import Hoodle.Device -import Hoodle.Type.Clipboard import Hoodle.Type.Enum import Hoodle.Type.Canvas import Hoodle.Type.PageArrangement@@ -34,7 +33,7 @@ | PenMove Int PointerCoord | PenUp Int PointerCoord | PenColorChanged PenColor- | PenWidthChanged Int -- (PenType -> Double)+ | PenWidthChanged Int | AssignPenMode (Either PenType SelectType) | BackgroundStyleChanged BackgroundStyle | HScrollBarMoved Int Double@@ -58,10 +57,14 @@ | GotContextMenuSignal ContextMenuEvent | LaTeXInput (Maybe (ByteString,ByteString)) | TextInput (Maybe String) - -- | EventConnected+ | AddLink (Maybe (String,FilePath)) | EventDisconnected- deriving (Show,Eq,Ord)-+ | GetHoodleFileInfo (IORef (Maybe String))+ | GotLink (Maybe String) (Int,Int)+ deriving Show+ +instance Show (IORef a) where + show _ = "IORef" -- | data MenuEvent = MenuNew @@ -75,6 +78,8 @@ | MenuLoadSVG | MenuLaTeX | MenuEmbedPredefinedImage+ | MenuEmbedPredefinedImage2+ | MenuEmbedPredefinedImage3 | MenuPrint | MenuExport | MenuQuit @@ -84,8 +89,6 @@ | MenuCopy | MenuPaste | MenuDelete- -- | MenuNetCopy- -- | MenuNetPaste | MenuFullScreen | MenuZoom | MenuZoomIn@@ -117,11 +120,11 @@ | MenuPaperColor | MenuPaperStyle | MenuApplyToAllPages - | MenuLoadBackground- | MenuBackgroundScreenshot + | MenuEmbedAllPDFBkg | MenuDefaultPaper | MenuSetAsDefaultPaper | MenuText + | MenuAddLink | MenuShapeRecognizer | MenuRuler | MenuSelectRegion@@ -143,6 +146,7 @@ | MenuSmoothScroll | MenuUsePopUpMenu | MenuEmbedImage+ | MenuEmbedPDF | MenuDiscardCoreEvents | MenuEraserTip | MenuPressureSensitivity@@ -172,6 +176,10 @@ | CMenuCopy | CMenuDelete | CMenuCanvasView CanvasId PageNum Double Double + | CMenuRotateCW+ | CMenuRotateCCW + | CMenuAutosavePage+ | CMenuLinkConvert Link | CMenuCustom deriving (Show, Ord, Eq)
src/Hoodle/Type/HoodleState.hs view
@@ -16,9 +16,11 @@ ( HoodleState(..) , HoodleModeState(..) , IsOneTimeSelectMode(..)+, Settings(..)+, UIComponentSignalHandler(..) -- | labels , hoodleModeState-, currFileName+, hoodleFileControl , cvsInfoMap , currentCanvas , frameState@@ -35,18 +37,30 @@ , undoTable , backgroundStyle , isFullScreen -, doesUseXInput -, doesSmoothScroll -, doesUsePopUpMenu-, doesEmbedImage+, settings+, uiComponentSignalHandler , isOneTimeSelectMode-, pageModeSignal , lastTimeCanvasConfigure , hookSet , tempLog , tempQueue +-- +, hoodleFileName +--+, doesUseXInput +, doesSmoothScroll +, doesUsePopUpMenu+, doesEmbedImage+, doesEmbedPDF+-- +, penModeSignal+, pageModeSignal+, penPointSignal+, penColorSignal -- | others , emptyHoodleState+, defaultSettings +, defaultUIComponentSignalHandler , getHoodle -- | additional lenses , getCanvasInfoMap @@ -90,7 +104,6 @@ import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.Canvas-import Hoodle.Type.Clipboard import Hoodle.Type.Window import Hoodle.Type.Undo import Hoodle.Type.Alias @@ -116,7 +129,7 @@ data HoodleState = HoodleState { _hoodleModeState :: HoodleModeState- , _currFileName :: Maybe FilePath+ , _hoodleFileControl :: HoodleFileControl , _cvsInfoMap :: CanvasInfoMap , _currentCanvas :: (CanvasId,CanvasInfoBox) , _frameState :: WindowConfig @@ -124,7 +137,6 @@ , _rootContainer :: Box , _rootOfRootWindow :: Window , _currentPenDraw :: PenDraw- -- , _clipboard :: Clipboard , _callBack :: MyEvent -> IO () , _deviceList :: DeviceList , _penInfo :: PenInfo@@ -134,26 +146,30 @@ , _undoTable :: UndoTable HoodleModeState , _backgroundStyle :: BackgroundStyle , _isFullScreen :: Bool - , _doesUseXInput :: Bool - , _doesSmoothScroll :: Bool - , _doesUsePopUpMenu :: Bool - , _doesEmbedImage :: Bool + , _settings :: Settings + , _uiComponentSignalHandler :: UIComponentSignalHandler , _isOneTimeSelectMode :: IsOneTimeSelectMode- , _pageModeSignal :: Maybe (ConnectId RadioAction)+ -- , _pageModeSignal :: Maybe (ConnectId RadioAction)+ -- , _penModeSignal :: Maybe (ConnectId RadioAction) , _lastTimeCanvasConfigure :: Maybe UTCTime , _hookSet :: Maybe Hook , _tempQueue :: Queue (Either (ActionOrder MyEvent) MyEvent) , _tempLog :: String -> String } + -- | lens for hoodleModeState hoodleModeState :: Simple Lens HoodleState HoodleModeState hoodleModeState = lens _hoodleModeState (\f a -> f { _hoodleModeState = a } ) --- | lens for currFileName-currFileName :: Simple Lens HoodleState (Maybe FilePath)-currFileName = lens _currFileName (\f a -> f { _currFileName = a } ) ++-- | +hoodleFileControl :: Simple Lens HoodleState HoodleFileControl+hoodleFileControl = lens _hoodleFileControl (\f a -> f { _hoodleFileControl = a })+++ -- | lens for cvsInfoMap cvsInfoMap :: Simple Lens HoodleState CanvasInfoMap cvsInfoMap = lens _cvsInfoMap (\f a -> f { _cvsInfoMap = a } )@@ -218,30 +234,20 @@ isFullScreen :: Simple Lens HoodleState Bool isFullScreen = lens _isFullScreen (\f a -> f { _isFullScreen = a } ) --- | flag for XInput extension (needed for using full power of wacom)-doesUseXInput :: Simple Lens HoodleState Bool-doesUseXInput = lens _doesUseXInput (\f a -> f { _doesUseXInput = a } )---- | flag for smooth scrolling -doesSmoothScroll :: Simple Lens HoodleState Bool-doesSmoothScroll = lens _doesSmoothScroll (\f a -> f { _doesSmoothScroll = a } )---- | flag for using popup menu-doesUsePopUpMenu :: Simple Lens HoodleState Bool-doesUsePopUpMenu = lens _doesUsePopUpMenu (\f a -> f { _doesUsePopUpMenu = a } )+-- | +settings :: Simple Lens HoodleState Settings +settings = lens _settings (\f a -> f { _settings = a } ) --- | flag for embedding image as base64 in hdl file -doesEmbedImage :: Simple Lens HoodleState Bool-doesEmbedImage = lens _doesEmbedImage (\f a -> f { _doesEmbedImage = a } )+-- | +uiComponentSignalHandler :: Simple Lens HoodleState UIComponentSignalHandler+uiComponentSignalHandler = lens _uiComponentSignalHandler (\f a -> f { _uiComponentSignalHandler = a }) -- | lens for isOneTimeSelectMode isOneTimeSelectMode :: Simple Lens HoodleState IsOneTimeSelectMode isOneTimeSelectMode = lens _isOneTimeSelectMode (\f a -> f { _isOneTimeSelectMode = a } ) --- | lens for pageModeSignal-pageModeSignal :: Simple Lens HoodleState (Maybe (ConnectId RadioAction))-pageModeSignal = lens _pageModeSignal (\f a -> f { _pageModeSignal = a } ) + -- | lens for lastTimeCanvasConfigure lastTimeCanvasConfigure :: Simple Lens HoodleState (Maybe UTCTime) lastTimeCanvasConfigure = lens _lastTimeCanvasConfigure (\f a -> f { _lastTimeCanvasConfigure = a } )@@ -259,52 +265,139 @@ tempLog = lens _tempLog (\f a -> f { _tempLog = a } ) --- makeLenses ''HoodleState +-- | +data HoodleFileControl = + HoodleFileControl { _hoodleFileName :: Maybe FilePath } -emptyHoodleState :: HoodleState -emptyHoodleState = - HoodleState - { _hoodleModeState = ViewAppendState emptyGHoodle- , _currFileName = Nothing - , _cvsInfoMap = error "emptyHoodleState.cvsInfoMap"- , _currentCanvas = error "emtpyHoodleState.currentCanvas"- , _frameState = error "emptyHoodleState.frameState" - , _rootWindow = error "emtpyHoodleState.rootWindow"- , _rootContainer = error "emptyHoodleState.rootContainer"- , _rootOfRootWindow = error "emptyHoodleState.rootOfRootWindow"- , _currentPenDraw = emptyPenDraw - -- , _clipboard = emptyClipboard- , _callBack = error "emtpyHoodleState.callBack"- , _deviceList = error "emtpyHoodleState.deviceList"- , _penInfo = defaultPenInfo - , _selectInfo = SelectInfo SelectRectangleWork - , _gtkUIManager = error "emptyHoodleState.gtkUIManager"- , _isSaved = False - , _undoTable = emptyUndo 1 - -- , _isEventBlocked = False - , _backgroundStyle = BkgStyleLined- , _isFullScreen = False- , _doesUseXInput = False+-- | lens for currFileName+hoodleFileName :: Simple Lens HoodleFileControl (Maybe FilePath)+hoodleFileName = lens _hoodleFileName (\f a -> f { _hoodleFileName = a } )++-- | +data UIComponentSignalHandler = + UIComponentSignalHandler{ _penModeSignal :: Maybe (ConnectId RadioAction)+ , _pageModeSignal :: Maybe (ConnectId RadioAction)+ , _penPointSignal :: Maybe (ConnectId RadioAction)+ , _penColorSignal :: Maybe (ConnectId RadioAction)+ } ++-- | lens for penModeSignal+penModeSignal :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction))+penModeSignal = lens _penModeSignal (\f a -> f { _penModeSignal = a } )++-- | lens for pageModeSignal+pageModeSignal :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction))+pageModeSignal = lens _pageModeSignal (\f a -> f { _pageModeSignal = a } )++-- | lens for penPointSignal+penPointSignal :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction))+penPointSignal = lens _penPointSignal (\f a -> f { _penPointSignal = a } )++-- | lens for penColorSignal+penColorSignal :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction))+penColorSignal = lens _penColorSignal (\f a -> f { _penColorSignal = a } )+++-- | A set of Hoodle settings +data Settings = + Settings { _doesUseXInput :: Bool + , _doesSmoothScroll :: Bool + , _doesUsePopUpMenu :: Bool + , _doesEmbedImage :: Bool + , _doesEmbedPDF :: Bool + } + ++-- | flag for XInput extension (needed for using full power of wacom)+doesUseXInput :: Simple Lens Settings Bool+doesUseXInput = lens _doesUseXInput (\f a -> f { _doesUseXInput = a } )++-- | flag for smooth scrolling +doesSmoothScroll :: Simple Lens Settings Bool+doesSmoothScroll = lens _doesSmoothScroll (\f a -> f { _doesSmoothScroll = a } )++-- | flag for using popup menu+doesUsePopUpMenu :: Simple Lens Settings Bool+doesUsePopUpMenu = lens _doesUsePopUpMenu (\f a -> f { _doesUsePopUpMenu = a } )++-- | flag for embedding image as base64 in hdl file +doesEmbedImage :: Simple Lens Settings Bool+doesEmbedImage = lens _doesEmbedImage (\f a -> f { _doesEmbedImage = a } )++-- | flag for embedding pdf background as base64 in hdl file +doesEmbedPDF :: Simple Lens Settings Bool+doesEmbedPDF = lens _doesEmbedPDF (\f a -> f { _doesEmbedPDF = a } )+++-- | default hoodle state +emptyHoodleState :: IO HoodleState +emptyHoodleState = do+ hdl <- emptyGHoodle+ return $+ HoodleState + { _hoodleModeState = ViewAppendState hdl + , _hoodleFileControl = emptyHoodleFileControl + -- , _currFileName = Nothing + , _cvsInfoMap = error "emptyHoodleState.cvsInfoMap"+ , _currentCanvas = error "emtpyHoodleState.currentCanvas"+ , _frameState = error "emptyHoodleState.frameState" + , _rootWindow = error "emtpyHoodleState.rootWindow"+ , _rootContainer = error "emptyHoodleState.rootContainer"+ , _rootOfRootWindow = error "emptyHoodleState.rootOfRootWindow"+ , _currentPenDraw = emptyPenDraw + -- , _clipboard = emptyClipboard+ , _callBack = error "emtpyHoodleState.callBack"+ , _deviceList = error "emtpyHoodleState.deviceList"+ , _penInfo = defaultPenInfo + , _selectInfo = SelectInfo SelectRectangleWork + , _gtkUIManager = error "emptyHoodleState.gtkUIManager"+ , _isSaved = False + , _undoTable = emptyUndo 1 + -- , _isEventBlocked = False + , _backgroundStyle = BkgStyleLined+ , _isFullScreen = False+ , _settings = defaultSettings+ , _uiComponentSignalHandler = defaultUIComponentSignalHandler + , _isOneTimeSelectMode = NoOneTimeSelectMode+ -- , _pageModeSignal = Nothing+ -- , _penModeSignal = Nothing + , _lastTimeCanvasConfigure = Nothing + , _hookSet = Nothing+ , _tempQueue = emptyQueue+ , _tempLog = id + }++emptyHoodleFileControl :: HoodleFileControl +emptyHoodleFileControl = + HoodleFileControl { _hoodleFileName = Nothing } +++defaultUIComponentSignalHandler :: UIComponentSignalHandler+defaultUIComponentSignalHandler = + UIComponentSignalHandler{ _penModeSignal = Nothing + , _pageModeSignal = Nothing + , _penPointSignal = Nothing + , _penColorSignal = Nothing + } +++-- | default settings+defaultSettings :: Settings+defaultSettings = + Settings + { _doesUseXInput = False , _doesSmoothScroll = False , _doesUsePopUpMenu = True , _doesEmbedImage = True - , _isOneTimeSelectMode = NoOneTimeSelectMode- , _pageModeSignal = Nothing- , _lastTimeCanvasConfigure = Nothing - , _hookSet = Nothing- , _tempQueue = emptyQueue- , _tempLog = id - }+ , _doesEmbedPDF = True + } + -- | - getHoodle :: HoodleState -> Hoodle EditMode -getHoodle = either id makehdl . hoodleModeStateEither . view hoodleModeState - where makehdl thdl = GHoodle (view gselTitle thdl) (view gselAll thdl)-+getHoodle = either id gSelect2GHoodle . hoodleModeStateEither . view hoodleModeState -- | - getCurrentCanvasId :: HoodleState -> CanvasId getCurrentCanvasId = fst . _currentCanvas @@ -350,10 +443,7 @@ ViewAppendState hdl -> liftIO . liftM ViewAppendState . updateHoodleBuf $ hdl _ -> return hdlmodestate1 -- -- |- getCanvasInfo :: CanvasId -> HoodleState -> CanvasInfoBox getCanvasInfo cid xstate = let cinfoMap = getCanvasInfoMap xstate@@ -361,7 +451,6 @@ in maybeError' ("no canvas with id = " ++ show cid) maybeCvs -- | - setCanvasInfo :: (CanvasId,CanvasInfoBox) -> HoodleState -> HoodleState setCanvasInfo (cid,cinfobox) xstate = let cmap = getCanvasInfoMap xstate@@ -371,7 +460,6 @@ -- | change current canvas. this is the master function - updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> HoodleState -> HoodleState updateFromCanvasInfoAsCurrentCanvas cinfobox xstate = let cid = unboxGet canvasId cinfobox @@ -383,48 +471,18 @@ , _cvsInfoMap = cmap' } -- | - setCanvasId :: CanvasId -> CanvasInfoBox -> CanvasInfoBox setCanvasId cid = insideAction4CvsInfoBox (set canvasId cid) - - - -- (CanvasInfoBox cinfo) = CanvasInfoBox (cinfo { _canvasId = cid }) - -- | - modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) -> HoodleState -> HoodleState modifyCanvasInfo cid f xstate = maybe xstate id . flip setCanvasInfoMap xstate . M.adjust f cid . getCanvasInfoMap $ xstate - -{---- | should be deprecated-modifyCurrentCanvasInfo :: (CanvasInfoBox -> CanvasInfoBox) - -> HoodleState- -> HoodleState-modifyCurrentCanvasInfo f = over currentCanvasInfo f --}--{---- | should be deprecated -modifyCurrCvsInfoM :: (Monad m) => (CanvasInfoBox -> m CanvasInfoBox) - -> HoodleState- -> m HoodleState-modifyCurrCvsInfoM f st = do - let cinfobox = view currentCanvasInfo st - cid = getCurrentCanvasId st - ncinfobox <- f cinfobox- let cinfomap = getCanvasInfoMap st- ncinfomap = M.adjust (const ncinfobox) cid cinfomap - maybe (return st) return (setCanvasInfoMap ncinfomap st) --}- -- | - hoodleModeStateEither :: HoodleModeState -> Either (Hoodle EditMode) (Hoodle SelectMode) hoodleModeStateEither hdlmodst = case hdlmodst of ViewAppendState hdl -> Left hdl
src/Hoodle/Type/PageArrangement.hs view
@@ -16,11 +16,8 @@ -- from other packages import Control.Applicative-import Control.Category ((.))--- import Control.Error.Util (note)-import Control.Lens+import Control.Lens (Simple,Lens,view,lens) import Data.Foldable (toList)--- import Data.Maybe (fromJust) -- from hoodle-platform import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic@@ -30,9 +27,7 @@ import Hoodle.Type.Alias import Hoodle.Util -- -import Prelude hiding ((.),id) - -- | data ZoomMode = Original | FitWidth | FitHeight | Zoom Double @@ -108,6 +103,26 @@ apply f (ViewPortBBox bbox1) = ViewPortBBox (f bbox1) {-# INLINE apply #-} ++-- | +xformViewPortFitInSize :: Dimension -> (BBox -> BBox) -> ViewPortBBox -> ViewPortBBox+xformViewPortFitInSize (Dim w h) f (ViewPortBBox bbx) = + let BBox (x1,y1) (x2,y2) = f bbx + (x1',x2') + | x2>w && w-(x2-x1)>0 = (w-(x2-x1),w) + | x2>w && w-(x2-x1)<=0 = (0,x2-x1) + | x1<0 = (0,x2-x1)+ | otherwise = (x1,x2)+ (y1',y2') + | y2>h && h-(y2-y1)>0 = (h-(y2-y1),h)+ | y2>h && h-(y2-y1)<=0 = (0,y2-y1)+ | y1 <0 = (0,y2-y1)+ | otherwise = (y1,y2)+ in ViewPortBBox (BBox (x1',y1') (x2',y2') )+ + + + -- | data structure for coordinate arrangement of pages in desktop coordinate data PageArrangement a where SingleArrangement :: CanvasDimension @@ -155,11 +170,17 @@ let dim = view gdimension . head . toList . view gpages $ hdl (sinvx,sinvy) = getRatioPageCanvas zmode (PageDimension dim) cdim cnstrnt = DesktopWidthConstrained (cw/sinvx) - (PageOrigin (x0,y0),_) = maybeError' "makeContArr" (pageArrFuncCont cnstrnt hdl pnum)- ddim@(DesktopDimension (Dim w h)) = deskDimCont cnstrnt hdl + -- default to zero if error + (PageOrigin (x0,y0),_) = maybe (PageOrigin (0,0),PageDimension (Dim cw ch)) + id (pageArrFuncCont cnstrnt hdl pnum)+ ddim@(DesktopDimension iddim) = deskDimCont cnstrnt hdl (x1,y1) = (xpos+x0,ypos+y0) (x2,y2) = (xpos+x0+cw/sinvx,ypos+y0+ch/sinvy) - (x1',x2') + ovport =ViewPortBBox (BBox (x1,y1) (x2,y2))+ vport = xformViewPortFitInSize iddim id ovport+ in ContinuousArrangement cdim ddim (pageArrFuncCont cnstrnt hdl) vport++{- (x1',x2') | x2>w && w-(x2-x1)>0 = (w-(x2-x1),w) | x2>w && w-(x2-x1)<=0 = (0,x2-x1) | otherwise = (x1,x2)@@ -167,9 +188,9 @@ | y2>h && h-(y2-y1)>0 = (h-(y2-y1),h) | y2>h && h-(y2-y1)<=0 = (0,y2-y1) | otherwise = (y1,y2)- vport = ViewPortBBox (BBox (x1',y1') (x2',y2') )- in ContinuousArrangement cdim ddim (pageArrFuncCont cnstrnt hdl) vport+ vport = ViewPortBBox (BBox (x1',y1') (x2',y2') ) -} + -- | pageArrFuncCont :: DesktopConstraint -> Hoodle EditMode @@ -244,60 +265,5 @@ getter (SingleArrangement _ (PageDimension dim) _) = DesktopDimension dim getter (ContinuousArrangement _ ddim _ _) = ddim ---{---- | -pageFunction :: PageArrangement ContinuousSinglePage -> PageNum -> Maybe PageOrigin-pageFunction (ContinuousSingleArrangement _ _ pfunc _ ) = pfunc ---- | -pageArrEither :: PageArrangement a - -> Either (PageArrangement SinglePage) (PageArrangement ContinuousSinglePage)-pageArrEither arr@(SingleArrangement _ _ _) = Left arr -pageArrEither arr@(ContinuousSingleArrangement _ _ _ _) = Right arr ---}-- -{- PageOrigin (w',h') = maybeError - ("deskdimCont" ++ - show (map (pageArrFuncCont cdim hdl . PageNum) [0..5])) - $ pageArrFuncCont cdim hdl - (PageNum . (\x->x-1) . length $ plst ) - Dim _ h2 = view g_dimension (last plst)- h = h' + h2 - w = maximum . map (dim_width.view g_dimension) $ plst- in DesktopDimension (Dim w h) -}---{- --- previous version --- |-pageArrFuncCont :: Hoodle EditMode -> PageNum -> Maybe PageOrigin -pageArrFuncCont hdl (PageNum n)- | n < 0 = Nothing - | n >= len = Nothing - | otherwise = Just (PageOrigin (0,ys !! n))- where addf x y = x + y + predefinedPageSpacing- pgs = gToList . view g_pages $ hdl - len = length pgs - ys = scanl addf 0 . map (dim_height.view g_dimension) $ pgs --}- -{- --- previous version --- |-deskDimCont :: Hoodle EditMode -> DesktopDimension -deskDimCont hdl = - let plst = gToList . view g_pages $ hdl- PageOrigin (_,h') = maybeError - ("deskdimCont" ++ - show (map (pageArrFuncCont hdl . PageNum) [0..5])) - $ pageArrFuncCont hdl - (PageNum . (\x->x-1) . length $ plst )- Dim _ h2 = view g_dimension (last plst)- h = h' + h2 - w = maximum . map (dim_width.view g_dimension) $ plst- in DesktopDimension (Dim w h)--}
src/Hoodle/Type/Predefined.hs view
@@ -30,14 +30,18 @@ predefinedLassoColor = (1.0,116.0/255.0,0,0.8) -- | - predefinedLassoWidth :: Double -predefinedLassoWidth = 4.0+predefinedLassoWidth = 1.0 -- | +predefinedLassoHandleSize :: Double +predefinedLassoHandleSize = 4.0 ++-- | + predefinedLassoDash :: ([Double],Double)-predefinedLassoDash = ([10,5],10) +predefinedLassoDash = ([2,2],4) -- |
src/Hoodle/Util.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Util --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,8 +14,11 @@ module Hoodle.Util where +import Control.Applicative +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Char8 as B import Data.Maybe-import Data.Hoodle.Simple+import Network.URI import System.Directory import System.Environment @@ -22,7 +27,11 @@ import Data.Time.Clock import Data.Time.Format import System.Locale+-- +import Data.Hoodle.Simple ++ -- for test -- import Blaze.ByteString.Builder -- import Text.Hoodle.Builder @@ -44,6 +53,10 @@ L.putStrLn (builder hdlsimple) -} +(#) :: a -> (a -> b) -> b +(#) = flip ($)+infixr 0 #+ maybeFlip :: Maybe a -> b -> (a->b) -> b maybeFlip m n j = maybe n j m @@ -88,6 +101,22 @@ maybeError' :: String -> Maybe a -> a maybeError' str = maybe (error str) id +++data UrlPath = FileUrl FilePath ++-- | +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"))+ r = parseOnly p (B.pack str)+ in case r of + Left _ -> Just (FileUrl str) + Right f -> Just (FileUrl (unEscapeString f))+ {- timeShow :: String -> IO ()
src/Hoodle/View/Coordinate.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.View.Coordinate--- Copyright : (c) 2012 Ian-Woo Kim+-- Copyright : (c) 2012,2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,10 +14,8 @@ module Hoodle.View.Coordinate where - import Control.Applicative-import Control.Category-import Control.Lens+import Control.Lens (view) import Control.Monad import Data.Foldable (toList) import qualified Data.IntMap as M@@ -34,7 +32,6 @@ import Hoodle.Type.PageArrangement import Hoodle.Type.Alias -- -import Prelude hiding ((.),id) -- | data structure for transformation among screen, canvas, desktop and page coordinates @@ -53,7 +50,6 @@ } -- | make a canvas geometry data structure from current status - makeCanvasGeometry :: PageNum -> PageArrangement vm -> DrawingArea @@ -170,11 +166,9 @@ device2Desktop _geometry NoPointerCoord = error "NoPointerCoordinate device2Desktop" -- | --getPagesInViewPortRange :: CanvasGeometry -> Hoodle EditMode -> [PageNum]-getPagesInViewPortRange geometry hdl = - let ViewPortBBox bbox = canvasViewPort geometry- ivbbox = Intersect (Middle bbox)+getPagesInRange :: CanvasGeometry ->ViewPortBBox-> Hoodle EditMode -> [PageNum]+getPagesInRange geometry (ViewPortBBox bbox) hdl = + let ivbbox = Intersect (Middle bbox) pagemap = view gpages hdl pnums = map PageNum [ 0 .. (length . toList $ pagemap)-1 ] pgcheck n pg = let Dim w h = view gdimension pg @@ -187,6 +181,14 @@ _ -> True f (PageNum n) = maybe False (pgcheck n) . M.lookup n $ pagemap in filter f pnums+ +++-- | +getPagesInViewPortRange :: CanvasGeometry -> Hoodle EditMode -> [PageNum]+getPagesInViewPortRange geometry hdl = + let vport = canvasViewPort geometry+ in getPagesInRange geometry vport hdl -- |
src/Hoodle/View/Draw.hs view
@@ -15,8 +15,6 @@ module Hoodle.View.Draw where import Control.Applicative --- import Control.Concurrent--- import Control.Monad (liftM) import Control.Monad.Trans import Control.Monad.Trans.Maybe import Graphics.UI.Gtk hiding (get,set)@@ -34,13 +32,12 @@ import Data.Hoodle.Generic import Data.Hoodle.Predefined import Data.Hoodle.Select-import Data.Hoodle.Simple (Dimension(..))+import Data.Hoodle.Simple (Dimension(..),Stroke(..)) import Graphics.Hoodle.Render.Generic import Graphics.Hoodle.Render.Highlight import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Type.HitTest import Graphics.Hoodle.Render.Util --- import Graphics.Hoodle.Render.Generic -- from this package import Hoodle.Type.Canvas import Hoodle.Type.Alias @@ -212,7 +209,12 @@ xformfunc -- clipBBox (fmap (flip inflate 1) mbboxnew) -- ad hoc ? pg <- render (pnum,page) mbboxnew flag+ -- Start Widget when isCurrentCvs (emphasisCanvasRender ColorBlue geometry) + -- widget test+ -- let mbbox_canvas = fmap (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord )) mbboxnew + -- renderTestWidget mbbox_canvas (view (canvasWidgets.testWidgetPosition) cinfo)+ -- End Widget resetClip return pg doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew @@ -284,7 +286,12 @@ 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 resetClip return nhdl doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew@@ -305,7 +312,7 @@ msfc = view mDrawSurface cinfo pgs = view gselAll thdl mcpg = view (at (unPageNum pnum)) pgs - hdl = GHoodle (view gselTitle thdl) pgs + hdl = gSelect2GHoodle thdl geometry <- makeCanvasGeometry pnum arr canvas let drawpgs = catMaybes . map f $ (getPagesInViewPortRange geometry hdl) @@ -335,9 +342,13 @@ r <- runMaybeT $ do (n,tpage) <- MaybeT (return mtpage) lift (selpagerender (PageNum n,tpage)) let nthdl2 = set gselSelected r nthdl- -- maybe (return ()) (\(n,tpage)-> selpagerender (PageNum n,tpage)) mtpage 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 resetClip return nthdl2 doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew@@ -358,8 +369,8 @@ return pg' -- |-drawSinglePageSel :: DrawingFunction SinglePage SelectMode -drawSinglePageSel = drawFuncSelGen rendercontent renderselect+drawSinglePageSel :: CanvasGeometry -> DrawingFunction SinglePage SelectMode +drawSinglePageSel geometry = drawFuncSelGen rendercontent renderselect where rendercontent (_pnum,tpg) mbbox flag = do let pg' = hPage2RPage tpg case flag of @@ -368,7 +379,7 @@ Efficient -> cairoRenderOption (InBBoxOption mbbox) (InBBox pg') >> return () return () renderselect (_pnum,tpg) mbbox _flag = do - cairoHittedBoxDraw tpg mbbox+ cairoHittedBoxDraw geometry tpg mbbox return () -- | @@ -380,20 +391,20 @@ -- |-drawContHoodleSel :: DrawingFunction ContinuousPage SelectMode-drawContHoodleSel = drawContPageSelGen renderother renderselect +drawContHoodleSel :: CanvasGeometry -> DrawingFunction ContinuousPage SelectMode+drawContHoodleSel geometry = drawContPageSelGen renderother renderselect where renderother (PageNum n,page) mbbox flag = do 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- cairoHittedBoxDraw tpg mbbox + cairoHittedBoxDraw geometry tpg mbbox return (n,tpg) -- |-cairoHittedBoxDraw :: Page SelectMode -> Maybe BBox -> Render () -cairoHittedBoxDraw tpg mbbox = do +cairoHittedBoxDraw :: CanvasGeometry->Page SelectMode -> Maybe BBox -> Render () +cairoHittedBoxDraw geometry tpg mbbox = do let layers = view glayers tpg slayer = view selectedLayer layers case unTEitherAlterHitted . view gitems $ slayer of@@ -401,21 +412,24 @@ clipBBox mbbox setSourceRGBA 0.0 0.0 1.0 1.0 let hititms = concatMap unHitted (getB alist)- mapM_ renderSelectedItem hititms -- renderSelectedStroke + mapM_ renderSelectedItem hititms let ulbbox = unUnion . mconcat . fmap (Union .Middle . getBBox) $ hititms case ulbbox of - Middle bbox -> renderSelectHandle bbox + Middle bbox -> renderSelectHandle geometry bbox _ -> return () resetClip Left _ -> return () -- | -renderLasso :: Seq (Double,Double) -> Render ()-renderLasso lst = do - setLineWidth predefinedLassoWidth+renderLasso :: CanvasGeometry -> Seq (Double,Double) -> Render ()+renderLasso geometry lst = do + let z = canvas2DesktopRatio geometry+ setLineWidth (predefinedLassoWidth*z) uncurry4 setSourceRGBA predefinedLassoColor- uncurry setDash predefinedLassoDash + let (dasha,dashb) = predefinedLassoDash + adjusteddash = (fmap (*z) dasha,dashb*z) + uncurry setDash adjusteddash case viewl lst of EmptyL -> return () x :< xs -> do uncurry moveTo x@@ -434,12 +448,13 @@ stroke -- |-renderSelectedStroke :: StrokeBBox -> Render () +renderSelectedStroke :: BBoxed Stroke -> Render () renderSelectedStroke str = do setLineWidth 1.5 setSourceRGBA 0 0 1 1 renderStrkHltd str + -- | renderSelectedItem :: RItem -> Render () renderSelectedItem itm = do @@ -447,47 +462,112 @@ setSourceRGBA 0 0 1 1 renderRItemHltd itm +-- | +canvas2DesktopRatio :: CanvasGeometry -> Double +canvas2DesktopRatio geometry =+ let DeskCoord (tx1,_) = canvas2Desktop geometry (CvsCoord (0,0)) + DeskCoord (tx2,_) = canvas2Desktop geometry (CvsCoord (1,0))+ in tx2-tx1++ -- |-renderSelectHandle :: BBox -> Render () -renderSelectHandle bbox = do - setLineWidth predefinedLassoWidth+renderSelectHandle :: CanvasGeometry -> BBox -> Render () +renderSelectHandle geometry bbox = do + let z = canvas2DesktopRatio geometry + setLineWidth (predefinedLassoWidth*z) uncurry4 setSourceRGBA predefinedLassoColor- uncurry setDash predefinedLassoDash + let (dasha,dashb) = predefinedLassoDash + adjusteddash = (fmap (*z) dasha,dashb*z) + uncurry 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-5) (y1-5) 10 10 + rectangle (x1-hsize) (y1-hsize) (2*hsize) (2*hsize) fill setSourceRGBA 1 0 0 0.8- rectangle (x1-5) (y2-5) 10 10 + rectangle (x1-hsize) (y2-hsize) (2*hsize) (2*hsize) fill setSourceRGBA 1 0 0 0.8- rectangle (x2-5) (y1-5) 10 10 + rectangle (x2-hsize) (y1-hsize) (2*hsize) (2*hsize) fill setSourceRGBA 1 0 0 0.8- rectangle (x2-5) (y2-5) 10 10 + rectangle (x2-hsize) (y2-hsize) (2*hsize) (2*hsize) fill setSourceRGBA 0.5 0 0.2 0.8- rectangle (x1-3) (0.5*(y1+y2)-3) 6 6 + 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-3) (0.5*(y1+y2)-3) 6 6 + 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)-3) (y1-3) 6 6 + 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)-3) (y2-3) 6 6 + rectangle (0.5*(x1+x2)-hsize*0.6) (y2-hsize*0.6) (1.2*hsize) (1.2*hsize) fill -{---- |-cairoBBox :: BBox -> Render () -cairoBBox bbox = do - let (x1,y1) = bbox_upperleft bbox- (x2,y2) = bbox_lowerright bbox- rectangle x1 y1 (x2-x1) (y2-y1)- stroke--}+renderPanZoomWidget :: Maybe BBox -> CanvasCoordinate -> Render () +renderPanZoomWidget 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 0.5+ rectangle (x+30) (y+30) 40 40 + fill + resetClip +++-- | +canvasImageSurface :: Maybe Double -- ^ multiply + -> CanvasGeometry+ -> Hoodle EditMode + -> IO (Surface,Dimension)+canvasImageSurface mmulti geometry hdl = do + let ViewPortBBox bbx_desk = getCanvasViewPort geometry + nbbx_desk = case mmulti of+ Nothing -> bbx_desk + Just z -> let (x0,y0) = bbox_upperleft bbx_desk+ (x1,y1) = bbox_lowerright bbx_desk+ Dim ws_desk hs_desk = bboxToDim bbx_desk+ in BBox (x0-z*ws_desk,y0-z*hs_desk) (x1+z*ws_desk,y1+z*hs_desk) + 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 + 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)+ renderfunc = do + setSourceRGBA 0.5 0.5 0.5 1+ rectangle 0 0 w_cvs h_cvs + fill + + mapM_ onepagerender drawpgs + print (Prelude.length drawpgs)+ sfc <- createImageSurface FormatARGB32 (floor w_cvs) (floor h_cvs)+ renderWith sfc renderfunc + return (sfc, Dim w_cvs h_cvs)++
+ src/Hoodle/Widget/PanZoom.hs view
@@ -0,0 +1,275 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Widget.PanZoom+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Widget.PanZoom where++-- from other packages+import Control.Category+import Control.Lens (view,set)+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)+-- from hoodle-platform +import Data.Hoodle.BBox++import Data.Hoodle.Simple++++import Graphics.Hoodle.Render.Util.HitTest+-- +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.View.Coordinate+import Hoodle.View.Draw+-- +import Prelude hiding ((.),id)+++data WidgetMode = Moving | Zooming | Panning Bool ++widgetCheckPen :: CanvasId -> PointerCoord + -> MainCoroutine () + -> MainCoroutine ()+widgetCheckPen cid pcoord act = do + xst <- get+ let cinfobox = getCanvasInfo cid xst + boxAction (f xst) cinfobox + where + f xst cinfo = do + let cvs = view drawArea cinfo+ pnum = (PageNum . view currentPageNum) cinfo + arr = view (viewInfo.pageArrangement) cinfo+ geometry <- liftIO $ makeCanvasGeometry pnum arr cvs + let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord+ let owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.testWidgetPosition) cinfo+ 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)+ 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 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 +++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+ ztx = 1 + tx / 200+ zty = 1 + ty / 200+ zx | ztx > 2 = 2 + | ztx < 0.5 = 0.5+ | otherwise = ztx+ zy | zty > 2 = 2 + | zty < 0.5 = 0.5+ | otherwise = zty + z | zx >= 1 && zy >= 1 = max zx zy+ | zx < 1 && zy < 1 = min zx zy + | otherwise = zx+ xtrans = (1 -z)*xo/z-w+ ytrans = (1- z)*yo/z-h + in (z,(xtrans,ytrans))++-- |+findPanXform :: Dimension + -> ((Double,Double),(Double,Double)) + -> (Double,Double)+findPanXform (Dim w h) ((x0,y0),(x,y)) = + let tx = x - x0 + ty = y - y0 + dx | tx > w = w + | tx < (-w) = -w + | otherwise = tx + dy | ty > h = h + | ty < (-h) = -h + | otherwise = ty + in ((dx-w),(dy-h))+++-- | +startWidgetAction :: WidgetMode + -> CanvasId + -> CanvasGeometry + -> (Surface,Surface)+ -> CanvasCoordinate -- ^ original widget position+ -> CanvasCoordinate -- ^ where pen pressed + -> UTCTime+ -> MainCoroutine ()+startWidgetAction mode cid geometry (sfc,sfc2)+ owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do+ r <- nextevent+ case r of + PenMove _ pcoord -> do + processWithDefTimeInterval+ (startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy) + (\ctime -> movingRender mode cid geometry (sfc,sfc2) owxy oxy pcoord + >> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy ctime)+ otime + PenUp _ pcoord -> do + case mode of + Zooming -> do + let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord + CanvasDimension cdim = canvasDim geometry + 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 + Nothing -> return () + Just pnpgxy -> do + xstate <- get+ geom' <- liftIO $ getCanvasGeometryCvsId cid xstate+ let DeskCoord (xd,yd) = page2Desktop geom' pnpgxy+ DeskCoord (xd0,yd0) = canvas2Desktop geom' ccoord + moveViewPortBy (return ()) cid + (\(xorig,yorig)->(xorig+xd-xd0,yorig+yd-yd0)) + Panning _ -> do + let (x_d,y_d) = (unDeskCoord . device2Desktop geometry) pcoord + (x0_d,y0_d) = (unDeskCoord . canvas2Desktop geometry) + (CvsCoord (x0,y0))+ (dx_d,dy_d) = (x_d-x0_d,y_d-y0_d)+ moveViewPortBy (return ()) cid + (\(xorig,yorig)->(xorig-dx_d,yorig-dy_d)) + _ -> return ()+ invalidate cid + _ -> startWidgetAction mode cid geometry (sfc,sfc2) owxy oxy otime+++movingRender :: WidgetMode -> CanvasId -> CanvasGeometry -> (Surface,Surface) + -> CanvasCoordinate -> CanvasCoordinate -> PointerCoord + -> MainCoroutine () +movingRender mode cid geometry (sfc,sfc2) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do + let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord + xst <- get + case mode of+ Moving -> do + let CanvasDimension (Dim cw ch) = canvasDim geometry + cinfobox = getCanvasInfo cid xst + nposx | xw+x-x0 < -50 = -50 + | xw+x-x0 > cw-50 = cw-50 + | otherwise = xw+x-x0+ 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)+ 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 + 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 + Panning b -> do + let cinfobox = getCanvasInfo cid xst + CanvasDimension cdim = canvasDim geometry + (xtrans,ytrans) = findPanXform cdim ((x0,y0),(x,y))+ let CanvasDimension (Dim cw ch) = canvasDim geometry + nposx | xw+x-x0 < -50 = -50 + | xw+x-x0 > cw-50 = cw-50 + | otherwise = xw+x-x0+ nposy | yw+y-y0 < -50 = -50 + | yw+y-y0 > ch-50 = ch-50 + | otherwise = yw+y-y0 + nwpos = if b + 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+ 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 + -- + 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++