diff --git a/hoodle-core.cabal b/hoodle-core.cabal --- a/hoodle-core.cabal +++ b/hoodle-core.cabal @@ -1,5 +1,5 @@ Name: hoodle-core -Version: 0.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 diff --git a/resource/latex-tool.png b/resource/latex-tool.png new file mode 100644 Binary files /dev/null and b/resource/latex-tool.png differ diff --git a/resource/menu.xml b/resource/menu.xml --- a/resource/menu.xml +++ b/resource/menu.xml @@ -16,6 +16,7 @@ + @@ -151,8 +152,10 @@ + + @@ -207,7 +210,8 @@ - + + diff --git a/src/Hoodle/Accessor.hs b/src/Hoodle/Accessor.hs --- a/src/Hoodle/Accessor.hs +++ b/src/Hoodle/Accessor.hs @@ -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 diff --git a/src/Hoodle/Coroutine/ContextMenu.hs b/src/Hoodle/Coroutine/ContextMenu.hs --- a/src/Hoodle/Coroutine/ContextMenu.hs +++ b/src/Hoodle/Coroutine/ContextMenu.hs @@ -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) diff --git a/src/Hoodle/Coroutine/Default.hs b/src/Hoodle/Coroutine/Default.hs --- a/src/Hoodle/Coroutine/Default.hs +++ b/src/Hoodle/Coroutine/Default.hs @@ -1,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 diff --git a/src/Hoodle/Coroutine/Dialog.hs b/src/Hoodle/Coroutine/Dialog.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Dialog.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Dialog +-- Copyright : (c) 2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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)) diff --git a/src/Hoodle/Coroutine/Draw.hs b/src/Hoodle/Coroutine/Draw.hs --- a/src/Hoodle/Coroutine/Draw.hs +++ b/src/Hoodle/Coroutine/Draw.hs @@ -1,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 diff --git a/src/Hoodle/Coroutine/Eraser.hs b/src/Hoodle/Coroutine/Eraser.hs --- a/src/Hoodle/Coroutine/Eraser.hs +++ b/src/Hoodle/Coroutine/Eraser.hs @@ -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 diff --git a/src/Hoodle/Coroutine/File.hs b/src/Hoodle/Coroutine/File.hs --- a/src/Hoodle/Coroutine/File.hs +++ b/src/Hoodle/Coroutine/File.hs @@ -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) diff --git a/src/Hoodle/Coroutine/Layer.hs b/src/Hoodle/Coroutine/Layer.hs --- a/src/Hoodle/Coroutine/Layer.hs +++ b/src/Hoodle/Coroutine/Layer.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Link.hs b/src/Hoodle/Coroutine/Link.hs --- a/src/Hoodle/Coroutine/Link.hs +++ b/src/Hoodle/Coroutine/Link.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Minibuffer.hs b/src/Hoodle/Coroutine/Minibuffer.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Minibuffer.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.Minibuffer +-- Copyright : (c) 2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + diff --git a/src/Hoodle/Coroutine/Mode.hs b/src/Hoodle/Coroutine/Mode.hs --- a/src/Hoodle/Coroutine/Mode.hs +++ b/src/Hoodle/Coroutine/Mode.hs @@ -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) ------------------------------------- diff --git a/src/Hoodle/Coroutine/Network.hs b/src/Hoodle/Coroutine/Network.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Network.hs @@ -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 +-- 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 + diff --git a/src/Hoodle/Coroutine/Page.hs b/src/Hoodle/Coroutine/Page.hs --- a/src/Hoodle/Coroutine/Page.hs +++ b/src/Hoodle/Coroutine/Page.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Pen.hs b/src/Hoodle/Coroutine/Pen.hs --- a/src/Hoodle/Coroutine/Pen.hs +++ b/src/Hoodle/Coroutine/Pen.hs @@ -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) => diff --git a/src/Hoodle/Coroutine/Scroll.hs b/src/Hoodle/Coroutine/Scroll.hs --- a/src/Hoodle/Coroutine/Scroll.hs +++ b/src/Hoodle/Coroutine/Scroll.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Select.hs b/src/Hoodle/Coroutine/Select.hs --- a/src/Hoodle/Coroutine/Select.hs +++ b/src/Hoodle/Coroutine/Select.hs @@ -1,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] diff --git a/src/Hoodle/Coroutine/Select/Clipboard.hs b/src/Hoodle/Coroutine/Select/Clipboard.hs --- a/src/Hoodle/Coroutine/Select/Clipboard.hs +++ b/src/Hoodle/Coroutine/Select/Clipboard.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Select/ManipulateImage.hs b/src/Hoodle/Coroutine/Select/ManipulateImage.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/Select/ManipulateImage.hs @@ -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 +-- 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)) + diff --git a/src/Hoodle/Coroutine/TextInput.hs b/src/Hoodle/Coroutine/TextInput.hs --- a/src/Hoodle/Coroutine/TextInput.hs +++ b/src/Hoodle/Coroutine/TextInput.hs @@ -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 ()) diff --git a/src/Hoodle/Coroutine/VerticalSpace.hs b/src/Hoodle/Coroutine/VerticalSpace.hs --- a/src/Hoodle/Coroutine/VerticalSpace.hs +++ b/src/Hoodle/Coroutine/VerticalSpace.hs @@ -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 ------------------------------------------------------------- diff --git a/src/Hoodle/Coroutine/Window.hs b/src/Hoodle/Coroutine/Window.hs --- a/src/Hoodle/Coroutine/Window.hs +++ b/src/Hoodle/Coroutine/Window.hs @@ -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 diff --git a/src/Hoodle/Device.hsc b/src/Hoodle/Device.hsc --- a/src/Hoodle/Device.hsc +++ b/src/Hoodle/Device.hsc @@ -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 diff --git a/src/Hoodle/GUI.hs b/src/Hoodle/GUI.hs --- a/src/Hoodle/GUI.hs +++ b/src/Hoodle/GUI.hs @@ -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 diff --git a/src/Hoodle/GUI/Menu.hs b/src/Hoodle/GUI/Menu.hs --- a/src/Hoodle/GUI/Menu.hs +++ b/src/Hoodle/GUI/Menu.hs @@ -5,7 +5,7 @@ -- Module : Hoodle.GUI.Menu -- Copyright : (c) 2011-2013 Ian-Woo Kim -- --- License : GPL-3 +-- License : BSD3 -- Maintainer : Ian-Woo Kim -- 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 diff --git a/src/Hoodle/GUI/Reflect.hs b/src/Hoodle/GUI/Reflect.hs --- a/src/Hoodle/GUI/Reflect.hs +++ b/src/Hoodle/GUI/Reflect.hs @@ -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 $ diff --git a/src/Hoodle/ModelAction/ContextMenu.hs b/src/Hoodle/ModelAction/ContextMenu.hs --- a/src/Hoodle/ModelAction/ContextMenu.hs +++ b/src/Hoodle/ModelAction/ContextMenu.hs @@ -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 diff --git a/src/Hoodle/ModelAction/File.hs b/src/Hoodle/ModelAction/File.hs --- a/src/Hoodle/ModelAction/File.hs +++ b/src/Hoodle/ModelAction/File.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Page.hs b/src/Hoodle/ModelAction/Page.hs --- a/src/Hoodle/ModelAction/Page.hs +++ b/src/Hoodle/ModelAction/Page.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Select.hs b/src/Hoodle/ModelAction/Select.hs --- a/src/Hoodle/ModelAction/Select.hs +++ b/src/Hoodle/ModelAction/Select.hs @@ -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) diff --git a/src/Hoodle/ModelAction/Select/Transform.hs b/src/Hoodle/ModelAction/Select/Transform.hs --- a/src/Hoodle/ModelAction/Select/Transform.hs +++ b/src/Hoodle/ModelAction/Select/Transform.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Window.hs b/src/Hoodle/ModelAction/Window.hs --- a/src/Hoodle/ModelAction/Window.hs +++ b/src/Hoodle/ModelAction/Window.hs @@ -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 -} diff --git a/src/Hoodle/Script/Hook.hs b/src/Hoodle/Script/Hook.hs --- a/src/Hoodle/Script/Hook.hs +++ b/src/Hoodle/Script/Hook.hs @@ -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 } diff --git a/src/Hoodle/Type/Canvas.hs b/src/Hoodle/Type/Canvas.hs --- a/src/Hoodle/Type/Canvas.hs +++ b/src/Hoodle/Type/Canvas.hs @@ -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 diff --git a/src/Hoodle/Type/Coroutine.hs b/src/Hoodle/Type/Coroutine.hs --- a/src/Hoodle/Type/Coroutine.hs +++ b/src/Hoodle/Type/Coroutine.hs @@ -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 -- | diff --git a/src/Hoodle/Type/Enum.hs b/src/Hoodle/Type/Enum.hs --- a/src/Hoodle/Type/Enum.hs +++ b/src/Hoodle/Type/Enum.hs @@ -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 }) diff --git a/src/Hoodle/Type/Event.hs b/src/Hoodle/Type/Event.hs --- a/src/Hoodle/Type/Event.hs +++ b/src/Hoodle/Type/Event.hs @@ -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 -- 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 diff --git a/src/Hoodle/Type/HoodleState.hs b/src/Hoodle/Type/HoodleState.hs --- a/src/Hoodle/Type/HoodleState.hs +++ b/src/Hoodle/Type/HoodleState.hs @@ -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 diff --git a/src/Hoodle/Type/PageArrangement.hs b/src/Hoodle/Type/PageArrangement.hs --- a/src/Hoodle/Type/PageArrangement.hs +++ b/src/Hoodle/Type/PageArrangement.hs @@ -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') ) -} -- | diff --git a/src/Hoodle/Type/Predefined.hs b/src/Hoodle/Type/Predefined.hs --- a/src/Hoodle/Type/Predefined.hs +++ b/src/Hoodle/Type/Predefined.hs @@ -15,7 +15,7 @@ import Data.Time.Clock -- | - +millisec :: Integer millisec = 1000000000 dtime_bound :: NominalDiffTime diff --git a/src/Hoodle/Type/Widget.hs b/src/Hoodle/Type/Widget.hs --- a/src/Hoodle/Type/Widget.hs +++ b/src/Hoodle/Type/Widget.hs @@ -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 } diff --git a/src/Hoodle/Util.hs b/src/Hoodle/Util.hs --- a/src/Hoodle/Util.hs +++ b/src/Hoodle/Util.hs @@ -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 diff --git a/src/Hoodle/View/Coordinate.hs b/src/Hoodle/View/Coordinate.hs --- a/src/Hoodle/View/Coordinate.hs +++ b/src/Hoodle/View/Coordinate.hs @@ -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 diff --git a/src/Hoodle/View/Draw.hs b/src/Hoodle/View/Draw.hs --- a/src/Hoodle/View/Draw.hs +++ b/src/Hoodle/View/Draw.hs @@ -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 diff --git a/src/Hoodle/Widget/Clock.hs b/src/Hoodle/Widget/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Widget/Clock.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Widget.Clock +-- Copyright : (c) 2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + diff --git a/src/Hoodle/Widget/Dispatch.hs b/src/Hoodle/Widget/Dispatch.hs --- a/src/Hoodle/Widget/Dispatch.hs +++ b/src/Hoodle/Widget/Dispatch.hs @@ -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 diff --git a/src/Hoodle/Widget/Layer.hs b/src/Hoodle/Widget/Layer.hs --- a/src/Hoodle/Widget/Layer.hs +++ b/src/Hoodle/Widget/Layer.hs @@ -3,7 +3,7 @@ -- Module : Hoodle.Widget.Layer -- Copyright : (c) 2013 Ian-Woo Kim -- --- License : GPL-3 +-- License : BSD3 -- Maintainer : Ian-Woo Kim -- 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 () diff --git a/src/Hoodle/Widget/PanZoom.hs b/src/Hoodle/Widget/PanZoom.hs --- a/src/Hoodle/Widget/PanZoom.hs +++ b/src/Hoodle/Widget/PanZoom.hs @@ -3,7 +3,7 @@ -- Module : Hoodle.Widget.PanZoom -- Copyright : (c) 2013 Ian-Woo Kim -- --- License : GPL-3 +-- License : BSD3 -- Maintainer : Ian-Woo Kim -- 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 ()