hoodle-core 0.12 → 0.13
raw patch · 50 files changed
+2155/−1039 lines, 50 filesdep +binarydep +dbusdep +network-infodep ~attoparsecdep ~cairodep ~cerealbinary-added
Dependencies added: binary, dbus, network-info, network-simple, stm, svgcairo, text
Dependency ranges changed: attoparsec, cairo, cereal, configurator, directory, filepath, gtk, hoodle-builder, hoodle-parser, hoodle-types, mtl, pango, strict, template-haskell, transformers, transformers-free, xournal-parser
Files
- hoodle-core.cabal +32/−21
- resource/latex-tool.png binary
- resource/menu.xml +5/−1
- src/Hoodle/Accessor.hs +24/−13
- src/Hoodle/Coroutine/ContextMenu.hs +148/−106
- src/Hoodle/Coroutine/Default.hs +52/−28
- src/Hoodle/Coroutine/Dialog.hs +101/−0
- src/Hoodle/Coroutine/Draw.hs +4/−3
- src/Hoodle/Coroutine/Eraser.hs +2/−5
- src/Hoodle/Coroutine/File.hs +212/−324
- src/Hoodle/Coroutine/Layer.hs +2/−2
- src/Hoodle/Coroutine/Link.hs +15/−15
- src/Hoodle/Coroutine/Minibuffer.hs +194/−0
- src/Hoodle/Coroutine/Mode.hs +2/−2
- src/Hoodle/Coroutine/Network.hs +151/−0
- src/Hoodle/Coroutine/Page.hs +8/−11
- src/Hoodle/Coroutine/Pen.hs +18/−39
- src/Hoodle/Coroutine/Scroll.hs +10/−8
- src/Hoodle/Coroutine/Select.hs +86/−88
- src/Hoodle/Coroutine/Select/Clipboard.hs +2/−3
- src/Hoodle/Coroutine/Select/ManipulateImage.hs +187/−0
- src/Hoodle/Coroutine/TextInput.hs +179/−62
- src/Hoodle/Coroutine/VerticalSpace.hs +4/−5
- src/Hoodle/Coroutine/Window.hs +1/−2
- src/Hoodle/Device.hsc +1/−1
- src/Hoodle/GUI.hs +11/−0
- src/Hoodle/GUI/Menu.hs +14/−9
- src/Hoodle/GUI/Reflect.hs +1/−2
- src/Hoodle/ModelAction/ContextMenu.hs +2/−13
- src/Hoodle/ModelAction/File.hs +64/−15
- src/Hoodle/ModelAction/Page.hs +6/−7
- src/Hoodle/ModelAction/Select.hs +1/−2
- src/Hoodle/ModelAction/Select/Transform.hs +13/−6
- src/Hoodle/ModelAction/Window.hs +43/−31
- src/Hoodle/Script/Hook.hs +6/−0
- src/Hoodle/Type/Canvas.hs +117/−64
- src/Hoodle/Type/Coroutine.hs +27/−3
- src/Hoodle/Type/Enum.hs +8/−1
- src/Hoodle/Type/Event.hs +60/−17
- src/Hoodle/Type/HoodleState.hs +20/−12
- src/Hoodle/Type/PageArrangement.hs +15/−34
- src/Hoodle/Type/Predefined.hs +1/−1
- src/Hoodle/Type/Widget.hs +41/−2
- src/Hoodle/Util.hs +11/−5
- src/Hoodle/View/Coordinate.hs +3/−3
- src/Hoodle/View/Draw.hs +60/−11
- src/Hoodle/Widget/Clock.hs +139/−0
- src/Hoodle/Widget/Dispatch.hs +13/−12
- src/Hoodle/Widget/Layer.hs +18/−22
- src/Hoodle/Widget/PanZoom.hs +21/−28
hoodle-core.cabal view
@@ -1,5 +1,5 @@ Name: hoodle-core-Version: 0.12+Version: 0.13 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 @@ -28,36 +28,36 @@ 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.*,+ mtl > 2,+ directory > 1,+ filepath > 1, + strict > 0.3,+ gtk > 0.12, + cairo > 0.12,+ pango > 0.12, gd >= 3000.7, - attoparsec == 0.10.*,+ attoparsec >= 0.10, coroutine-object >= 0.2, - transformers == 0.3.*,- transformers-free == 1.0.*,- hoodle-types >= 0.2.1,- hoodle-parser >= 0.2.1,- xournal-parser >= 0.5.0.1,+ 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,- hoodle-builder >= 0.2.1, containers >= 0.4,- template-haskell == 2.*,+ template-haskell > 2, bytestring >= 0.9, base64-bytestring >= 0.1, either >= 3.1, errors >= 1.3, lens >= 2.5, process >= 1.1, - configurator == 0.2.*,+ configurator >= 0.2, time >= 1.2, - Diff == 0.1.*,+ Diff >= 0.1 && < 0.2, dyre >= 0.8.11, - cereal == 0.3.5.*,+ cereal >= 0.3.5, base64-bytestring >= 0.1, old-locale >= 1.0, uuid >= 1.2.7, @@ -66,7 +66,14 @@ poppler >= 0.12.2.2, fsnotify >= 0.0.7, system-filepath >= 0.4, - pureMD5 + svgcairo >= 0.12,+ binary,+ dbus >= 0.10, + network-simple >= 0.3,+ text >= 0.10,+ stm >= 2, + pureMD5, + network-info Exposed-Modules: Hoodle.Accessor@@ -76,18 +83,22 @@ Hoodle.Coroutine.Commit Hoodle.Coroutine.ContextMenu Hoodle.Coroutine.Default+ Hoodle.Coroutine.Dialog Hoodle.Coroutine.Draw Hoodle.Coroutine.Eraser Hoodle.Coroutine.File Hoodle.Coroutine.Highlighter Hoodle.Coroutine.Layer Hoodle.Coroutine.Link+ Hoodle.Coroutine.Minibuffer Hoodle.Coroutine.Mode+ Hoodle.Coroutine.Network Hoodle.Coroutine.Page Hoodle.Coroutine.Pen Hoodle.Coroutine.Scroll Hoodle.Coroutine.Select Hoodle.Coroutine.Select.Clipboard+ Hoodle.Coroutine.Select.ManipulateImage Hoodle.Coroutine.TextInput Hoodle.Coroutine.VerticalSpace Hoodle.Coroutine.Window@@ -125,6 +136,7 @@ Hoodle.Util Hoodle.View.Coordinate Hoodle.View.Draw+ Hoodle.Widget.Clock Hoodle.Widget.Dispatch Hoodle.Widget.Layer Hoodle.Widget.PanZoom@@ -132,7 +144,6 @@ Paths_hoodle_core c-sources: csrc/c_initdevice.c- -- csrc/XInput.c include-dirs: csrc install-includes: csrc/c_initdevice.h
+ resource/latex-tool.png view
binary file changed (absent → 1373 bytes)
@@ -16,6 +16,7 @@ <menuitem action="LDPREIMG2A" /> <menuitem action="LDPREIMG3A" /> <menuitem action="LATEXA" />+ <menuitem action="COMBINELATEXA" /> <separator /> <menuitem action="PRINTA" /> <menuitem action="EXPORTA" />@@ -151,8 +152,10 @@ <menuitem action="EBDIMGA" /> <menuitem action="EBDPDFA" /> <menuitem action="FLWLNKA" />+ <menuitem action="KEEPRATIOA" /> <menuitem action="TOGPANZOOMA" /> <menuitem action="TOGLAYERA" />+ <menuitem action="TOGCLOCKA" /> <menuitem action="DCRDCOREA" /> <menuitem action="ERSRTIPA" /> <menuitem action="PRESSRSENSA" /> @@ -207,7 +210,8 @@ <toolitem action="ERASERA" /> <toolitem action="HIGHLTA" /> <separator /> - <toolitem action="TEXTA" /> + <toolitem action="TEXTA" />+ <toolitem action="LATEXA" /> <!-- <toolitem action="DEFAULTA" /> --> <!-- <toolitem action="DEFPENA" /> --> <!-- <toolitem action="SHPRECA" /> -->
src/Hoodle/Accessor.hs view
@@ -51,7 +51,7 @@ xstate <- St.get let hdlmodst = view hoodleModeState xstate cinfobox = view currentCanvasInfo xstate - return $ fmap4CvsInfoBox (\x->getCurrentPageFromHoodleModeState x hdlmodst) cinfobox+ return $ forBoth' unboxBiAct (flip getCurrentPageFromHoodleModeState hdlmodst) cinfobox -- | getCurrentPageCvsId :: CanvasId -> MainCoroutine (Page EditMode) @@ -59,13 +59,12 @@ xstate <- St.get let hdlmodst = view hoodleModeState xstate cinfobox = getCanvasInfo cid xstate - return $ fmap4CvsInfoBox (\c->getCurrentPageFromHoodleModeState c hdlmodst) cinfobox+ return $ forBoth' unboxBiAct (flip getCurrentPageFromHoodleModeState hdlmodst) cinfobox -- | -getCurrentPageEitherFromHoodleModeState :: - (ViewMode a) => - CanvasInfo a -> HoodleModeState -> Either (Page EditMode) (Page SelectMode)+getCurrentPageEitherFromHoodleModeState + :: CanvasInfo a -> HoodleModeState -> Either (Page EditMode) (Page SelectMode) getCurrentPageEitherFromHoodleModeState cinfo hdlmodst = let cpn = view currentPageNum cinfo page = getCurrentPageFromHoodleModeState cinfo hdlmodst@@ -108,32 +107,41 @@ -- | +{- 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@@ -146,36 +154,39 @@ 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- cpn = PageNum . unboxGet currentPageNum $ cinfobox - canvas = unboxGet drawArea cinfobox- fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry + cpn = PageNum . view (unboxLens currentPageNum) $ cinfobox + canvas = view (unboxLens drawArea) cinfobox+ fsingle :: CanvasInfo a -> IO CanvasGeometry fsingle = flip (makeCanvasGeometry cpn) canvas . view (viewInfo.pageArrangement) - boxAction fsingle cinfobox+ forBoth' unboxBiAct fsingle cinfobox -- | getGeometry4CurrCvs :: HoodleState -> IO CanvasGeometry getGeometry4CurrCvs xstate = do let cinfobox = view currentCanvasInfo xstate- cpn = PageNum . unboxGet currentPageNum $ cinfobox - canvas = unboxGet drawArea cinfobox- fsingle :: (ViewMode a) => CanvasInfo a -> IO CanvasGeometry + cpn = PageNum . view (unboxLens currentPageNum) $ cinfobox + canvas = view (unboxLens drawArea) cinfobox+ fsingle :: CanvasInfo a -> IO CanvasGeometry fsingle = flip (makeCanvasGeometry cpn) canvas . view (viewInfo.pageArrangement) - boxAction fsingle cinfobox+ forBoth' unboxBiAct fsingle cinfobox -- | update flag in HoodleState when corresponding toggle UI changed updateFlagFromToggleUI :: String -- ^ UI toggle button id
src/Hoodle/Coroutine/ContextMenu.hs view
@@ -16,20 +16,16 @@ module Hoodle.Coroutine.ContextMenu where -- from other packages--import Control.Concurrent- import Control.Applicative--- import Control.Category import Control.Lens (view,set,(%~)) import Control.Monad.State hiding (mapM_,forM_)-import Data.Attoparsec 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.Monoid import Data.UUID.V4 +import qualified Data.Text.Encoding as TE import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set) import System.Directory @@ -41,20 +37,21 @@ import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Select-import Data.Hoodle.Simple (SVG(..),Item(..),Link(..),hoodleID,defaultHoodle)+import Data.Hoodle.Simple (SVG(..), Item(..), Link(..), defaultHoodle) import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type import Graphics.Hoodle.Render.Type.HitTest-import qualified Text.Hoodle.Parse.Attoparsec as PA import Text.Hoodle.Builder (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.Scroll-import Hoodle.Coroutine.Select.Clipboard +import Hoodle.Coroutine.Select.Clipboard+import Hoodle.Coroutine.Select.ManipulateImage import Hoodle.Coroutine.TextInput import Hoodle.ModelAction.ContextMenu import Hoodle.ModelAction.Page @@ -62,6 +59,7 @@ import Hoodle.ModelAction.Select.Transform import Hoodle.Script.Hook import Hoodle.Type.Coroutine+import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement @@ -97,8 +95,7 @@ put $ set cvsInfoMap (IM.adjust (const cinfobox') cid cmap) xstate adjustScrollbarWithGeometryCvsId cid invalidateAll -processContextMenu CMenuRotateCW = return () -- rotateSelection CW-processContextMenu CMenuRotateCCW = return () -- rotateSelection CCW+processContextMenu (CMenuRotate dir imgbbx) = rotateImage dir imgbbx processContextMenu CMenuAutosavePage = do xst <- get pg <- getCurrentPageCurr @@ -152,6 +149,10 @@ 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 (CMenuCropImage imgbbox) = cropImage imgbbox processContextMenu CMenuCustom = do either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get where action thdl = do @@ -170,7 +171,7 @@ mapM_ (\hititms -> let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms in case ulbbox of - Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do + Middle bbox -> do svg <- liftIO $ makeSVGFromSelection hititms bbox uuid <- liftIO $ nextRandom let uuidbstr = B.pack (show uuid) @@ -221,100 +222,141 @@ modify (tempQueue %~ enqueue (action xstate mselitms cid cids)) >> waitSomeEvent (\e->case e of ContextMenuCreated -> True ; _ -> False) >> return () - where action xstate msitms cid cids - = Left . ActionOrder $ - \evhandler -> do - menu <- menuNew - menuSetTitle menu "MyMenu"- case msitms of - Nothing -> return ()- Just sitms -> do - menuitem1 <- menuItemNewWithLabel "Make SVG"- menuitem2 <- menuItemNewWithLabel "Make PDF"- menuitem3 <- menuItemNewWithLabel "Cut"- menuitem4 <- menuItemNewWithLabel "Copy"- menuitem5 <- menuItemNewWithLabel "Delete"- menuitem6 <- menuItemNewWithLabel "New File Linked Here"- menuitem1 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG)))- menuitem2 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF)))- menuitem3 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuCut)))- menuitem4 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuCopy)))- menuitem5 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuDelete)))- menuitem6 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuAssocWithNewFile)))- menuAttach menu menuitem1 0 1 1 2 - menuAttach menu menuitem2 0 1 2 3- menuAttach menu menuitem3 1 2 0 1 - menuAttach menu menuitem4 1 2 1 2 - menuAttach menu menuitem5 1 2 2 3 - menuAttach menu menuitem6 1 2 3 4 - mapM_ (\mi -> menuAttach menu mi 1 2 5 6) =<< menuCreateALink evhandler sitms - case sitms of - sitm : [] -> do - case sitm of - RItemLink lnkbbx _msfc -> do - let lnk = bbxed_content lnkbbx- forM_ ((urlParse . B.unpack . link_location) lnk)- (\urlpath -> do milnk <- menuOpenALink evhandler urlpath- menuAttach menu milnk 0 1 3 4 )- case lnk of - Link i _typ lstr txt cmd rdr pos dim -> - convertLinkFromSimpleToDocID lnk >>= - mapM_ (\link -> do - let LinkDocID _ uuid _ _ _ _ _ _ = link - menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) - menuitemcvt `on` menuItemActivate $ do- 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 - _ -> return () - - _ -> return () - case (customContextMenuTitle =<< view hookSet xstate) of - Nothing -> return () - Just ttl -> do - custommenu <- menuItemNewWithLabel ttl - custommenu `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuCustom)))- menuAttach menu custommenu 0 1 0 1 - - menuitem8 <- menuItemNewWithLabel "Autosave This Page Image"- menuitem8 `on` menuItemActivate $ - evhandler (UsrEv (GotContextMenuSignal (CMenuAutosavePage)))- menuAttach menu menuitem8 1 2 4 5 - - runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0 - widgetShowAll menu - menuPopup menu Nothing - return (UsrEv ContextMenuCreated)+ where + action xstate msitms cid cids + = Left . ActionOrder $ \evhandler -> do + menu <- menuNew + menuSetTitle menu "MyMenu"+ case msitms of + Nothing -> return ()+ Just sitms -> do + menuitem1 <- menuItemNewWithLabel "Make SVG"+ menuitem2 <- menuItemNewWithLabel "Make PDF"+ menuitem3 <- menuItemNewWithLabel "Cut"+ menuitem4 <- menuItemNewWithLabel "Copy"+ menuitem5 <- menuItemNewWithLabel "Delete"+ menuitem6 <- menuItemNewWithLabel "New File Linked Here"+ menuitem1 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG)))+ menuitem2 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF)))+ menuitem3 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuCut)))+ menuitem4 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuCopy)))+ menuitem5 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuDelete)))+ menuitem6 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuAssocWithNewFile)))+ menuAttach menu menuitem1 0 1 1 2 + menuAttach menu menuitem2 0 1 2 3+ menuAttach menu menuitem3 1 2 0 1 + menuAttach menu menuitem4 1 2 1 2 + menuAttach menu menuitem5 1 2 2 3 + menuAttach menu menuitem6 1 2 3 4 + mapM_ (\mi -> menuAttach menu mi 1 2 5 6) =<< menuCreateALink evhandler sitms + case sitms of + sitm : [] -> do + case sitm of + RItemLink lnkbbx _msfc -> do + let lnk = bbxed_content lnkbbx+ forM_ ((urlParse . B.unpack . link_location) lnk)+ (\urlpath -> do milnk <- menuOpenALink urlpath+ menuAttach menu milnk 0 1 3 4 )+ case lnk of + Link _i _typ _lstr _txt _cmd _rdr _pos _dim -> + convertLinkFromSimpleToDocID lnk >>= + mapM_ (\link -> do + let LinkDocID _ uuid _ _ _ _ _ _ = link + menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) + menuitemcvt `on` menuItemActivate $ do+ 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 + RItemSVG svgbbx _msfc -> do+ let svg = bbxed_content svgbbx+ BBox (x0,y0) _ = getBBox svgbbx+ forM_ ((,) <$> svg_text svg <*> svg_command svg) $ \(btxt,cmd) -> do+ let txt = TE.decodeUtf8 btxt+ case cmd of + "pango" -> do + menuitemedt <- menuItemNewWithLabel ("Edit Text") + menuitemedt `on` menuItemActivate $ do + evhandler (UsrEv (GotContextMenuSignal (CMenuPangoConvert (x0,y0) txt)))+ menuAttach menu menuitemedt 0 1 4 5+ return ()+ "latex" -> do + menuitemedt <- menuItemNewWithLabel ("Edit LaTeX")+ menuitemedt `on` menuItemActivate $ do+ evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvert (x0,y0) txt)))+ menuAttach menu menuitemedt 0 1 4 5 + --+ menuitemnet <- menuItemNewWithLabel ("Edit LaTeX Network")+ menuitemnet `on` menuItemActivate $ do+ evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvertNetwork (x0,y0) txt)))+ menuAttach menu menuitemnet 0 1 5 6+ 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+ menuitemrotcw <- menuItemNewWithLabel ("Rotate Image CW") + menuitemrotcw `on` menuItemActivate $ do + (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CW imgbbx)+ menuitemrotccw <- menuItemNewWithLabel ("Rotate Image CCW") + menuitemrotccw `on` menuItemActivate $ do + (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CCW imgbbx)+ -- + menuAttach menu menuitemcrop 0 1 4 5+ menuAttach menu menuitemrotcw 0 1 5 6+ menuAttach menu menuitemrotccw 0 1 6 7+ -- + return ()+ _ -> return () - makeMenu evhdlr mn currcid cid - = when (currcid /= cid) $ do - n <- get- mi <- liftIO $ menuItemNewWithLabel ("Show here in cvs" ++ show cid)- liftIO $ mi `on` menuItemActivate $ - evhdlr (UsrEv (GotContextMenuSignal (CMenuCanvasView cid pnum x y)))- liftIO $ menuAttach mn mi 2 3 n (n+1) - put (n+1) + _ -> return () + case (customContextMenuTitle =<< view hookSet xstate) of + Nothing -> return () + Just ttl -> do + custommenu <- menuItemNewWithLabel ttl + custommenu `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuCustom)))+ menuAttach menu custommenu 0 1 0 1 ++ menuitem8 <- menuItemNewWithLabel "Autosave This Page Image"+ menuitem8 `on` menuItemActivate $ + evhandler (UsrEv (GotContextMenuSignal (CMenuAutosavePage)))+ menuAttach menu menuitem8 1 2 4 5 ++ runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0 + widgetShowAll menu + menuPopup menu Nothing + return (UsrEv ContextMenuCreated)++ makeMenu evhdlr mn currcid cid = when (currcid /= cid) $ do + n <- get+ mi <- liftIO $ menuItemNewWithLabel ("Show here in cvs" ++ show cid)+ liftIO $ mi `on` menuItemActivate $ + evhdlr (UsrEv (GotContextMenuSignal (CMenuCanvasView cid pnum x y)))+ liftIO $ menuAttach mn mi 2 3 n (n+1) + put (n+1)
src/Hoodle/Coroutine/Default.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- |@@ -26,12 +27,12 @@ import qualified Data.IntMap as M import Data.IORef import Data.Maybe+import Data.Monoid ((<>)) import Data.Time.Clock import Graphics.UI.Gtk hiding (get,set) import System.Process -- from hoodle-platform import Control.Monad.Trans.Crtn.Driver-import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Object import Control.Monad.Trans.Crtn.Logger.Simple import Control.Monad.Trans.Crtn.Queue @@ -78,9 +79,10 @@ import Hoodle.Type.Undo import Hoodle.Type.Window import Hoodle.Type.Widget-import Hoodle.Widget.PanZoom-import Hoodle.Widget.Layer+import Hoodle.Widget.Clock import Hoodle.Widget.Dispatch +import Hoodle.Widget.Layer+import Hoodle.Widget.PanZoom -- import Prelude hiding ((.), id) @@ -222,8 +224,6 @@ waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False) put nxst -- -- | selectMode :: MainCoroutine () selectMode = do @@ -233,7 +233,7 @@ ptype <- liftM (view (selectInfo.selectType)) get case ptype of SelectRectangleWork -> selectRectStart pbtn cid pcoord - SelectRegionWork -> selectLassoStart pbtn cid pcoord + SelectLassoWork -> selectLassoStart pbtn cid pcoord _ -> return () PenMove cid pcoord -> disableTouch >> notifyLink cid pcoord TouchDown cid pcoord -> touchStart cid pcoord @@ -245,10 +245,11 @@ selectPenWidthChanged w _ -> defaultEventProcess r1 - -- | defaultEventProcess :: UserEvent -> MainCoroutine () defaultEventProcess (UpdateCanvas cid) = invalidate cid +defaultEventProcess (UpdateCanvasEfficient cid) = + invalidateInBBox Nothing Efficient cid defaultEventProcess (Menu m) = menuEventProcess m defaultEventProcess (HScrollBarMoved cid v) = hscrollBarMoved cid v defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v@@ -267,18 +268,19 @@ Right sm -> do modify (selectInfo.selectType .~ sm) modeChange ToSelectMode -defaultEventProcess (PenColorChanged c) = +defaultEventProcess (PenColorChanged c) = do modify (penInfo.currentTool.penColor .~ c)+ reflectPenColorUI defaultEventProcess (PenWidthChanged v) = do - st <- get - let ptype = view (penInfo.penType) st- let w = int2Point ptype v- let stNew = set (penInfo.currentTool.penWidth) w st - put stNew + st <- get + let ptype = view (penInfo.penType) st+ let w = int2Point ptype v+ let stNew = set (penInfo.currentTool.penWidth) w st + put stNew defaultEventProcess (BackgroundStyleChanged bsty) = do modify (backgroundStyle .~ bsty) xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate hdl = getHoodle xstate pgs = view gpages hdl cpage = getPageFromGHoodleMap pgnum hdl@@ -319,18 +321,37 @@ return (UsrEv ActionOrdered) modify (tempQueue %~ enqueue ioact) defaultEventProcess FileReloadOrdered = fileReload -defaultEventProcess (CustomKeyEvent str) = - if str == "[]:\"Super_L\"" - then do- xst <- liftM (over (settings.doesUseTouch) not) get - put xst - let action = mkIOaction $ \_evhandler -> do - setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst- return (UsrEv ActionOrdered)- modify (tempQueue %~ enqueue action)- waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False) - toggleTouch- else return ()+defaultEventProcess (CustomKeyEvent str) = do+ liftIO $ print str+ if | str == "[]:\"Super_L\"" -> do + xst <- liftM (over (settings.doesUseTouch) not) get + put xst + let action = mkIOaction $ \_evhandler -> do + setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst+ return (UsrEv ActionOrdered)+ modify (tempQueue %~ enqueue action)+ waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False) + toggleTouch+ | str == "[]:\"1\"" -> colorfunc ColorBlack+ | str == "[]:\"2\"" -> colorfunc ColorBlue + | str == "[]:\"3\"" -> colorfunc ColorRed+ | str == "[]:\"4\"" -> colorfunc ColorGreen+ | str == "[]:\"5\"" -> colorfunc ColorGray+ | str == "[]:\"6\"" -> colorfunc ColorLightBlue+ | str == "[]:\"7\"" -> colorfunc ColorLightGreen+ | str == "[]:\"8\"" -> colorfunc ColorMagenta+ | str == "[]:\"9\"" -> colorfunc ColorOrange+ | str == "[]:\"0\"" -> colorfunc ColorYellow+ | str == "[]:\"minus\"" -> colorfunc ColorWhite+ | str == "[]:\"a\"" -> toolfunc PenWork + | str == "[]:\"b\"" -> toolfunc HighlighterWork+ | str == "[]:\"c\"" -> toolfunc EraserWork+ | str == "[]:\"d\"" -> toolfunc VerticalSpaceWork+ | otherwise -> return ()+ where + colorfunc c = doIOaction $ \_evhandler -> return (UsrEv (PenColorChanged c))+ toolfunc t = doIOaction $ \_evhandler -> return (UsrEv (AssignPenMode (Left t)))+defaultEventProcess (ImageFileDropped fname) = embedImage fname defaultEventProcess ev = -- for debugging do liftIO $ putStrLn "--- no default ---" liftIO $ print ev @@ -360,7 +381,8 @@ menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG menuEventProcess MenuLoadSVG = fileLoadSVG-menuEventProcess MenuLaTeX = fileLaTeX+menuEventProcess MenuLaTeX = laTeXInput (100,100) (laTeXHeader <> "\n\n" <> laTeXFooter)+menuEventProcess MenuCombineLaTeX = combineLaTeXText menuEventProcess MenuUndo = undo menuEventProcess MenuRedo = redo menuEventProcess MenuOpen = askIfSave fileOpen@@ -404,11 +426,12 @@ menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" (settings.doesEmbedImage) >> return () menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return () menuEventProcess MenuFollowLinks = updateFlagFromToggleUI "FLWLNKA" (settings.doesFollowLinks) >> return ()+menuEventProcess MenuKeepAspectRatio = updateFlagFromToggleUI "KEEPRATIOA" (settings.doesKeepAspectRatio) >> return () menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return () menuEventProcess MenuRelaunch = liftIO $ relaunchApplication menuEventProcess MenuColorPicker = colorPick menuEventProcess MenuFullScreen = fullScreen-menuEventProcess MenuText = textInput +menuEventProcess MenuText = textInput (100,100) "" menuEventProcess MenuAddLink = addLink menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage menuEventProcess MenuEmbedPredefinedImage2 = embedPredefinedImage2 @@ -432,6 +455,7 @@ menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground menuEventProcess MenuTogglePanZoomWidget = (togglePanZoom . view (currentCanvas._1)) =<< get menuEventProcess MenuToggleLayerWidget = (toggleLayer . view (currentCanvas._1)) =<< get +menuEventProcess MenuToggleClockWidget = (toggleClock . view (currentCanvas._1)) =<< get menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m
+ src/Hoodle/Coroutine/Dialog.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Dialog+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Dialog where++import Control.Lens ((%~),view)+import Control.Monad.Loops+import Control.Monad.State+import Graphics.UI.Gtk hiding (get,set)+import System.Directory (getCurrentDirectory)+-- +import Control.Monad.Trans.Crtn.Queue+--+import Hoodle.Coroutine.Draw+import qualified Hoodle.Script.Coroutine as S+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum+import Hoodle.Type.Event+import Hoodle.Type.HoodleState+--++-- |+okMessageBox :: String -> MainCoroutine () +okMessageBox msg = modify (tempQueue %~ enqueue action) + >> waitSomeEvent (\case GotOk -> True ; _ -> False) + >> return () + where + action = mkIOaction $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal]+ MessageQuestion ButtonsOk msg + _res <- dialogRun dialog + widgetDestroy dialog + return (UsrEv GotOk)++-- | +okCancelMessageBox :: String -> MainCoroutine Bool +okCancelMessageBox msg = modify (tempQueue %~ enqueue action) + >> waitSomeEvent p >>= return . q+ where + p (OkCancel _) = True + p _ = False + q (OkCancel b) = b + q _ = False + action = mkIOaction $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal]+ MessageQuestion ButtonsOkCancel msg + res <- dialogRun dialog + let b = case res of + ResponseOk -> True+ _ -> False+ widgetDestroy dialog + return (UsrEv (OkCancel b))++-- | +fileChooser :: FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath) +fileChooser choosertyp mfname = do + mrecentfolder <- S.recentFolderHook + xst <- get + let rtrwin = view rootOfRootWindow xst + liftIO $ widgetQueueDraw rtrwin + + modify (tempQueue %~ enqueue (action rtrwin mrecentfolder)) >> go + where + go = do r <- nextevent + case r of + FileChosen b -> return b + UpdateCanvas cid -> -- this is temporary+ invalidateInBBox Nothing Efficient cid >> go + _ -> go + action win mrf = mkIOaction $ \_evhandler -> do + dialog <- fileChooserDialogNew Nothing (Just win) choosertyp + [ ("OK", ResponseOk) + , ("Cancel", ResponseCancel) ]+ case mrf of + Just rf -> fileChooserSetCurrentFolder dialog rf + Nothing -> getCurrentDirectory >>= fileChooserSetCurrentFolder dialog + maybe (return ()) (fileChooserSetCurrentName dialog) mfname + -- !!!!!! really hackish solution !!!!!!+ whileM_ (liftM (>0) eventsPending) (mainIterationDo False)+ + res <- dialogRun dialog+ mr <- case res of + ResponseDeleteEvent -> return Nothing+ ResponseOk -> fileChooserGetFilename dialog + ResponseCancel -> return Nothing + _ -> putStrLn "??? in fileOpen" >> return Nothing + widgetDestroy dialog+ return (UsrEv (FileChosen mr))
src/Hoodle/Coroutine/Draw.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- |@@ -56,7 +57,7 @@ -> MainCoroutine () invalidateGeneral cid mbbox flag drawf drawfsel drawcont drawcontsel = do xst <- get - selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst+ unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst where fsingle :: HoodleState -> CanvasInfo SinglePage -> MainCoroutine () fsingle xstate cvsInfo = do let cpn = PageNum . view currentPageNum $ cvsInfo @@ -127,7 +128,7 @@ invalidateTemp :: CanvasId -> Surface -> Render () -> MainCoroutine () invalidateTemp cid tempsurface rndr = do xst <- get - selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst + forBoth' unboxBiAct (fsingle xst) . getCanvasInfo cid $ xst where fsingle xstate cvsInfo = do let canvas = view drawArea cvsInfo pnum = PageNum . view currentPageNum $ cvsInfo @@ -147,7 +148,7 @@ -> MainCoroutine () invalidateTempBasePage cid tempsurface pnum rndr = do xst <- get - selectBoxAction (fsingle xst) (fsingle xst) . getCanvasInfo cid $ xst + forBoth' unboxBiAct (fsingle xst) . getCanvasInfo cid $ xst where fsingle xstate cvsInfo = do let canvas = view drawArea cvsInfo geometry <- liftIO $ getCanvasGeometryCvsId cid xstate
src/Hoodle/Coroutine/Eraser.hs view
@@ -19,7 +19,6 @@ -- import Graphics.UI.Gtk hiding (get,set,disconnect) -- import Data.Hoodle.Generic-import Data.Hoodle.BBox import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Type.Item import Graphics.Hoodle.Render.Util.HitTest@@ -39,7 +38,6 @@ import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement import Hoodle.View.Coordinate-import Hoodle.View.Draw -- -- |@@ -62,9 +60,9 @@ eraserProcess cid pnum geometry itms (x0,y0) = do r <- nextevent xst <- get- boxAction (f r xst) . getCanvasInfo cid $ xst + forBoth' unboxBiAct (f r xst) . getCanvasInfo cid $ xst where - f :: (ViewMode a) => UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()+ f :: UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine () f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cvsInfo) upact defact = eraserProcess cid pnum geometry itms (x0,y0)@@ -82,7 +80,6 @@ pgnum = view currentPageNum cvsInfo currlayer = getCurrentLayer page let (newitms,maybebbox) = St.runState (eraseHitted hittestitem) Nothing- -- maybebbox = fmap (flip inflate 2.0) maybebbox1 newlayerbbox <- liftIO . updateLayerBuf dim maybebbox . set gitems newitms $ currlayer let newpagebbox = adjustCurrentLayer newlayerbbox page
src/Hoodle/Coroutine/File.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- |@@ -20,30 +21,28 @@ import Control.Applicative ((<$>),(<*>)) import Control.Concurrent import Control.Lens (view,set,over,(%~))-import Control.Monad.Loops-import Control.Monad.State hiding (mapM)+import Control.Monad.State hiding (mapM,forM_) import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.ByteString (readFile)-import Data.ByteString.Base64 import Data.ByteString.Char8 as B (pack,unpack) import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 (md5)+import Data.Foldable (forM_)+import qualified Data.List as List import Data.Maybe import qualified Data.IntMap as IM import Data.Time.Clock-import Data.UUID.V4 import Filesystem.Path.CurrentOS (decodeString, encodeString)-import Graphics.GD.ByteString import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set) import System.Directory-import System.Exit import System.FilePath import qualified System.FSNotify as FS+import System.IO (hClose, hFileSize, openFile, IOMode(..)) import System.Process -- from hoodle-platform import Control.Monad.Trans.Crtn-import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox import Data.Hoodle.Generic@@ -56,8 +55,10 @@ import Text.Hoodle.Builder -- from this package import Hoodle.Accessor+import Hoodle.Coroutine.Dialog import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.Minibuffer import Hoodle.Coroutine.Mode import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.TextInput@@ -69,90 +70,16 @@ import Hoodle.ModelAction.Window import qualified Hoodle.Script.Coroutine as S import Hoodle.Script.Hook--- import Hoodle.Type.Alias import Hoodle.Type.Canvas import Hoodle.Type.Coroutine-import Hoodle.Type.Enum import Hoodle.Type.Event hiding (TypSVG) import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement-import Hoodle.View.Draw+import Hoodle.Util -- import Prelude hiding (readFile,concat,mapM) ----- |-okMessageBox :: String -> MainCoroutine () -okMessageBox msg = modify (tempQueue %~ enqueue action) - >> waitSomeEvent (\x->case x of GotOk -> True ; _ -> False) - >> return () - where - action = mkIOaction $ - \_evhandler -> do - dialog <- messageDialogNew Nothing [DialogModal]- MessageQuestion ButtonsOk msg - _res <- dialogRun dialog - widgetDestroy dialog - return (UsrEv GotOk)- -- | -okCancelMessageBox :: String -> MainCoroutine Bool -okCancelMessageBox msg = modify (tempQueue %~ enqueue action) - >> waitSomeEvent p >>= return . q- where - p (OkCancel _) = True - p _ = False - q (OkCancel b) = b - q _ = False - action = mkIOaction $ - \_evhandler -> do - dialog <- messageDialogNew Nothing [DialogModal]- MessageQuestion ButtonsOkCancel msg - res <- dialogRun dialog - let b = case res of - ResponseOk -> True- _ -> False- widgetDestroy dialog - return (UsrEv (OkCancel b))---- | -fileChooser :: FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath) -fileChooser choosertyp mfname = do - mrecentfolder <- S.recentFolderHook - xst <- get - let rtrwin = view rootOfRootWindow xst - liftIO $ widgetQueueDraw rtrwin - - modify (tempQueue %~ enqueue (action rtrwin mrecentfolder)) >> go - where - go = do r <- nextevent - case r of - FileChosen b -> return b - UpdateCanvas cid -> -- this is temporary- invalidateInBBox Nothing Efficient cid >> go - _ -> go - action win mrf = mkIOaction $ \_evhandler -> do - dialog <- fileChooserDialogNew Nothing (Just win) choosertyp - [ ("OK", ResponseOk) - , ("Cancel", ResponseCancel) ]- case mrf of - Just rf -> fileChooserSetCurrentFolder dialog rf - Nothing -> getCurrentDirectory >>= fileChooserSetCurrentFolder dialog - maybe (return ()) (fileChooserSetCurrentName dialog) mfname - -- !!!!!! really hackish solution !!!!!!- whileM_ (liftM (>0) eventsPending) (mainIterationDo False)- - res <- dialogRun dialog- mr <- case res of - ResponseDeleteEvent -> return Nothing- ResponseOk -> fileChooserGetFilename dialog - ResponseCancel -> return Nothing - _ -> putStrLn "??? in fileOpen" >> return Nothing - widgetDestroy dialog- return (UsrEv (FileChosen mr))---- | askIfSave :: MainCoroutine () -> MainCoroutine () askIfSave action = do xstate <- get @@ -199,7 +126,6 @@ (S.afterSaveHook filename . rHoodle2Hoodle . getHoodle) xstate else fileExtensionInvalid (".hdl","save") >> fileSaveAs - -- | interleaving a monadic action between each pair of subsequent actions sequence1_ :: (Monad m) => m () -> [m ()] -> m () sequence1_ _ [] = return () @@ -228,18 +154,14 @@ let hdl = getHoodle xstate liftIO (renderjob hdl filename) - -- | fileStartSync :: MainCoroutine () fileStartSync = do - xst <- get let mf = (,) <$> view (hoodleFileControl.hoodleFileName) xst <*> view (hoodleFileControl.lastSavedTime) xst - -- liftIO $ print mf maybe (return ()) (\(filename,lasttime) -> action filename lasttime) mf - -- fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action where - action filename lasttime = do + action filename _lasttime = do let ioact = mkIOaction $ \evhandler ->do forkIO $ do FS.withManager $ \wm -> do @@ -250,7 +172,7 @@ let mchangedfile = case ev of FS.Added fp _ -> Just (encodeString fp) FS.Modified fp _ -> Just (encodeString fp)- FS.Removed fp _ -> Nothing + FS.Removed _fp _ -> Nothing print mchangedfile case mchangedfile of Nothing -> return ()@@ -311,10 +233,8 @@ -- | main coroutine for open a file fileOpen :: MainCoroutine () fileOpen = do - mfilename <- fileChooser FileChooserActionOpen Nothing- case mfilename of - Nothing -> return ()- Just filename -> fileLoad filename + mfilename <- fileChooser FileChooserActionOpen Nothing+ forM_ mfilename fileLoad -- | main coroutine for save as fileSaveAs :: MainCoroutine () @@ -403,80 +323,78 @@ invalidateAll +-- |+checkEmbedImageSize :: FilePath -> MainCoroutine (Maybe FilePath) +checkEmbedImageSize filename = do + xst <- get + runMaybeT $ do + sizelimit <- (MaybeT . return) (warningEmbedImageSize =<< view hookSet xst)+ siz <- liftIO $ do + h <- openFile filename ReadMode + s <- hFileSize h + hClose h+ return s + guard (siz > sizelimit) + let suggestscale :: Double = sqrt (fromIntegral sizelimit / fromIntegral siz) + b <- lift . okCancelMessageBox $ "The size of " ++ filename ++ "=" ++ show siz ++ "\nis bigger than limit=" ++ show sizelimit ++ ".\nWill you reduce size?"+ guard b + let ext = let x' = takeExtension filename + in if (not.null) x' then tail x' else "" + tmpfile <- liftIO $ mkTmpFile ext + cmd <- (MaybeT . return) (shrinkCmd4EmbedImage =<< view hookSet xst) + liftIO $ cmd suggestscale filename tmpfile+ return tmpfile + -- | fileLoadPNGorJPG :: MainCoroutine () fileLoadPNGorJPG = do - fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action - where - action filename = do - xst <- get - let isembedded = view (settings.doesEmbedImage) xst - nitm <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) - insertItemAt Nothing nitm + fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) embedImage +embedImage :: FilePath -> MainCoroutine ()+embedImage filename = do + xst <- get + nitm <- + 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 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 -> ((unboxGet currentPageNum.view currentCanvasInfo) xst,Nothing)+ Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) xst,Nothing) (ulx,uly) = (bbox_upperleft.getBBox) ritm- nitm = case mpos of - Nothing -> ritm - Just (PageCoord (nx,ny)) -> - changeItemBy (\(x,y)->(x+nx-ulx,y+ny-uly)) ritm+ 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 [nitm]) :- Empty) + 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 - let nxst2 = set hoodleModeState (SelectState nthdl) nxst- put nxst2+ put ( ( set hoodleModeState (SelectState nthdl) + . set isOneTimeSelectMode YesAfterSelect) nxst) invalidateAll - --- | -makeNewItemImage :: Bool -- ^ isEmbedded?- -> FilePath - -> IO Item-makeNewItemImage isembedded filename = - if isembedded - then let fileext = takeExtension filename - imgaction - | fileext == ".PNG" || fileext == ".png" = loadpng - | fileext == ".JPG" || fileext == ".jpg" = loadjpg - | otherwise = loadsrc - in imgaction - else loadsrc - where loadsrc = (return . ItemImage) (Image (B.pack filename) (100,100) (Dim 300 300))- loadpng = do - img <- loadPngFile filename- (w,h) <- imageSize img - let dim | 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 - loadjpg = do - img <- loadJpegFile filename- (w,h) <- imageSize img - let dim | 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 - + -- | fileLoadSVG :: MainCoroutine () fileLoadSVG = do @@ -486,7 +404,7 @@ xstate <- get liftIO $ putStrLn filename bstr <- liftIO $ readFile filename - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate hdl = getHoodle xstate currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage@@ -500,74 +418,10 @@ SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "fileLoadSVG" nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate- put nxstate2- invalidateAll ---fileLaTeX :: MainCoroutine () -fileLaTeX = do modify (tempQueue %~ enqueue action) - minput <- go- case minput of - Nothing -> return () - Just (latex,svg) -> afteraction (latex,svg) - where - go = do r <- nextevent- case r of - LaTeXInput input -> return input - _ -> go - action = mkIOaction $ - \_evhandler -> do - dialog <- messageDialogNew Nothing [DialogModal]- MessageQuestion ButtonsOkCancel "latex input"- vbox <- dialogGetUpper dialog- txtvw <- textViewNew- boxPackStart vbox txtvw PackGrow 0 - widgetShowAll dialog- res <- dialogRun dialog - case res of - ResponseOk -> do - buf <- textViewGetBuffer txtvw - istart <- textBufferGetStartIter buf- iend <- textBufferGetEndIter buf- l <- textBufferGetText buf istart iend True- widgetDestroy dialog- tdir <- getTemporaryDirectory- writeFile (tdir </> "latextest.tex") l - let cmd = "lasem-render-0.6 " ++ (tdir </> "latextest.tex") ++ " -f svg -o " ++ (tdir </> "latextest.svg" )- print cmd - excode <- system cmd - case excode of - ExitSuccess -> do - svg <- readFile (tdir </> "latextest.svg")- return (UsrEv (LaTeXInput (Just (B.pack l,svg))))- _ -> return (UsrEv (LaTeXInput Nothing))-- _ -> do - widgetDestroy dialog- return (UsrEv (LaTeXInput Nothing))- afteraction (latex,svg) = do - xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate- hdl = getHoodle xstate - currpage = getPageFromGHoodleMap pgnum hdl- currlayer = getCurrentLayer currpage- newitem <- (liftIO . cnstrctRItem . ItemSVG) - (SVG (Just latex) Nothing svg (100,100) (Dim 300 50))- let otheritems = view gitems currlayer - 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) "fileLaTeX"- nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate- put nxstate2+ put ( ( set hoodleModeState (SelectState nthdl) + . set isOneTimeSelectMode YesAfterSelect) nxstate) invalidateAll -- -- | askQuitProgram :: MainCoroutine () askQuitProgram = do @@ -579,95 +433,26 @@ -- | embedPredefinedImage :: MainCoroutine () embedPredefinedImage = do - liftIO $ putStrLn "embedPredefinedImage" mpredefined <- S.embedPredefinedImageHook - liftIO $ print mpredefined case mpredefined of Nothing -> return () - Just filename -> do - xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate- hdl = getHoodle xstate - currpage = getPageFromGHoodleMap pgnum hdl- currlayer = getCurrentLayer currpage- isembedded = True- newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) -- let otheritems = view gitems currlayer - let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) - modeChange ToSelectMode - nxstate <- get - thdl <- case view hoodleModeState nxstate of- SelectState thdl' -> return thdl'- _ -> (lift . EitherT . return . Left . Other) "embedPredefinedImage"- nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set isOneTimeSelectMode YesAfterSelect - . set hoodleModeState (SelectState nthdl) - $ nxstate- put nxstate2- invalidateAll - + Just filename -> embedImage filename+ -- | this is temporary. I will remove it embedPredefinedImage2 :: MainCoroutine () embedPredefinedImage2 = do - liftIO $ putStrLn "embedPredefinedImage2" mpredefined <- S.embedPredefinedImage2Hook - liftIO $ print mpredefined case mpredefined of Nothing -> return () - Just filename -> do - xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate- hdl = getHoodle xstate - currpage = getPageFromGHoodleMap pgnum hdl- currlayer = getCurrentLayer currpage- isembedded = True- newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) -- let otheritems = view gitems currlayer - let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) - modeChange ToSelectMode - nxstate <- get - thdl <- case view hoodleModeState nxstate of- SelectState thdl' -> return thdl'- _ -> (lift . EitherT . return . Left . Other) "embedPredefinedImage2"- nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set isOneTimeSelectMode YesAfterSelect - . set hoodleModeState (SelectState nthdl) - $ nxstate- put nxstate2- invalidateAll + Just filename -> embedImage filename -- | this is temporary. I will remove it embedPredefinedImage3 :: MainCoroutine () embedPredefinedImage3 = do - liftIO $ putStrLn "embedPredefinedImage3" mpredefined <- S.embedPredefinedImage3Hook - liftIO $ print mpredefined case mpredefined of Nothing -> return () - Just filename -> do - xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate- hdl = getHoodle xstate - currpage = getPageFromGHoodleMap pgnum hdl- currlayer = getCurrentLayer currpage- isembedded = True- newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) -- let otheritems = view gitems currlayer - let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) - modeChange ToSelectMode - nxstate <- get - thdl <- case view hoodleModeState nxstate of- SelectState thdl' -> return thdl'- _ -> (lift . EitherT . return . Left . Other) "embedPredefinedImage3"- nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set isOneTimeSelectMode YesAfterSelect - . set hoodleModeState (SelectState nthdl) - $ nxstate- put nxstate2- invalidateAll + Just filename -> embedImage filename -- | embedAllPDFBackground :: MainCoroutine () @@ -679,58 +464,161 @@ commit (set hoodleModeState (ViewAppendState nhdl) xst) invalidateAll +mkRevisionHdlFile :: Hoodle -> IO (String,String)+mkRevisionHdlFile hdl = do + hdir <- getHomeDirectory+ tempfile <- mkTmpFile "hdl"+ let hdlbstr = builder hdl + L.writeFile tempfile hdlbstr+ ctime <- getCurrentTime + let idstr = B.unpack (view hoodleID hdl)+ md5str = show (md5 hdlbstr)+ name = "UUID_"++idstr++"_MD5Digest_"++md5str++"_ModTime_"++ show ctime+ nfilename = name <.> "hdl"+ vcsdir = hdir </> ".hoodle.d" </> "vcs"+ b <- doesDirectoryExist vcsdir + unless b $ createDirectory vcsdir+ renameFile tempfile (vcsdir </> nfilename) + return (md5str,name) +++mkRevisionPdfFile :: RHoodle -> String -> IO ()+mkRevisionPdfFile hdl fname = do + hdir <- getHomeDirectory+ tempfile <- mkTmpFile "pdf"+ renderjob hdl tempfile + let nfilename = fname <.> "pdf"+ vcsdir = hdir </> ".hoodle.d" </> "vcs"+ b <- doesDirectoryExist vcsdir + unless b $ createDirectory vcsdir+ renameFile tempfile (vcsdir </> nfilename) + -- | fileVersionSave :: MainCoroutine () fileVersionSave = do - hdl <- liftM (rHoodle2Hoodle . getHoodle ) get- minput <- textInputDialog- doIOaction $ \_evhandler -> do - putStrLn "version save"- tdir <- getTemporaryDirectory - hdir <- getHomeDirectory- uuid <- nextRandom- let uuidstr = show uuid - tempfile = tdir </> uuidstr <.> "hdl"- hdlbstr = builder hdl - L.writeFile tempfile hdlbstr- ctime <- getCurrentTime - let idstr = B.unpack (view hoodleID hdl)- md5str = show (md5 hdlbstr)- nfilename = "UUID_"++idstr++"_MD5Digest_"++md5str++"_ModTime_"++ show ctime <.> "hdl"- vcsdir = hdir </> ".hoodle.d" </> "vcs"- b <- doesDirectoryExist vcsdir - unless b $ createDirectory vcsdir- renameFile tempfile (vcsdir </> nfilename) - --- let txtstr = maybe "" id minput - -- + rhdl <- getHoodle <$> 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+ return (UsrEv (GotRevisionInk md5str strks'))+ r <- waitSomeEvent (\case GotRevisionInk _ _ -> True ; _ -> False )+ let GotRevisionInk md5str strks = r + nrev = RevisionInk (B.pack md5str) strks+ modify (\xst -> let hdlmodst = view hoodleModeState xst + in case hdlmodst of + ViewAppendState rhdl' -> + let nrhdl = over grevisions (<> [nrev]) rhdl' + in set hoodleModeState (ViewAppendState nrhdl) xst + SelectState thdl -> + let nthdl = over gselRevisions (<> [nrev]) thdl+ in set hoodleModeState (SelectState nthdl) xst)+ commit_ + Left () -> do + txtstr <- maybe "" id <$> textInputDialog+ doIOaction $ \_evhandler -> do + (md5str,fname) <- mkRevisionHdlFile hdl+ mkRevisionPdfFile rhdl fname return (UsrEv (GotRevision md5str txtstr))- -- modify (tempQueue %~ enqueue action) - r <- waitSomeEvent (\x -> case x of GotRevision _ _ -> True ; _ -> False )- let GotRevision md5str txtstr = r - nrev = Revision (B.pack md5str) (B.pack txtstr)- modify (\xst -> let hdlmodst = view hoodleModeState xst - in case hdlmodst of - ViewAppendState rhdl -> - let nrhdl = over grevisions (<> [nrev]) rhdl - in set hoodleModeState (ViewAppendState nrhdl) xst - SelectState thdl -> - let nthdl = over gselRevisions (<> [nrev]) thdl- in set hoodleModeState (SelectState nthdl) xst)- commit_ + r <- waitSomeEvent (\case GotRevision _ _ -> True ; _ -> False )+ let GotRevision md5str txtstr' = r + nrev = Revision (B.pack md5str) (B.pack txtstr')+ modify (\xst -> let hdlmodst = view hoodleModeState xst + in case hdlmodst of + ViewAppendState rhdl' -> + let nrhdl = over grevisions (<> [nrev]) rhdl' + in set hoodleModeState (ViewAppendState nrhdl) xst + SelectState thdl -> + let nthdl = over gselRevisions (<> [nrev]) thdl+ in set hoodleModeState (SelectState nthdl) xst)+ commit_ +++showRevisionDialog :: Hoodle -> [Revision] -> MainCoroutine ()+showRevisionDialog hdl revs = + modify (tempQueue %~ enqueue action) + >> 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+ return (UsrEv GotOk)+++mkPangoText :: String -> 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 + return layout+ rdr layout = do setSourceRGBA 0 0 0 1+ updateLayout layout + 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 + case rev of + RevisionInk _ strks -> scale 0.5 0.5 >> mapM_ cairoRender strks+ Revision _ txt -> mkPangoText (B.unpack txt) + hdir <- getHomeDirectory+ let vcsdir = hdir </> ".hoodle.d" </> "vcs"+ btn <- buttonNewWithLabel "view"+ btn `on` buttonPressEvent $ tryEvent $ do + files <- liftIO $ getDirectoryContents vcsdir + let fstrinit = "UUID_" ++ B.unpack (view hoodleID hdl) + ++ "_MD5Digest_" ++ B.unpack (view revmd5 rev)+ + matched = filter ((== "fdp") . take 3 . reverse) + . filter (\f -> fstrinit `List.isPrefixOf` f) $ files+ case matched of + x : _ -> + 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+ fileShowRevisions :: MainCoroutine () fileShowRevisions = do - hdl <- liftM getHoodle get - let revs = view grevisions hdl- revstrs = unlines $ map (\rev -> B.unpack (view revmd5 rev) ++ ":" ++ B.unpack (view revtxt rev)) revs- okMessageBox revstrs+ rhdl <- liftM getHoodle get + let hdl = rHoodle2Hoodle rhdl+ let revs = view grevisions rhdl+ showRevisionDialog hdl revs fileShowUUID :: MainCoroutine () fileShowUUID = do - hdl <- liftM getHoodle get - let uuidstr = view ghoodleID hdl- okMessageBox (B.unpack uuidstr)+ hdl <- liftM getHoodle get + let uuidstr = view ghoodleID hdl+ okMessageBox (B.unpack uuidstr)
src/Hoodle/Coroutine/Layer.hs view
@@ -43,7 +43,7 @@ -> MainCoroutine HoodleState layerAction action = do xst <- get - selectBoxAction (fsingle xst) (fsingle xst) . view currentCanvasInfo $ xst+ forBoth' unboxBiAct (fsingle xst) . view currentCanvasInfo $ xst where fsingle xstate cvsInfo = do let epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst@@ -100,7 +100,7 @@ startGotoLayerAt :: MainCoroutine () startGotoLayerAt = - selectBoxAction fsingle fsingle . view currentCanvasInfo =<< get+ forBoth' unboxBiAct fsingle . view currentCanvasInfo =<< get where fsingle cvsInfo = do xstate <- get
src/Hoodle/Coroutine/Link.hs view
@@ -25,10 +25,10 @@ import Data.Foldable (forM_) import Data.Monoid (mconcat) import Data.UUID.V4 (nextRandom)+import qualified Data.Text as T import Graphics.UI.Gtk hiding (get,set) import System.FilePath -- from hoodle-platform-import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.BBox import Data.Hoodle.Generic@@ -40,12 +40,14 @@ import Graphics.Hoodle.Render.Util.HitTest -- from this package import Hoodle.Accessor+import Hoodle.Coroutine.Dialog import Hoodle.Coroutine.Draw-import Hoodle.Coroutine.File +import Hoodle.Coroutine.File (insertItemAt) import Hoodle.Coroutine.Select.Clipboard import Hoodle.Coroutine.TextInput import Hoodle.Device import Hoodle.ModelAction.ContextMenu+import Hoodle.ModelAction.File (makeNewItemImage) import Hoodle.ModelAction.Select import Hoodle.Type.Canvas import Hoodle.Type.Coroutine@@ -55,7 +57,6 @@ import Hoodle.Type.PageArrangement import Hoodle.Util import Hoodle.View.Coordinate-import Hoodle.View.Draw -- import Prelude hiding (mapM_) @@ -65,7 +66,7 @@ -> CanvasCoordinate -> IO (B.ByteString, BBox) makeTextSVGFromStringAt str cid xst ccoord = do - rdr <- makePangoTextSVG str + rdr <- makePangoTextSVG (0,0) (T.pack str) -- for the time being, I use string geometry <- getCanvasGeometryCvsId cid xst let mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord return $ case mpgcoord of @@ -78,9 +79,9 @@ notifyLink :: CanvasId -> PointerCoord -> MainCoroutine () notifyLink cid pcoord = do xst <- get - (boxAction (f xst) . getCanvasInfo cid) xst + (forBoth' unboxBiAct (f xst) . getCanvasInfo cid) xst where - f :: forall b. (ViewMode b) => HoodleState -> CanvasInfo b -> MainCoroutine ()+ f :: forall b. HoodleState -> CanvasInfo b -> MainCoroutine () f xst cvsInfo = do let cpn = PageNum . view currentPageNum $ cvsInfo arr = view (viewInfo.pageArrangement) cvsInfo @@ -112,13 +113,13 @@ then Just <$> newNotify cvsInfo geometry pnum (head hitted) (Just obbx_desk) else return (Just (Nothing,obbx_desk)) forM_ mresult (\(mnewnotified,bbx_desk) -> do- let ncinfobox = (unboxSet notifiedItem mnewnotified . getCanvasInfo cid) xst + let ncinfobox = (set (unboxLens notifiedItem) mnewnotified . getCanvasInfo cid) xst put (setCanvasInfo (cid,ncinfobox) xst) invalidateInBBox (Just bbx_desk) Efficient cid ) ---- newNotify :: CanvasInfo a -> CanvasGeometry -> PageNum -> RItem -> Maybe BBox -> MainCoroutine (Maybe (PageNum,BBox,RItem),BBox) - newNotify cvsInfo geometry pnum lnk mobbx_desk = do + newNotify _cvsInfo geometry pnum lnk mobbx_desk = do let bbx = getBBox lnk bbx_desk = xformBBox (unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord) bbx nbbx_desk = maybe bbx_desk (\obbx_desk->unionBBox bbx_desk obbx_desk) mobbx_desk@@ -159,7 +160,6 @@ Just (HttpUrl url) -> do case getSelectedItmsFromHoodleState xst of Nothing -> do - liftIO $ print "here" uuidbstr <- liftIO $ B.pack . show <$> nextRandom rdrbbx <- liftIO $ makeTextSVGFromStringAt url cid xst (CvsCoord (fromIntegral x,fromIntegral y))@@ -169,7 +169,7 @@ when b $ do let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms case ulbbox of - Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do + Middle bbox -> do svg <- liftIO $ makeSVGFromSelection hititms bbox uuidbstr <- liftIO $ B.pack . show <$> nextRandom deleteSelection @@ -179,7 +179,7 @@ let fn = takeFileName fp case getSelectedItmsFromHoodleState xst of Nothing -> do - rdr <- liftIO (makePangoTextSVG fn) + rdr <- liftIO (makePangoTextSVG (0,0) (T.pack fn)) geometry <- liftIO $ getCanvasGeometryCvsId cid xst let ccoord = CvsCoord (fromIntegral x,fromIntegral y) mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord @@ -194,12 +194,12 @@ when b $ do let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms case ulbbox of - Middle bbox@(BBox (ulx,uly) (lrx,lry)) -> do + Middle bbox -> do svg <- liftIO $ makeSVGFromSelection hititms bbox uuid <- liftIO $ nextRandom- let uuidbstr = B.pack (show uuid) + let uuidbstr' = B.pack (show uuid) deleteSelection - linkInsert "simple" (uuidbstr,fp) fn (svg_render svg,bbox) + linkInsert "simple" (uuidbstr',fp) fn (svg_render svg,bbox) _ -> return () liftIO $ putStrLn "gotLink" liftIO $ print mstr @@ -216,7 +216,7 @@ Just (str,fname) -> do uuid <- liftIO $ nextRandom let uuidbstr = B.pack (show uuid)- rdr <- liftIO (makePangoTextSVG str) + rdr <- liftIO (makePangoTextSVG (0,0) (T.pack str)) linkInsert "simple" (uuidbstr,fname) str rdr where go = do r <- nextevent
+ src/Hoodle/Coroutine/Minibuffer.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Minibuffer +-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Minibuffer where ++import Control.Applicative ((<$>),(<*>))+import Control.Lens ((%~),view)+import Control.Monad.State (modify,get)+import Data.Foldable (Foldable(..),mapM_,forM_,toList)+import Data.Sequence (Seq,(|>),empty,singleton,viewl,ViewL(..))+import Graphics.UI.Gtk hiding (get,set)+import Graphics.Rendering.Cairo+-- +import Control.Monad.Trans.Crtn.Queue (enqueue)+import Data.Hoodle.Simple+import Graphics.Hoodle.Render (renderStrk)+--+import Hoodle.Coroutine.Draw+import Hoodle.Device+import Hoodle.ModelAction.Pen (createNewStroke)+import Hoodle.Type.Canvas (defaultPenInfo, defaultPenWCS, penWidth)+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum+import Hoodle.Type.Event+import Hoodle.Type.HoodleState+--+import Prelude hiding (length,mapM_)++drawMiniBufBkg :: 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++drawMiniBuf :: (Foldable t) => t Stroke -> Render ()+drawMiniBuf strks = drawMiniBufBkg >> mapM_ renderStrk strks+ ++minibufDialog :: String -> MainCoroutine (Either () [Stroke])+minibufDialog msg = do + xst <- get+ let dev = view deviceList xst + let ui = view gtkUIManager xst + agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->+ case x of + [] -> error "No action group? "+ y:_ -> return y )+ uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> + return (castToToggleAction x) )+ doesUseX11Ext <- liftIO $ toggleActionGetActive uxinputa+ modify (tempQueue %~ enqueue (action dev doesUseX11Ext)) + minibufInit+ where + action dev _doesUseX11Ext = mkIOaction $ \evhandler -> do + dialog <- dialogNew + msgLabel <- labelNew (Just msg) + cvs <- drawingAreaNew + cvs `on` sizeRequest $ return (Requisition 500 50)+ cvs `on` exposeEvent $ tryEvent $ do+ drawwdw <- liftIO $ widgetGetDrawWindow cvs + liftIO (renderWithDrawable drawwdw drawMiniBufBkg)+ (liftIO . evhandler . UsrEv . MiniBuffer . MiniBufferInitialized) drawwdw+ cvs `on` buttonPressEvent $ tryEvent $ do + (mbtn,mp) <- getPointer dev+ forM_ mp $ \p -> do+ let pbtn = maybe PenButton1 id mbtn + case pbtn of+ TouchButton -> return ()+ _ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenDown pbtn p)+ cvs `on` buttonReleaseEvent $ tryEvent $ do + (mbtn,mp) <- getPointer dev+ forM_ mp $ \p -> do + let pbtn = maybe PenButton1 id mbtn + case pbtn of+ TouchButton -> return ()+ _ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenUp p)+ cvs `on` motionNotifyEvent $ tryEvent $ do + (mbtn,mp) <- getPointer dev+ forM_ mp $ \p -> do + let pbtn = maybe PenButton1 id mbtn + case pbtn of + TouchButton -> return () + _ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenMove p)+ {- if doesUseX11Ext + then widgetSetExtensionEvents cvs [ExtensionEventsAll]+ else widgetSetExtensionEvents cvs [ExtensionEventsNone] -}+ widgetAddEvents cvs [PointerMotionMask,Button1MotionMask] + --+ vbox <- dialogGetUpper dialog+ hbox <- hBoxNew False 0 + boxPackStart hbox msgLabel PackNatural 0 + boxPackStart vbox hbox PackNatural 0+ boxPackStart vbox cvs PackNatural 0+ _btnOk <- dialogAddButton dialog "Ok" ResponseOk+ _btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel+ _btnText <- dialogAddButton dialog "TextInput" (ResponseUser 1) + widgetShowAll dialog+ res <- dialogRun dialog + widgetDestroy dialog + case res of + ResponseOk -> return (UsrEv (OkCancel True))+ ResponseCancel -> return (UsrEv (OkCancel False))+ ResponseUser 1 -> return (UsrEv ChangeDialog)+ _ -> return (UsrEv (OkCancel False))++minibufInit :: MainCoroutine (Either () [Stroke])+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) + liftIO $ invalidateMinibuf drawwdw srcsfc + minibufStart drawwdw (srcsfc,tgtsfc) empty + _ -> minibufInit)++invalidateMinibuf :: DrawWindow -> Surface -> IO ()+invalidateMinibuf drawwdw tgtsfc = + renderWithDrawable drawwdw $ do + setSourceSurface tgtsfc 0 0 + setOperator OperatorSource + paint ++minibufStart :: DrawWindow + -> (Surface,Surface) -- ^ (source surface, target surface)+ -> Seq Stroke -> MainCoroutine (Either () [Stroke])+minibufStart drawwdw (srcsfc,tgtsfc) strks = do + r <- nextevent + case r of + UpdateCanvas cid -> do invalidateInBBox Nothing Efficient cid+ minibufStart drawwdw (srcsfc,tgtsfc) strks+ OkCancel True -> (return . Right) (toList strks)+ OkCancel False -> (return . Right) []+ ChangeDialog -> return (Left ())+ MiniBuffer (MiniBufferPenDown PenButton1 pcoord) -> do + ps <- onestroke drawwdw (srcsfc,tgtsfc) (singleton pcoord) + let nstrks = strks |> mkstroke ps+ liftIO $ renderWith srcsfc (drawMiniBuf nstrks)+ minibufStart drawwdw (srcsfc,tgtsfc) nstrks+ _ -> minibufStart drawwdw (srcsfc,tgtsfc) strks+ +onestroke :: DrawWindow -> (Surface,Surface) -> Seq PointerCoord + -> MainCoroutine (Seq PointerCoord)+onestroke drawwdw (srcsfc,tgtsfc) pcoords = do + r <- nextevent + case r of + MiniBuffer (MiniBufferPenMove pcoord) -> do + let newpcoords = pcoords |> pcoord + liftIO $ do drawstrokebit (srcsfc,tgtsfc) newpcoords+ invalidateMinibuf drawwdw tgtsfc+ onestroke drawwdw (srcsfc,tgtsfc) newpcoords+ MiniBuffer (MiniBufferPenUp pcoord) -> return (pcoords |> pcoord)+ _ -> onestroke drawwdw (srcsfc,tgtsfc) pcoords++drawstrokebit :: (Surface,Surface) -> Seq PointerCoord -> IO()+drawstrokebit (srcsfc,tgtsfc) ps = + renderWith tgtsfc $ do + setSourceSurface srcsfc 0 0+ setOperator OperatorSource + 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 + _ -> return ()+ +mkstroke :: Seq PointerCoord -> Stroke+mkstroke ps = let xyzs = fmap ((,,) <$> pointerX <*> pointerY <*> const 1.0) ps+ pinfo = defaultPenInfo+ in createNewStroke pinfo xyzs+ +
src/Hoodle/Coroutine/Mode.hs view
@@ -84,9 +84,9 @@ _ -> return () adjustScrollbarWithGeometryCurrent where cont2single xst = - selectBoxAction (noaction xst) (whencont xst) . view currentCanvasInfo $ xst+ unboxBiAct (noaction xst) (whencont xst) . view currentCanvasInfo $ xst single2cont xst = - selectBoxAction (whensing xst) (noaction xst) . view currentCanvasInfo $ xst+ unboxBiAct (whensing xst) (noaction xst) . view currentCanvasInfo $ xst noaction :: HoodleState -> a -> MainCoroutine HoodleState noaction xstate = const (return xstate) -------------------------------------
+ src/Hoodle/Coroutine/Network.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Network+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Network where++import Control.Applicative+import Control.Concurrent hiding (yield)++import Control.Lens ++import Control.Monad.State (modify,get)+import Control.Monad.Trans+import Control.Monad.Trans.Maybe (MaybeT(..))+import qualified Data.Binary as Bi +import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Data.Foldable as F (mapM_)++import Data.Monoid ((<>),mconcat)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Word+import Graphics.UI.Gtk hiding (get,set)+import Network.Info+import Network.Simple.TCP++-- ++import Control.Monad.Trans.Crtn.Queue (enqueue)+-- ++import Hoodle.Coroutine.Draw+import Hoodle.Script.Hook+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum+import Hoodle.Type.Event+import Hoodle.Type.HoodleState (tempQueue,hookSet)+-- ++server :: (AllEvent -> IO ()) -> HostPreference -> T.Text -> IO ()+server evhandler ip txt = do+ listen ip "4040" $ \(lsock, _) -> + accept lsock $ \(sock,addr) -> do + let bstr = TE.encodeUtf8 txt+ bstr_size :: Word32 = (fromIntegral . B.length) bstr + bstr_size_binary = (mconcat . LB.toChunks . Bi.encode) bstr_size+ -- B.putStrLn () + putStrLn $ "TCP connection established from " ++ show addr+ send sock (bstr_size_binary <> TE.encodeUtf8 txt)+ + mbstr <- runMaybeT $ do + bstr' <- MaybeT (recv sock 4)+ let getsize :: B.ByteString -> Word32 + getsize = Bi.decode . LB.fromChunks . return+ size = (fromIntegral . getsize) bstr'++ go s bs = do + liftIO $ putStrLn ("requested size = " ++ show s)+ bstr1 <- MaybeT (recv sock s)+ let s' = B.length bstr1 + liftIO $ putStrLn ("obtained size = " ++ show s')+ if s <= s' + then return (bs <> bstr1)+ else go (s-s') (bs <> bstr1) + go size B.empty + + -- print mbstr + F.mapM_ (evhandler . UsrEv . NetworkProcess . NetworkReceived . TE.decodeUtf8) mbstr++networkTextInput :: T.Text -> MainCoroutine (Maybe T.Text)+networkTextInput txt = do + mipscr <- runMaybeT $ do hkset <- MaybeT (view hookSet <$> lift get)+ (MaybeT . return) (getIPaddress hkset) + + let ipfind = do + let ipv4num (IPv4 x) = x + ismacnull (MAC a b c d e f) = a == 0 && b == 0 && c == 0 + && d == 0 && e == 0 && f == 0 + + ifcs <- liftIO $ getNetworkInterfaces+ let ifcs2 = Prelude.filter (not . ismacnull . mac) + . Prelude.filter (((/=) 0) . ipv4num . ipv4 ) $ ifcs+ return (if Prelude.null ifcs2 then "127.0.0.1" else (show . ipv4 . head) ifcs2) + ip <- maybe ipfind liftIO mipscr ++ doIOaction $ \evhandler -> do + -- T.putStrLn txt+ done <- newEmptyMVar+ tid <- forkIO (server evhandler (Host ip) txt) + (return . UsrEv . NetworkProcess) (NetworkInitialized tid done)+ let go = do + r <- nextevent+ case r of+ UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> go+ NetworkProcess (NetworkInitialized tid done) -> return (tid,done)+ _ -> go + (tid,done) <- go + let ipdialog msg = mkIOaction $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal]+ MessageQuestion ButtonsOkCancel msg + forkIO $ do + readMVar done + dialogResponse dialog ResponseOk+ + res <- dialogRun dialog + let b = case res of + ResponseOk -> True+ _ -> False+ widgetDestroy dialog + return (UsrEv (OkCancel b))++ + modify (tempQueue %~ enqueue (ipdialog ("networkedit " ++ ip ++ " 4040")))+ --+ let actf t = do + r <- nextevent+ case r of + UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid + >> actf t+ OkCancel True -> (return . Just) t+ OkCancel False -> return Nothing+ NetworkProcess (NetworkReceived txt') -> do + doIOaction $ \_ -> postGUISync (putMVar done ())+ >> (return . UsrEv . NetworkProcess) NetworkCloseDialog+ actf txt' + + _ -> actf t+ ntxt <- actf txt+ -- + doIOaction $ \_evhandler -> do + killThread tid+ (return . UsrEv . NetworkProcess) NetworkClosed+ --+ return ntxt+
src/Hoodle/Coroutine/Page.hs view
@@ -36,7 +36,6 @@ import Hoodle.Type.Enum import Hoodle.Util import Hoodle.View.Coordinate-import Hoodle.View.Draw -- -- | change page of current canvas using a modify function@@ -44,7 +43,7 @@ changePage modifyfn = updateXState changePageAction >> adjustScrollbarWithGeometryCurrent >> invalidateAllInBBox Nothing Efficient - where changePageAction xst = selectBoxAction (fsingle xst) (fcont xst) + where changePageAction xst = unboxBiAct (fsingle xst) (fcont xst) . view currentCanvasInfo $ xst fsingle xstate cvsInfo = do let xojst = view hoodleModeState $ xstate @@ -109,7 +108,7 @@ >> adjustScrollbarWithGeometryCvsId cid >> renderfunc where zoomUpdateAction xst = - selectBoxAction (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst + unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst fsingle xstate cinfo = do geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo page <- getCurrentPageCvsId cid@@ -176,9 +175,9 @@ -- | pageZoomChangeRel :: ZoomModeRel -> MainCoroutine () pageZoomChangeRel rzmode = do - boxAction fsingle . view currentCanvasInfo =<< get + forBoth' unboxBiAct fsingle . view currentCanvasInfo =<< get where - fsingle :: (ViewMode a) => CanvasInfo a -> MainCoroutine ()+ fsingle :: CanvasInfo a -> MainCoroutine () fsingle cinfo = do let cpn = PageNum (view currentPageNum cinfo) arr = view (viewInfo.pageArrangement) cinfo @@ -194,9 +193,8 @@ >> canvasZoomUpdateAll >> invalidateAll where - npgBfrAct xst = boxAction (fsimple xst) . view currentCanvasInfo $ xst- fsimple :: (ViewMode a) => HoodleState -> CanvasInfo a - -> MainCoroutine HoodleState+ npgBfrAct xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst+ fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState fsimple xstate cinfo = do case view hoodleModeState xstate of ViewAppendState hdl -> do @@ -213,9 +211,8 @@ deleteCurrentPage = do updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll where - delpgact xst = boxAction (fsimple xst) . view currentCanvasInfo $ xst- fsimple :: (ViewMode a) => HoodleState -> CanvasInfo a- -> MainCoroutine HoodleState+ delpgact xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst+ fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState fsimple xstate cinfo = do case view hoodleModeState xstate of ViewAppendState hdl -> do
src/Hoodle/Coroutine/Pen.hs view
@@ -16,18 +16,17 @@ -- from other packages import Control.Applicative ((<$>),(<*>))--- import Control.Category import Control.Lens (view,set,at) import Control.Monad hiding (mapM_,forM_) import Control.Monad.State hiding (mapM_,forM_) -- import Control.Monad.Trans-import Data.Foldable (mapM_,forM_)+import Data.Functor.Identity (Identity(..))+import Data.Foldable (forM_) import Data.Sequence hiding (filter) import Data.Maybe import Data.Time.Clock import Graphics.Rendering.Cairo -- from hoodle-platform-import Data.Hoodle.Predefined import Data.Hoodle.BBox import Data.Hoodle.Generic (gpages) import Data.Hoodle.Simple (Dimension(..))@@ -39,7 +38,6 @@ import Hoodle.Coroutine.Draw import Hoodle.ModelAction.Page import Hoodle.ModelAction.Pen-import Hoodle.Type.Alias import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum@@ -56,8 +54,8 @@ -- |-createTempRender :: PageNum -> CanvasGeometry -> Page EditMode -> a -> MainCoroutine (TempRender a) -createTempRender _pnum geometry _page x = do +createTempRender :: CanvasGeometry -> a -> MainCoroutine (TempRender a) +createTempRender geometry x = do xst <- get let cinfobox = view currentCanvasInfo xst mcvssfc = view (unboxLens mDrawSurface) cinfobox @@ -73,33 +71,25 @@ paint return sfc) mcvssfc-- -- (srcsfc,_) <- liftIO $ canvasImageSurface Nothing geometry hdl - - liftIO $ renderWith srcsfc $ do emphasisCanvasRender ColorRed geometry - tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch) -- (floor wsfc) (floor hsfc)+ tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor cw) (floor ch) let trdr = TempRender srcsfc tgtsfc (cw,ch) x return trdr ---- -- | page switch if pen click a page different than the current page penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox penPageSwitch pgn = do xstate <- get let cibox = view currentCanvasInfo xstate - ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum pgn)) cibox + ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum pgn))) cibox put (set currentCanvasInfo ncibox xstate) invalidateAllInBBox Nothing Efficient return ncibox -- | Common Pen Work starting point -commonPenStart :: (forall a. ViewMode a => CanvasInfo a -> PageNum -> CanvasGeometry +commonPenStart :: (forall a. CanvasInfo a -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine () ) -> CanvasId -> PointerCoord -> MainCoroutine ()@@ -108,11 +98,11 @@ let currcid = getCurrentCanvasId oxstate when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll) nxstate <- get- boxAction f . getCanvasInfo cid $ nxstate- where f :: forall b. (ViewMode b) => CanvasInfo b -> MainCoroutine ()+ forBoth' unboxBiAct f . getCanvasInfo cid $ nxstate+ where f :: forall b. CanvasInfo b -> MainCoroutine () f cvsInfo = do let cpn = PageNum . view currentPageNum $ cvsInfo- arr = view (viewInfo.pageArrangement) cvsInfo + arr = view (viewInfo.pageArrangement) cvsInfo canvas = view drawArea cvsInfo geometry <- liftIO $ makeCanvasGeometry cpn arr canvas let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord @@ -124,31 +114,28 @@ return (set currentPageNum (unPageNum pgn) cvsInfo ) else return cvsInfo action nCvsInfo pgn geometry (x,y) - -- | enter pen drawing mode penStart :: CanvasId -> PointerCoord -> MainCoroutine () penStart cid pcoord = commonPenStart penAction cid pcoord- where penAction :: forall b. (ViewMode b) => CanvasInfo b -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine ()+ where penAction :: forall b. CanvasInfo b -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine () penAction _cinfo pnum geometry (x,y) = do xstate <- get let PointerCoord _ _ _ z = pcoord let currhdl = getHoodle xstate pinfo = view penInfo xstate mpage = view (gpages . at (unPageNum pnum)) currhdl - forM_ mpage $ \page -> do - trdr <- createTempRender pnum geometry page (empty |> (x,y,z)) + 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) -+ -- case viewl pdraw of EmptyL -> return () (x1,_y1,_z1) :< _rest -> do if x1 <= 1e-3 -- this is ad hoc but.. - then do - liftIO $ putStrLn " horizontal line cured !" - invalidateAll+ then invalidateAll else do (newhdl,bbox) <- liftIO $ addPDraw pinfo currhdl pnum pdraw commit . set hoodleModeState (ViewAppendState newhdl) @@ -157,10 +144,6 @@ nbbox = xformBBox f bbox invalidateAllInBBox (Just nbbox) BkgEfficient - - -- -- | main pen coordinate adding process -- | now being changed penProcess :: CanvasId -> PageNum @@ -171,10 +154,10 @@ penProcess cid pnum geometry trdr ((x0,y0),z0) = do r <- nextevent xst <- get - boxAction (fsingle r xst) . getCanvasInfo cid $ xst+ forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst where pdraw = tempInfo trdr - fsingle :: forall b. (ViewMode b) => + fsingle :: forall b. UserEvent -> HoodleState -> CanvasInfo b -> MainCoroutine (Seq (Double,Double,Double)) fsingle r xstate cvsInfo = @@ -182,8 +165,7 @@ (penProcess cid pnum geometry trdr ((x0,y0),z0)) (\(pcoord,(x,y)) -> do let PointerCoord _ _ _ z = pcoord - let canvas = view drawArea cvsInfo- pinfo = view penInfo xstate+ let pinfo = view penInfo xstate let xformfunc = cairoXform4PageCoordinate geometry pnum tmpstrk = createNewStroke pinfo pdraw renderfunc = do @@ -221,7 +203,6 @@ then ordaction pgn (cpn,pxy) else chgaction pgn (cpn,pxy) - -- | in page action penMoveAndUpOnly :: Monad m => UserEvent -> PageNum @@ -251,8 +232,6 @@ PenUp _ pcoord -> upaction pcoord _ -> defact -- -- | process action when last time was before time diff limit, otherwise -- just do default action. processWithTimeInterval :: (Monad m, MonadIO m) =>
src/Hoodle/Coroutine/Scroll.hs view
@@ -20,6 +20,7 @@ import Control.Monad.Trans.Either -- from hoodle-platform import Control.Monad.Trans.Crtn+import Data.Functor.Identity (Identity(..)) import Data.Hoodle.BBox -- from this package import Hoodle.Type.Enum@@ -32,7 +33,6 @@ import Hoodle.Coroutine.Draw import Hoodle.Accessor import Hoodle.View.Coordinate-import Hoodle.View.Draw -- -- | @@ -42,9 +42,9 @@ updateXState (return . act) >> adjustScrollbarWithGeometryCvsId cid >> rndr where act xst = let cinfobox = getCanvasInfo cid xst - ncinfobox = selectBox moveact moveact cinfobox + ncinfobox = (runIdentity . forBoth unboxBiXform (return . moveact)) cinfobox in setCanvasInfo (cid,ncinfobox) xst- moveact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a + moveact :: CanvasInfo a -> CanvasInfo a moveact cinfo = let BBox (x0,y0) _ = (unViewPortBBox . view (viewInfo.pageArrangement.viewPortBBox)) cinfo@@ -61,9 +61,9 @@ xstate <- get let cinfobox = getCanvasInfo cid xstate geometry <- liftIO (getCanvasGeometryCvsId cid xstate)- let (hadj,vadj) = unboxGet adjustments cinfobox - connidh = unboxGet horizAdjConnId cinfobox - connidv = unboxGet vertAdjConnId cinfobox+ let (hadj,vadj) = view (unboxLens adjustments) cinfobox + connidh = view (unboxLens horizAdjConnId) cinfobox + connidv = view (unboxLens vertAdjConnId) cinfobox liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv)) @@ -134,8 +134,10 @@ lst | b = lst' | otherwise = [v] forM_ lst $ \v' -> do - updateXState $ return . over currentCanvasInfo - (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v'))+ updateXState $ return . over currentCanvasInfo + (runIdentity + . unboxBiXform (Identity . scrollmovecanvas v) + (Identity . scrollmovecanvasCont geometry v') ) invalidateInBBox Nothing Efficient cid where scrollmovecanvas vv cvsInfo = let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo
src/Hoodle/Coroutine/Select.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE MultiWayIf #-}+ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Select @@ -29,7 +31,6 @@ import qualified Graphics.Rendering.Cairo.Matrix as Mat -- from hoodle-platform import Data.Hoodle.Select-import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic import Data.Hoodle.BBox import Graphics.Hoodle.Render.Generic@@ -62,21 +63,6 @@ -- import Prelude hiding ((.), id) --{---- |-createTempSelectRender :: PageNum -> CanvasGeometry -> Page EditMode- -> a - -> MainCoroutine (TempSelectRender a) -createTempSelectRender _pnum geometry _page x = do - xst <- get- let hdl = getHoodle xst- let Dim cw ch = unCanvasDimension . canvasDim $ geometry- (tempsurface,_) <- liftIO $ canvasImageSurface Nothing geometry hdl - let tempselection = TempSelectRender tempsurface (cw,ch) x- return tempselection --}- -- | For Selection mode from pen mode with 2nd pen button dealWithOneTimeSelectMode :: MainCoroutine () -- ^ main action -> MainCoroutine () -- ^ terminating action@@ -92,29 +78,45 @@ updateXState (return . set isOneTimeSelectMode NoOneTimeSelectMode) modeChange ToViewAppendMode --- | main mouse pointer click entrance in rectangular selection mode. --- choose either starting new rectangular selection or move previously + +-- | common main mouse pointer click entrance in selection mode. +-- choose either starting new selection or move previously -- selected selection. --- (dev note: need to be refactored with selectLassoStart)-selectRectStart :: PenButton -> CanvasId -> PointerCoord -> MainCoroutine ()-selectRectStart pbtn cid = commonPenStart rectaction cid- where rectaction cinfo pnum geometry (x,y) = do+commonSelectStart :: SelectType + -> PenButton + -> CanvasId + -> PointerCoord + -> MainCoroutine ()+commonSelectStart typ pbtn cid = case typ of + SelectHandToolWork -> (\_ -> return ())+ _ -> commonPenStart selectaction cid+ where selectaction cinfo pnum geometry (x,y) = do itms <- rItmsInCurrLyr ctime <- liftIO $ getCurrentTime- let newSelectAction page = + let newSelectAction _page = dealWithOneTimeSelectMode - (do tsel <- createTempRender pnum geometry page [] - newSelectRectangle cid pnum geometry itms - (x,y) ((x,y),ctime) tsel+ (do tsel <- createTempRender geometry [] + case typ of + SelectRectangleWork -> + newSelectRectangle cid pnum geometry itms + (x,y) ((x,y),ctime) tsel+ SelectLassoWork -> + newSelectLasso cinfo pnum geometry itms + (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel+ _ -> return () surfaceFinish (tempSurfaceSrc tsel) showContextMenu (pnum,(x,y)) ) (return ()) - action (Right tpage) | hitInHandle tpage (x,y) = + action (Right tpage) | hitInHandle tpage (x,y) = do + let doesKeepRatio = case pbtn of + PenButton1 -> True+ PenButton3 -> False+ _ -> False case getULBBoxFromSelected tpage of Middle bbox -> maybe (return ()) - (\handle -> startResizeSelect + (\handle -> startResizeSelect doesKeepRatio handle cid pnum geometry bbox ((x,y),ctime) tpage) (checkIfHandleGrasped bbox (x,y))@@ -133,6 +135,12 @@ let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst action epage +-- | main mouse pointer click entrance in rectangular selection mode. +-- choose either starting new rectangular selection or move previously +-- selected selection. +selectRectStart :: PenButton -> CanvasId -> PointerCoord -> MainCoroutine ()+selectRectStart = commonSelectStart SelectRectangleWork + -- | newSelectRectangle :: CanvasId -> PageNum @@ -146,7 +154,7 @@ (prev,otime) tempselection = do r <- nextevent xst <- get - boxAction (fsingle r xst) . getCanvasInfo cid $ xst+ forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo)@@ -217,9 +225,7 @@ -> MainCoroutine () startMoveSelect cid pnum geometry ((x,y),ctime) tpage = do itmimage <- liftIO $ mkItmsNImg geometry tpage- tsel <- createTempRender pnum geometry- (hPage2RPage tpage) - itmimage + tsel <- createTempRender geometry itmimage moveSelect cid pnum geometry (x,y) ((x,y),ctime) tsel surfaceFinish (tempSurfaceSrc tsel) surfaceFinish (tempSurfaceTgt tsel)@@ -239,7 +245,7 @@ (prev,otime) tempselection = do xst <- get r <- nextevent - boxAction (fsingle r xst) . getCanvasInfo cid $ xst + forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst where fsingle r xstate cinfo = penMoveAndUpInterPage r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) @@ -267,12 +273,12 @@ invalidateTempBasePage cid (tempSurfaceSrc tempselection) pnum (drawTempSelectImage geometry tempselection xformmat) moveSelect cid pnum geometry orig (ncoord,ntime) tempselection- upact :: (ViewMode a) => HoodleState -> CanvasInfo a -> PointerCoord -> MainCoroutine () + upact :: HoodleState -> CanvasInfo a -> PointerCoord -> MainCoroutine () upact xst cinfo pcoord = switchActionEnteringDiffPage pnum geometry pcoord (return ()) (chgaction xst cinfo) (ordaction xst cinfo)- chgaction :: (ViewMode a) => HoodleState -> CanvasInfo a -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () + chgaction :: HoodleState -> CanvasInfo a -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () chgaction xstate cinfo oldpgn (newpgn,PageCoord (x,y)) = do let hdlmodst@(SelectState thdl) = view hoodleModeState xstate epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst@@ -296,7 +302,8 @@ coroutineaction = do nthdl2 <- liftIO $ updateTempHoodleSelectIO nthdl1 ntpage (unPageNum newpgn) let cibox = view currentCanvasInfo xstate1 - ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum newpgn)) cibox + ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum newpgn))) + cibox cmap = getCanvasInfoMap xstate1 cmap' = M.adjust (const ncibox) cid cmap xst = maybe xstate1 id $ setCanvasInfoMap cmap' xstate1@@ -325,7 +332,8 @@ -- | prepare for resizing selection -startResizeSelect :: Handle +startResizeSelect :: Bool -- ^ doesKeepRatio+ -> Handle -> CanvasId -> PageNum -> CanvasGeometry @@ -333,13 +341,12 @@ -> ((Double,Double),UTCTime) -> Page SelectMode -> MainCoroutine () -startResizeSelect handle cid pnum geometry bbox +startResizeSelect doesKeepRatio handle cid pnum geometry bbox ((x,y),ctime) tpage = do itmimage <- liftIO $ mkItmsNImg geometry tpage - tsel <- createTempRender pnum geometry - (hPage2RPage tpage) - itmimage - resizeSelect handle cid pnum geometry bbox ((x,y),ctime) tsel + tsel <- createTempRender geometry itmimage + resizeSelect doesKeepRatio + handle cid pnum geometry bbox ((x,y),ctime) tsel surfaceFinish (tempSurfaceSrc tsel) surfaceFinish (tempSurfaceTgt tsel) surfaceFinish (imageSurface itmimage)@@ -347,7 +354,8 @@ invalidateAllInBBox Nothing Efficient -- | -resizeSelect :: Handle +resizeSelect :: Bool -- ^ doesKeepRatio+ -> Handle -> CanvasId -> PageNum -> CanvasGeometry@@ -355,19 +363,31 @@ -> ((Double,Double),UTCTime) -> TempRender ItmsNImg -> MainCoroutine ()-resizeSelect handle cid pnum geometry origbbox +resizeSelect doesKeepRatio handle cid pnum geometry origbbox (prev,otime) tempselection = do xst <- get r <- nextevent - boxAction (fsingle r xst) . getCanvasInfo cid $ xst+ forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst where- fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo)- defact = resizeSelect handle cid pnum geometry + fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact moveact (upact xstate cinfo)+ defact = resizeSelect doesKeepRatio handle cid pnum geometry origbbox (prev,otime) tempselection- moveact _xstate _cinfo (_pcoord,(x,y)) = do + moveact (_pcoord,(x,y)) = do (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y) when willUpdate $ do - let newbbox = getNewBBoxFromHandlePos handle origbbox (x,y) + let newbbox' = getNewBBoxFromHandlePos handle origbbox (x,y) + newbbox = + if doesKeepRatio + then let BBox (xo0,yo0) (xo1,yo1) = origbbox + BBox (x0,y0) (x1,y1) = newbbox' + r = (yo1 - yo0) / (xo1 - xo0)+ in if | xo1 == xo0 -> newbbox' + | handle == HandleTL -> BBox (x0,y1+(x0-x1)*r) (x1,y1) + | handle == HandleTR -> BBox (x0,y1+(x0-x1)*r) (x1,y1)+ | handle == HandleBL -> BBox (x0,y0) (x1,y0+(x1-x0)*r)+ | handle == HandleBR -> BBox (x0,y0) (x1,y0+(x1-x0)*r)+ | otherwise -> newbbox'+ else newbbox' sfunc = scaleFromToBBox origbbox newbbox xform = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry . (,) pnum . PageCoord@@ -380,13 +400,25 @@ invalidateTemp cid (tempSurfaceSrc tempselection) (drawTempSelectImage geometry tempselection xformmat)- resizeSelect handle cid pnum geometry + resizeSelect doesKeepRatio handle cid pnum geometry origbbox (ncoord,ntime) tempselection upact xstate cinfo pcoord = do let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return- newbbox = getNewBBoxFromHandlePos handle origbbox (x,y)+ newbbox' = getNewBBoxFromHandlePos handle origbbox (x,y)+ newbbox = + if doesKeepRatio + then let BBox (xo0,yo0) (xo1,yo1) = origbbox + BBox (x0,y0) (x1,y1) = newbbox' + r = (yo1 - yo0) / (xo1 - xo0)+ in if | xo1 == xo0 || yo1 == yo0 -> newbbox' + | handle == HandleTL -> BBox (x0,y1+(x0-x1)*r) (x1,y1) + | handle == HandleTR -> BBox (x0,y1+(x0-x1)*r) (x1,y1)+ | handle == HandleBL -> BBox (x0,y0) (x1,y0+(x1-x0)*r)+ | handle == HandleBR -> BBox (x0,y0) (x1,y0+(x1-x0)*r)+ | otherwise -> newbbox'+ else newbbox' hdlmodst@(SelectState thdl) = view hoodleModeState xstate epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst pagenum = view currentPageNum cinfo@@ -447,45 +479,11 @@ -- choose either starting new rectangular selection or move previously -- selected selection. selectLassoStart :: PenButton -> CanvasId -> PointerCoord -> MainCoroutine ()-selectLassoStart pbtn cid = commonPenStart lassoAction cid - where lassoAction cinfo pnum geometry (x,y) = do - itms <- rItmsInCurrLyr- ctime <- liftIO $ getCurrentTime- let newSelectAction page = - dealWithOneTimeSelectMode - (do tsel <- createTempRender pnum geometry page [] - newSelectLasso cinfo pnum geometry itms - (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel- surfaceFinish (tempSurfaceSrc tsel)- surfaceFinish (tempSurfaceTgt tsel)- showContextMenu (pnum,(x,y))- )- (return ()) - let action (Right tpage) | hitInSelection tpage (x,y) = - case pbtn of- PenButton1 -> startMoveSelect cid pnum geometry ((x,y),ctime) tpage- PenButton3 -> do - waitSomeEvent (\e -> case e of PenUp _ _ -> True ; _ -> False) - showContextMenu (pnum,(x,y)) - _ -> return () - action (Right tpage) | hitInHandle tpage (x,y) = - case getULBBoxFromSelected tpage of - Middle bbox -> - maybe (return ()) - (\handle -> startResizeSelect - handle cid pnum geometry - bbox ((x,y),ctime) tpage)- (checkIfHandleGrasped bbox (x,y))- _ -> return () - action (Right tpage) | otherwise = (newSelectAction . hPage2RPage) tpage - action (Left page) = newSelectAction page- xstate <- get - let hdlmodst = view hoodleModeState xstate - let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst - action epage+selectLassoStart = commonSelectStart SelectLassoWork + -- | -newSelectLasso :: (ViewMode a) => CanvasInfo a+newSelectLasso :: CanvasInfo a -> PageNum -> CanvasGeometry -> [RItem]
src/Hoodle/Coroutine/Select/Clipboard.hs view
@@ -19,7 +19,6 @@ import Control.Monad.State import Graphics.UI.Gtk hiding (get,set) -- from hoodle-platform -import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue import Data.Hoodle.Generic import Data.Hoodle.Select@@ -77,7 +76,7 @@ copySelection = do updateXState copySelectionAction >> invalidateAll where copySelectionAction xst = - boxAction (fsingle xst) . view currentCanvasInfo $ xst+ forBoth' unboxBiAct (fsingle xst) . view currentCanvasInfo $ xst fsingle xstate cinfo = maybe (return xstate) id $ do let hdlmodst = view hoodleModeState xstate let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst@@ -115,7 +114,7 @@ ritms <- liftIO (mapM cnstrctRItem itms) modeChange ToSelectMode >>updateXState (pasteAction ritms) >> invalidateAll where - pasteAction itms xst = boxAction (fsimple itms xst) . view currentCanvasInfo $ xst+ pasteAction itms xst = forBoth' unboxBiAct (fsimple itms xst) . view currentCanvasInfo $ xst fsimple itms xstate cinfo = do geometry <- liftIO (getGeometry4CurrCvs xstate) let pagenum = view currentPageNum cinfo
+ src/Hoodle/Coroutine/Select/ManipulateImage.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.Select.ManipulateImage+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Manipulate Image in selection+-- +-----------------------------------------------------------------------------++module Hoodle.Coroutine.Select.ManipulateImage where++import Control.Lens (set, view, _2)+import Control.Monad (when)+import Control.Monad.State (get)+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 Data.Hoodle.BBox+import Data.Hoodle.Simple+import Graphics.Hoodle.Render.Item+import Graphics.Hoodle.Render.Util.HitTest (isBBox2InBBox1)+--+import Hoodle.Accessor+import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.Draw+import Hoodle.Coroutine.Pen+import Hoodle.Device+import Hoodle.ModelAction.Page+import Hoodle.ModelAction.Pen+import Hoodle.ModelAction.Select+import Hoodle.ModelAction.Select.Transform+import qualified Hoodle.Type.Alias as A+import Hoodle.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum+import Hoodle.Type.Event+import Hoodle.Type.HoodleState+import Hoodle.Type.PageArrangement+import Hoodle.View.Coordinate+import Hoodle.View.Draw+--++cropImage :: BBoxed Image -> MainCoroutine ()+cropImage imgbbx = do + liftIO $ putStrLn "cropImage called"+ xst <- get+ let (cid,cinfobox) = view currentCanvas xst + hdlmodst = view hoodleModeState xst+ epage = forBoth' unboxBiAct (flip getCurrentPageEitherFromHoodleModeState hdlmodst) cinfobox+ case hdlmodst of + ViewAppendState _ -> return ()+ SelectState thdl -> do + case epage of + Left _ -> return ()+ Right tpage -> initCropImage cid (thdl,tpage)+ where+ initCropImage cid (thdl,tpage) = do + r <- waitSomeEvent (\case PenDown _ _ _ -> True; _ -> False)+ case r of+ PenDown cid' _pbtn pcoord -> do + if (cid == cid') then startCropRect cid imgbbx (thdl,tpage) pcoord else return ()+ _ -> return ()++startCropRect :: CanvasId + -> BBoxed Image + -> (A.Hoodle A.SelectMode,A.Page A.SelectMode) + -> PointerCoord + -> MainCoroutine ()+startCropRect cid imgbbx (thdl,tpage) pcoord0 = do + xst <- get+ geometry <- liftIO $ getGeometry4CurrCvs xst+ forM_ ((desktop2Page geometry . device2Desktop geometry) pcoord0) $ \(p0,c0) -> do+ 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)+ let pnum = (fst . tempInfo) tsel+ let img = bbxed_content imgbbx+ obbox = getBBox imgbbx+ when (isBBox2InBBox1 obbox nbbox) $ do+ mimg' <- liftIO $ createCroppedImage img obbox nbbox + forM_ mimg' $ \img' -> do+ rimg' <- liftIO $ cnstrctRItem (ItemImage img') + let ntpage = replaceSelection rimg' tpage+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpage (unPageNum pnum)+ commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst))+ invalidateAllInBBox Nothing Efficient + return ()+ +-- | start making a new crop rectangle+newCropRect :: CanvasId + -> CanvasGeometry + -> TempRender (PageNum,BBox) + -> (Double,Double) + -> ((Double,Double),UTCTime) + -> MainCoroutine BBox+newCropRect cid geometry tsel orig (prev,otime) = do+ let pnum = (fst . tempInfo) tsel+ r <- nextevent + penMoveAndUpOnly r pnum geometry defact moveact upact+ where + defact = newCropRect cid geometry tsel orig (prev,otime)+ -- + moveact (_pcoord,(x,y)) = do + (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)+ if willUpdate + then do + let oinfo@(_,BBox xy0 _) = tempInfo tsel + nbbox = BBox xy0 (x,y)+ ninfo = set _2 nbbox oinfo + invalidateTemp cid (tempSurfaceSrc tsel) (renderBoxSelection nbbox)+ newCropRect cid geometry tsel {tempInfo = ninfo} orig (ncoord,ntime)+ else defact+ -- + upact _pcoord = (return . snd . tempInfo) tsel++createCroppedImage :: Image -> BBox -> BBox -> IO (Maybe Image)+createCroppedImage img (BBox (xo0,yo0) (xo1,yo1)) (BBox (xn0,yn0) (xn1,yn1)) = do+ let src = img_src img+ embed = getByteStringIfEmbeddedPNG src+ case embed of+ Nothing -> return Nothing+ Just bstr -> do + gdimg <- G.loadPngByteString bstr+ (w,h) <- G.imageSize gdimg+ let w' = floor $ (fromIntegral w) * (xn1-xn0) / (xo1-xo0) + h' = floor $ (fromIntegral h) * (yn1-yn0) / (yo1-yo0)+ x1 = floor $ (fromIntegral w) * (xn0-xo0) / (xo1-xo0) + y1 = floor $ (fromIntegral h) * (yn0-yo0) / (yo1-yo0)+ ngdimg <- G.newImage (w',h')+ G.copyRegion (x1,y1) (w',h') gdimg (0,0) ngdimg+ nbstr <- G.savePngByteString ngdimg + let nb64str = encode nbstr + nebdsrc = "data:image/png;base64," <> nb64str+ return . Just $ Image nebdsrc (xn0,yn0) (Dim (xn1-xn0) (yn1-yn0))++rotateImage :: RotateDir -> BBoxed Image -> MainCoroutine ()+rotateImage dir imgbbx = do + xst <- get+ let (_cid,cinfobox) = view currentCanvas xst + hdlmodst = view hoodleModeState xst+ pnum = (PageNum . forBoth' unboxBiAct (view currentPageNum)) cinfobox + epage = forBoth' unboxBiAct (flip getCurrentPageEitherFromHoodleModeState hdlmodst) cinfobox+ case hdlmodst of + ViewAppendState _ -> return ()+ SelectState thdl -> do + 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') + let ntpage = replaceSelection rimg' tpage+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpage (unPageNum pnum)+ commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst))+ invalidateAllInBBox Nothing Efficient + return ()+++createRotatedImage :: RotateDir -> Image -> BBox -> IO (Maybe Image) +createRotatedImage dir img (BBox (x0,y0) (x1,y1)) = do+ let src = img_src img+ embed = getByteStringIfEmbeddedPNG src+ case embed of+ Nothing -> return Nothing+ Just bstr -> do + gdimg <- G.loadPngByteString bstr+ ngdimg <- G.rotateImage (case dir of CW -> 3 ; CCW -> 1) gdimg+ nbstr <- G.savePngByteString ngdimg + let nb64str = encode nbstr + nebdsrc = "data:image/png;base64," <> nb64str+ return . Just $ Image nebdsrc (x0,y0) (Dim (y1-y0) (x1-x0))+
src/Hoodle/Coroutine/TextInput.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- |@@ -15,33 +18,46 @@ module Hoodle.Coroutine.TextInput where import Control.Applicative-import Control.Lens (view,set,(%~))-import Control.Monad.State hiding (mapM_)+import Control.Lens (_1,_2,_3,view,set,(%~))+import Control.Monad.State hiding (mapM_, forM_) import Control.Monad.Trans.Either import Data.Attoparsec-import Data.Foldable (mapM_)+import qualified Data.ByteString.Char8 as B +import Data.Foldable (mapM_, forM_)+import Data.List (sortBy)+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.UUID.V4 (nextRandom) import Graphics.Rendering.Cairo+import qualified Graphics.Rendering.Cairo.SVG as RSVG import Graphics.Rendering.Pango.Cairo import Graphics.UI.Gtk hiding (get,set)+import System.Directory +import System.Exit (ExitCode(..))+import System.FilePath +import System.Process (readProcessWithExitCode) -- import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Event import Control.Monad.Trans.Crtn.Queue -import qualified Data.ByteString.Char8 as B import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Simple import Graphics.Hoodle.Render.Item import Graphics.Hoodle.Render.Type.HitTest-import System.Directory -import System.FilePath +import Graphics.Hoodle.Render.Type.Hoodle (rHoodle2Hoodle) import qualified Text.Hoodle.Parse.Attoparsec as PA -- import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page import Hoodle.ModelAction.Select+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.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.Enum@@ -51,7 +67,8 @@ -- import Prelude hiding (readFile,mapM_) --- | ++-- | single line text input : almost abandoned now textInputDialog :: MainCoroutine (Maybe String) textInputDialog = do doIOaction $ \_evhandler -> do @@ -80,57 +97,131 @@ _ -> go go +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+ (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)+ -- + 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+ -- + _btnOk <- dialogAddButton dialog "Ok" ResponseOk+ _btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel+ _btnNetwork <- dialogAddButton dialog "Network" (ResponseUser 1)+ widgetShowAll dialog+ res <- dialogRun dialog+ widgetDestroy dialog+ case res of + ResponseOk -> return (UsrEv (OkCancel True))+ ResponseCancel -> return (UsrEv (OkCancel False))+ ResponseUser 1 -> return (UsrEv (NetworkProcess NetworkDialog))+ _ -> return (UsrEv (OkCancel False)) +multiLineLoop :: T.Text -> MainCoroutine (Maybe T.Text)+multiLineLoop txt = do + r <- nextevent+ case r of + UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid + >> multiLineLoop txt+ OkCancel True -> (return . Just) txt+ OkCancel False -> return Nothing+ NetworkProcess NetworkDialog -> networkTextInput txt+ MultiLine (MultiLineChanged txt') -> multiLineLoop txt'+ _ -> 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"))+ +-- | 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+ )+ -- | -textInput :: MainCoroutine ()-textInput = textInputDialog >>= mapM_ (\str->liftIO (makePangoTextSVG str) >>= svgInsert str)- -{-- modify (tempQueue %~ enqueue action) - minput <- go- case minput of - Nothing -> return () - Just str -> liftIO (makePangoTextSVG str) >>= svgInsert str - where - go = do r <- nextevent- case r of - TextInput input -> return input - _ -> go - action = mkIOaction $ - \_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 - case res of - ResponseOk -> do - buf <- textViewGetBuffer txtvw - (istart,iend) <- (,) <$> textBufferGetStartIter buf- <*> textBufferGetEndIter buf- l <- textBufferGetText buf istart iend True- widgetDestroy dialog- return (UsrEv (TextInput (Just l)))- _ -> do - widgetDestroy dialog- return (UsrEv (TextInput Nothing))--}+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+ ) +laTeXHeader :: T.Text+laTeXHeader = "\\documentclass{article}\n\+ \\\pagestyle{empty}\n\+ \\\begin{document}\n"+ +laTeXFooter :: T.Text+laTeXFooter = "\\end{document}\n"++makeLaTeXSVG :: (Double,Double) -> T.Text + -> IO (Either String (B.ByteString,BBox))+makeLaTeXSVG (x0,y0) txt = do+ cdir <- getCurrentDirectory+ tdir <- getTemporaryDirectory+ tfilename <- show <$> nextRandom+ + setCurrentDirectory tdir+ let check msg act = liftIO act >>= \(ecode,str) -> case ecode of ExitSuccess -> right () ; _ -> left (msg ++ ":" ++ str)+ + B.writeFile (tfilename <.> "tex") (TE.encodeUtf8 txt)+ r <- runEitherT $ do + check "error during pdflatex" $ do + (ecode,ostr,estr) <- readProcessWithExitCode "xelatex" [tfilename <.> "tex"] ""+ return (ecode,ostr++estr)+ check "error during pdfcrop" $ do + (ecode,ostr,estr) <- readProcessWithExitCode "pdfcrop" [tfilename <.> "pdf",tfilename ++ "_crop" <.> "pdf"] "" + return (ecode,ostr++estr)+ check "error during pdf2svg" $ do+ (ecode,ostr,estr) <- readProcessWithExitCode "pdf2svg" [tfilename ++ "_crop" <.> "pdf",tfilename <.> "svg"] ""+ return (ecode,ostr++estr)+ bstr <- liftIO $ B.readFile (tfilename <.> "svg")+ rsvg <- liftIO $ RSVG.svgNewFromString (B.unpack bstr) + let (w,h) = RSVG.svgGetSize rsvg+ return (bstr,BBox (x0,y0) (x0+fromIntegral w,y0+fromIntegral h)) + setCurrentDirectory cdir+ return r+ + -- |-svgInsert :: String -> (B.ByteString,BBox) -> MainCoroutine () -svgInsert str (svgbstr,BBox (x0,y0) (x1,y1)) = do +svgInsert :: (T.Text,String) -> (B.ByteString,BBox) -> MainCoroutine () +svgInsert (txt,cmd) (svgbstr,BBox (x0,y0) (x1,y1)) = do xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ let pgnum = view (unboxLens currentPageNum) . view currentCanvasInfo $ xstate hdl = getHoodle xstate currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage- newitem <- (liftIO . cnstrctRItem . ItemSVG) - (SVG (Just (B.pack str)) Nothing svgbstr - (100,100) (Dim (x1-x0) (y1-y0))) + (SVG (Just (TE.encodeUtf8 txt)) (Just (B.pack cmd)) svgbstr + (x0,y0) (Dim (x1-x0) (y1-y0))) let otheritems = view gitems currlayer let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) @@ -140,8 +231,8 @@ SelectState thdl' -> return thdl' _ -> (lift . EitherT . return . Left . Other) "svgInsert" nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum - let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate- put nxstate2+ put (set hoodleModeState (SelectState nthdl) nxstate)+ commit_ invalidateAll -- | @@ -149,31 +240,30 @@ convertLinkFromSimpleToDocID (Link i _typ lstr txt cmd rdr pos dim) = do case urlParse (B.unpack lstr) of Nothing -> return Nothing- Just (HttpUrl url) -> return Nothing+ Just (HttpUrl _url) -> return Nothing Just (FileUrl file) -> do b <- doesFileExist file if b then do bstr <- B.readFile file case parseOnly PA.hoodle bstr of - Left str -> return Nothing+ Left _str -> return Nothing Right hdl -> do let uuid = view hoodleID hdl link = LinkDocID i uuid (B.pack file) txt cmd rdr pos dim return (Just link) else return Nothing convertLinkFromSimpleToDocID _ = return Nothing - - + -- | linkInsert :: B.ByteString -> (B.ByteString,FilePath) -> String -> (B.ByteString,BBox) -> MainCoroutine ()-linkInsert typ (uuidbstr,fname) str (svgbstr,BBox (x0,y0) (x1,y1)) = do +linkInsert _typ (uuidbstr,fname) str (svgbstr,BBox (x0,y0) (x1,y1)) = do xstate <- get - let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate hdl = getHoodle xstate currpage = getPageFromGHoodleMap pgnum hdl currlayer = getCurrentLayer currpage@@ -196,14 +286,14 @@ invalidateAll -- |-makePangoTextSVG :: String -> IO (B.ByteString,BBox) -makePangoTextSVG str = do +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 str + layoutSetText layout (T.unpack str) -- this is gtk2hs pango limitation (_,reclog) <- layoutGetExtents layout let PangoRectangle x y w h = reclog -- 10 is just dirty-fix@@ -216,6 +306,33 @@ let tfile = tdir </> "embedded.svg" withSVGSurface tfile (x1-x0) (y1-y0) $ \s -> renderWith s (rdr layout) bstr <- B.readFile tfile - return (bstr,BBox (x0,y0) (x1,y1)) -+ 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 + l <- view layers pg+ i <- view items l+ case i of + ItemSVG svg -> + case svg_command svg of+ Just "latex" -> do + let (_,y) = svg_pos svg + return ((pgnum,y,) <$> svg_text svg) + _ -> []+ _ -> []+ let cfunc :: (Ord a,Ord b,Ord c) => (a,b,c) -> (a,b,c) -> Ordering + cfunc x y | view _1 x > view _1 y = GT+ | view _1 x < view _1 y = LT+ | otherwise = if | view _2 x > view _2 y -> GT+ | view _2 x < view _2 y -> LT+ | otherwise -> EQ+ 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+ forM_ mfilename (\filename -> liftIO (B.writeFile filename resulttxt) >> return ())
src/Hoodle/Coroutine/VerticalSpace.hs view
@@ -104,9 +104,8 @@ >> commit_ >> canvasZoomUpdateAll >> invalidateAll where- npgBfrAct xst = boxAction (fsimple xst) . view currentCanvasInfo $ xst- fsimple :: (ViewMode a) => HoodleState -> CanvasInfo a - -> MainCoroutine HoodleState+ npgBfrAct xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst+ fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState fsimple xstate _cinfo = do case view hoodleModeState xstate of ViewAppendState hdl -> do @@ -160,12 +159,12 @@ (x0,y0) sfcs@(sfcbkg,sfcitm,sfctot) otime = do r <- nextevent xst <- get- boxAction (f r xst) . getCanvasInfo cid $ xst + forBoth' unboxBiAct (f r xst) . getCanvasInfo cid $ xst where Dim w h = view gdimension pg CvsCoord (_,y0_cvs) = (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x0,y0)) -------------------------------------------------------------- f :: (ViewMode a) => UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()+ f :: UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine () f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact (moveact xstate cvsInfo) upact -------------------------------------------------------------
src/Hoodle/Coroutine/Window.hs view
@@ -34,7 +34,6 @@ import Hoodle.Type.HoodleState import Hoodle.Type.PageArrangement import Hoodle.Type.Window-import Hoodle.View.Draw -- -- | canvas configure with general zoom update func@@ -43,7 +42,7 @@ -> CanvasDimension -> MainCoroutine () canvasConfigureGenUpdate updatefunc cid cdim - = updateXState (selectBoxAction fsingle fcont . getCanvasInfo cid ) >> updatefunc + = updateXState (unboxBiAct fsingle fcont . getCanvasInfo cid ) >> updatefunc where fsingle cinfo = do xstate <- get cinfo' <- liftIO $ updateCanvasDimForSingle cdim cinfo
src/Hoodle/Device.hsc view
@@ -207,7 +207,7 @@ (touchx :: Double) <- peekByteOff ptrax 0 (touchy :: Double) <- peekByteOff ptrax 8 (touchz :: Double) <- peekByteOff ptrax 16 - (touchw :: Double) <- peekByteOff ptrax 24+ -- (touchw :: Double) <- peekByteOff ptrax 24 return $ Just (PointerCoord Touch touchx touchy touchz) | otherwise = return Nothing -- return $ PointerCoord Core x y 1.0
src/Hoodle/GUI.hs view
@@ -14,6 +14,7 @@ module Hoodle.GUI where +import Control.Concurrent (threadDelay, forkIO) import Control.Exception (SomeException(..),catch) import Control.Lens (view) import Control.Monad hiding (mapM_)@@ -106,6 +107,16 @@ liftIO $ eventHandler tref (UsrEv (Menu MenuQuit)) return True widgetShowAll window+ -- + -- this is a test for asynchronous events+ -- + forkIO $ forever $ do + threadDelay 1000000+ -- putStrLn "event!"+ postGUIAsync (eventHandler tref (SysEv ClockUpdateEvent))+ + -- + -- test end -- let mainaction = do eventHandler tref (UsrEv Initialized) mainGUI
src/Hoodle/GUI/Menu.hs view
@@ -5,7 +5,7 @@ -- Module : Hoodle.GUI.Menu -- Copyright : (c) 2011-2013 Ian-Woo Kim ----- License : GPL-3+-- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com> -- Stability : experimental -- Portability : GHC@@ -46,6 +46,7 @@ , ("eraser.png" , "myeraser") , ("highlighter.png", "myhighlighter") , ("text-tool.png" , "mytext")+ , ("latex-tool.png" , "mylatex") , ("shapes.png" , "myshapes") , ("ruler.png" , "myruler") , ("lasso.png" , "mylasso")@@ -187,7 +188,8 @@ 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") Nothing (justMenu MenuLaTeX)+ 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)@@ -206,8 +208,6 @@ copya <- actionNewAndRegister "COPYA" "Copy" (Just "Just a Stub") (Just stockCopy) (justMenu MenuCopy) pastea <- actionNewAndRegister "PASTEA" "Paste" (Just "Just a Stub") (Just stockPaste) (justMenu MenuPaste) deletea <- actionNewAndRegister "DELETEA" "Delete" (Just "Just a Stub") (Just stockDelete) (justMenu MenuDelete)- -- netcopya <- actionNewAndRegister "NETCOPYA" "Copy to NetworkClipboard" (Just "Just a Stub") Nothing (justMenu MenuNetCopy)- -- netpastea <- actionNewAndRegister "NETPASTEA" "Paste from NetworkClipboard" (Just "Just a Stub") Nothing (justMenu MenuNetPaste) -- view menu fscra <- actionNewAndRegister "FSCRA" "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen)@@ -293,9 +293,13 @@ flwlnka <- toggleActionNew "FLWLNKA" "Follow Links" (Just "Just a stub") Nothing flwlnka `on` actionToggled $ do eventHandler evar (UsrEv (Menu MenuFollowLinks)) + keepratioa <- toggleActionNew "KEEPRATIOA" "Keep Aspect Ratio" (Just "Just a stub") Nothing+ keepratioa `on` actionToggled $ do + eventHandler evar (UsrEv (Menu MenuKeepAspectRatio)) -- 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) ersrtipa <- actionNewAndRegister "ERSRTIPA" "Eraser Tip" (Just "Just a Stub") Nothing (justMenu MenuEraserTip)@@ -332,7 +336,7 @@ mapM_ (actionGroupAddAction agr) [ undoa, redoa, cuta, copya, pastea, deletea ] mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing) - [ newa, annpdfa, ldpnga, ldsvga, latexa, ldpreimga, ldpreimg2a, ldpreimg3a, opena, savea, saveasa+ [ newa, annpdfa, ldpnga, ldsvga, latexa, combinelatexa, ldpreimga, ldpreimg2a, ldpreimg3a, 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@@ -343,7 +347,7 @@ , texta, linka, shpreca, rulera, clra, clrpcka, penopta , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta, relauncha- , togpanzooma, toglayera+ , togpanzooma, toglayera, togclocka , dcrdcorea, ersrtipa, pghilta, mltpgvwa , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa @@ -352,7 +356,7 @@ ] mapM_ (actionGroupAddAction agr) - [uxinputa, handa, smthscra, popmenua, ebdimga, ebdpdfa, flwlnka, pressrsensa]+ [uxinputa, handa, smthscra, popmenua, ebdimga, ebdpdfa, flwlnka, keepratioa, pressrsensa] -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode evar) mpgmodconnid <- actionGroupAddRadioActionsAndGetConnID agr viewmods 0 (assignViewMode evar) -- const (return ()))@@ -488,7 +492,7 @@ int2PenType 1 = Left EraserWork int2PenType 2 = Left HighlighterWork -- int2PenType 3 = Left TextWork -int2PenType 4 = Right SelectRegionWork+int2PenType 4 = Right SelectLassoWork int2PenType 5 = Right SelectRectangleWork int2PenType 6 = Left VerticalSpaceWork -- int2PenType 7 = Right SelectHandToolWork@@ -500,8 +504,9 @@ penType2Int (Left EraserWork) = 1 penType2Int (Left HighlighterWork) = 2 penType2Int (Left VerticalSpaceWork) = 6-penType2Int (Right SelectRegionWork) = 4 +penType2Int (Right SelectLassoWork) = 4 penType2Int (Right SelectRectangleWork) = 5 +penType2Int _ = 100 -- penType2Int (Right SelectHandToolWork) = 7
src/Hoodle/GUI/Reflect.hs view
@@ -52,8 +52,7 @@ ra1 <- maybe (error "reflectUI") return =<< liftIO (actionGroupGetAction (head agr) "ONEPAGEA") let wra1 = castToRadioAction ra1 - selectBoxAction (pgmodupdate_s mconnid wra1) - (pgmodupdate_c mconnid wra1) cinfobox + unboxBiAct (pgmodupdate_s mconnid wra1) (pgmodupdate_c mconnid wra1) cinfobox return () where pgmodupdate_s mconnid wra1 _cinfo = do liftIO $ blockWhile mconnid $
src/Hoodle/ModelAction/ContextMenu.hs view
@@ -20,7 +20,6 @@ import System.FilePath import System.Process -- --- import Control.Monad.Trans.Crtn.Driver import Data.Hoodle.BBox import Data.Hoodle.Simple import Graphics.Hoodle.Render @@ -30,23 +29,13 @@ import Hoodle.Util -- |-menuOpenALink :: (AllEvent -> IO ()) -> UrlPath -> IO MenuItem-menuOpenALink evhandler urlpath = do +menuOpenALink :: {- (AllEvent -> IO ()) -> -} UrlPath -> IO MenuItem+menuOpenALink {- evhandler -} urlpath = do let urlname = case urlpath of FileUrl fp -> fp HttpUrl url -> url menuitemlnk <- menuItemNewWithLabel ("Open "++urlname) menuitemlnk `on` menuItemActivate $ openLinkAction urlpath - {- do- case urlpath of - FileUrl fp -> do - let cmdargs = [fp]- createProcess (proc "hoodle" cmdargs) - return () - HttpUrl url -> do - let cmdargs = [url]- createProcess (proc "xdg-open" cmdargs) - return () -} return menuitemlnk
src/Hoodle/ModelAction/File.hs view
@@ -27,11 +27,13 @@ import Data.Maybe import Data.Monoid ((<>)) import Data.Time.Clock+import Graphics.GD.ByteString import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage import System.Directory (canonicalizePath) import System.FilePath (takeExtension)+import System.IO (hClose, hFileSize, openFile, IOMode(..)) import System.Process -- from hoodle-platform import Data.Hoodle.Generic@@ -47,9 +49,7 @@ import Text.Hoodle.Migrate.FromXournal -- from this package import Hoodle.Type.HoodleState--- --- import Prelude hiding ((.),id)-+import Hoodle.Util -- | check hoodle version and migrate if necessary checkVersionAndMigrate :: C.ByteString -> IO (Either String Hoodle) @@ -162,13 +162,34 @@ makeNewHoodleWithPDF :: Bool -- ^ doesEmbedPDF -> FilePath -- ^ pdf file -> IO (Maybe Hoodle) -makeNewHoodleWithPDF doesembed fp = do - canonicalfp <- canonicalizePath fp - let fname = C.pack canonicalfp - mdoc <- popplerGetDocFromFile fname+makeNewHoodleWithPDF doesembed ofp = do + ocanonicalfp <- canonicalizePath ofp + let ofname = C.pack ocanonicalfp + let sizelimit = 10000000 + siz <- do + h <- openFile ofp ReadMode+ s <- hFileSize h+ hClose h+ return s+ (nfp,nfname) <- if (siz > sizelimit) + then do putStrLn $ "size is " ++ show siz ++ ", which is larger than " ++ show sizelimit+ nfp' <- mkTmpFile "pdf"+ let nfname' = C.pack nfp' + readProcess "gs" [ "-q", "-dNOPAUSE", "-dBATCH", "-dSAFER"+ , "-sDEVICE=pdfwrite", "-dCompatibilityLevel=1.3"+ , "-dPDFSETTINGS=/screen", "-dEmbedAllFonts=true" + , "-dSubsetFonts=true", "-dColorImageDownsampleType=/Bicubic"+ , "-dColorImageResolution=72", "-dGrayImageDownsampleType=/Bicubic"+ , "-dGrayImageResolution=72", "-dMonoImageDownsampleType=/Bicubic"+ , "-dMonoImageResolution=72", "-sOutputFile="++nfp'+ , ofp ] "" + return (nfp',nfname')+ else return (ocanonicalfp,ofname) + + mdoc <- popplerGetDocFromFile nfname case mdoc of Nothing -> do - putStrLn $ "no such file " ++ fp + putStrLn $ "no such file " ++ nfp return Nothing Just doc -> do n <- Poppler.documentGetNPages doc @@ -177,12 +198,12 @@ pg <- Poppler.documentGetPage doc (i-1) (w,h) <- PopplerPage.pageGetSize pg let dim = Dim w h - return (createPage doesembed dim fname i) + return (createPage doesembed dim nfname i) pgs <- mapM createPageAct [1..n]- hdl <- set title fname . set pages pgs <$> emptyHoodle+ hdl <- set title nfname . set pages pgs <$> emptyHoodle nhdl <- if doesembed then do - bstr <- C.readFile canonicalfp + bstr <- C.readFile nfp let ebdsrc = makeEmbeddedPdfSrcString bstr return (set embeddedPdf (Just ebdsrc) hdl) else return hdl @@ -218,10 +239,6 @@ toggleSave ui False return (set isSaved True . set (hoodleFileControl.lastSavedTime) (Just ctime) $ xstate ) ---- -- | this function must be moved to GUI.Reflect toggleSave :: UIManager -> Bool -> IO () toggleSave ui b = do @@ -232,4 +249,36 @@ Just savea <- actionGroupGetAction agr "SAVEA" actionSetSensitive savea b +-- | +makeNewItemImage :: Bool -- ^ isEmbedded?+ -> FilePath + -> IO Item+makeNewItemImage isembedded filename = + if isembedded + then let fileext = takeExtension filename + imgaction + | fileext == ".PNG" || fileext == ".png" = loadpng + | fileext == ".JPG" || fileext == ".jpg" = loadjpg + | otherwise = loadsrc + in imgaction + else loadsrc + where loadsrc = (return . ItemImage) (Image (C.pack filename) (100,100) (Dim 300 300))+ loadpng = do + img <- loadPngFile filename+ (w,h) <- imageSize img + let dim | 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 + loadjpg = do + img <- loadJpegFile filename+ (w,h) <- imageSize img + let dim | 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
src/Hoodle/ModelAction/Page.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- |@@ -17,12 +18,11 @@ import Control.Applicative import Control.Lens (view,set) import Control.Monad (liftM)--- import Control.Monad.Trans.Either+import Data.Functor.Identity (Identity(..)) import qualified Data.IntMap as M import Data.Traversable (mapM) import Graphics.UI.Gtk (adjustmentGetValue) -- from hoodle-platform--- import Control.Monad.Trans.Crtn import Data.Hoodle.Generic import Data.Hoodle.Select import Data.Hoodle.Zipper @@ -62,7 +62,7 @@ -- | adjustPage :: HoodleModeState -> CanvasInfoBox -> CanvasInfoBox -adjustPage hdlmodst = selectBox fsingle fsingle +adjustPage hdlmodst = runIdentity . forBoth unboxBiXform (return . fsingle) where fsingle :: CanvasInfo a -> CanvasInfo a fsingle cinfo = let cpn = view currentPageNum cinfo pagemap = getPageMap hdlmodst@@ -129,15 +129,14 @@ updatePage (SelectState thdl) c = do let hdl = gSelect2GHoodle thdl updateCvsInfoFrmHoodle hdl c- -- GHoodle (view gselTitle thdl) (view gselAll thdl) -- | setPage :: HoodleState -> PageNum -> CanvasId -> IO CanvasInfoBox setPage xstate pnum cid = do let cinfobox = getCanvasInfo cid xstate- selectBoxAction (liftM CanvasSinglePage . setPageSingle xstate pnum) - (liftM CanvasContPage . setPageCont xstate pnum)- cinfobox+ unboxBiAct (liftM CanvasSinglePage . setPageSingle xstate pnum) + (liftM CanvasContPage . setPageCont xstate pnum)+ cinfobox -- | setPageSingle : in Single Page mode setPageSingle :: HoodleState -> PageNum
src/Hoodle/ModelAction/Select.hs view
@@ -16,7 +16,6 @@ -- from other package import Control.Lens (view,set)-import Control.Monad import Data.Algorithm.Diff import Data.Foldable (foldl') import qualified Data.IntMap as M@@ -60,7 +59,7 @@ | HandleBM | HandleML | HandleMR- deriving (Show)+ deriving (Show, Eq) -- | scaleFromToBBox :: BBox -> BBox -> (Double,Double) -> (Double,Double)
src/Hoodle/ModelAction/Select/Transform.hs view
@@ -91,10 +91,6 @@ nlnk = LinkDocID i lid loc t c bstr (x1,y1) (Dim (x2-x1) (y2-y1)) in runIdentity (makeBBoxed nlnk) ---- -- | modify the whole selection using a function changeSelectionBy :: ((Double,Double) -> (Double,Double)) -> Page SelectMode -> Page SelectMode@@ -110,8 +106,6 @@ layer' = GLayer buf . TEitherAlterHitted . Right $ alist' in set (glayers.selectedLayer) layer' tpage - - -- | special case of offset modification changeSelectionByOffset :: (Double,Double) -> Page SelectMode -> Page SelectMode changeSelectionByOffset (offx,offy) = changeSelectionBy (offsetFunc (offx,offy))@@ -120,4 +114,17 @@ offsetFunc :: (Double,Double) -> (Double,Double) -> (Double,Double) offsetFunc (offx,offy) = \(x,y)->(x+offx,y+offy) +-- | replace selection with one item+replaceSelection :: RItem -> Page SelectMode -> Page SelectMode +replaceSelection ritm tpage = + let activelayer = rItmsInActiveLyr tpage+ buf = view (glayers.selectedLayer.gbuffer) tpage+ in case activelayer of + Right (x :- Hitted _ys :- xs) -> + let xs' :: [RItem]+ xs' = concat (getA xs) + alist' = x :- Hitted [ritm] :- xs' :- Empty + layer' = GLayer buf . TEitherAlterHitted . Right $ alist'+ in set (glayers.selectedLayer) layer' tpage + _ -> tpage
src/Hoodle/ModelAction/Window.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -15,24 +16,45 @@ module Hoodle.ModelAction.Window where -- from other packages+import Control.Concurrent+import Control.Concurrent.STM import Control.Lens (view)+import Control.Monad import Control.Monad.Trans import qualified Data.IntMap as M+import Data.Maybe (mapMaybe)+import qualified Data.Text as T+import DBus+import DBus.Client import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (set) import System.FilePath-- -- from this package import Hoodle.Device import Hoodle.Type.Canvas import Hoodle.Type.Event-import Hoodle.Type.PageArrangement import Hoodle.Type.Window import Hoodle.Type.HoodleState import Hoodle.Util -- +getDBUSEvent :: (AllEvent -> IO ()) -> TVar Bool -> IO ()+getDBUSEvent callback tvar = do+ client <- connectSession+ requestName client "org.ianwookim" []+ forkIO $ listen client matchAny { matchInterface = Just "org.ianwookim.hoodle" + , matchMember = Just "filepath"+ } + test+ forever getLine+ where test sig = do + putStrLn "getDBUSEvent"+ 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)))))+ return ()+ -- | set frame title according to file name setTitleFromFileName :: HoodleState -> IO () setTitleFromFileName xstate = do @@ -49,13 +71,13 @@ in (maximum cids) + 1 -- | initialize CanvasInfo with creating windows and connect events-initCanvasInfo :: ViewMode a => HoodleState -> CanvasId -> IO (CanvasInfo a)+initCanvasInfo :: HoodleState -> CanvasId -> IO (CanvasInfo a) initCanvasInfo xstate cid = minimalCanvasInfo xstate cid >>= connectDefaultEventCanvasInfo xstate -- | only creating windows -minimalCanvasInfo :: ViewMode a => HoodleState -> CanvasId -> IO (CanvasInfo a)+minimalCanvasInfo :: HoodleState -> CanvasId -> IO (CanvasInfo a) minimalCanvasInfo _xstate cid = do canvas <- drawingAreaNew scrwin <- scrolledWindowNew Nothing Nothing @@ -64,14 +86,13 @@ vadj <- adjustmentNew 0 0 500 100 200 200 scrolledWindowSetHAdjustment scrwin hadj scrolledWindowSetVAdjustment scrwin vadj - -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic return $ CanvasInfo cid canvas Nothing scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing defaultCanvasWidgets Nothing -- | only connect events -connectDefaultEventCanvasInfo :: ViewMode a => - HoodleState -> CanvasInfo a -> IO (CanvasInfo a )+connectDefaultEventCanvasInfo + :: HoodleState -> CanvasInfo a -> IO (CanvasInfo a ) connectDefaultEventCanvasInfo xstate cinfo = do let callback = view callBack xstate dev = view deviceList xstate @@ -90,7 +111,6 @@ m <- eventModifier n <- eventKeyName let keystr = show m ++ ":" ++ show n- -- liftIO $ putStrLn (show m ++ ":" ++ show n) liftIO $ (callback (UsrEv (CustomKeyEvent keystr))) _bpevent <- canvas `on` buttonPressEvent $ tryEvent $ do liftIO $ widgetGrabFocus canvas @@ -115,7 +135,13 @@ case pbtn of TouchButton -> (liftIO . callback . UsrEv) (TouchUp cid p) _ -> (liftIO . callback . UsrEv) (PenUp cid p)- _focus <- canvas `on` focusInEvent $ tryEvent $ liftIO $ widgetGrabFocus canvas + + tvar <- newTVarIO False + forkIO $ getDBUSEvent callback tvar+ _focus <- canvas `on` focusInEvent $ tryEvent $ liftIO $ do+ atomically (writeTVar tvar True)+ widgetGrabFocus canvas + _focusout <- canvas `on` focusOutEvent $ tryEvent $ liftIO $ atomically (writeTVar tvar False) _exposeev <- canvas `on` exposeEvent $ tryEvent $ do liftIO $ widgetGrabFocus canvas (liftIO . callback . UsrEv) (UpdateCanvas cid) @@ -167,9 +193,8 @@ -- | recreate windows from old canvas info but no event connect -reinitCanvasInfoStage1 :: (ViewMode a) => - HoodleState - -> CanvasInfo a -> IO (CanvasInfo a)+reinitCanvasInfoStage1 + :: HoodleState -> CanvasInfo a -> IO (CanvasInfo a) reinitCanvasInfoStage1 xstate oldcinfo = do let cid = view canvasId oldcinfo newcinfo <- minimalCanvasInfo xstate cid @@ -180,8 +205,8 @@ -- | event connect -reinitCanvasInfoStage2 :: (ViewMode a) => - HoodleState -> CanvasInfo a -> IO (CanvasInfo a)+reinitCanvasInfoStage2 + :: HoodleState -> CanvasInfo a -> IO (CanvasInfo a) reinitCanvasInfoStage2 = connectDefaultEventCanvasInfo -- | event connecting for all windows @@ -191,7 +216,7 @@ eventConnect xstate (Node cid) = do let cmap = getCanvasInfoMap xstate cinfobox = maybeError' "eventConnect" $ M.lookup cid cmap- ncinfobox <- insideAction4CvsInfoBoxF (reinitCanvasInfoStage2 xstate) cinfobox+ ncinfobox <- forBoth unboxBiXform (reinitCanvasInfoStage2 xstate) cinfobox let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate return (xstate', Node cid) eventConnect xstate (HSplit wconf1 wconf2) = do @@ -203,13 +228,6 @@ (xstate'',wconf2') <- eventConnect xstate' wconf2 return (xstate'',VSplit wconf1' wconf2') -{- case cinfobox of - CanvasInfoBox cinfo -> do - ncinfo <- reinitCanvasInfoStage2 xstate cinfo - let xstate' = updateFromCanvasInfoAsCurrentCanvas (CanvasInfoBox ncinfo) xstate -}--- -- | default construct frame constructFrame :: HoodleState -> WindowConfig @@ -232,9 +250,9 @@ cmap' = M.insert cid cinfobox' ocmap xstate' = maybe oxstate id (setCanvasInfoMap cmap' oxstate) return (cinfobox',cmap',xstate')- ncinfobox <- insideAction4CvsInfoBoxF (reinitCanvasInfoStage1 xstate) cinfobox+ ncinfobox <- forBoth unboxBiXform (reinitCanvasInfoStage1 xstate) cinfobox let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate- let scrwin = fmap4CvsInfoBox (castToWidget.view scrolledWindow) ncinfobox+ let scrwin = forBoth' unboxBiAct (castToWidget.view scrolledWindow) ncinfobox return (xstate', scrwin, Node cid) constructFrame' template xstate (HSplit wconf1 wconf2) = do (xstate',win1,wconf1') <- constructFrame' template xstate wconf1 @@ -267,9 +285,3 @@ widgetShowAll vpane' return (xstate'',castToWidget vpane', VSplit wconf1' wconf2') ---{- case cinfobox of - CanvasInfoBox cinfo -> do - ncinfo <- reinitCanvasInfoStage1 xstate cinfo - let xstate' = updateFromCanvasInfoAsCurrentCanvas (CanvasInfoBox ncinfo) xstate -}
src/Hoodle/Script/Hook.hs view
@@ -30,6 +30,9 @@ , embedPredefinedImage2Hook :: Maybe (IO FilePath) , embedPredefinedImage3Hook :: Maybe (IO FilePath) , lookupPathFromId :: Maybe (String -> IO (Maybe FilePath))+ , warningEmbedImageSize :: Maybe Integer+ , shrinkCmd4EmbedImage :: Maybe (Double -> FilePath -> FilePath -> IO ()) + , getIPaddress :: Maybe (IO String) } @@ -47,4 +50,7 @@ , embedPredefinedImage2Hook = Nothing , embedPredefinedImage3Hook = Nothing , lookupPathFromId = Nothing + , warningEmbedImageSize = Nothing+ , shrinkCmd4EmbedImage = Nothing+ , getIPaddress = Nothing }
src/Hoodle/Type/Canvas.hs view
@@ -1,5 +1,11 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, ExistentialQuantification,- Rank2Types, GADTs, RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- |@@ -69,15 +75,19 @@ , xfrmCvsInfo , xfrmViewInfo , getDrawAreaFromBox-, unboxGet-, unboxSet+-- , unboxGet+-- , unboxSet , unboxLens-, fmap4CvsInfoBox-, insideAction4CvsInfoBox-, insideAction4CvsInfoBoxF-, boxAction-, selectBoxAction-, selectBox+, unboxBiAct+, unboxBiXform+, forBoth+, forBoth'+-- , unboxSelect+-- , fmap4CvsInfoBox+-- , insideAction4CvsInfoBox+-- , insideAction4CvsInfoBoxF+-- , boxAction+-- , selectBox -- * others , updateCanvasDimForSingle , updateCanvasDimForContSingle@@ -113,12 +123,11 @@ points = lens _points (\f a -> f { _points = a } ) -- | -data ViewInfo a = (ViewMode a) => - ViewInfo { _zoomMode :: ZoomMode - , _pageArrangement :: PageArrangement a } +data ViewInfo (a :: ViewMode) = + ViewInfo { _zoomMode :: ZoomMode + , _pageArrangement :: PageArrangement a } -xfrmViewInfo :: (ViewMode a, ViewMode b) => - (PageArrangement a -> PageArrangement b) +xfrmViewInfo :: (PageArrangement a -> PageArrangement b) -> ViewInfo a -> ViewInfo b xfrmViewInfo f ViewInfo {..} = @@ -151,24 +160,23 @@ -- |-data CanvasInfo a = - (ViewMode a) => CanvasInfo { _canvasId :: CanvasId- , _drawArea :: DrawingArea- , _mDrawSurface :: Maybe Surface - , _scrolledWindow :: ScrolledWindow- , _viewInfo :: ViewInfo a- , _currentPageNum :: Int- , _horizAdjustment :: Adjustment- , _vertAdjustment :: Adjustment - , _horizAdjConnId :: Maybe (ConnectId Adjustment)- , _vertAdjConnId :: Maybe (ConnectId Adjustment)- , _canvasWidgets :: CanvasWidgets- , _notifiedItem :: Maybe (PageNum,BBox,RItem) - }+data CanvasInfo (a :: ViewMode) = + CanvasInfo { _canvasId :: CanvasId+ , _drawArea :: DrawingArea+ , _mDrawSurface :: Maybe Surface + , _scrolledWindow :: ScrolledWindow+ , _viewInfo :: ViewInfo a+ , _currentPageNum :: Int+ , _horizAdjustment :: Adjustment+ , _vertAdjustment :: Adjustment + , _horizAdjConnId :: Maybe (ConnectId Adjustment) + , _vertAdjConnId :: Maybe (ConnectId Adjustment)+ , _canvasWidgets :: CanvasWidgets+ , _notifiedItem :: Maybe (PageNum,BBox,RItem) + } -- | -xfrmCvsInfo :: (ViewMode a, ViewMode b) => - (ViewInfo a -> ViewInfo b) +xfrmCvsInfo :: (ViewInfo a -> ViewInfo b) -> CanvasInfo a -> CanvasInfo b xfrmCvsInfo f CanvasInfo {..} = CanvasInfo { _canvasId = _canvasId@@ -258,69 +266,114 @@ notifiedItem = lens _notifiedItem (\f a -> f { _notifiedItem = a }) -- |-data CanvasInfoBox = CanvasSinglePage (CanvasInfo SinglePage) - | CanvasContPage (CanvasInfo ContinuousPage)--+data CanvasInfoBox where + CanvasSinglePage :: CanvasInfo SinglePage -> CanvasInfoBox + CanvasContPage :: CanvasInfo ContinuousPage -> CanvasInfoBox+ --- | apply a funtion to Generic CanvasInfo -fmap4CvsInfoBox :: (forall a. (ViewMode a)=> CanvasInfo a -> r) -> CanvasInfoBox -> r -fmap4CvsInfoBox f (CanvasSinglePage x) = f x -fmap4CvsInfoBox f (CanvasContPage x) = f x +-- 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)+-} --- | fmap-like operation for box-insideAction4CvsInfoBoxF :: (Functor f) => - (forall a. (ViewMode a) => CanvasInfo a -> f (CanvasInfo a))- -> CanvasInfoBox -> f CanvasInfoBox-insideAction4CvsInfoBoxF f (CanvasSinglePage x) = fmap CanvasSinglePage (f x)-insideAction4CvsInfoBoxF f (CanvasContPage x) = fmap CanvasContPage (f x) - --- |-getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea -getDrawAreaFromBox = unboxGet drawArea+forBoth :: + ((CanvasInfo SinglePage -> f (CanvasInfo SinglePage))+ -> (CanvasInfo ContinuousPage -> f (CanvasInfo ContinuousPage)) + -> (CanvasInfoBox -> f CanvasInfoBox)) + -> (forall a. CanvasInfo a -> f (CanvasInfo a))+ -> CanvasInfoBox -> f CanvasInfoBox+forBoth m f = m f f --- | -unboxGet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> CanvasInfoBox -> b -unboxGet f x = fmap4CvsInfoBox (view f) x +forBoth' :: ((CanvasInfo SinglePage -> r)+ -> (CanvasInfo ContinuousPage -> r) + -> (CanvasInfoBox -> r) )+ -> (forall a. CanvasInfo a -> r)+ -> CanvasInfoBox -> r+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)) + -> (CanvasInfo ContinuousPage -> f (CanvasInfo ContinuousPage)) + -> CanvasInfoBox -> f CanvasInfoBox +unboxBiXform fsingle _fcont (CanvasSinglePage cinfo) = fmap CanvasSinglePage (fsingle cinfo)+unboxBiXform _fsingle fcont (CanvasContPage cinfo) = fmap CanvasContPage (fcont cinfo) + +-- | single page action and continuous page act+unboxBiAct :: (CanvasInfo SinglePage -> r) + -> (CanvasInfo ContinuousPage -> r) + -> CanvasInfoBox -> r+unboxBiAct fsingle _fcont (CanvasSinglePage cinfo) = fsingle cinfo+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 +-}+ -- | -unboxSet :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> b -> CanvasInfoBox -> CanvasInfoBox+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) unboxSet l b (CanvasContPage a) = CanvasContPage (set l b a) -unboxLens :: (forall a. (ViewMode a) => Simple Lens (CanvasInfo a) b) -> Simple Lens CanvasInfoBox b+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. ViewMode a => CanvasInfo a -> m b) +boxAction :: Monad m => (forall a. CanvasInfo a -> m b) -> CanvasInfoBox -> m b -boxAction f c = fmap4CvsInfoBox f c +boxAction f c = unboxAct f c -- f (CanvasInfoBox cinfo) = f cinfo +-} --- | either-like operation-selectBoxAction :: (Monad m) => - (CanvasInfo SinglePage -> m a) - -> (CanvasInfo ContinuousPage -> m a) -> CanvasInfoBox -> m a -selectBoxAction fsingle _fcont (CanvasSinglePage cinfo) = fsingle cinfo-selectBoxAction _fsingle fcont (CanvasContPage cinfo) = fcont 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) -- | type CanvasInfoMap = M.IntMap CanvasInfoBox
src/Hoodle/Type/Coroutine.hs view
@@ -21,12 +21,13 @@ -- from other packages import Control.Applicative import Control.Concurrent-import Control.Lens ((^.),(.~),(%~))--- import Control.Monad.Error+import Control.Lens ((^.),(.~),(%~),view,set)+ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Either --- import Data.IORef +import Data.Time.Clock+import Data.Time.LocalTime -- from hoodle-platform import Control.Monad.Trans.Crtn import Control.Monad.Trans.Crtn.Object@@ -35,8 +36,10 @@ 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 -- @@ -63,6 +66,27 @@ 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 -- |
src/Hoodle/Type/Enum.hs view
@@ -69,7 +69,7 @@ data VerticalSpaceMode = GoingUp | GoingDown | OverPage -- | select tool type-data SelectType = SelectRegionWork +data SelectType = SelectLassoWork | SelectRectangleWork | SelectHandToolWork deriving (Show,Eq,Ord) @@ -79,7 +79,14 @@ } deriving (Show) +data RotateDir = CW | CCW deriving (Show, Ord, Eq) ++--+-- lenses+--++-- | selectType :: Simple Lens SelectInfo SelectType selectType = lens _selectType (\f a -> f { _selectType = a })
src/Hoodle/Type/Event.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE FlexibleInstances #-}+ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Event -- Copyright : (c) 2011-2013 Ian-Woo Kim ----- License : GPL-3+-- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com> -- Stability : experimental -- Portability : GHC@@ -15,32 +17,35 @@ module Hoodle.Type.Event where -- from other package-import Control.Monad-import Data.ByteString -import Data.IORef-import Data.Time.Clock-import Graphics.UI.Gtk+import Control.Concurrent +import Data.ByteString +import Data.IORef+import qualified Data.Text as T+import Data.Time.Clock+import Graphics.UI.Gtk hiding (Image) -- from hoodle-platform import Control.Monad.Trans.Crtn.Event -import Data.Hoodle.Simple+import Data.Hoodle.BBox+import Data.Hoodle.Simple -- from this package-import Hoodle.Device -import Hoodle.Type.Enum-import Hoodle.Type.Canvas-import Hoodle.Type.PageArrangement+import Hoodle.Device +import Hoodle.Type.Enum+import Hoodle.Type.Canvas+import Hoodle.Type.PageArrangement -- | data AllEvent = UsrEv UserEvent | SysEv SystemEvent deriving Show -- | -data SystemEvent = TestSystemEvent +data SystemEvent = TestSystemEvent | ClockUpdateEvent deriving Show -+ -- | data UserEvent = Initialized | CanvasConfigure Int Double Double | UpdateCanvas Int+ | UpdateCanvasEfficient Int | PenDown Int PenButton PointerCoord | PenMove Int PointerCoord | PenUp Int PointerCoord @@ -70,7 +75,7 @@ | ContextMenuCreated | GotContextMenuSignal ContextMenuEvent | LaTeXInput (Maybe (ByteString,ByteString))- | TextInput (Maybe String) + | TextInput (Maybe String) | AddLink (Maybe (String,FilePath)) | EventDisconnected | GetHoodleFileInfo (IORef (Maybe String))@@ -79,7 +84,13 @@ | FileReloadOrdered | CustomKeyEvent String | GotRevision String String+ | GotRevisionInk String [Stroke]+ | ChangeDialog | ActionOrdered + | MiniBuffer MiniBufferEvent+ | MultiLine MultiLineEvent+ | NetworkProcess NetworkEvent+ | ImageFileDropped FilePath deriving Show instance Show (IORef a) where @@ -96,6 +107,7 @@ | MenuLoadPNGorJPG | MenuLoadSVG | MenuLaTeX+ | MenuCombineLaTeX | MenuEmbedPredefinedImage | MenuEmbedPredefinedImage2 | MenuEmbedPredefinedImage3 @@ -172,8 +184,10 @@ | MenuEmbedImage | MenuEmbedPDF | MenuFollowLinks+ | MenuKeepAspectRatio | MenuTogglePanZoomWidget | MenuToggleLayerWidget+ | MenuToggleClockWidget | MenuDiscardCoreEvents | MenuEraserTip | MenuPressureSensitivity@@ -191,7 +205,7 @@ | MenuSavePreferences | MenuAbout | MenuDefault- deriving (Show, Ord, Eq)+ deriving Show -- (Show, Ord, Eq) -- | data ImgType = TypSVG | TypPDF @@ -203,14 +217,43 @@ | CMenuCopy | CMenuDelete | CMenuCanvasView CanvasId PageNum Double Double - | CMenuRotateCW- | CMenuRotateCCW | CMenuAutosavePage | CMenuLinkConvert Link | CMenuCreateALink | CMenuAssocWithNewFile+ | CMenuPangoConvert (Double,Double) T.Text+ | CMenuLaTeXConvert (Double,Double) T.Text+ | CMenuLaTeXConvertNetwork (Double,Double) T.Text+ | CMenuCropImage (BBoxed Image)+ | CMenuRotate RotateDir (BBoxed Image) | CMenuCustom deriving (Show, Ord, Eq) +++-- | event for minibuffer operation (currently pen only) +data MiniBufferEvent = MiniBufferInitialized DrawWindow+ | MiniBufferPenDown PenButton PointerCoord+ | MiniBufferPenUp PointerCoord+ | MiniBufferPenMove PointerCoord+ deriving Show++instance Show DrawWindow where+ show _ = "DrawWindow"++-- | event for multiline text view/buffer+data MultiLineEvent = MultiLineChanged T.Text+ deriving Show++-- | event for network+data NetworkEvent = NetworkDialog + | NetworkInitialized ThreadId (MVar ())+ | NetworkReceived T.Text+ | NetworkCloseDialog+ | NetworkClosed+ deriving Show++instance Show (MVar ()) where+ show _ = "MVar" -- | viewModeToUserEvent :: RadioAction -> IO UserEvent
src/Hoodle/Type/HoodleState.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- |@@ -56,6 +57,7 @@ , doesEmbedImage , doesEmbedPDF , doesFollowLinks+, doesKeepAspectRatio -- , penModeSignal , pageModeSignal@@ -86,8 +88,9 @@ ) where import Control.Category-import Control.Lens+import Control.Lens (Simple,Lens,view,set,lens) import Control.Monad.State hiding (get,modify)+import Data.Functor.Identity (Identity(..)) import qualified Data.IntMap as M import Data.Maybe import Data.Time.Clock@@ -126,7 +129,7 @@ deriving (Show,Eq,Ord) data HoodleState = - HoodleState { _hoodleModeState :: HoodleModeState+ HoodleState { _hoodleModeState :: HoodleModeState , _hoodleFileControl :: HoodleFileControl , _cvsInfoMap :: CanvasInfoMap , _currentCanvas :: (CanvasId,CanvasInfoBox)@@ -315,6 +318,7 @@ , _doesEmbedImage :: Bool , _doesEmbedPDF :: Bool , _doesFollowLinks :: Bool + , _doesKeepAspectRatio :: Bool } @@ -346,6 +350,9 @@ doesFollowLinks :: Simple Lens Settings Bool doesFollowLinks = lens _doesFollowLinks (\f a -> f { _doesFollowLinks = a } ) +-- | flag for keeping aspect ratio+doesKeepAspectRatio :: Simple Lens Settings Bool+doesKeepAspectRatio = lens _doesKeepAspectRatio (\f a -> f { _doesKeepAspectRatio = a } ) -- | default hoodle state emptyHoodleState :: IO HoodleState @@ -367,7 +374,7 @@ , _callBack = error "emtpyHoodleState.callBack" , _deviceList = error "emtpyHoodleState.deviceList" , _penInfo = defaultPenInfo - , _selectInfo = SelectInfo SelectRectangleWork + , _selectInfo = SelectInfo SelectLassoWork , _gtkUIManager = error "emptyHoodleState.gtkUIManager" , _isSaved = False , _undoTable = emptyUndo 1 @@ -413,6 +420,7 @@ , _doesEmbedImage = True , _doesEmbedPDF = True , _doesFollowLinks = True+ , _doesKeepAspectRatio = False } @@ -485,7 +493,7 @@ -- | change current canvas. this is the master function updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> HoodleState -> HoodleState updateFromCanvasInfoAsCurrentCanvas cinfobox xstate = - let cid = unboxGet canvasId cinfobox + let cid = view (unboxLens canvasId) cinfobox cmap = getCanvasInfoMap xstate cmap' = M.insert cid cinfobox cmap in xstate { _currentCanvas = (cid,cinfobox)@@ -493,7 +501,7 @@ -- | setCanvasId :: CanvasId -> CanvasInfoBox -> CanvasInfoBox -setCanvasId cid = insideAction4CvsInfoBox (set canvasId cid) +setCanvasId cid = runIdentity . forBoth unboxBiXform (return . set canvasId cid) -- | modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) -> HoodleState@@ -510,17 +518,17 @@ SelectState thdl -> Right thdl -- | -getCurrentPageFromHoodleModeState :: (ViewMode a) => CanvasInfo a - -> HoodleModeState -> Page EditMode +getCurrentPageFromHoodleModeState + :: CanvasInfo a -> HoodleModeState -> Page EditMode getCurrentPageFromHoodleModeState cinfo hdlmodst = let cpn = view currentPageNum cinfo pagemap = getPageMapFromHoodleModeState hdlmodst in maybeError' "updatePageFromCanvasToHoodle" $ M.lookup cpn pagemap -- | -getCurrentPageDimFromHoodleModeState :: (ViewMode a) => CanvasInfo a - -> HoodleModeState -> PageDimension-getCurrentPageDimFromHoodleModeState cinfo = +getCurrentPageDimFromHoodleModeState + :: CanvasInfo a -> HoodleModeState -> PageDimension+getCurrentPageDimFromHoodleModeState cinfo = PageDimension . view gdimension . getCurrentPageFromHoodleModeState cinfo @@ -533,7 +541,7 @@ showCanvasInfoMapViewPortBBox :: HoodleState -> IO () showCanvasInfoMapViewPortBBox xstate = do let cmap = getCanvasInfoMap xstate- print . map (unboxGet (viewInfo.pageArrangement.viewPortBBox)) . M.elems $ cmap + print . map (view (unboxLens (viewInfo.pageArrangement.viewPortBBox))) . M.elems $ cmap
src/Hoodle/Type/PageArrangement.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE EmptyDataDecls, GADTs, TypeOperators, GeneralizedNewtypeDeriving, NoMonoPatBinds #-}+{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonoPatBinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- |@@ -28,27 +34,12 @@ import Hoodle.Util -- --- | -+-- | supported zoom modes data ZoomMode = Original | FitWidth | FitHeight | Zoom Double deriving (Show,Eq) --- | sum type class (later, will be replaced by Kind promotion) -data ViewModeSumType = VMSinglePage | VMContPage --class ViewMode a ---- | only one page show at a time-data SinglePage = SinglePage---- | -instance ViewMode SinglePage ---- | continuously show pages in general-data ContinuousPage = ContinuousPage---- | -instance ViewMode ContinuousPage+-- | supported view modes+data ViewMode = SinglePage | ContinuousPage -- | newtype PageNum = PageNum { unPageNum :: Int } @@ -112,13 +103,13 @@ ymargin = if 0.5*((y2-y1)-h) > 0 then 0.5*((y2-y1)-h) else 0 (x1',x2') | x2>w && w-(x2-x1)>0 = (w-(x2-x1),w) - | x2>w && w-(x2-x1)<=0 = (-xmargin,-xmargin+x2-x1) -- (0,x2-x1) - | x1< (-xmargin) = (-xmargin,-xmargin+x2-x1) -- (0,x2-x1)+ | x2>w && w-(x2-x1)<=0 = (-xmargin,-xmargin+x2-x1)+ | x1< (-xmargin) = (-xmargin,-xmargin+x2-x1) | otherwise = (x1,x2) (y1',y2') | y2>h && h-(y2-y1)>0 = (h-(y2-y1),h)- | y2>h && h-(y2-y1)<=0 = (-ymargin,-ymargin+y2-y1) -- (0,y2-y1)- | y1 < (-ymargin) = (-ymargin,-ymargin+y2-y1) -- (0,y2-y1)+ | y2>h && h-(y2-y1)<=0 = (-ymargin,-ymargin+y2-y1) + | y1 < (-ymargin) = (-ymargin,-ymargin+y2-y1) | otherwise = (y1,y2) in ViewPortBBox (BBox (x1',y1') (x2',y2') ) @@ -126,7 +117,7 @@ -- | data structure for coordinate arrangement of pages in desktop coordinate-data PageArrangement a where+data PageArrangement (a :: ViewMode) where SingleArrangement :: CanvasDimension -> PageDimension -> ViewPortBBox @@ -181,16 +172,6 @@ ovport =ViewPortBBox (BBox (x1,y1) (x2,y2)) vport = xformViewPortFitInSize iddim id ovport in ContinuousArrangement cdim ddim (pageArrFuncCont cnstrnt hdl) vport--{- (x1',x2') - | x2>w && w-(x2-x1)>0 = (w-(x2-x1),w) - | x2>w && w-(x2-x1)<=0 = (0,x2-x1) - | otherwise = (x1,x2)- (y1',y2') - | y2>h && h-(y2-y1)>0 = (h-(y2-y1),h)- | y2>h && h-(y2-y1)<=0 = (0,y2-y1)- | otherwise = (y1,y2)- vport = ViewPortBBox (BBox (x1',y1') (x2',y2') ) -} -- |
src/Hoodle/Type/Predefined.hs view
@@ -15,7 +15,7 @@ import Data.Time.Clock -- | -+millisec :: Integer millisec = 1000000000 dtime_bound :: NominalDiffTime
src/Hoodle/Type/Widget.hs view
@@ -19,6 +19,7 @@ , CanvasWidgets , WidgetConfig , LayerWidgetConfig +, ClockWidgetConfig -- * lenses , panZoomWidgetPosition , panZoomWidgetTouchIsZoom@@ -26,9 +27,13 @@ , layerWidgetConfig , layerWidgetPosition , layerWidgetShowContent+, clockWidgetConfig+, clockWidgetPosition+, clockWidgetTime , widgetConfig , doesUsePanZoomWidget , doesUseLayerWidget+, doesUseClockWidget -- * defaults , defaultCanvasWidgets , defaultLWConfig @@ -43,11 +48,12 @@ -- | -data WidgetItem = PanZoomWidget | LayerWidget+data WidgetItem = PanZoomWidget | LayerWidget | ClockWidget deriving (Show,Eq,Ord) -- | -allWidgets = [PanZoomWidget, LayerWidget] +allWidgets :: [WidgetItem] +allWidgets = [PanZoomWidget, LayerWidget, ClockWidget] -- | @@ -76,10 +82,24 @@ layerWidgetShowContent = lens _layerWidgetShowContent (\f a -> f { _layerWidgetShowContent = a}) +-- |+data ClockWidgetConfig = ClkConfig { _clockWidgetPosition :: CanvasCoordinate+ , _clockWidgetTime :: (Int,Int,Int)+ }+ + +clockWidgetPosition :: Simple Lens ClockWidgetConfig CanvasCoordinate+clockWidgetPosition = lens _clockWidgetPosition (\f a -> f { _clockWidgetPosition = a } )++clockWidgetTime :: Simple Lens ClockWidgetConfig (Int,Int,Int)+clockWidgetTime = lens _clockWidgetTime (\f a -> f { _clockWidgetTime = a })++ -- | data CanvasWidgets = CanvasWidgets { _panZoomWidgetConfig :: PanZoomWidgetConfig , _layerWidgetConfig :: LayerWidgetConfig + , _clockWidgetConfig :: ClockWidgetConfig , _widgetConfig :: WidgetConfig } @@ -91,13 +111,18 @@ layerWidgetConfig :: Simple Lens CanvasWidgets LayerWidgetConfig layerWidgetConfig = lens _layerWidgetConfig (\f a -> f { _layerWidgetConfig = a }) +-- | +clockWidgetConfig :: Simple Lens CanvasWidgets ClockWidgetConfig +clockWidgetConfig = lens _clockWidgetConfig (\f a -> f { _clockWidgetConfig = a }) + -- | default hoodle widgets defaultCanvasWidgets :: CanvasWidgets defaultCanvasWidgets = CanvasWidgets { _panZoomWidgetConfig = defaultPZWConfig , _layerWidgetConfig = defaultLWConfig + , _clockWidgetConfig = defaultClkConfig , _widgetConfig = defaultWidgetConfig } @@ -114,8 +139,17 @@ , _layerWidgetShowContent = False } +-- | +defaultClkConfig :: ClockWidgetConfig +defaultClkConfig = + ClkConfig { _clockWidgetPosition = CvsCoord (500,300) + , _clockWidgetTime = (3,40,28)+ }++ data WidgetConfig = WidgetConfig { _doesUsePanZoomWidget :: Bool , _doesUseLayerWidget :: Bool + , _doesUseClockWidget :: Bool } -- | flag for pan zoom widget @@ -126,11 +160,16 @@ doesUseLayerWidget :: Simple Lens WidgetConfig Bool doesUseLayerWidget = lens _doesUseLayerWidget (\f a -> f {_doesUseLayerWidget = a}) +-- | flag for clock widget +doesUseClockWidget :: Simple Lens WidgetConfig Bool +doesUseClockWidget = lens _doesUseClockWidget (\f a -> f {_doesUseClockWidget = a}) + -- | default widget configuration defaultWidgetConfig :: WidgetConfig defaultWidgetConfig = WidgetConfig { _doesUsePanZoomWidget = False , _doesUseLayerWidget = False+ , _doesUseClockWidget = False }
src/Hoodle/Util.hs view
@@ -18,14 +18,14 @@ import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as B import Data.Maybe+import Data.Time.Clock +import Data.Time.Format+import Data.UUID.V4 (nextRandom) import Network.URI- import System.Directory import System.Environment import System.FilePath import System.IO-import Data.Time.Clock -import Data.Time.Format import System.Locale -- import Data.Hoodle.Simple@@ -97,8 +97,8 @@ <|> try (string "http://" *> return H) <|> try (string "https://" *> return HS) <|> (return N) )- rem <- manyTill anyChar ((satisfy (inClass "\r\n") *> return ()) <|> endOfInput)- return (b,rem) + remaining <- manyTill anyChar ((satisfy (inClass "\r\n") *> return ()) <|> endOfInput)+ return (b,remaining) r = parseOnly p (B.pack str) in case r of Left _ -> Nothing @@ -109,3 +109,9 @@ HS -> Just (HttpUrl ("https://" ++ f)) +-- | +mkTmpFile :: String -> IO FilePath+mkTmpFile ext = do + tdir <- getTemporaryDirectory+ tuuid <- nextRandom+ return $ tdir </> show tuuid <.> ext
src/Hoodle/View/Coordinate.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GADTs, TupleSections #-}+{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- |@@ -195,8 +196,7 @@ -- | -getCvsGeomFrmCvsInfo :: (ViewMode a) => - CanvasInfo a -> IO CanvasGeometry +getCvsGeomFrmCvsInfo :: CanvasInfo a -> IO CanvasGeometry getCvsGeomFrmCvsInfo cinfo = do let cpn = PageNum . view currentPageNum $ cinfo canvas = view drawArea cinfo
src/Hoodle/View/Draw.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE GADTs, Rank2Types, TypeFamilies, ScopedTypeVariables #-}-+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.View.Draw @@ -27,7 +30,6 @@ import Data.Sequence import Graphics.UI.Gtk hiding (get,set) import Graphics.Rendering.Cairo-import Graphics.Rendering.Pango.Cairo -- from hoodle-platform import Data.Hoodle.BBox import Data.Hoodle.Generic@@ -54,7 +56,7 @@ -- | -type family DrawingFunction v :: * -> * +type family DrawingFunction (v :: ViewMode) :: * -> * -- | @@ -123,7 +125,7 @@ post -- | -doubleBufferFlush :: ViewMode a => Surface -> CanvasInfo a -> IO () +doubleBufferFlush :: Surface -> CanvasInfo a -> IO () doubleBufferFlush sfc cinfo = do let canvas = view drawArea cinfo win <- widgetGetDrawWindow canvas@@ -591,8 +593,8 @@ --------------------------------------------------- -- | -drawWidgets :: ViewMode a => - [WidgetItem] -> Hoodle EditMode -> CanvasInfo a -> Maybe BBox -> Render () +drawWidgets :: [WidgetItem] -> Hoodle EditMode + -> CanvasInfo a -> Maybe BBox -> Render () drawWidgets witms hdl cinfo mbbox = do when (PanZoomWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUsePanZoomWidget) cinfo) $ renderPanZoomWidget (view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) cinfo)@@ -600,7 +602,15 @@ when (LayerWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseLayerWidget) cinfo) (drawLayerWidget hdl cinfo mbbox (view (canvasWidgets.layerWidgetConfig.layerWidgetPosition) cinfo)) + when (ClockWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseClockWidget) cinfo) $+ renderClockWidget mbbox (view (canvasWidgets.clockWidgetConfig) cinfo) +++---------------------+-- Pan Zoom Widget --+---------------------+ -- | renderPanZoomWidget :: Bool -> Maybe BBox -> CanvasCoordinate -> Render () renderPanZoomWidget b mbbox (CvsCoord (x,y)) = do @@ -631,8 +641,11 @@ stroke resetClip -drawLayerWidget :: ViewMode a => - Hoodle EditMode +------------------+-- Layer Widget -- +------------------++drawLayerWidget :: Hoodle EditMode -> CanvasInfo a -> Maybe BBox -> CanvasCoordinate @@ -720,8 +733,8 @@ identityMatrix l <- createLayout str updateLayout l - (_,reclog) <- liftIO $ layoutGetExtents l- let PangoRectangle _ _ w h = reclog + (_,reclog2) <- liftIO $ layoutGetExtents l+ let PangoRectangle _ _ w h = reclog2 moveTo (x+30) (y+20) let sx = 40 / w sy = 60 / h @@ -729,4 +742,40 @@ layoutPath l setSourceRGBA 0 0 0 0.4 fill++------------------+-- Clock Widget --+------------------++renderClockWidget :: Maybe BBox -> ClockWidgetConfig -> 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 + clipBBox mbbox + setSourceRGBA 0.5 0.5 0.2 0.3 + arc x y 50 0.0 (2.0*pi)+ 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+ --+ 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+ -- + 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+ -- + resetClip
+ src/Hoodle/Widget/Clock.hs view
@@ -0,0 +1,139 @@+-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Widget.Clock+-- Copyright : (c) 2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-- Clock widget drawing and action+-- +-----------------------------------------------------------------------------++module Hoodle.Widget.Clock where++import Control.Lens (view,set,over)+import Control.Monad.State +import Data.Functor.Identity (Identity(..))+import Data.List (delete)+import Data.Time+import Graphics.Rendering.Cairo+--+import Data.Hoodle.BBox+import Data.Hoodle.Simple +import Graphics.Hoodle.Render.Util.HitTest+--+import Hoodle.Coroutine.Draw+import Hoodle.Coroutine.Pen+import Hoodle.Device+import Hoodle.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum+import Hoodle.Type.Event+import Hoodle.Type.HoodleState +import Hoodle.Type.PageArrangement+import Hoodle.Type.Widget+import Hoodle.View.Coordinate+import Hoodle.View.Draw+--++-- | +data CWAction = Move (CanvasCoordinate,CanvasCoordinate)+ deriving (Show)+ ++checkPointerInClock :: (CanvasId,CanvasInfo a,CanvasGeometry) + -> PointerCoord + -> Maybe CWAction +checkPointerInClock (_cid,cinfo,geometry) pcoord + | b = + let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord+ owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.clockWidgetConfig.clockWidgetPosition) cinfo+ obbox = BBox (x0-50,y0-50) (x0+50,y0+50) + r | isPointInBBox obbox (x,y) = Just (Move (oxy,owxy))+ | otherwise = Nothing+ in r+ | otherwise = Nothing + where b = view (canvasWidgets.widgetConfig.doesUseClockWidget) cinfo ++-- |+startClockWidget :: (CanvasId,CanvasInfo a,CanvasGeometry)+ -> CWAction + -> MainCoroutine () +startClockWidget (cid,cinfo,geometry) (Move (oxy,owxy)) = do + xst <- get + let hdl = getHoodle xst+ (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface Nothing geometry hdl)+ -- need to draw other widgets here + let otherwidgets = delete ClockWidget allWidgets + liftIO $ renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) + -- end : need to draw other widgets here ^^^+ tgtsfc <- liftIO $ createImageSurface FormatARGB32 (floor wsfc) (floor hsfc)+ ctime <- liftIO getCurrentTime + manipulateCW cid geometry (srcsfc,tgtsfc) owxy oxy ctime + liftIO $ surfaceFinish srcsfc + liftIO $ surfaceFinish tgtsfc++-- | main event loop for clock widget+manipulateCW :: CanvasId + -> CanvasGeometry + -> (Surface,Surface) + -> CanvasCoordinate + -> CanvasCoordinate + -> UTCTime + -> MainCoroutine () +manipulateCW cid geometry (srcsfc,tgtsfc) owxy oxy otime = do + r <- nextevent+ case r of + PenMove _ pcoord -> do + processWithDefTimeInterval+ (manipulateCW cid geometry (srcsfc,tgtsfc) owxy oxy) + (\ctime -> moveClockWidget cid geometry (srcsfc,tgtsfc) owxy oxy pcoord + >> manipulateCW cid geometry (srcsfc,tgtsfc) owxy oxy ctime)+ otime + PenUp _ _ -> invalidate cid + _ -> return ()++moveClockWidget :: CanvasId + -> CanvasGeometry + -> (Surface,Surface) + -> CanvasCoordinate + -> CanvasCoordinate + -> PointerCoord+ -> MainCoroutine ()+moveClockWidget cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do + let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord + xst <- get + let CanvasDimension (Dim cw ch) = canvasDim geometry + cinfobox = getCanvasInfo cid xst + nposx | xw+x-x0 < -50 = -50 + | xw+x-x0 > cw-50 = cw-50 + | otherwise = xw+x-x0+ nposy | yw+y-y0 < -50 = -50 + | yw+y-y0 > ch-50 = ch-50 + | otherwise = yw+y-y0 + nwpos = CvsCoord (nposx,nposy) + changeact :: CanvasInfo a -> CanvasInfo a + changeact cinfo = + set (canvasWidgets.clockWidgetConfig.clockWidgetPosition) nwpos $ cinfo+ ncinfobox = (runIdentity . forBoth unboxBiXform (return . changeact)) cinfobox+ put (setCanvasInfo (cid,ncinfobox) xst)+ -- + xst2 <- get + let cinfobox2 = getCanvasInfo cid xst2 + cfg = view (unboxLens (canvasWidgets.clockWidgetConfig)) cinfobox2+ liftIO $ forBoth' unboxBiAct (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ()) + (renderClockWidget Nothing cfg) + >> doubleBufferFlush tgtsfc cinfo) cinfobox2++-- | +toggleClock :: CanvasId -> MainCoroutine () +toggleClock cid = do + modify (\xst -> + let ncinfobox = (over (unboxLens (canvasWidgets.widgetConfig.doesUseClockWidget)) not + . getCanvasInfo cid ) xst + in setCanvasInfo (cid,ncinfobox) xst)+ invalidateInBBox Nothing Efficient cid+
src/Hoodle/Widget/Dispatch.hs view
@@ -15,13 +15,13 @@ module Hoodle.Widget.Dispatch where import Control.Applicative ((<|>))-import Control.Lens (view,set,over)+import Control.Lens (view) import Control.Monad.State hiding (forM_) import Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as B import Data.Foldable (forM_)-import Data.Time -import Graphics.Rendering.Cairo ++ -- import Data.Hoodle.BBox import Data.Hoodle.Simple @@ -33,23 +33,22 @@ import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.HoodleState-import Hoodle.Type.Widget+ import Hoodle.Type.PageArrangement import Hoodle.Util import Hoodle.View.Coordinate -import Hoodle.View.Draw ++import Hoodle.Widget.Clock import Hoodle.Widget.Layer import Hoodle.Widget.PanZoom--- --- import Prelude hiding (forM_) widgetCheckPen :: CanvasId -> PointerCoord -> MainCoroutine () -- ^ default action -> MainCoroutine ()-widgetCheckPen cid pcoord defact = get >>= \xst -> boxAction (chk xst) (getCanvasInfo cid xst) +widgetCheckPen cid pcoord defact = get >>= \xst -> forBoth' unboxBiAct (chk xst) (getCanvasInfo cid xst) where - chk :: (ViewMode a) => HoodleState -> CanvasInfo a -> MainCoroutine () + chk :: HoodleState -> CanvasInfo a -> MainCoroutine () chk xstate cinfo = do let cvs = view drawArea cinfo pnum = (PageNum . view currentPageNum) cinfo @@ -60,11 +59,13 @@ (lift . startPanZoomWidget PenMode triplet <=< MaybeT . return . checkPointerInPanZoom triplet) pcoord <|> (lift . startLayerWidget triplet <=< MaybeT . return . checkPointerInLayer triplet) pcoord+ <|>+ (lift . startClockWidget triplet <=< MaybeT . return . checkPointerInClock triplet) pcoord <|> (do guard (view (settings.doesFollowLinks) xstate) - (pnum,bbox,ritem) <- (MaybeT . return . view notifiedItem) cinfo- (pnum',PageCoord (x,y)) <- (MaybeT . return . desktop2Page geometry . device2Desktop geometry) pcoord - guard (pnum == pnum') + (pnum',bbox,ritem) <- (MaybeT . return . view notifiedItem) cinfo+ (pnum'',PageCoord (x,y)) <- (MaybeT . return . desktop2Page geometry . device2Desktop geometry) pcoord + guard (pnum' == pnum'') guard (isPointInBBox bbox (x,y)) case ritem of RItemLink lnkbbx _ -> do
src/Hoodle/Widget/Layer.hs view
@@ -3,7 +3,7 @@ -- Module : Hoodle.Widget.Layer -- Copyright : (c) 2013 Ian-Woo Kim ----- License : GPL-3+-- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com> -- Stability : experimental -- Portability : GHC@@ -14,9 +14,9 @@ module Hoodle.Widget.Layer where -import Control.Lens (view,set,over)-import Control.Monad.State -import Control.Monad.Trans+import Control.Lens (view,set,over)+import Control.Monad.State +import Data.Functor.Identity (Identity(..)) import Data.List (delete) import Data.Sequence import Data.Time@@ -44,11 +44,10 @@ -- | data LWAction = Close | ToggleShowContent | Move (CanvasCoordinate,CanvasCoordinate) -checkPointerInLayer :: ViewMode a => - (CanvasId,CanvasInfo a,CanvasGeometry) +checkPointerInLayer :: (CanvasId,CanvasInfo a,CanvasGeometry) -> PointerCoord - -> Maybe LWAction -- (Maybe (CanvasCoordinate,CanvasCoordinate))-checkPointerInLayer (cid,cinfo,geometry) pcoord + -> Maybe LWAction +checkPointerInLayer (_cid,cinfo,geometry) pcoord | b = let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.layerWidgetConfig.layerWidgetPosition) cinfo@@ -63,12 +62,11 @@ | otherwise = Nothing where b = view (canvasWidgets.widgetConfig.doesUseLayerWidget) cinfo -startLayerWidget :: ViewMode a =>- (CanvasId,CanvasInfo a,CanvasGeometry)- -> LWAction -- Maybe (CanvasCoordinate,CanvasCoordinate)+startLayerWidget :: (CanvasId,CanvasInfo a,CanvasGeometry)+ -> LWAction -> MainCoroutine () -startLayerWidget (cid,cinfo,geometry) Close = toggleLayer cid -startLayerWidget (cid,cinfo,geometry) ToggleShowContent = do +startLayerWidget (cid,_cinfo,_geometry) Close = toggleLayer cid +startLayerWidget (cid,_cinfo,_geometry) ToggleShowContent = do liftIO $ putStrLn "ToggleShowContent hitted" modify (over (currentCanvasInfo . unboxLens (canvasWidgets.layerWidgetConfig.layerWidgetShowContent)) not) invalidate cid @@ -100,8 +98,7 @@ -> CanvasCoordinate -> UTCTime -> MainCoroutine () -manipulateLW cid geometry (srcsfc,tgtsfc) - owxy@(CvsCoord (xw,yw)) oxy@(CvsCoord (x0,y0)) otime = do +manipulateLW cid geometry (srcsfc,tgtsfc) owxy oxy otime = do r <- nextevent case r of PenMove _ pcoord -> do @@ -110,7 +107,7 @@ (\ctime -> moveLayerWidget cid geometry (srcsfc,tgtsfc) owxy oxy pcoord >> manipulateLW cid geometry (srcsfc,tgtsfc) owxy oxy ctime) otime - PenUp _ pcoord -> invalidate cid + PenUp _ _pcoord -> invalidate cid _ -> return () moveLayerWidget :: CanvasId @@ -132,19 +129,18 @@ | yw+y-y0 > ch-50 = ch-50 | otherwise = yw+y-y0 nwpos = CvsCoord (nposx,nposy) - changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a + changeact :: CanvasInfo a -> CanvasInfo a changeact cinfo = set (canvasWidgets.layerWidgetConfig.layerWidgetPosition) nwpos $ cinfo- ncinfobox = selectBox changeact changeact cinfobox+ ncinfobox = (runIdentity . forBoth unboxBiXform (return . changeact)) cinfobox put (setCanvasInfo (cid,ncinfobox) xst) let hdl = getHoodle xst - -- xst2 <- get - let cinfobox = getCanvasInfo cid xst2 - liftIO $ boxAction (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ()) + let cinfobox2 = getCanvasInfo cid xst2 + liftIO $ forBoth' unboxBiAct (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ()) (drawLayerWidget hdl cinfo Nothing nwpos) - >> doubleBufferFlush tgtsfc cinfo) cinfobox+ >> doubleBufferFlush tgtsfc cinfo) cinfobox2 -- | toggleLayer :: CanvasId -> MainCoroutine ()
src/Hoodle/Widget/PanZoom.hs view
@@ -3,7 +3,7 @@ -- Module : Hoodle.Widget.PanZoom -- Copyright : (c) 2013 Ian-Woo Kim ----- License : GPL-3+-- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com> -- Stability : experimental -- Portability : GHC@@ -21,7 +21,6 @@ import Data.List (delete) import Data.Time.Clock import Graphics.Rendering.Cairo -import Graphics.UI.Gtk hiding (get,set) import System.Process -- from hoodle-platform import Data.Hoodle.BBox@@ -30,7 +29,6 @@ -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Draw-import Hoodle.Coroutine.File import Hoodle.Coroutine.Page import Hoodle.Coroutine.Pen import Hoodle.Coroutine.Scroll@@ -53,11 +51,10 @@ deriving (Show,Eq,Ord) -checkPointerInPanZoom :: (ViewMode a) => - (CanvasId,CanvasInfo a,CanvasGeometry) +checkPointerInPanZoom :: (CanvasId,CanvasInfo a,CanvasGeometry) -> PointerCoord -> Maybe (Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate)))-checkPointerInPanZoom (cid,cinfo,geometry) pcoord +checkPointerInPanZoom (_cid,cinfo,geometry) pcoord | b = let oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo@@ -80,8 +77,7 @@ -- | -startPanZoomWidget :: (ViewMode a) =>- PanZoomTouch +startPanZoomWidget :: PanZoomTouch -> (CanvasId,CanvasInfo a,CanvasGeometry) -> Maybe (PanZoomMode,(CanvasCoordinate,CanvasCoordinate)) -> MainCoroutine ()@@ -112,20 +108,17 @@ findZoomXform :: Dimension -> ((Double,Double),(Double,Double),(Double,Double)) -> (Double,(Double,Double))-findZoomXform (Dim w h) ((xo,yo),(x0,y0),(x,y)) = +findZoomXform (Dim w h) ((xo,yo),(x0,_y0),(x,_y)) = let tx = x - x0 - ty = y - y0 + -- ty = y - y0 ztx = 1 + tx / 200- zty = 1 + ty / 200+ -- zty = 1 + ty / 200 zx | ztx > 2 = 2 | ztx < 0.5 = 0.5 | otherwise = ztx- zy | zty > 2 = 2 - | zty < 0.5 = 0.5- | otherwise = zty - {- z | zx >= 1 && zy >= 1 = max zx zy- | zx < 1 && zy < 1 = min zx zy - | otherwise = zx -}+ -- zy | zty > 2 = 2 + -- | zty < 0.5 = 0.5+ -- | otherwise = zty -- simplified z = zx xtrans = (1 -z)*xo/z-w@@ -226,16 +219,16 @@ | yw+y-y0 > ch-50 = ch-50 | otherwise = yw+y-y0 nwpos = CvsCoord (nposx,nposy) - changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a + changeact :: CanvasInfo a -> CanvasInfo a changeact cinfo = set (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) nwpos $ cinfo- ncinfobox = selectBox changeact changeact cinfobox+ ncinfobox = (runIdentity . forBoth unboxBiXform (return.changeact)) cinfobox isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox put (setCanvasInfo (cid,ncinfobox) xst) virtualDoubleBufferDraw srcsfc tgtsfc (return ()) (renderPanZoomWidget isTouchZoom Nothing nwpos) Zooming -> do let cinfobox = getCanvasInfo cid xst - let pos = runIdentity (boxAction (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox)+ let pos = runIdentity (forBoth' unboxBiAct (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox) let (xo,yo) = (xw+50,yw+50) CanvasDimension cdim = canvasDim geometry (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))@@ -257,7 +250,7 @@ nwpos = if b then CvsCoord (nposx,nposy) else - runIdentity (boxAction (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox)+ runIdentity (forBoth' unboxBiAct (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox) ncinfobox = set (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) nwpos cinfobox isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox put (setCanvasInfo (cid,ncinfobox) xst)@@ -267,7 +260,7 @@ -- xst2 <- get let cinfobox = getCanvasInfo cid xst2 - liftIO $ boxAction (doubleBufferFlush tgtsfc) cinfobox+ liftIO $ forBoth' unboxBiAct (doubleBufferFlush tgtsfc) cinfobox -- | @@ -282,9 +275,9 @@ -- | touchStart :: CanvasId -> PointerCoord -> MainCoroutine () -touchStart cid pcoord = boxAction chk =<< liftM (getCanvasInfo cid) get+touchStart cid pcoord = forBoth' unboxBiAct chk =<< liftM (getCanvasInfo cid) get where- chk :: (ViewMode a) => CanvasInfo a -> MainCoroutine () + chk :: CanvasInfo a -> MainCoroutine () chk cinfo = do let cvs = view drawArea cinfo pnum = (PageNum . view currentPageNum) cinfo @@ -292,15 +285,15 @@ geometry <- liftIO $ makeCanvasGeometry pnum arr cvs let triplet = (cid,cinfo,geometry) oxy@(CvsCoord (x,y)) = (desktop2Canvas geometry . device2Desktop geometry) pcoord- owxy@(CvsCoord (x0,y0)) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo + CvsCoord (x0,y0) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo obbox = BBox (x0,y0) (x0+100,y0+100) xst <- get if (isPointInBBox obbox (x,y)) then do - let changeact :: (ViewMode a) => CanvasInfo a -> CanvasInfo a + let changeact :: CanvasInfo a -> CanvasInfo a changeact = over (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) not - ncinfobox = selectBox changeact changeact . getCanvasInfo cid $ xst+ ncinfobox = runIdentity . forBoth unboxBiXform (return . changeact) . getCanvasInfo cid $ xst put (setCanvasInfo (cid,ncinfobox) xst) invalidateInBBox Nothing Efficient cid else do @@ -336,7 +329,7 @@ liftIO $ readProcess "xinput" [ "enable", dev_touch_str devlst ] "" return () --- let (cid,cinfobox) = view currentCanvas xst + let (cid,_cinfobox) = view currentCanvas xst put (set (currentCanvasInfo. unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) True xst) invalidateInBBox Nothing Efficient cid return ()