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