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