hoodle-core 0.8.0 → 0.9
raw patch · 40 files changed
+1882/−741 lines, 40 filesdep +gddep +pangodep +processdep ~coroutine-objectdep ~hoodle-builderdep ~hoodle-parser
Dependencies added: gd, pango, process
Dependency ranges changed: coroutine-object, hoodle-builder, hoodle-parser, hoodle-render, hoodle-types, lens, poppler, xournal-parser
Files
- LICENSE +1/−1
- hoodle-core.cabal +18/−11
- resource/menu.xml +223/−0
- src/Hoodle/Accessor.hs +51/−10
- src/Hoodle/Coroutine/Callback.hs +7/−17
- src/Hoodle/Coroutine/ContextMenu.hs +205/−0
- src/Hoodle/Coroutine/Default.hs +136/−42
- src/Hoodle/Coroutine/Draw.hs +12/−11
- src/Hoodle/Coroutine/Eraser.hs +3/−3
- src/Hoodle/Coroutine/File.hs +243/−35
- src/Hoodle/Coroutine/Mode.hs +10/−14
- src/Hoodle/Coroutine/Page.hs +25/−12
- src/Hoodle/Coroutine/Pen.hs +10/−10
- src/Hoodle/Coroutine/Scroll.hs +48/−29
- src/Hoodle/Coroutine/Select.hs +21/−8
- src/Hoodle/Coroutine/TextInput.hs +146/−0
- src/Hoodle/Coroutine/Window.hs +22/−23
- src/Hoodle/Device.hsc +0/−2
- src/Hoodle/GUI.hs +9/−9
- src/Hoodle/GUI/Menu.hs +79/−257
- src/Hoodle/ModelAction/Adjustment.hs +5/−2
- src/Hoodle/ModelAction/File.hs +9/−5
- src/Hoodle/ModelAction/Layer.hs +1/−1
- src/Hoodle/ModelAction/Page.hs +19/−22
- src/Hoodle/ModelAction/Pen.hs +4/−3
- src/Hoodle/ModelAction/Select.hs +24/−5
- src/Hoodle/ModelAction/Window.hs +2/−6
- src/Hoodle/Script/Coroutine.hs +37/−7
- src/Hoodle/Script/Hook.hs +19/−1
- src/Hoodle/Type/Canvas.hs +97/−39
- src/Hoodle/Type/Clipboard.hs +5/−1
- src/Hoodle/Type/Coroutine.hs +35/−14
- src/Hoodle/Type/Enum.hs +28/−1
- src/Hoodle/Type/Event.hs +35/−3
- src/Hoodle/Type/HoodleState.hs +137/−5
- src/Hoodle/Type/PageArrangement.hs +10/−9
- src/Hoodle/Type/Predefined.hs +1/−1
- src/Hoodle/Util.hs +24/−5
- src/Hoodle/Util/Verbatim.hs +0/−26
- src/Hoodle/View/Draw.hs +121/−91
LICENSE view
@@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011, 2012, Ian-Woo Kim. All rights reserved.+Copyright 2011-2013, Ian-Woo Kim. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
hoodle-core.cabal view
@@ -1,5 +1,5 @@ Name: hoodle-core-Version: 0.8.0+Version: 0.9 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 @@ -15,6 +15,7 @@ Cabal-Version: >= 1.8 data-files: template/*.html.st resource/*.png+ resource/*.xml CHANGES Config.hs Source-repository head@@ -28,7 +29,7 @@ Library hs-source-dirs: src- ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans ghc-prof-options: -caf-all -auto-all Build-Depends: base == 4.*, @@ -38,21 +39,25 @@ strict == 0.3.*, gtk == 0.12.*, cairo == 0.12.*,+ pango == 0.12.*,+ gd >= 3000.7, attoparsec == 0.10.*,- coroutine-object >= 0.1, + coroutine-object >= 0.2, transformers == 0.3.*, transformers-free == 1.0.*,- hoodle-types >= 0.1.0,- hoodle-parser >= 0.1.0,- xournal-parser >= 0.5.0,- hoodle-render >= 0.2.0,- hoodle-builder >= 0.1.0,+ hoodle-types >= 0.1.1,+ hoodle-parser >= 0.1.1,+ xournal-parser >= 0.5.0.1,+ hoodle-render >= 0.2.1,+ hoodle-builder >= 0.1.1, containers >= 0.4, template-haskell == 2.*, bytestring >= 0.9, + base64-bytestring >= 0.1, either >= 3, errors >= 1.3, - lens >= 2.4,+ lens >= 2.5,+ process >= 1.1, configurator == 0.2.*, time >= 1.2, TypeCompose == 0.9.*, @@ -62,7 +67,7 @@ base64-bytestring >= 0.1, old-locale >= 1.0 if flag(poppler) - Build-Depends: poppler >= 0.12.2.1 + Build-Depends: poppler >= 0.12.2.2 else Build-Depends: @@ -72,6 +77,7 @@ Hoodle.Coroutine Hoodle.Coroutine.Callback Hoodle.Coroutine.Commit+ Hoodle.Coroutine.ContextMenu Hoodle.Coroutine.Default Hoodle.Coroutine.Draw Hoodle.Coroutine.Eraser@@ -85,6 +91,7 @@ Hoodle.Coroutine.Scroll Hoodle.Coroutine.Select Hoodle.Coroutine.Select.Clipboard+ Hoodle.Coroutine.TextInput Hoodle.Coroutine.Window Hoodle.Device Hoodle.GUI@@ -114,7 +121,7 @@ Hoodle.Type.Window Hoodle.Type.HoodleState Hoodle.Util- Hoodle.Util.Verbatim + -- Hoodle.Util.Verbatim Hoodle.View.Coordinate Hoodle.View.Draw Other-Modules:
@@ -0,0 +1,223 @@+<ui> + <menubar>+ <menu action="FMA">+ <menuitem action="NEWA" />+ <menuitem action="OPENA" /> + <menuitem action="SAVEA" /> + <menuitem action="SAVEASA" /> + <menuitem action="RELOADA" />+ <separator /> + <menuitem action="RECENTA" /> + <separator /> + <menuitem action="ANNPDFA" />+ <menuitem action="LDIMGA" />+ <menuitem action="LDSVGA" />+ <menuitem action="LDPREIMGA" /> + <menuitem action="LATEXA" />+ <separator /> + <menuitem action="PRINTA" /> + <menuitem action="EXPORTA" />+ <separator /> + <menuitem action="QUITA" />+ </menu>+ <menu action="EMA">+ <menuitem action="UNDOA" />+ <menuitem action="REDOA" /> + <separator />+ <menuitem action="CUTA" /> + <menuitem action="COPYA" /> + <menuitem action="PASTEA" /> + <menuitem action="DELETEA" />+ <!-- <separator />+ <menuitem action="NETCOPYA" />+ <menuitem action="NETPASTEA" /> --> + </menu>+ <menu action="VMA">+ <menuitem action="CONTA" />+ <menuitem action="ONEPAGEA" />+ <separator />+ <menuitem action="FSCRA" />+ <separator />+ <menu action="ZOOMA" >+ <menuitem action="ZMINA" />+ <menuitem action="ZMOUTA" /> + <menuitem action="NRMSIZEA" /> + <menuitem action="PGWDTHA" /> + <menuitem action="PGHEIGHTA" />+ <menuitem action="SETZMA" /> + </menu>+ <separator />+ <menuitem action="FSTPAGEA" />+ <menuitem action="PRVPAGEA" />+ <menuitem action="NXTPAGEA" />+ <menuitem action="LSTPAGEA" />+ <separator />+ <menuitem action="SHWLAYERA" />+ <menuitem action="HIDLAYERA" />+ <separator />+ <menuitem action="HSPLITA" />+ <menuitem action="VSPLITA" />+ <menuitem action="DELCVSA" />+ </menu>+ <menu action="JMA">+ <menuitem action="NEWPGBA" />+ <menuitem action="NEWPGAA" />+ <menuitem action="NEWPGEA" />+ <menuitem action="DELPGA" /> + <separator />+ <menuitem action="EXPSVGA" /> + <separator /> + <menuitem action="NEWLYRA" />+ <menuitem action="NEXTLAYERA" />+ <menuitem action="PREVLAYERA" />+ <menuitem action="GOTOLAYERA" />+ <menuitem action="DELLYRA" /> + <separator />+ <menuitem action="PPSIZEA" />+ <menuitem action="PPCLRA" />+ <menu action="PPSTYA">+ <menuitem action="BKGPLAINA" />+ <menuitem action="BKGLINEDA" />+ <menuitem action="BKGRULEDA" />+ <menuitem action="BKGGRAPHA" />+ </menu>+ <menuitem action="APALLPGA" />+ <separator />+ <menuitem action="LDBKGA" />+ <menuitem action="BKGSCRSHTA" />+ <separator />+ <menuitem action="DEFPPA" /> + <menuitem action="SETDEFPPA" /> + </menu>+ <menu action="TMA">+ <menuitem action="PENA" />+ <menuitem action="ERASERA" />+ <menuitem action="HIGHLTA" />+ <separator />+ <menuitem action="TEXTA" /> + <menuitem action="SHPRECA" />+ <menuitem action="RULERA" /> + <separator />+ <menuitem action="SELREGNA" />+ <menuitem action="SELRECTA" />+ <menuitem action="VERTSPA" />+ <menuitem action="HANDA" />+ <separator />+ <menu action="CLRA"> + <menuitem action="BLACKA" /> + <menuitem action="BLUEA" /> + <menuitem action="REDA" /> + <menuitem action="GREENA" /> + <menuitem action="GRAYA" /> + <menuitem action="LIGHTBLUEA" /> + <menuitem action="LIGHTGREENA" /> + <menuitem action="MAGENTAA" />+ <menuitem action="ORANGEA" />+ <menuitem action="YELLOWA" />+ <menuitem action="WHITEA" />+ </menu>+ <menuitem action="CLRPCKA" /> + <menu action="PENOPTA"> + <menuitem action="PENVERYFINEA" /> + <menuitem action="PENFINEA" /> + <menuitem action="PENMEDIUMA" /> + <menuitem action="PENTHICKA" /> + <menuitem action="PENVERYTHICKA" /> + <menuitem action="PENULTRATHICKA" /> + </menu>+ <menuitem action="ERASROPTA" /> + <menuitem action="HILTROPTA" /> + <menuitem action="TXTFNTA" /> + <separator />+ <menuitem action="DEFPENA" /> + <menuitem action="DEFERSRA" /> + <menuitem action="DEFHILTRA" /> + <menuitem action="DEFTXTA" />+ <menuitem action="SETDEFOPTA" /> + </menu>+ <menu action="OMA">+ <menuitem action="UXINPUTA" />+ <menuitem action="SMTHSCRA" />+ <menuitem action="POPMENUA" /> + <menuitem action="EBDIMGA" />+ <menuitem action="DCRDCOREA" /> + <menuitem action="ERSRTIPA" /> + <menuitem action="PRESSRSENSA" /> + <menuitem action="PGHILTA" /> + <menuitem action="MLTPGVWA" /> + <menuitem action="MLTPGA" /> + <menuitem action="BTN2MAPA" /> + <menuitem action="BTN3MAPA" /> + <separator />+ <menuitem action="ANTIALIASBMPA" /> + <menuitem action="PRGRSBKGA" /> + <menuitem action="PRNTPPRULEA" /> + <menuitem action="LFTHNDSCRBRA" /> + <menuitem action="SHRTNMENUA" /> + <separator />+ <menuitem action="AUTOSAVEPREFA" /> + <menuitem action="SAVEPREFA" />+ <menuitem action="RELAUNCHA" />+ </menu>+ <menu action="HMA">+ <menuitem action="ABOUTA" />+ </menu>+ </menubar>+ <toolbar name="toolbar1" > + <toolitem action="SAVEA" />+ <toolitem action="NEWA" />+ <toolitem action="OPENA" />+ <separator />+ <toolitem action="CUTA" />+ <toolitem action="COPYA" />+ <toolitem action="PASTEA" />+ <separator /> + <toolitem action="UNDOA" /> + <toolitem action="REDOA" /> + <separator /> + <toolitem action="FSTPAGEA" />+ <toolitem action="PRVPAGEA" />+ <toolitem action="NXTPAGEA" />+ <toolitem action="LSTPAGEA" />+ <separator />+ <toolitem action="ZMOUTA" /> + <toolitem action="NRMSIZEA" /> + <toolitem action="ZMINA" />+ <toolitem action="PGWDTHA" /> + <toolitem action="SETZMA" />+ <toolitem action="FSCRA" />+ </toolbar>+ <toolbar name="toolbar2" > + <toolitem action="PENA" />+ <toolitem action="ERASERA" /> + <toolitem action="HIGHLTA" /> + <separator /> + <toolitem action="TEXTA" /> + <!-- <toolitem action="DEFAULTA" /> --> + <!-- <toolitem action="DEFPENA" /> --> + <!-- <toolitem action="SHPRECA" /> --> + <!-- <toolitem action="RULERA" /> --> + <!-- <separator /> -->+ <toolitem action="SELREGNA" /> + <toolitem action="SELRECTA" /> + <toolitem action="VERTSPA" /> + <toolitem action="HANDA" /> + <separator /> + <toolitem action="PENFINEA" /> + <toolitem action="PENMEDIUMA" /> + <toolitem action="PENTHICKA" /> + <separator />+ <toolitem action="CLRPCKA" />+ <toolitem action="BLACKA" /> + <toolitem action="BLUEA" /> + <toolitem action="REDA" /> + <toolitem action="GREENA" /> + <toolitem action="GRAYA" /> + <toolitem action="LIGHTBLUEA" /> + <toolitem action="LIGHTGREENA" /> + <toolitem action="MAGENTAA" /> + <toolitem action="ORANGEA" /> + <toolitem action="YELLOWA" /> + <toolitem action="WHITEA" /> + </toolbar>+</ui>
src/Hoodle/Accessor.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, Rank2Types #-} ----------------------------------------------------------------------------- -- |@@ -17,8 +17,8 @@ import Control.Applicative import Control.Category import Control.Lens-import Control.Monad hiding (mapM_)-import qualified Control.Monad.State as St hiding (mapM_)+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@@ -37,6 +37,11 @@ -- import Prelude hiding ((.),id,mapM_) +-- | +waitSomeEvent :: (MyEvent -> Bool) -> MainCoroutine MyEvent +waitSomeEvent p = do r <- nextevent+ if p r then return r else waitSomeEvent p + -- | update state updateXState :: (HoodleState -> MainCoroutine HoodleState) -> MainCoroutine () updateXState action = St.put =<< action =<< St.get @@ -53,10 +58,6 @@ cinfobox = view currentCanvasInfo xstate return $ fmap4CvsInfoBox (\x->getCurrentPageFromHoodleModeState x hdlmodst) cinfobox - -{- case cinfobox of - CanvasInfoBox cinfo -> -}- -- | getCurrentPageCvsId :: CanvasId -> MainCoroutine (Page EditMode) getCurrentPageCvsId cid = do @@ -65,9 +66,6 @@ cinfobox = getCanvasInfo cid xstate return $ fmap4CvsInfoBox (\c->getCurrentPageFromHoodleModeState c hdlmodst) cinfobox - -{- case cinfobox of - CanvasInfoBox cinfo -> return -} -- | getCurrentPageEitherFromHoodleModeState :: @@ -111,6 +109,14 @@ reflectUI ui cinfo return xst +-- | apply an action to all canvases +applyActionToAllCVS :: (CanvasId -> MainCoroutine ()) -> MainCoroutine () +applyActionToAllCVS action = do + xstate <- St.get + let cinfoMap = getCanvasInfoMap xstate+ keys = M.keys cinfoMap + forM_ keys action+ -- | reflect UI for current canvas info reflectUI :: UIManager -> CanvasInfoBox -> MainCoroutine () reflectUI ui cinfobox = do @@ -198,6 +204,41 @@ . view (viewInfo.pageArrangement) boxAction fsingle cinfobox +-- | update flag in HoodleState when corresponding toggle UI changed +updateFlagFromToggleUI :: String -- ^ UI toggle button id+ -> Simple Lens HoodleState Bool -- ^ lens for flag + -> MainCoroutine Bool+updateFlagFromToggleUI toggleid lensforflag = do + xstate <- St.get + let ui = view gtkUIManager xstate + agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->+ case x of + [] -> error "No action group? "+ y:_ -> return y )+ togglea <- liftIO (actionGroupGetAction agr toggleid) + >>= maybe (error "updateFlagFromToggleUI") + (return . castToToggleAction)+ b <- liftIO $ toggleActionGetActive togglea+ St.modify (set lensforflag b) + return b ++-- | set toggle UI button to the corresponding HoodleState +setToggleUIForFlag :: String + -> Simple Lens HoodleState Bool -- ^ lens for flag+ -> HoodleState + -> IO Bool +setToggleUIForFlag toggleid lensforflag xstate = do + let ui = view gtkUIManager xstate + b = view lensforflag xstate + agr <- uiManagerGetActionGroups ui >>= \x ->+ case x of + [] -> error "No action group? "+ y:_ -> return y + togglea <- actionGroupGetAction agr toggleid >>= \(Just x) -> + return (castToToggleAction x) + toggleActionSetActive togglea b+ return b + {- -- | getAllStrokeBBoxInCurrentPage :: MainCoroutine [StrokeBBox]
src/Hoodle/Coroutine/Callback.hs view
@@ -14,17 +14,19 @@ import Control.Concurrent import Control.Exception-import Data.Time-import System.Directory-import System.Environment-import System.FilePath-import System.Locale+-- import Data.Time+-- import System.Directory+-- import System.Environment+-- import System.FilePath+-- import System.Locale import System.IO import System.Exit -- import Control.Monad.Trans.Crtn.Driver import qualified Control.Monad.Trans.Crtn.EventHandler as E -- +import Hoodle.Util+-- import Prelude hiding (catch) eventHandler :: MVar (Maybe (Driver e IO ())) -> e -> IO ()@@ -43,15 +45,3 @@ patternerr :: PatternMatchFail -> IO () patternerr e = errorlog (show e) -errorlog :: String -> IO ()-errorlog str = do - homepath <- getEnv "HOME"- let dir = homepath </> ".hoodle.d"- createDirectoryIfMissing False dir- outh <- openFile (dir </> "error.log") AppendMode - utctime <- getCurrentTime - let timestr = formatTime defaultTimeLocale "%F %H:%M:%S %Z" utctime- hPutStr outh (timestr ++ " : " ) - hPutStrLn outh str- hClose outh -
+ src/Hoodle/Coroutine/ContextMenu.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.ContextMenu+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.ContextMenu where++-- from other packages+import Control.Applicative+import Control.Category+import Control.Lens+-- import Control.Monad.Trans.Maybe +import Control.Monad.State+-- import Data.ByteString.Char8 as B (pack)+-- import qualified Data.ByteString.Lazy as L+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.FilePath+-- 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.Select+import Graphics.Hoodle.Render+-- import Graphics.Hoodle.Render.Generic+-- import Graphics.Hoodle.Render.Item+import Graphics.Hoodle.Render.Type+-- import Graphics.Hoodle.Render.Type.HitTest +-- import Text.Hoodle.Builder +-- from this package +import Hoodle.Accessor+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.Script.Hook+-- import Hoodle.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.Event+import Hoodle.Type.HoodleState+import Hoodle.Type.PageArrangement +--+import Prelude hiding ((.),id)++processContextMenu :: ContextMenuEvent -> MainCoroutine () +processContextMenu (CMenuSaveSelectionAs ityp) = do + xstate <- get+ case view hoodleModeState xstate of + SelectState thdl -> do + liftIO $ putStrLn "SelectState"+ case view gselSelected thdl of + Nothing -> return () + Just (_,tpg) -> do + let hititms = getSelectedItms tpg + ulbbox = unUnion . mconcat . fmap (Union . Middle . getBBox) + $ hititms + case ulbbox of + Middle bbox -> + case ityp of + SVG -> exportCurrentSelectionAsSVG hititms bbox+ PDF -> exportCurrentSelectionAsPDF hititms bbox+ _ -> return () + _ -> return () +processContextMenu CMenuCut = cutSelection+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 + case mcinfobox of + Nothing -> liftIO $ putStrLn "error in processContextMenu"+ Just _cinfobox -> do + cinfobox' <- liftIO (setPage xstate pnum cid)+ put $ set cvsInfoMap (IM.adjust (const cinfobox') cid cmap) xstate + adjustScrollbarWithGeometryCvsId cid + invalidateAll +processContextMenu CMenuCustom = 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 () + +++ ++exportCurrentSelectionAsSVG :: [RItem] -> BBox -> MainCoroutine () +exportCurrentSelectionAsSVG hititms bbox@(BBox (ulx,uly) (lrx,lry)) = + fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action + where + action filename =+ -- this is rather temporary not to make mistake + if takeExtension filename /= ".svg" + 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+++exportCurrentSelectionAsPDF :: [RItem] -> BBox -> MainCoroutine () +exportCurrentSelectionAsPDF hititms bbox@(BBox (ulx,uly) (lrx,lry)) = + fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action + where + action filename =+ -- this is rather temporary not to make mistake + if takeExtension filename /= ".pdf" + 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+++showContextMenu :: (PageNum,(Double,Double)) -> MainCoroutine () +showContextMenu (pnum,(x,y)) = do + xstate <- get+ when (view 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) + >> return () + where action xstate msitms cid cids + = Left . ActionOrder $ + \evhandler -> do + menu <- menuNew + menuSetTitle menu "MyMenu"+ case msitms of + Nothing -> return ()+ Just _ -> 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 $ + evhandler (GotContextMenuSignal (CMenuSaveSelectionAs PDF))+ menuitem3 `on` menuItemActivate $ + evhandler (GotContextMenuSignal (CMenuCut)) + menuitem4 `on` menuItemActivate $ + 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 menuitem3 1 2 0 1 + menuAttach menu menuitem4 1 2 1 2 + menuAttach menu menuitem5 1 2 2 3 + 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 + runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0 + widgetShowAll menu + menuPopup menu Nothing + return ContextMenuCreated ++ makeMenu evhdlr mn currcid cid + = when (currcid /= cid) $ do + n <- get+ mi <- liftIO $ menuItemNewWithLabel ("Show here in cvs" ++ show cid)+ liftIO $ mi `on` menuItemActivate $ + evhdlr (GotContextMenuSignal (CMenuCanvasView cid pnum x y)) + liftIO $ menuAttach mn mi 2 3 n (n+1) + put (n+1) +
src/Hoodle/Coroutine/Default.hs view
@@ -21,21 +21,26 @@ import Control.Monad.Reader import Control.Monad.State import qualified Data.IntMap as M+-- import Data.IntMap.Lens 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(..))+import Data.Hoodle.Simple (Dimension(..), bkg_style) import Data.Hoodle.Generic+import Graphics.Hoodle.Render.Type.Background -- from this package import Hoodle.Accessor import Hoodle.Coroutine.Callback import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.ContextMenu import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Eraser import Hoodle.Coroutine.File@@ -46,11 +51,14 @@ import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.Select import Hoodle.Coroutine.Select.Clipboard+import Hoodle.Coroutine.TextInput import Hoodle.Coroutine.Mode import Hoodle.Coroutine.Window import Hoodle.Device import Hoodle.GUI.Menu import Hoodle.ModelAction.File+import Hoodle.ModelAction.Layer +import Hoodle.ModelAction.Page import Hoodle.ModelAction.Window import Hoodle.Script import Hoodle.Script.Hook@@ -67,10 +75,14 @@ import Prelude hiding ((.), id) -- |-initCoroutine :: DeviceList -> Window -> Maybe FilePath -> Maybe Hook - -> Int -- ^ maxundo - -> IO (EventVar,HoodleState,UIManager,VBox)-initCoroutine devlst window mfname mhook maxundo = do +initCoroutine :: DeviceList + -> Window + -> Maybe FilePath + -> Maybe Hook + -> Int -- ^ maxundo + -> Bool -- ^ xinputbool + -> IO (EventVar,HoodleState,UIManager,VBox)+initCoroutine devlst window mfname mhook maxundo xinputbool = do evar <- newEmptyMVar putMVar evar Nothing let st0new = set deviceList devlst @@ -86,14 +98,22 @@ $ st1 { _cvsInfoMap = M.empty } (st3,cvs,_wconf) <- constructFrame st2 (view frameState st2) (st4,wconf') <- eventConnect st3 (view frameState st3)- let st5 = set hookSet mhook + let st5 = set doesUseXInput xinputbool + . set hookSet mhook . set undoTable (emptyUndo maxundo) . set frameState wconf' - . set rootWindow cvs $ st4+ . set rootWindow cvs + $ st4 st6 <- getFileContent mfname st5+ -- very dirty, need to be cleaned + let hdlst6 = view hoodleModeState st6+ hdlst7 <- resetHoodleModeStateBuffers hdlst6+ let st7 = set hoodleModeState hdlst7 st6+ -- vbox <- vBoxNew False 0 - let startingXstate = set rootContainer (castToBox vbox) st6+ -- + let startingXstate = set rootContainer (castToBox vbox) st7 let startworld = world startingXstate . ReaderT $ (\(Arg DoEvent ev) -> guiProcess ev) putMVar evar . Just $ (driver simplelogger startworld)@@ -128,7 +148,6 @@ _ -> do ev' <- nextevent initialize ev' - -- | guiProcess :: MyEvent -> MainCoroutine () guiProcess ev = do @@ -145,9 +164,6 @@ mapM_ f assocs sequence_ (repeat dispatchMode) --- -- | dispatchMode :: MainCoroutine () dispatchMode = get >>= return . hoodleModeStateEither . view hoodleModeState@@ -170,7 +186,7 @@ (PenWork,EraserButton) -> eraserStart cid pcoord (EraserWork,_) -> eraserStart cid pcoord (HighlighterWork,_) -> highlighterStart cid pcoord- _ -> return () + -- _ -> return () _ -> defaultEventProcess r1 -- |@@ -184,16 +200,18 @@ SelectRectangleWork -> selectRectStart cid pcoord SelectRegionWork -> selectLassoStart cid pcoord _ -> return ()- PenColorChanged c -> do - modify (penInfo.currentTool.penColor .~ c)- selectPenColorChanged c+ PenColorChanged c -> do modify (penInfo.currentTool.penColor .~ c)+ selectPenColorChanged c PenWidthChanged v -> do - st <- get + 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 + put stNew -} _ -> defaultEventProcess r1 @@ -203,7 +221,7 @@ defaultEventProcess (Menu m) = menuEventProcess m defaultEventProcess (HScrollBarMoved cid v) = hscrollBarMoved cid v defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v-defaultEventProcess (VScrollBarStart cid _v) = vscrollStart cid +defaultEventProcess (VScrollBarStart cid v) = vscrollStart cid v defaultEventProcess PaneMoveStart = paneMoveStart defaultEventProcess (CanvasConfigure cid w' h') = doCanvasConfigure cid (CanvasDimension (Dim w' h'))@@ -214,10 +232,19 @@ defaultEventProcess (AssignPenMode t) = case t of Left pm -> do - -- put . set (penInfo.penType) pm =<< get + -- 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) = @@ -228,6 +255,25 @@ let w = int2Point ptype v let stNew = set (penInfo.currentTool.penWidth) w st put stNew +defaultEventProcess (BackgroundStyleChanged bsty) = do+ modify (backgroundStyle .~ bsty)+ xstate <- get + let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ hdl = getHoodle xstate + pgs = view gpages hdl + (_,cpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)+ cbkg = view gbackground cpage+ nbkg + | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg + in bkg2RBkg bkg { bkg_style = convertBackgroundStyleToByteString bsty } + | otherwise = cbkg + npage = set gbackground nbkg cpage + npgs = set (at pgnum) (Just npage) pgs + nhdl = set gpages npgs hdl + modeChange ToViewAppendMode + modify (set hoodleModeState (ViewAppendState nhdl))+ invalidateAll +defaultEventProcess (GotContextMenuSignal ctxtmenu) = processContextMenu ctxtmenu defaultEventProcess ev = -- for debugging do liftIO $ putStrLn "--- no default ---" liftIO $ print ev @@ -253,9 +299,12 @@ menuEventProcess MenuNewPageBefore = newPage PageBefore menuEventProcess MenuNewPageAfter = newPage PageAfter menuEventProcess MenuDeletePage = deleteCurrentPage+menuEventProcess MenuExportPageSVG = exportCurrentPageAsSVG menuEventProcess MenuNew = askIfSave fileNew menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF-menuEventProcess MenuLoadImage = fileLoadImage+menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG+menuEventProcess MenuLoadSVG = fileLoadSVG+menuEventProcess MenuLaTeX = fileLaTeX menuEventProcess MenuUndo = undo menuEventProcess MenuRedo = redo menuEventProcess MenuOpen = askIfSave fileOpen@@ -282,34 +331,79 @@ menuEventProcess MenuDeleteLayer = deleteCurrentLayer menuEventProcess MenuUseXInput = do xstate <- get - let ui = view gtkUIManager xstate - agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->- case x of - [] -> error "No action group? "- y:_ -> return y )- uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA") - >>= maybe (error "MenuUseXInput") (return . castToToggleAction)- b <- liftIO $ toggleActionGetActive uxinputa+ b <- updateFlagFromToggleUI "UXINPUTA" 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 MenuPressureSensitivity = updateXState pressSensAction - where pressSensAction xstate = do - let ui = view gtkUIManager xstate - agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->- case x of - [] -> error "No action group? "- y:_ -> return y )- pressrsensa <- liftIO (actionGroupGetAction agr "PRESSRSENSA") - >>= maybe (error "MenuPressureSensitivity") - (return . castToToggleAction)- b <- liftIO $ toggleActionGetActive pressrsensa- return (set (penInfo.variableWidthPen) b xstate) +menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" doesSmoothScroll >> return ()+menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" doesUsePopUpMenu >> return ()+menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" doesEmbedImage >> return ()+menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return () menuEventProcess MenuRelaunch = liftIO $ relaunchApplication+menuEventProcess MenuColorPicker = colorPick +menuEventProcess MenuFullScreen = fullScreen+menuEventProcess MenuText = textInput +menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage +menuEventProcess MenuApplyToAllPages = do + xstate <- get + let bsty = view backgroundStyle xstate + let hdl = getHoodle xstate + pgs = view gpages hdl + changeBkg cpage = + let cbkg = view gbackground cpage+ nbkg + | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg + in bkg2RBkg bkg { bkg_style = convertBackgroundStyleToByteString bsty } + | otherwise = cbkg + in set gbackground nbkg cpage + npgs = fmap changeBkg pgs + nhdl = set gpages npgs hdl + modeChange ToViewAppendMode + modify (set hoodleModeState (ViewAppendState nhdl))+ invalidateAll menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m +-- | +colorPick :: MainCoroutine () +colorPick = do mc <- colorPickerBox "Pen Color" + liftIO $ print mc + maybe (return ()) + (\c->modify (penInfo.currentTool.penColor .~ c)) + mc +-- | +colorConvert :: Color -> PenColor +colorConvert (Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0 ++-- | +colorPickerBox :: String -> MainCoroutine (Maybe PenColor) +colorPickerBox msg = do + xst <- get + let pcolor = view ( penInfo.currentTool.penColor) xst + modify (tempQueue %~ enqueue (action pcolor)) >> go + where + action pcolor = + Left . ActionOrder $ + \_evhandler -> do + dialog <- colorSelectionDialogNew msg+ csel <- colorSelectionDialogGetColor dialog+ let (r,g,b,_a) = convertPenColorToRGBA pcolor + color = Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0))+ + colorSelectionSetCurrentColor csel color+ res <- dialogRun dialog + mc <- case res of + ResponseOk -> do + clrsel <- colorSelectionDialogGetColor dialog + clr <- colorSelectionGetCurrentColor clrsel + return (Just (colorConvert clr))+ _ -> return Nothing + widgetDestroy dialog + return (ColorChosen mc)+ go = do r <- nextevent + case r of + ColorChosen mc -> return mc + _ -> go
src/Hoodle/Coroutine/Draw.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Draw --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -61,16 +61,16 @@ let cpn = PageNum . view currentPageNum $ cvsInfo isCurrentCvs = cid == getCurrentCanvasId xstate epage = getCurrentPageEitherFromHoodleModeState cvsInfo (view hoodleModeState xstate)+ cvs = view drawArea cvsInfo+ msfc = view mDrawSurface cvsInfo case epage of Left page -> do - liftIO (unSinglePageDraw drawf isCurrentCvs - <$> view drawArea <*> pure (cpn,page) - <*> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo )+ liftIO (unSinglePageDraw drawf isCurrentCvs (cvs,msfc) (cpn,page)+ <$> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) return () Right tpage -> do - liftIO (unSinglePageDraw drawfsel isCurrentCvs- <$> view drawArea <*> pure (cpn,tpage) - <*> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo )+ liftIO (unSinglePageDraw drawfsel isCurrentCvs (cvs,msfc) (cpn,tpage)+ <$> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) return () fcont :: HoodleState -> CanvasInfo ContinuousPage -> MainCoroutine () fcont xstate cvsInfo = do @@ -95,12 +95,10 @@ mapM_ invalidate (filter (/=currCvsId) keys) -- | invalidate clear - invalidate :: CanvasId -> MainCoroutine () invalidate = invalidateInBBox Nothing Clear -- | - invalidateInBBox :: Maybe BBox -- ^ desktop coord -> DrawFlag -> CanvasId -> MainCoroutine ()@@ -108,16 +106,19 @@ invalidateGeneral cid mbbox flag drawSinglePage drawSinglePageSel drawContHoodle drawContHoodleSel --- | ++-- | invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate -> DrawFlag -> MainCoroutine ()-invalidateAllInBBox mbbox flag = do +invalidateAllInBBox mbbox flag = applyActionToAllCVS (invalidateInBBox mbbox flag)+{- do xstate <- get let cinfoMap = getCanvasInfoMap xstate keys = M.keys cinfoMap forM_ keys (invalidateInBBox mbbox flag)+-} -- |
src/Hoodle/Coroutine/Eraser.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Eraser --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -82,19 +82,19 @@ then do page <- getCurrentPageCvsId cid let currhdl = unView . view hoodleModeState $ xstate + dim = view gdimension page pgnum = view currentPageNum cvsInfo (mcurrlayer, currpage) = getCurrentLayerOrSet page currlayer = maybe (error "eraserProcess") id mcurrlayer let (newitms,maybebbox1) = St.runState (eraseHitted hittestitem) Nothing maybebbox = fmap (flip inflate 2.0) maybebbox1- newlayerbbox <- liftIO . updateLayerBuf maybebbox + newlayerbbox <- liftIO . updateLayerBuf dim maybebbox . set gitems newitms $ currlayer let newpagebbox = adjustCurrentLayer newlayerbbox currpage newhdlbbox = over gpages (IM.adjust (const newpagebbox) pgnum) currhdl newhdlmodst = ViewAppendState newhdlbbox commit . set hoodleModeState newhdlmodst =<< (liftIO (updatePageAll newhdlmodst xstate))- -- invalidateWithBuf cid invalidateInBBox Nothing Efficient cid nitms <- rItmsInCurrLyr eraserProcess cid pnum geometry connidup connidmove nitms (x,y)
src/Hoodle/Coroutine/File.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- |@@ -18,14 +18,23 @@ import Control.Category import Control.Lens import Control.Monad.State+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 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.Generic@@ -38,9 +47,11 @@ import Graphics.Hoodle.Render.Type.HitTest import Text.Hoodle.Builder -- from this package +import Hoodle.Accessor import Hoodle.Coroutine.Draw import Hoodle.Coroutine.Commit import Hoodle.Coroutine.Mode +import Hoodle.Coroutine.Scroll import Hoodle.ModelAction.File import Hoodle.ModelAction.Layer import Hoodle.ModelAction.Page@@ -50,19 +61,19 @@ import Hoodle.Script.Hook import Hoodle.Type.Canvas import Hoodle.Type.Coroutine-import Hoodle.Type.Event+import Hoodle.Type.Event hiding (SVG) import Hoodle.Type.HoodleState+import Hoodle.Util ---import Prelude hiding ((.),id)+import Prelude hiding ((.),id,readFile) + -- | okMessageBox :: String -> MainCoroutine () -okMessageBox msg = modify (tempQueue %~ enqueue action) >> go +okMessageBox msg = modify (tempQueue %~ enqueue action) + >> waitSomeEvent (==GotOk) + >> return () where - go = do r <- nextevent - case r of - GotOk -> return () - _ -> go action = Left . ActionOrder $ \_evhandler -> do dialog <- messageDialogNew Nothing [DialogModal]@@ -73,8 +84,11 @@ -- | okCancelMessageBox :: String -> MainCoroutine Bool -okCancelMessageBox msg = modify (tempQueue %~ enqueue action) >> go +okCancelMessageBox msg = modify (tempQueue %~ enqueue action) + >> waitSomeEvent p >>= return . p where + p (OkCancel b) = b -- True + p _ = False action = Left . ActionOrder $ \_evhandler -> do dialog <- messageDialogNew Nothing [DialogModal]@@ -85,25 +99,25 @@ _ -> False widgetDestroy dialog return (OkCancel b)- go = do r <- nextevent - case r of - OkCancel b -> return b - _ -> go -- | -fileChooser :: FileChooserAction -> MainCoroutine (Maybe FilePath) -fileChooser choosertyp = modify (tempQueue %~ enqueue action) >> go +fileChooser :: FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath) +fileChooser choosertyp mfname = do + mrecentfolder <- S.recentFolderHook + modify (tempQueue %~ enqueue (action mrecentfolder)) >> go where go = do r <- nextevent case r of FileChosen b -> return b _ -> go - action = Left . ActionOrder $ \_evhandler -> do + action mrf = Left . ActionOrder $ \_evhandler -> do dialog <- fileChooserDialogNew Nothing Nothing choosertyp [ ("OK", ResponseOk) , ("Cancel", ResponseCancel) ]- cwd <- getCurrentDirectory - fileChooserSetCurrentFolder dialog cwd + case mrf of + Just rf -> fileChooserSetCurrentFolder dialog rf + Nothing -> getCurrentDirectory >>= fileChooserSetCurrentFolder dialog + maybe (return ()) (fileChooserSetCurrentName dialog) mfname res <- dialogRun dialog mr <- case res of ResponseDeleteEvent -> return Nothing@@ -125,6 +139,10 @@ False -> return () else action ++++ -- | fileNew :: MainCoroutine () fileNew = do @@ -151,7 +169,7 @@ put . set isSaved True $ xstate let ui = view gtkUIManager xstate liftIO $ toggleSave ui False- S.afterSaveHook hdl+ S.afterSaveHook filename hdl else fileExtensionInvalid (".hdl","save") >> fileSaveAs @@ -174,7 +192,7 @@ -- | fileExport :: MainCoroutine ()-fileExport = fileChooser FileChooserActionSave >>= maybe (return ()) action +fileExport = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action where action filename = -- this is rather temporary not to make mistake @@ -186,6 +204,20 @@ liftIO (renderjob hdl filename) +-- | need to be merged with ContextMenuEventSVG+exportCurrentPageAsSVG :: MainCoroutine ()+exportCurrentPageAsSVG = fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action + where + action filename = + -- this is rather temporary not to make mistake + if takeExtension filename /= ".svg" + then fileExtensionInvalid (".svg","export") >> exportCurrentPageAsSVG + else do + cpg <- getCurrentPageCurr+ let Dim w h = view gdimension cpg + liftIO $ withSVGSurface filename w h $ \s -> renderWith s $ + cairoRenderOption (InBBoxOption Nothing) (InBBox cpg) >> return ()+ -- | fileLoad :: FilePath -> MainCoroutine () fileLoad filename = do@@ -197,13 +229,30 @@ $ xstateNew liftIO $ setTitleFromFileName xstateNew clearUndoHistory + modeChange ToViewAppendMode + resetHoodleBuffers 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"+ xst <- get + nhdlst <- liftIO $ resetHoodleModeStateBuffers (view hoodleModeState xst)+ let nxst = set hoodleModeState nhdlst xst+ put nxst ++++ -- | main coroutine for open a file fileOpen :: MainCoroutine () fileOpen = do - mfilename <- fileChooser FileChooserActionOpen+ mfilename <- fileChooser FileChooserActionOpen Nothing case mfilename of Nothing -> return () Just filename -> fileLoad filename @@ -219,9 +268,11 @@ hookSaveAsAction xstate = do hset <- view hookSet xstate saveAsHook hset- defSaveAsAction xstate hdl = - fileChooser FileChooserActionSave - >>= maybe (return ()) (action xstate hdl) + defSaveAsAction xstate hdl = do + let msuggestedact = view hookSet xstate >>= fileNameSuggestionHook + (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact + mr <- fileChooser FileChooserActionSave msuggested + maybe (return ()) (action xstate hdl) mr where action xst' hd filename = if takeExtension filename /= ".hdl" then fileExtensionInvalid (".hdl","save")@@ -246,7 +297,7 @@ let ui = view gtkUIManager xstateNew liftIO $ toggleSave ui False liftIO $ setTitleFromFileName xstateNew - S.afterSaveHook hdl'+ S.afterSaveHook filename hdl' -- | main coroutine for open a file @@ -275,7 +326,7 @@ -- | fileAnnotatePDF :: MainCoroutine () fileAnnotatePDF = - fileChooser FileChooserActionOpen >>= maybe (return ()) action + fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action where action filename = do xstate <- get @@ -289,9 +340,9 @@ -- | -fileLoadImage :: MainCoroutine ()-fileLoadImage = do - fileChooser FileChooserActionOpen >>= maybe (return ()) action +fileLoadPNGorJPG :: MainCoroutine ()+fileLoadPNGorJPG = do + fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action where action filename = do xstate <- get @@ -299,21 +350,151 @@ let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate hdl = getHoodle xstate (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)- currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer - newitem <- (liftIO . cnstrctRItem . ItemImage) - (Image (B.pack filename) (100,100) (Dim 300 300))+ 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 - let thdl = case view hoodleModeState nxstate of- SelectState thdl' -> thdl'- _ -> error "fileLoadImage"+ 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 +++-- | +makeNewItemImage :: Bool -- ^ isEmbedded?+ -> FilePath + -> IO Item+makeNewItemImage isembedded filename = + if isembedded + then let fileext = takeExtension filename + imgaction + | fileext == ".PNG" || fileext == ".png" = loadpng + | fileext == ".JPG" || fileext == ".jpg" = loadjpg + | otherwise = loadsrc + in imgaction + else loadsrc + where loadsrc = (return . ItemImage) (Image (B.pack filename) (100,100) (Dim 300 300))+ loadpng = do + img <- loadPngFile filename+ (w,h) <- imageSize img + let dim | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w)+ | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 + bstr <- savePngByteString img + let b64str = encode bstr + ebdsrc = "data:image/png;base64," <> b64str+ return . ItemImage $ Image ebdsrc (100,100) dim -- (Dim 300 300)+ loadjpg = do + img <- loadJpegFile filename+ (w,h) <- imageSize img + let dim | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w)+ | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 + bstr <- savePngByteString img + let b64str = encode bstr + ebdsrc = "data:image/png;base64," <> b64str+ return . ItemImage $ Image ebdsrc (100,100) dim -- (Dim 300 300) + +-- | +fileLoadSVG :: MainCoroutine ()+fileLoadSVG = do + fileChooser FileChooserActionOpen Nothing >>= maybe (return ()) action + where + action filename = do + xstate <- get + liftIO $ putStrLn filename + 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 + newitem <- (liftIO . cnstrctRItem . ItemSVG) + (SVG Nothing Nothing bstr (100,100) (Dim 300 300))+ 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) "fileLoadSVG"+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate+ put nxstate2+ invalidateAll +++fileLaTeX :: MainCoroutine () +fileLaTeX = do modify (tempQueue %~ enqueue action) + minput <- go+ case minput of + Nothing -> return () + Just (latex,svg) -> afteraction (latex,svg) + where + go = do r <- nextevent+ case r of + LaTeXInput input -> return input + _ -> go + action = Left . ActionOrder $ + \_evhandler -> do + 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+ l <- textBufferGetText buf istart iend True+ widgetDestroy dialog+ tdir <- getTemporaryDirectory+ writeFile (tdir </> "latextest.tex") l + let cmd = "lasem-render-0.6 " ++ (tdir </> "latextest.tex") ++ " -f svg -o " ++ (tdir </> "latextest.svg" )+ print cmd + excode <- system cmd + case excode of + ExitSuccess -> do + svg <- readFile (tdir </> "latextest.svg")+ return (LaTeXInput (Just (B.pack l,svg)))+ _ -> return (LaTeXInput Nothing)++ _ -> do + widgetDestroy dialog+ return (LaTeXInput Nothing)+ afteraction (latex,svg) = do + 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 + newitem <- (liftIO . cnstrctRItem . ItemSVG) + (SVG (Just latex) Nothing svg (100,100) (Dim 300 50))+ let otheritems = view gitems currlayer + let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) + modeChange ToSelectMode + nxstate <- get + thdl <- case view hoodleModeState nxstate of+ SelectState thdl' -> return thdl'+ _ -> (lift . EitherT . return . Left . Other) "fileLaTeX"+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate+ put nxstate2+ invalidateAll +++ -- | askQuitProgram :: MainCoroutine () askQuitProgram = do @@ -322,4 +503,31 @@ True -> liftIO mainQuit False -> return () +-- | +embedPredefinedImage :: MainCoroutine () +embedPredefinedImage = do + liftIO $ putStrLn "embedPredefinedImage"+ mpredefined <- S.embedPredefinedImageHook + liftIO $ print mpredefined+ case mpredefined of + Nothing -> return () + Just filename -> do + xstate <- get + let pgnum = unboxGet currentPageNum . view currentCanvasInfo $ xstate+ hdl = getHoodle xstate + (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)+ currlayer = maybeError' "something wrong in addPDraw" mcurrlayer + isembedded = True+ newitem <- liftIO (cnstrctRItem =<< makeNewItemImage isembedded filename) + let otheritems = view gitems currlayer + let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty) + modeChange ToSelectMode + nxstate <- get + thdl <- case view hoodleModeState nxstate of+ SelectState thdl' -> return thdl'+ _ -> (lift . EitherT . return . Left . Other) "embedPredefinedImage"+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate+ put nxstate2+ invalidateAll
src/Hoodle/Coroutine/Mode.hs view
@@ -16,12 +16,14 @@ import Control.Applicative import Control.Category--- import Data.Label import Control.Lens-import Control.Monad.Trans+import Control.Monad.State +-- import Control.Monad.Trans import qualified Data.IntMap as M-import Graphics.UI.Gtk (adjustmentGetValue)---+import Graphics.UI.Gtk hiding (get,set) -- (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@@ -29,11 +31,12 @@ import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Accessor-import Hoodle.Coroutine.Scroll import Hoodle.Coroutine.Draw+import Hoodle.Coroutine.Scroll 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@@ -69,7 +72,6 @@ $ GSelect (view gtitle hdl) (view gpages hdl) Nothing -- | - viewModeChange :: MyEvent -> MainCoroutine () viewModeChange command = do case command of @@ -87,7 +89,6 @@ whencont xstate cinfo = do geometry <- liftIO $ getGeometry4CurrCvs xstate cdim <- liftIO $ return . canvasDim $ geometry - -- =<< getCanvasGeometry xstate page <- getCurrentPageCurr let zmode = view (viewInfo.zoomMode) cinfo canvas = view drawArea cinfo @@ -101,6 +102,7 @@ let nvinfo = ViewInfo (view zoomMode (view viewInfo cinfo)) arr ncinfo = CanvasInfo (view canvasId cinfo) canvas+ (view mDrawSurface cinfo) (view scrolledWindow cinfo) nvinfo (unPageNum cpn)@@ -108,8 +110,6 @@ (view vertAdjustment cinfo) (view horizAdjConnId cinfo) (view vertAdjConnId cinfo)- -- liftIO $ putStrLn " after " - -- liftIO $ printCanvasMode (getCurrentCanvasId xstate) (CanvasSinglePage ncinfo) return $ set currentCanvasInfo (CanvasSinglePage ncinfo) xstate ------------------------------------- whensing xstate cinfo = do @@ -127,6 +127,7 @@ nvinfo = ViewInfo (view zoomMode vinfo) arr ncinfotemp = CanvasInfo (view canvasId cinfo) (view drawArea cinfo)+ (view mDrawSurface cinfo) (view scrolledWindow cinfo) nvinfo (view currentPageNum cinfo)@@ -139,8 +140,3 @@ return . over currentCanvasInfo (const (CanvasContPage ncinfo)) $ xstate - {-- let hdl = getHoodle xstate- cinfo' <- liftIO $ updateCvsInfoFrmHoodle hdl cinfo - return . modifyCurrentCanvasInfo (const cinfo') $ xstate- -}
src/Hoodle/Coroutine/Page.hs view
@@ -22,6 +22,8 @@ -- 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 import Hoodle.Coroutine.Draw@@ -44,14 +46,15 @@ changePage :: (Int -> Int) -> MainCoroutine () changePage modifyfn = updateXState changePageAction >> adjustScrollbarWithGeometryCurrent- >> invalidateCurrent+ >> invalidateAll -- invalidateCurrent where changePageAction xst = selectBoxAction (fsingle xst) (fcont xst) . view currentCanvasInfo $ xst fsingle xstate cvsInfo = do let xojst = view hoodleModeState $ xstate npgnum = modifyfn (view currentPageNum cvsInfo) cid = view canvasId cvsInfo- (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState npgnum xojst+ bsty = view backgroundStyle xstate + (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'@@ -59,10 +62,11 @@ return xstatefinal fcont xstate cvsInfo = do - let xojst = view hoodleModeState $ xstate + let xojst = view hoodleModeState xstate npgnum = modifyfn (view currentPageNum cvsInfo) cid = view canvasId cvsInfo- (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState npgnum xojst+ bsty = view backgroundStyle xstate + (b,npgnum',_selectedpage,xojst') = changePageInHoodleModeState bsty npgnum xojst xstate' <- liftIO $ updatePageAll xojst' xstate ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'@@ -71,21 +75,29 @@ -- | -changePageInHoodleModeState :: Int -> HoodleModeState - -> (Bool,Int,Page EditMode,HoodleModeState)-changePageInHoodleModeState npgnum hdlmodst =+changePageInHoodleModeState :: BackgroundStyle + -> Int -- ^ new page number + -> HoodleModeState + -> (Bool,Int,Page EditMode,HoodleModeState)+changePageInHoodleModeState bsty npgnum hdlmodst = let ehdl = hoodleModeStateEither hdlmodst pgs = either (view gpages) (view gselAll) ehdl totnumpages = M.size pgs- lpage = maybeError "changePage" (M.lookup (totnumpages-1) pgs)+ lpage = maybeError' "changePage" (M.lookup (totnumpages-1) pgs) (isChanged,npgnum',npage',ehdl') | npgnum >= totnumpages = - let npage = newSinglePageFromOld lpage+ let cbkg = view gbackground lpage+ nbkg + | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg + in bkg2RBkg bkg { S.bkg_style = convertBackgroundStyleToByteString bsty } + | otherwise = cbkg + npage = set gbackground nbkg + . newSinglePageFromOld $ lpage npages = M.insert totnumpages npage pgs in (True,totnumpages,npage,- either (Left . set gpages npages) (Right. set gselAll npages) ehdl )+ either (Left . set gpages npages) (Right. set gselAll npages) ehdl ) | otherwise = let npg = if npgnum < 0 then 0 else npgnum- pg = maybeError "changePage" (M.lookup npg pgs)+ pg = maybeError' "changePage" (M.lookup npg pgs) in (False,npg,pg,ehdl) in (isChanged,npgnum',npage',either ViewAppendState SelectState ehdl') @@ -187,7 +199,8 @@ fsimple xstate cinfo = do case view hoodleModeState xstate of ViewAppendState hdl -> do - hdl' <- liftIO $ addNewPageInHoodle dir hdl (view currentPageNum cinfo)+ let bsty = view backgroundStyle xstate + hdl' = addNewPageInHoodle bsty dir hdl (view currentPageNum cinfo) return =<< liftIO . updatePageAll (ViewAppendState hdl') . set hoodleModeState (ViewAppendState hdl') $ xstate SelectState _ -> do
src/Hoodle/Coroutine/Pen.hs view
@@ -21,7 +21,7 @@ import Control.Monad.State -- import Control.Monad.Trans import Data.Sequence hiding (filter)-import qualified Data.Map as M+-- import qualified Data.Map as M import Data.Maybe import Graphics.UI.Gtk hiding (get,set,disconnect) -- from hoodle-platform@@ -49,14 +49,13 @@ -- | page switch if pen click a page different than the current page-penPageSwitch :: -- (ViewMode a) => - -- CanvasInfo a -> - PageNum -> MainCoroutine CanvasInfoBox -- (CanvasInfo a)-penPageSwitch {- cinfo -} pgn = do +penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox +penPageSwitch pgn = do xstate <- get let cibox = view currentCanvasInfo xstate ncibox = insideAction4CvsInfoBox (set currentPageNum (unPageNum pgn)) cibox put (set currentCanvasInfo ncibox xstate) + invalidateAll return ncibox @@ -83,7 +82,7 @@ $ \(pgn,PageCoord (x,y)) -> do nCvsInfo <- if (cpn /= pgn) then do penPageSwitch pgn- -- temporary dirty fix + -- temporary dirty fix return (set currentPageNum (unPageNum pgn) cvsInfo ) else return cvsInfo connidup <- connectPenUp nCvsInfo @@ -106,8 +105,8 @@ =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate)) let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord nbbox = xformBBox f bbox - invalidateAllInBBox (Just (inflate nbbox 2.0)) Efficient-+ invalidateAllInBBox (Just nbbox) BkgEfficient -- Efficient+ -- | main pen coordinate adding process -- | now being changed penProcess :: CanvasId -> PageNum @@ -129,10 +128,11 @@ (\(pcoord,(x,y)) -> do let PointerCoord _ _ _ z = pcoord let canvas = view drawArea cvsInfo+ msfc = view mDrawSurface cvsInfo ptype = view (penInfo.penType) xstate pcolor = view (penInfo.currentTool.penColor) xstate pwidth = view (penInfo.currentTool.penWidth) xstate - (pcr,pcg,pcb,pca)= fromJust (M.lookup pcolor penColorRGBAmap) + (pcr,pcg,pcb,pca) = convertPenColorToRGBA pcolor opacity = case ptype of HighlighterWork -> predefined_highlighter_opacity _ -> 1.0@@ -140,7 +140,7 @@ let pressureType = case view (penInfo.variableWidthPen) xstate of True -> Pressure False -> NoPressure- liftIO $ drawCurvebitGen pressureType canvas geometry + 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 )
src/Hoodle/Coroutine/Scroll.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Coroutine.Scroll @@ -13,10 +15,14 @@ module Hoodle.Coroutine.Scroll where import Control.Category+-- import Control.Concurrent import Control.Lens 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 -- from this package import Hoodle.Type.Event @@ -73,57 +79,70 @@ 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 -- | -vscrollStart :: CanvasId -> MainCoroutine () -vscrollStart cid = do +vscrollStart :: CanvasId -> Double -> MainCoroutine () +vscrollStart cid v = do chkCvsIdNInvalidate cid - vscrollMove cid + vscrollMove cid v -- | -vscrollMove :: CanvasId -> MainCoroutine () -vscrollMove cid = do +vscrollMove :: CanvasId -> Double -> MainCoroutine () +vscrollMove cid v0 = do ev <- nextevent xst <- get geometry <- liftIO (getCanvasGeometryCvsId cid xst) case ev of VScrollBarMoved cid' v -> do - when (cid /= cid') $ error "something wrong in vscrollMove"- updateXState $ return . over currentCanvasInfo - (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v))- -- invalidateWithBuf cid - invalidateInBBox Nothing Efficient cid - vscrollMove cid + when (cid /= cid') $ + (lift . hoistEither . Left . Other) "something wrong in vscrollMove"+ smoothScroll cid geometry v0 v + vscrollMove cid v VScrollBarEnd cid' v -> do - when (cid /= cid') $ error "something wrong in vscrollMove" - updateXState $ return. over currentCanvasInfo - (selectBox (scrollmovecanvas v) (scrollmovecanvasCont geometry v)) - invalidate cid' + when (cid /= cid') $ + (lift . hoistEither . Left . Other) "something wrong in vscrollMove" + smoothScroll cid geometry v0 v+ invalidateAll return ()- VScrollBarStart cid' _v -> vscrollStart cid' + VScrollBarStart cid' v -> vscrollStart cid' v _ -> return () - where scrollmovecanvas v cvsInfo = ++++-- | +smoothScroll :: CanvasId -> CanvasGeometry -> Double -> Double -> MainCoroutine () +smoothScroll cid geometry v0 v = do + xst <- get + let b = view doesSmoothScroll xst + let diff = (v - v0) + lst' | (diff < 20 && diff > -20) = [v]+ | (diff < 5 &&diff > -5) = []+ | otherwise = let m :: Int = floor (minimum [20, (abs diff) / 10.0])+ delta = diff / fromIntegral m + in [v0 + fromIntegral n*delta | n <- [1..m] ]+ lst | b = lst' + | otherwise = [v] + forM_ lst $ \v' -> do + 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) - (apply (moveBBoxULCornerTo (fst vm_orig,v))) cvsInfo - - scrollmovecanvasCont geometry v cvsInfo = + (apply (moveBBoxULCornerTo (fst vm_orig,vv))) cvsInfo + -- + scrollmovecanvasCont geom vv cvsInfo = let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo cpn = PageNum . view currentPageNum $ cvsInfo - ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (0,v))+ ncpn = maybe cpn fst $ desktop2Page geom (DeskCoord (0,vv)) in over currentPageNum (const (unPageNum ncpn)) . over (viewInfo.pageArrangement.viewPortBBox) - (apply (moveBBoxULCornerTo (fst vm_orig,v))) $ cvsInfo -------+ (apply (moveBBoxULCornerTo (fst vm_orig,vv))) $ cvsInfo
src/Hoodle/Coroutine/Select.hs view
@@ -42,6 +42,7 @@ import Hoodle.Accessor import Hoodle.Device import Hoodle.Coroutine.Commit+import Hoodle.Coroutine.ContextMenu import Hoodle.Coroutine.Draw import Hoodle.Coroutine.EventConnect import Hoodle.Coroutine.Mode@@ -96,6 +97,7 @@ -- | main mouse pointer click entrance in rectangular selection mode. -- choose either starting new rectangular selection or move previously -- selected selection. +-- (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@@ -106,7 +108,9 @@ (do tsel <- createTempSelectRender pnum geometry page [] newSelectRectangle cid pnum geometry cidmove cidup itms (x,y) ((x,y),ctime) tsel- surfaceFinish (tempSurface tsel)) + surfaceFinish (tempSurface tsel) + showContextMenu (pnum,(x,y))+ ) (disconnect [cidmove,cidup]) let action (Right tpage) | hitInHandle tpage (x,y) = @@ -220,6 +224,7 @@ moveSelect cid pnum geometry cidmove cidup (x,y) ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) surfaceFinish (imageSurface itmimage)+ invalidateAll -- | moveSelect :: CanvasId@@ -342,7 +347,7 @@ resizeSelect handle cid pnum geometry cidmove cidup bbox ((x,y),ctime) tsel surfaceFinish (tempSurface tsel) surfaceFinish (imageSurface itmimage)- + invalidateAll -- | resizeSelect :: Handle @@ -454,7 +459,9 @@ (do tsel <- createTempSelectRender pnum geometry page [] newSelectLasso cinfo pnum geometry cidmove cidup itms (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel- surfaceFinish (tempSurface tsel))+ surfaceFinish (tempSurface tsel)+ showContextMenu (pnum,(x,y))+ ) (disconnect [cidmove, cidup] ) let action (Right tpage) | hitInSelection tpage (x,y) = startMoveSelect cid pnum geometry cidmove cidup ((x,y),ctime) tpage@@ -485,9 +492,7 @@ -> Seq (Double,Double) -> TempSelection -> MainCoroutine ()-newSelectLasso cvsInfo pnum geometry cidmove cidup itms orig (prev,otime) lasso tsel = do- r <- nextevent - fsingle r cvsInfo +newSelectLasso cvsInfo pnum geometry cidmove cidup itms orig (prev,otime) lasso tsel = nextevent >>= flip fsingle cvsInfo where fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact (moveact cinfo) (upact cinfo)@@ -509,8 +514,16 @@ hdlmodst = view hoodleModeState xstate epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst cpn = view currentPageNum cinfo - hittestlasso = hltFilteredBy (hitLassoItem (nlasso |> orig)) itms- selectitms = fmapAL unNotHitted id hittestlasso+ hittestlasso1 = hltFilteredBy (hitLassoItem (nlasso |> orig)) itms+ selectitms1 = fmapAL unNotHitted id hittestlasso1+ selecteditms1 = (concatMap unHitted . getB) selectitms1 + hittestlasso2 = flip hltFilteredBy itms $ + \itm-> (not.isStrkInRItem) itm + && isPointInBBox (getBBox itm) (x,y)+ selectitms2 = fmapAL unNotHitted id hittestlasso2+ selectitms + | (not.null) selecteditms1 = selectitms1 + | otherwise = selectitms2 SelectState thdl = view hoodleModeState xstate newpage = case epage of Left pagebbox ->
+ src/Hoodle/Coroutine/TextInput.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Hoodle.Coroutine.TextInput +-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.TextInput where++import Control.Applicative+import Control.Lens+import Control.Monad.State +-- import Control.Monad.Trans+import Control.Monad.Trans.Either+import Graphics.Rendering.Cairo+import Graphics.Rendering.Pango.Cairo+import Graphics.UI.Gtk hiding (get,set)+-- +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 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 + where + go = do r <- nextevent+ case r of + TextInput input -> return input + _ -> go + action = Left . ActionOrder $ + \_evhandler -> do + dialog <- messageDialogNew Nothing [DialogModal]+ MessageQuestion ButtonsOkCancel "text input"+ vbox <- dialogGetUpper dialog+ txtvw <- textViewNew+ boxPackStart vbox txtvw PackGrow 0 + widgetShowAll dialog+ res <- dialogRun dialog + case res of + ResponseOk -> do + buf <- textViewGetBuffer txtvw + (istart,iend) <- (,) <$> textBufferGetStartIter buf+ <*> textBufferGetEndIter buf+ l <- textBufferGetText buf istart iend True+ widgetDestroy dialog+ return (TextInput (Just l))+ _ -> do + widgetDestroy dialog+ return (TextInput Nothing)++makePangoTextSVGInsert :: String -> MainCoroutine () +makePangoTextSVGInsert str = 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 + newitem <- (liftIO . cnstrctRItem . ItemSVG) + (SVG (Just (B.pack str)) Nothing svg (100,100) (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) "makePangoTextSVGInsert"+ nthdl <- liftIO $ updateTempHoodleSelectIO thdl ntpg pgnum + let nxstate2 = set hoodleModeState (SelectState nthdl) nxstate+ put nxstate2+ invalidateAll +++{- tdir <- getTemporaryDirectory+ writeFile (tdir </> "latextest.tex") l + let cmd = "lasem-render-0.6 " ++ (tdir </> "latextest.tex") ++ " -f svg -o " ++ (tdir </> "latextest.svg" )+ print cmd + excode <- system cmd + case excode of + ExitSuccess -> do + svg <- readFile (tdir </> "latextest.svg")+ return (LaTeXInput (Just (B.pack l,svg)))+ _ -> return (LaTeXInput Nothing) -}+
src/Hoodle/Coroutine/Window.hs view
@@ -37,7 +37,7 @@ import Hoodle.Type.PageArrangement -- import Hoodle.Type.Predefined import Hoodle.Type.Window-import Hoodle.Util+-- import Hoodle.Util import Hoodle.View.Draw -- import Prelude hiding ((.),id)@@ -52,13 +52,13 @@ >> updatefunc where fsingle cinfo = do xstate <- get - let cinfo' = updateCanvasDimForSingle cdim cinfo + cinfo' <- liftIO $ updateCanvasDimForSingle cdim cinfo return $ setCanvasInfo (cid,CanvasSinglePage cinfo') xstate fcont cinfo = do xstate <- get page <- getCurrentPageCvsId cid let pdim = PageDimension (view gdimension page)- let cinfo' = updateCanvasDimForContSingle pdim cdim cinfo + cinfo' <- liftIO $ updateCanvasDimForContSingle pdim cdim cinfo return $ setCanvasInfo (cid,CanvasContPage cinfo') xstate -- | @@ -68,24 +68,6 @@ doCanvasConfigure = canvasConfigureGenUpdate canvasZoomUpdateAll -- | -{--canvasConfigure' :: CanvasId -> CanvasDimension -> MainCoroutine () -canvasConfigure' cid cdim = do- xstate <- get - ctime <- liftIO getCurrentTime - maybe defaction (chkaction ctime) (view lastTimeCanvasConfigure xstate) - where defaction = do - ntime <- liftIO getCurrentTime- doCanvasConfigure cid cdim - updateXState (return . set lastTimeCanvasConfigure (Just ntime)) - chkaction ctime otime = do - let dtime = diffUTCTime ctime otime - if dtime > predefinedWinReconfTimeBound- then defaction - else return ()--}---- | eitherSplit :: SplitType -> MainCoroutine () eitherSplit stype = do xstate <- get@@ -97,7 +79,7 @@ case enewfstate of Left _ -> return () Right fstate' -> do - let cinfobox = maybeError "eitherSplit" . M.lookup currcid $ cmap + cinfobox <- maybeError "eitherSplit" . M.lookup currcid $ cmap let rtwin = view rootWindow xstate rtcntr = view rootContainer xstate rtrwin = view rootOfRootWindow xstate @@ -171,7 +153,24 @@ -- | not yet implemented? paneMoved :: MainCoroutine () paneMoved = do - liftIO $ putStrLn "pane moved called"+ liftIO $ putStrLn "pane moved called"+ +-- |+fullScreen :: MainCoroutine ()+fullScreen = do + xst <- get + let b = view isFullScreen xst+ rwin = view rootOfRootWindow xst + if b + then do + liftIO $ windowUnfullscreen rwin+ modify (over isFullScreen (const False))+ else do + liftIO $ windowFullscreen rwin + modify (over isFullScreen (const True))++ +
src/Hoodle/Device.hsc view
@@ -109,8 +109,6 @@ _ -> rbtn let tst = (rbtnfinal,pcoord)- -- (,) rbtn <$> (liftIO $ coord ptr x y dev axf)- -- liftIO $ print tst return tst where getInfo ptr = do
src/Hoodle/GUI.hs view
@@ -29,6 +29,7 @@ -- -- import Control.Monad.Trans.Crtn.EventHandler -- from this package+import Hoodle.Accessor import Hoodle.Config import Hoodle.Coroutine import Hoodle.Coroutine.Callback@@ -51,20 +52,19 @@ devlst <- initDevice cfg maxundo <- getMaxUndo cfg >>= \mmax -> maybe (return 50) (return . id) mmax- (tref,st0,ui,vbox) <- initCoroutine devlst window mfname mhook maxundo - setTitleFromFileName st0 xinputbool <- getXInputConfig cfg - agr <- uiManagerGetActionGroups ui >>= \x ->- case x of - [] -> error "No action group? "- y:_ -> return y - uxinputa <- actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> - return (castToToggleAction x) - toggleActionSetActive uxinputa xinputbool+ (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 + -- 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
src/Hoodle/GUI/Menu.hs view
@@ -22,6 +22,7 @@ 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 @@ -29,7 +30,7 @@ import Hoodle.Coroutine.Callback import Hoodle.Type import Hoodle.Type.Clipboard-import Hoodle.Util.Verbatim+-- import Hoodle.Util.Verbatim -- import Prelude hiding ((.),id) import Paths_hoodle_core@@ -39,232 +40,10 @@ justMenu :: MenuEvent -> Maybe MyEvent justMenu = Just . Menu --- |--uiDeclTest :: String -uiDeclTest = [verbatim|<ui> - <menubar>- <menu action="VMA">- <menuitem action="CONTA" />- <menuitem action="ONEPAGEA" />- <separator />- <menuitem action="FSCRA" />- <separator />- </menu>- </menubar>-</ui>|]- -- | --uiDecl :: String -uiDecl = [verbatim|<ui> - <menubar>- <menu action="FMA">- <menuitem action="NEWA" />- <menuitem action="ANNPDFA" /> - <menuitem action="LDIMGA" />- <menuitem action="OPENA" /> - <menuitem action="SAVEA" /> - <menuitem action="SAVEASA" /> - <menuitem action="RELOADA" />- <separator /> - <menuitem action="RECENTA" /> - <separator /> - <menuitem action="PRINTA" /> - <menuitem action="EXPORTA" />- <separator /> - <menuitem action="QUITA" />- </menu>- <menu action="EMA">- <menuitem action="UNDOA" />- <menuitem action="REDOA" /> - <separator />- <menuitem action="CUTA" /> - <menuitem action="COPYA" /> - <menuitem action="PASTEA" /> - <menuitem action="DELETEA" />- <separator />- <menuitem action="NETCOPYA" />- <menuitem action="NETPASTEA" />- </menu>- <menu action="VMA">- <menuitem action="CONTA" />- <menuitem action="ONEPAGEA" />- <separator />- <menuitem action="FSCRA" />- <separator />- <menu action="ZOOMA" >- <menuitem action="ZMINA" />- <menuitem action="ZMOUTA" /> - <menuitem action="NRMSIZEA" /> - <menuitem action="PGWDTHA" /> - <menuitem action="PGHEIGHTA" />- <menuitem action="SETZMA" /> - </menu>- <separator />- <menuitem action="FSTPAGEA" />- <menuitem action="PRVPAGEA" />- <menuitem action="NXTPAGEA" />- <menuitem action="LSTPAGEA" />- <separator />- <menuitem action="SHWLAYERA" />- <menuitem action="HIDLAYERA" />- <separator />- <menuitem action="HSPLITA" />- <menuitem action="VSPLITA" />- <menuitem action="DELCVSA" />- </menu>- <menu action="JMA">- <menuitem action="NEWPGBA" />- <menuitem action="NEWPGAA" />- <menuitem action="NEWPGEA" />- <menuitem action="DELPGA" /> - <separator />- <menuitem action="NEWLYRA" />- <menuitem action="NEXTLAYERA" />- <menuitem action="PREVLAYERA" />- <menuitem action="GOTOLAYERA" />- <menuitem action="DELLYRA" /> - <separator />- <menuitem action="PPSIZEA" />- <menuitem action="PPCLRA" />- <menuitem action="PPSTYA" />- <menuitem action="APALLPGA" />- <separator />- <menuitem action="LDBKGA" />- <menuitem action="BKGSCRSHTA" />- <separator />- <menuitem action="DEFPPA" /> - <menuitem action="SETDEFPPA" /> - </menu>- <menu action="TMA">- <menuitem action="PENA" />- <menuitem action="ERASERA" />- <menuitem action="HIGHLTA" />- <menuitem action="TEXTA" /> - <separator />- <menuitem action="SHPRECA" />- <menuitem action="RULERA" /> - <separator />- <menuitem action="SELREGNA" />- <menuitem action="SELRECTA" />- <menuitem action="VERTSPA" />- <menuitem action="HANDA" />- <separator />- <menu action="CLRA"> - <menuitem action="BLACKA" /> - <menuitem action="BLUEA" /> - <menuitem action="REDA" /> - <menuitem action="GREENA" /> - <menuitem action="GRAYA" /> - <menuitem action="LIGHTBLUEA" /> - <menuitem action="LIGHTGREENA" /> - <menuitem action="MAGENTAA" />- <menuitem action="ORANGEA" />- <menuitem action="YELLOWA" />- <menuitem action="WHITEA" />- </menu> - <menu action="PENOPTA"> - <menuitem action="PENVERYFINEA" /> - <menuitem action="PENFINEA" /> - <menuitem action="PENMEDIUMA" /> - <menuitem action="PENTHICKA" /> - <menuitem action="PENVERYTHICKA" /> - <menuitem action="PENULTRATHICKA" /> - </menu>- <menuitem action="ERASROPTA" /> - <menuitem action="HILTROPTA" /> - <menuitem action="TXTFNTA" /> - <separator />- <menuitem action="DEFPENA" /> - <menuitem action="DEFERSRA" /> - <menuitem action="DEFHILTRA" /> - <menuitem action="DEFTXTA" />- <menuitem action="SETDEFOPTA" /> - </menu>- <menu action="OMA">- <menuitem action="UXINPUTA" />- <menuitem action="DCRDCOREA" /> - <menuitem action="ERSRTIPA" /> - <menuitem action="PRESSRSENSA" /> - <menuitem action="PGHILTA" /> - <menuitem action="MLTPGVWA" /> - <menuitem action="MLTPGA" /> - <menuitem action="BTN2MAPA" /> - <menuitem action="BTN3MAPA" /> - <separator />- <menuitem action="ANTIALIASBMPA" /> - <menuitem action="PRGRSBKGA" /> - <menuitem action="PRNTPPRULEA" /> - <menuitem action="LFTHNDSCRBRA" /> - <menuitem action="SHRTNMENUA" /> - <separator />- <menuitem action="AUTOSAVEPREFA" /> - <menuitem action="SAVEPREFA" />- <menuitem action="RELAUNCHA" />- </menu>- <menu action="HMA">- <menuitem action="ABOUTA" />- </menu>- </menubar>- <toolbar name="toolbar1" > - <toolitem action="SAVEA" />- <toolitem action="NEWA" />- <toolitem action="OPENA" />- <separator />- <toolitem action="CUTA" />- <toolitem action="COPYA" />- <toolitem action="PASTEA" />- <separator /> - <toolitem action="UNDOA" /> - <toolitem action="REDOA" /> - <separator /> - <toolitem action="FSTPAGEA" />- <toolitem action="PRVPAGEA" />- <toolitem action="NXTPAGEA" />- <toolitem action="LSTPAGEA" />- <separator />- <toolitem action="ZMOUTA" /> - <toolitem action="NRMSIZEA" /> - <toolitem action="ZMINA" />- <toolitem action="PGWDTHA" /> - <toolitem action="SETZMA" />- <toolitem action="FSCRA" />- </toolbar>- <toolbar name="toolbar2" > - <toolitem action="PENA" />- <toolitem action="ERASERA" /> - <toolitem action="HIGHLTA" /> - <toolitem action="TEXTA" /> - <separator /> - <!-- <toolitem action="DEFAULTA" /> --> - <!-- <toolitem action="DEFPENA" /> --> - <!-- <toolitem action="SHPRECA" /> --> - <!-- <toolitem action="RULERA" /> --> - <!-- <separator /> -->- <toolitem action="SELREGNA" /> - <toolitem action="SELRECTA" /> - <toolitem action="VERTSPA" /> - <toolitem action="HANDA" /> - <separator /> - <toolitem action="PENFINEA" /> - <toolitem action="PENMEDIUMA" /> - <toolitem action="PENTHICKA" /> - <separator />- <toolitem action="BLACKA" /> - <toolitem action="BLUEA" /> - <toolitem action="REDA" /> - <toolitem action="GREENA" /> - <toolitem action="GRAYA" /> - <toolitem action="LIGHTBLUEA" /> - <toolitem action="LIGHTGREENA" /> - <toolitem action="MAGENTAA" /> - <toolitem action="ORANGEA" /> - <toolitem action="YELLOWA" /> - <toolitem action="WHITEA" /> - </toolbar>-</ui>-|]+-- uiDecl :: String +-- uiDecl = [verbatim|+-- |] iconList :: [ (String,String) ] iconList = [ ("fullscreen.png" , "myfullscreen")@@ -297,14 +76,12 @@ ] -- | - viewmods :: [RadioActionEntry] viewmods = [ RadioActionEntry "CONTA" "Continuous" Nothing Nothing Nothing 0 , RadioActionEntry "ONEPAGEA" "One Page" Nothing Nothing Nothing 1 ] -- | - pointmods :: [RadioActionEntry] pointmods = [ RadioActionEntry "PENVERYFINEA" "Very fine" Nothing Nothing Nothing 0 , RadioActionEntry "PENFINEA" "Fine" (Just "mythin") Nothing Nothing 1@@ -321,7 +98,7 @@ penmods = [ RadioActionEntry "PENA" "Pen" (Just "mypen") Nothing Nothing 0 , RadioActionEntry "ERASERA" "Eraser" (Just "myeraser") Nothing Nothing 1 , RadioActionEntry "HIGHLTA" "Highlighter" (Just "myhighlighter") Nothing Nothing 2- , RadioActionEntry "TEXTA" "Text" (Just "mytext") Nothing Nothing 3 +-- , RadioActionEntry "TEXTA" "Text" (Just "mytext") Nothing Nothing 3 , RadioActionEntry "SELREGNA" "Select Region" (Just "mylasso") Nothing Nothing 4 , RadioActionEntry "SELRECTA" "Select Rectangle" (Just "myrectselect") Nothing Nothing 5 , RadioActionEntry "VERTSPA" "Vertical Space" (Just "mystretch") Nothing Nothing 6@@ -344,8 +121,15 @@ , RadioActionEntry "BLACKA" "Black" (Just "myblack") Nothing Nothing 0 ] --- |+-- | +bkgstyles :: [RadioActionEntry] +bkgstyles = [ RadioActionEntry "BKGGRAPHA" "Graph" Nothing Nothing Nothing 3 + , RadioActionEntry "BKGPLAINA" "Plain" Nothing Nothing Nothing 0+ , RadioActionEntry "BKGLINEDA" "Lined" Nothing Nothing Nothing 1+ , RadioActionEntry "BKGRULEDA" "Ruled" Nothing Nothing Nothing 2 + ] +-- | iconResourceAdd :: IconFactory -> FilePath -> (FilePath, StockId) -> IO () iconResourceAdd iconfac resdir (fp,stid) = do @@ -389,20 +173,25 @@ fma <- actionNewAndRegister "FMA" "File" Nothing Nothing Nothing ema <- actionNewAndRegister "EMA" "Edit" Nothing Nothing Nothing vma <- actionNewAndRegister "VMA" "View" Nothing Nothing Nothing- jma <- actionNewAndRegister "JMA" "Journal" Nothing Nothing Nothing+ jma <- actionNewAndRegister "JMA" "Page" Nothing Nothing Nothing tma <- actionNewAndRegister "TMA" "Tools" Nothing Nothing Nothing oma <- actionNewAndRegister "OMA" "Options" Nothing Nothing Nothing hma <- actionNewAndRegister "HMA" "Help" Nothing Nothing Nothing -- file menu newa <- actionNewAndRegister "NEWA" "New" (Just "Just a Stub") (Just stockNew) (justMenu MenuNew)- annpdfa <- actionNewAndRegister "ANNPDFA" "Annotate PDF" (Just "Just a Stub") Nothing (justMenu MenuAnnotatePDF)- ldimga <- actionNewAndRegister "LDIMGA" "Load Image" (Just "Just a Stub") Nothing (justMenu MenuLoadImage) opena <- actionNewAndRegister "OPENA" "Open" (Just "Just a Stub") (Just stockOpen) (justMenu MenuOpen) savea <- actionNewAndRegister "SAVEA" "Save" (Just "Just a Stub") (Just stockSave) (justMenu MenuSave) saveasa <- actionNewAndRegister "SAVEASA" "Save As" (Just "Just a Stub") (Just stockSaveAs) (justMenu MenuSaveAs) reloada <- actionNewAndRegister "RELOADA" "Reload File" (Just "Just a Stub") Nothing (justMenu MenuReload) recenta <- actionNewAndRegister "RECENTA" "Recent Document" (Just "Just a Stub") Nothing (justMenu MenuRecentDocument)+ annpdfa <- actionNewAndRegister "ANNPDFA" "Annotate PDF" (Just "Just a Stub") Nothing (justMenu MenuAnnotatePDF)+ ldpnga <- actionNewAndRegister "LDIMGA" "Load PNG or JPG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadPNGorJPG)+ ldsvga <- actionNewAndRegister "LDSVGA" "Load SVG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadSVG)+ latexa <- actionNewAndRegister "LATEXA" "LaTeX" (Just "Just a Stub") Nothing (justMenu MenuLaTeX)+ ldpreimga <- actionNewAndRegister "LDPREIMGA" "Embed Predefined Image File" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage)++ 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)@@ -436,11 +225,12 @@ vsplita <- actionNewAndRegister "VSPLITA" "Vertical Split" (Just "vertical split") Nothing (justMenu MenuVSplit) delcvsa <- actionNewAndRegister "DELCVSA" "Delete Current Canvas" (Just "delete current canvas") Nothing (justMenu MenuDelCanvas) - -- journal menu + -- page menu newpgba <- actionNewAndRegister "NEWPGBA" "New Page Before" (Just "Just a Stub") Nothing (justMenu MenuNewPageBefore) newpgaa <- actionNewAndRegister "NEWPGAA" "New Page After" (Just "Just a Stub") Nothing (justMenu MenuNewPageAfter) newpgea <- actionNewAndRegister "NEWPGEA" "New Page At End" (Just "Just a Stub") Nothing (justMenu MenuNewPageAtEnd) delpga <- actionNewAndRegister "DELPGA" "Delete Page" (Just "Just a Stub") Nothing (justMenu MenuDeletePage)+ expsvga <- actionNewAndRegister "EXPSVGA" "Export Current Page to SVG" (Just "Just a Stub") Nothing (justMenu MenuExportPageSVG) newlyra <- actionNewAndRegister "NEWLYRA" "New Layer" (Just "Just a Stub") Nothing (justMenu MenuNewLayer) nextlayera <- actionNewAndRegister "NEXTLAYERA" "Next Layer" (Just "Just a Stub") Nothing (justMenu MenuNextLayer) prevlayera <- actionNewAndRegister "PREVLAYERA" "Prev Layer" (Just "Just a Stub") Nothing (justMenu MenuPrevLayer)@@ -448,7 +238,7 @@ dellyra <- actionNewAndRegister "DELLYRA" "Delete Layer" (Just "Just a Stub") Nothing (justMenu MenuDeleteLayer) ppsizea <- actionNewAndRegister "PPSIZEA" "Paper Size" (Just "Just a Stub") Nothing (justMenu MenuPaperSize) ppclra <- actionNewAndRegister "PPCLRA" "Paper Color" (Just "Just a Stub") Nothing (justMenu MenuPaperColor)- ppstya <- actionNewAndRegister "PPSTYA" "Paper Style" (Just "Just a Stub") Nothing (justMenu MenuPaperStyle)+ 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)@@ -456,6 +246,7 @@ 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) 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)@@ -463,6 +254,7 @@ -- vertspa <- actionNewAndRegister "VERTSPA" "Vertical Space" (Just "Just a Stub") (Just "mystretch") (justMenu MenuVerticalSpace) -- handa <- actionNewAndRegister "HANDA" "Hand Tool" (Just "Just a Stub") (Just "myhand") (justMenu MenuHandTool) clra <- actionNewAndRegister "CLRA" "Color" (Just "Just a Stub") Nothing Nothing+ clrpcka <- actionNewAndRegister "CLRPCKA" "Color Picker.." (Just "Just a Stub") (Just stockSelectColor) (justMenu MenuColorPicker ) penopta <- actionNewAndRegister "PENOPTA" "Pen Options" (Just "Just a Stub") Nothing (justMenu MenuPenOptions) erasropta <- actionNewAndRegister "ERASROPTA" "Eraser Options" (Just "Just a Stub") Nothing (justMenu MenuEraserOptions) hiltropta <- actionNewAndRegister "HILTROPTA" "Highlighter Options" (Just "Just a Stub") Nothing (justMenu MenuHighlighterOptions)@@ -478,14 +270,22 @@ uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing uxinputa `on` actionToggled $ do eventHandler evar (Menu MenuUseXInput)--- AndRegister "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing (justMenu MenuUseXInput)+ smthscra <- toggleActionNew "SMTHSCRA" "Smooth Scrolling" (Just "Just a stub") Nothing+ smthscra `on` actionToggled $ do + eventHandler evar (Menu MenuSmoothScroll)+ popmenua <- toggleActionNew "POPMENUA" "Use Popup Menu" (Just "Just a stub") Nothing+ popmenua `on` actionToggled $ do + eventHandler evar (Menu MenuUsePopUpMenu) + ebdimga <- toggleActionNew "EBDIMGA" "Embed PNG/JPG Image" (Just "Just a stub") Nothing+ ebdimga `on` actionToggled $ do + eventHandler evar (Menu MenuEmbedImage) 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 pressrsensa `on` actionToggled $ do eventHandler evar (Menu MenuPressureSensitivity)--- AndRegister "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing (justMenu MenuUseXInput) + @@ -513,16 +313,15 @@ [fma,ema,vma,jma,tma,oma,hma] mapM_ (actionGroupAddAction agr) [ undoa, redoa, cuta, copya, pastea, deletea ] - -- actionGroupAddActionWithAccel agr undoa (Just "<control>z") mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing) - [ newa, annpdfa, ldimga, opena, savea, saveasa, reloada, recenta, printa, exporta, quita- {- , netcopya, netpastea -}+ [ newa, annpdfa, ldpnga, ldsvga, latexa, ldpreimga, 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, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra- , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa- , shpreca, rulera, clra, penopta + , 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 , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta, relauncha , dcrdcorea, ersrtipa, pghilta, mltpgvwa@@ -533,22 +332,27 @@ ] actionGroupAddAction agr uxinputa + actionGroupAddAction agr smthscra+ actionGroupAddAction agr popmenua + actionGroupAddAction agr ebdimga 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) - + actionGroupAddRadioActions agr bkgstyles 2 (assignBkgStyle evar)+ + let disabledActions = [ recenta, printa {- , exporta-} , cuta, copya, {- pastea, -} deletea- , fscra, setzma+ {- , fscra -}+ , setzma , shwlayera, hidlayera , newpgea, {- delpga, -} ppsizea, ppclra- , ppstya, apallpga, ldbkga, bkgscrshta, defppa, setdefppa+ {- , ppstya, apallpga -} + , ldbkga, bkgscrshta, defppa, setdefppa , shpreca, rulera , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta , setdefopta@@ -560,7 +364,7 @@ ] enabledActions = [ opena, savea, saveasa, reloada, quita, pastea, fstpagea, prvpagea, nxtpagea, lstpagea- , clra, penopta, zooma, nrmsizea, pgwdtha + , clra, penopta, zooma, nrmsizea, pgwdtha, texta ] -- mapM_ (\x->actionSetSensitive x True) enabledActions @@ -569,7 +373,9 @@ -- -- radio actions --- ui <- uiManagerNew + ui <- uiManagerNew+ + uiDecl <- readFile (resDir </> "menu.xml") uiManagerAddUiFromString ui uiDecl uiManagerInsertActionGroup ui agr 0 -- Just ra1 <- actionGroupGetAction agr "ONEPAGEA"@@ -616,12 +422,20 @@ v <- radioActionGetCurrentValue a eventHandler evar (PenWidthChanged v) + -- | +assignBkgStyle :: EventVar -> RadioAction -> IO ()+assignBkgStyle evar a = do + v <- radioActionGetCurrentValue a + let sty = int2BkgStyle v + eventHandler evar (BackgroundStyleChanged sty) ++-- | int2PenType :: Int -> Either PenType SelectType int2PenType 0 = Left PenWork int2PenType 1 = Left EraserWork int2PenType 2 = Left HighlighterWork-int2PenType 3 = Left TextWork +-- int2PenType 3 = Left TextWork int2PenType 4 = Right SelectRegionWork int2PenType 5 = Right SelectRectangleWork int2PenType 6 = Right SelectVerticalSpaceWork@@ -648,12 +462,12 @@ 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 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" -- | @@ -670,3 +484,11 @@ int2Color 9 = ColorYellow int2Color 10 = ColorWhite int2Color _ = error "No such color"+++int2BkgStyle :: Int -> BackgroundStyle +int2BkgStyle 0 = BkgStylePlain +int2BkgStyle 1 = BkgStyleLined+int2BkgStyle 2 = BkgStyleRuled+int2BkgStyle 3 = BkgStyleGraph+int2BkgStyle _ = BkgStyleRuled
src/Hoodle/ModelAction/Adjustment.hs view
@@ -38,8 +38,11 @@ adjustmentSetUpper vadj h adjustmentSetValue hadj x0 adjustmentSetValue vadj y0- adjustmentSetPageSize hadj (min xsize w)- adjustmentSetPageSize vadj (min ysize h)+ print (xsize,ysize) + adjustmentSetPageSize hadj xsize -- (min xsize w)+ adjustmentSetPageSize vadj ysize -- (min ysize h)+ adjustmentSetPageIncrement hadj (xsize*0.9)+ adjustmentSetPageIncrement vadj (ysize*0.9) maybe (return ()) signalUnblock mconnidh maybe (return ()) signalUnblock mconnidv
src/Hoodle/ModelAction/File.hs view
@@ -102,11 +102,15 @@ return Nothing Just doc -> do n <- Poppler.documentGetNPages doc - pg <- Poppler.documentGetPage doc 0 - (w,h) <- PopplerPage.pageGetSize pg- let dim = Dim w h - hdl = set title fname - . set pages (map (createPage dim fname) [1..n]) ++ let createPageAct i = do + pg <- Poppler.documentGetPage doc (i-1) + (w,h) <- PopplerPage.pageGetSize pg+ let dim = Dim w h + return (createPage dim fname i) + pgs <- mapM createPageAct [1..n]+ let hdl = set title fname + . set pages pgs $ emptyHoodle return (Just hdl) #else
src/Hoodle/ModelAction/Layer.hs view
@@ -15,7 +15,7 @@ -- from other packages import Control.Category import Control.Compose-import Control.Lens (view,set,over)+import Control.Lens (view,set) import Data.IORef import Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk as Gtk (get)
src/Hoodle/ModelAction/Page.hs view
@@ -18,12 +18,15 @@ import Control.Category import Control.Lens import Control.Monad (liftM)+-- import Control.Monad.Trans.Either import qualified Data.IntMap as M import Data.Traversable (mapM) import Graphics.UI.Gtk (adjustmentGetValue) -- from hoodle-platform+-- import Control.Monad.Trans.Crtn import Data.Hoodle.Generic import Data.Hoodle.Select+import qualified Data.Hoodle.Simple as S import Graphics.Hoodle.Render.Type -- from this package import Hoodle.Util@@ -77,7 +80,7 @@ -- | getPageFromGHoodleMap :: Int -> GHoodle M.IntMap a -> a getPageFromGHoodleMap pagenum = - maybeError ("getPageFromGHoodleMap " ++ show pagenum) . M.lookup pagenum . view gpages+ maybeError' ("getPageFromGHoodleMap " ++ show pagenum) . M.lookup pagenum . view gpages -- | @@ -100,9 +103,6 @@ . CanvasSinglePage . set currentPageNum pagenum . xfrmCvsInfo (const nvinfo) $ cinfo - -- return . CanvasInfoBox - -- . set currentPageNum pagenum - -- . set (viewInfo.pageArrangement) arr $ cinfo updateCvsInfoFrmHoodle hdl (CanvasContPage cinfo) = do let pagenum = view currentPageNum cinfo oarr = view (viewInfo.pageArrangement) cinfo @@ -116,18 +116,14 @@ Nothing -> return (CanvasContPage cinfo) Just ulcoord -> do let cdim = canvasDim geometry - let arr = makeContinuousArrangement zmode cdim hdl ulcoord - vinfo = view viewInfo cinfo + arr = makeContinuousArrangement zmode cdim hdl ulcoord+ let vinfo = view viewInfo cinfo nvinfo = xfrmViewInfo (const arr) vinfo return . CanvasContPage . set currentPageNum pagenum . xfrmCvsInfo (const nvinfo) $ cinfo - --- let ulcoord = maybeError "updateCvsFromHoodle" $ - - -- | updatePage :: HoodleModeState -> CanvasInfoBox -> IO CanvasInfoBox updatePage (ViewAppendState hdl) c = updateCvsInfoFrmHoodle hdl c@@ -135,13 +131,6 @@ let hdl = GHoodle (view gselTitle thdl) (view gselAll thdl) updateCvsInfoFrmHoodle hdl c --- boxAction f cinfobox--- where f :: (ViewMode a) => ViewModeSumType -> CanvasInfo a -> IO CanvasInfoBox--- f mode cinfo = do --- fcont _cinfo = do --- let hdl = GHoodle (view gselTitle thdl) (view gselAll thdl)--- updateCvsInfoFrmHoodle VMContPage hdl cinfobox- -- | setPage :: HoodleState -> PageNum -> CanvasId -> IO CanvasInfoBox setPage xstate pnum cid = do @@ -186,19 +175,27 @@ -- | -addNewPageInHoodle :: AddDirection +addNewPageInHoodle :: BackgroundStyle+ -> AddDirection -> Hoodle EditMode -> Int - -> IO (Hoodle EditMode)-addNewPageInHoodle dir hdl cpn = do + -> Hoodle EditMode -- IO (Hoodle EditMode)+addNewPageInHoodle bsty dir hdl cpn = let pagelst = M.elems . view gpages $ hdl (pagesbefore,cpage:pagesafter) = splitAt cpn pagelst- npage = newSinglePageFromOld cpage+ cbkg = view gbackground cpage+ nbkg + | isRBkgSmpl cbkg = let bkg = rbkg2Bkg cbkg + in bkg2RBkg bkg { S.bkg_style = convertBackgroundStyleToByteString bsty } + | otherwise = cbkg + npage = set gbackground nbkg + . newSinglePageFromOld + $ cpage npagelst = case dir of PageBefore -> pagesbefore ++ (npage : cpage : pagesafter) PageAfter -> pagesbefore ++ (cpage : npage : pagesafter) nhdl = set gpages (M.fromList . zip [0..] $ npagelst) hdl- return nhdl+ in nhdl -- return nhdl -- | relZoomRatio :: CanvasGeometry -> ZoomModeRel -> Double
src/Hoodle/ModelAction/Pen.hs view
@@ -19,7 +19,7 @@ import Data.Foldable import qualified Data.IntMap as IM import Data.Maybe-import qualified Data.Map as M+-- import qualified Data.Map as M import Data.Sequence hiding (take, drop) import Data.Strict.Tuple hiding (uncurry) -- from hoodle-platform @@ -47,10 +47,11 @@ addPDraw pinfo hdl (PageNum pgnum) pdraw = do let ptype = view penType pinfo pcolor = view (currentTool.penColor) pinfo- pcolname = fromJust (M.lookup pcolor penColorNameMap)+ pcolname = convertPenColorToByteString pcolor pwidth = view (currentTool.penWidth) pinfo pvwpen = view variableWidthPen pinfo (mcurrlayer,currpage) = getCurrentLayerOrSet (getPageFromGHoodleMap pgnum hdl)+ dim = view gdimension currpage currlayer = maybe (error "something wrong in addPDraw") id mcurrlayer ptool = case ptype of PenWork -> "pen" @@ -70,7 +71,7 @@ newstrokebbox = mkStrokeBBox newstroke bbox = strkbbx_bbx newstrokebbox- newlayerbbox <- updateLayerBuf (Just bbox)+ newlayerbbox <- updateLayerBuf dim (Just bbox) . over gitems (++[RItemStroke newstrokebbox]) $ currlayer
src/Hoodle/ModelAction/Select.hs view
@@ -41,8 +41,9 @@ import Graphics.Hoodle.Render.Util.HitTest -- from this package import Hoodle.ModelAction.Layer-import Hoodle.Type.Enum import Hoodle.Type.Alias+import Hoodle.Type.Enum+import Hoodle.Type.HoodleState import Hoodle.Type.Predefined import Hoodle.Type.PageArrangement import Hoodle.Util@@ -90,6 +91,7 @@ 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 @@ -118,6 +120,14 @@ 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 @@ -128,6 +138,12 @@ -- | getSelectedItms :: Page SelectMode -> [RItem] getSelectedItms = either (const []) (concatMap unHitted . getB) . rItmsInActiveLyr +-- |+getSelectedItmsFromHoodleState :: HoodleState -> Maybe [RItem] +getSelectedItmsFromHoodleState xstate = + case view hoodleModeState xstate of + ViewAppendState _ -> Nothing + SelectState thdl -> fmap (getSelectedItms.Prelude.snd) (view gselSelected thdl) -- | start a select mode with alter list selection makePageSelectMode :: Page EditMode -- ^ base page @@ -135,10 +151,8 @@ -> Page SelectMode -- ^ resultant select mode page makePageSelectMode page alist = let (mcurrlayer,npage) = getCurrentLayerOrSet page- clyr = maybeError "makePageSelectMode" mcurrlayer + clyr = maybeError' "makePageSelectMode" mcurrlayer nlyr= GLayer (view gbuffer clyr) (TEitherAlterHitted (Right alist))- -- tpg = mkHPage npage - -- npg = set (glayers.selectedLayer) nlyr tpg in set (glayers.selectedLayer) nlyr (mkHPage npage) @@ -382,8 +396,13 @@ hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2) && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2) where BBox (x1,y1) (x2,y2) = getBBox img+hitLassoItem lst (RItemSVG svg _) = + hitLassoPoint lst (x1,y1) && hitLassoPoint lst (x1,y2)+ && hitLassoPoint lst (x2,y1) && hitLassoPoint lst (x2,y2)+ where BBox (x1,y1) (x2,y2) = getBBox svg + data TempSelectRender a = TempSelectRender { tempSurface :: Surface , widthHeight :: (Double,Double) , tempSelectInfo :: a @@ -400,7 +419,7 @@ mkItmsNImg :: CanvasGeometry -> Page SelectMode -> IO ItmsNImg mkItmsNImg _geometry tpage = do let itms = getSelectedItms tpage- drawselection = mapM_ (renderItem.rItem2Item) itms + drawselection = mapM_ renderRItem itms -- (renderItem.rItem2Item) itms Dim cw ch = view gdimension tpage mbbox = case getULBBoxFromSelected tpage of Middle bbox -> Just bbox
src/Hoodle/ModelAction/Window.hs view
@@ -36,7 +36,6 @@ -- | set frame title according to file name- setTitleFromFileName :: HoodleState -> IO () setTitleFromFileName xstate = do case view currFileName xstate of@@ -46,21 +45,18 @@ [ windowTitle := takeFileName filename] -- | - newCanvasId :: CanvasInfoMap -> CanvasId newCanvasId cmap = let cids = M.keys cmap in (maximum cids) + 1 -- | initialize CanvasInfo with creating windows and connect events- initCanvasInfo :: ViewMode a => HoodleState -> CanvasId -> IO (CanvasInfo a) initCanvasInfo xstate cid = minimalCanvasInfo xstate cid >>= connectDefaultEventCanvasInfo xstate -- | only creating windows - minimalCanvasInfo :: ViewMode a => HoodleState -> CanvasId -> IO (CanvasInfo a) minimalCanvasInfo _xstate cid = do canvas <- drawingAreaNew@@ -71,7 +67,7 @@ scrolledWindowSetHAdjustment scrwin hadj scrolledWindowSetVAdjustment scrwin vadj -- scrolledWindowSetPolicy scrwin PolicyAutomatic PolicyAutomatic - return $ CanvasInfo cid canvas 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 -- | only connect events @@ -163,7 +159,7 @@ -> IO (HoodleState,WindowConfig) eventConnect xstate (Node cid) = do let cmap = getCanvasInfoMap xstate - cinfobox = maybeError "eventConnect" $ M.lookup cid cmap+ cinfobox = maybeError' "eventConnect" $ M.lookup cid cmap ncinfobox <- insideAction4CvsInfoBoxF (reinitCanvasInfoStage2 xstate) cinfobox let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate return (xstate', Node cid)
src/Hoodle/Script/Coroutine.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Script.Coroutine@@ -13,7 +15,9 @@ module Hoodle.Script.Coroutine where import Control.Lens+-- import Control.Monad import Control.Monad.State +import Control.Monad.Trans.Maybe -- from hoodle-platform import Data.Hoodle.Simple -- from this package@@ -21,26 +25,52 @@ import Hoodle.Type.Coroutine import Hoodle.Type.HoodleState -- -import Prelude hiding ((.),id) +{- -- |+runHookIO2 :: (Hook -> f) -> MainCoroutine ()+runHookIO2 a b = + liftM (H.afterSaveHook <=< view hookSet) get + >>= maybe (return ()) (\hk->liftIO (hk a b)) +-} -afterSaveHook :: Hoodle -> MainCoroutine ()-afterSaveHook hdl = do +-- | +afterSaveHook :: FilePath -> Hoodle -> MainCoroutine ()+afterSaveHook fp hdl = do xstate <- get let aftersavehk = do hset <- view hookSet xstate H.afterSaveHook hset- maybe (return ()) (\f -> liftIO (f hdl)) aftersavehk + maybe (return ()) (\f -> liftIO (f fp hdl)) aftersavehk -- | - -saveAsHook :: Hoodle -> MainCoroutine ()-saveAsHook hdl = do +saveAsHook :: FilePath -> Hoodle -> MainCoroutine ()+saveAsHook _fp hdl = do xstate <- get let saveashk = do hset <- view hookSet xstate H.saveAsHook hset maybe (return ()) (\f -> liftIO (f hdl)) saveashk +hoist :: (Monad m) => Maybe a -> MaybeT m a +hoist = MaybeT . return +-- |+recentFolderHook :: MainCoroutine (Maybe FilePath) +recentFolderHook = do + xstate <- get + (r :: Maybe FilePath) <- runMaybeT $ do + hset <- hoist (view hookSet xstate)+ rfolder <- hoist (H.recentFolderHook hset)+ liftIO rfolder+ return r ++-- | +embedPredefinedImageHook :: MainCoroutine (Maybe FilePath) +embedPredefinedImageHook = do + xstate <- get + (r :: Maybe FilePath) <- runMaybeT $ do + hset <- hoist (view hookSet xstate)+ rfilename <- hoist (H.embedPredefinedImageHook hset)+ liftIO rfilename + return r
src/Hoodle/Script/Hook.hs view
@@ -12,12 +12,30 @@ module Hoodle.Script.Hook where +-- import System.FilePath import Data.Hoodle.Simple -- | data Hook = Hook { saveAsHook :: Maybe (Hoodle -> IO ())- , afterSaveHook :: Maybe (Hoodle -> IO ())+ , afterSaveHook :: Maybe (FilePath -> Hoodle -> IO ())+ , afterOpenHook :: Maybe (FilePath -> Hoodle -> IO ()) , afterUpdateClipboardHook :: Maybe ([Item] -> IO ())+ , customContextMenuTitle :: Maybe String + , customContextMenuHook :: Maybe ([Item] -> IO ())+ , fileNameSuggestionHook :: Maybe (IO String) + , recentFolderHook :: Maybe (IO FilePath)+ , embedPredefinedImageHook :: Maybe (IO FilePath) } +defaultHook :: Hook +defaultHook = Hook { saveAsHook = Nothing+ , afterSaveHook = Nothing + , afterOpenHook = Nothing + , afterUpdateClipboardHook = Nothing+ , customContextMenuTitle = Nothing + , customContextMenuHook = Nothing + , fileNameSuggestionHook = Nothing + , recentFolderHook = Nothing + , embedPredefinedImageHook = Nothing + }
src/Hoodle/Type/Canvas.hs view
@@ -41,6 +41,7 @@ , pageArrangement , canvasId , drawArea +, mDrawSurface , scrolledWindow , viewInfo , currentPageNum @@ -84,6 +85,7 @@ import Control.Lens import qualified Data.IntMap as M import Data.Sequence+import Graphics.Rendering.Cairo import Graphics.UI.Gtk hiding (get,set) -- import Data.Hoodle.Simple (Dimension(..))@@ -101,7 +103,11 @@ -- | data PenDraw = PenDraw { _points :: Seq (Double,Double) } deriving (Show)- ++-- | lens for zoomMode +points :: Simple Lens PenDraw (Seq (Double,Double))+points = lens _points (\f a -> f { _points = a } )+ -- | data ViewInfo a = (ViewMode a) => ViewInfo { _zoomMode :: ZoomMode @@ -142,6 +148,7 @@ data CanvasInfo a = (ViewMode a) => CanvasInfo { _canvasId :: CanvasId , _drawArea :: DrawingArea+ , _mDrawSurface :: Maybe Surface , _scrolledWindow :: ScrolledWindow , _viewInfo :: ViewInfo a , _currentPageNum :: Int@@ -150,13 +157,15 @@ , _horizAdjConnId :: Maybe (ConnectId Adjustment) , _vertAdjConnId :: Maybe (ConnectId Adjustment) }- ++-- | xfrmCvsInfo :: (ViewMode a, ViewMode b) => (ViewInfo a -> ViewInfo b) -> CanvasInfo a -> CanvasInfo b xfrmCvsInfo f CanvasInfo {..} = CanvasInfo { _canvasId = _canvasId , _drawArea = _drawArea + , _mDrawSurface = _mDrawSurface , _scrolledWindow = _scrolledWindow , _viewInfo = f _viewInfo , _currentPageNum = _currentPageNum @@ -165,11 +174,13 @@ , _horizAdjConnId = _horizAdjConnId , _vertAdjConnId = _vertAdjConnId }- ++-- | defaultCvsInfoSinglePage :: CanvasInfo SinglePage defaultCvsInfoSinglePage = CanvasInfo { _canvasId = error "cvsid" , _drawArea = error "DrawingArea"+ , _mDrawSurface = Nothing , _scrolledWindow = error "ScrolledWindow" , _viewInfo = defaultViewInfoSinglePage , _currentPageNum = 0 @@ -188,6 +199,11 @@ drawArea = lens _drawArea (\f a -> f { _drawArea = a }) -- | +mDrawSurface :: Simple Lens (CanvasInfo a) (Maybe Surface) +mDrawSurface = lens _mDrawSurface (\f a -> f { _mDrawSurface = a })+++-- | scrolledWindow :: Simple Lens (CanvasInfo a) ScrolledWindow scrolledWindow = lens _scrolledWindow (\f a -> f { _scrolledWindow = a }) @@ -276,12 +292,6 @@ selectBoxAction _fsingle fcont (CanvasContPage cinfo) = fcont cinfo -{- case view (viewInfo.pageArrangement) cinfo of - SingleArrangement _ _ _ -> fsingle cinfo - ContinuousArrangement _ _ _ _ -> fcont cinfo --}-- -- | selectBox :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) -> (CanvasInfo ContinuousPage -> CanvasInfo ContinuousPage)@@ -289,23 +299,6 @@ selectBox fs _fc (CanvasSinglePage cinfo) = CanvasSinglePage (fs cinfo) selectBox _fs fc (CanvasContPage cinfo)= CanvasContPage (fc cinfo) - --- let idaction :: CanvasInfoBox -> Identity CanvasInfoBox--- idaction = selectBoxAction (return . CanvasInfoBox . fsingle) (return . CanvasInfoBox . fcont)--- in runIdentity . idaction ----{--viewModeBranch :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) - -> (CanvasInfo ContinuousPage -> CanvasInfo ContinuousPage) - -> CanvasInfo v -> CanvasInfo v -viewModeBranch fsingle fcont cinfo = - case view (viewInfo.pageArrangement) cinfo of - SingleArrangement _ _ _ -> fsingle cinfo - ContinuousArrangement _ _ _ _ -> fcont cinfo --}- -- | type CanvasInfoMap = M.IntMap CanvasInfoBox @@ -314,6 +307,15 @@ , _penColor :: PenColor } deriving (Show) +-- | lens for penWidth+penWidth :: Simple Lens WidthColorStyle Double+penWidth = lens _penWidth (\f a -> f { _penWidth = a } )++-- | lens for penColor+penColor :: Simple Lens WidthColorStyle PenColor+penColor = lens _penColor (\f a -> f { _penColor = a } )++ -- | data PenHighlighterEraserSet = PenHighlighterEraserSet { _currPen :: WidthColorStyle @@ -321,6 +323,26 @@ , _currEraser :: WidthColorStyle , _currText :: WidthColorStyle} deriving (Show) ++-- | lens for currPen+currPen :: Simple Lens PenHighlighterEraserSet WidthColorStyle+currPen = lens _currPen (\f a -> f { _currPen = a } )++-- | lens for currHighlighter+currHighlighter :: Simple Lens PenHighlighterEraserSet WidthColorStyle+currHighlighter = lens _currHighlighter (\f a -> f { _currHighlighter = a } )++-- | lens for currEraser+currEraser :: Simple Lens PenHighlighterEraserSet WidthColorStyle+currEraser = lens _currEraser (\f a -> f { _currEraser = a } )++-- | lens for currText+currText :: Simple Lens PenHighlighterEraserSet WidthColorStyle+currText = lens _currText (\f a -> f { _currText = a } )++++ -- | data PenInfo = PenInfo { _penType :: PenType@@ -329,6 +351,22 @@ } deriving (Show) +-- | lens for penType+penType :: Simple Lens PenInfo PenType +penType = lens _penType (\f a -> f { _penType = a } )++-- | lens for penSet+penSet :: Simple Lens PenInfo PenHighlighterEraserSet+penSet = lens _penSet (\f a -> f { _penSet = a } )++-- | lens for variableWidthPen+variableWidthPen :: Simple Lens PenInfo Bool+variableWidthPen = lens _variableWidthPen (\f a -> f { _variableWidthPen = a } )+++++ -- | currentTool :: Simple Lens PenInfo WidthColorStyle currentTool = lens chooser setter@@ -336,14 +374,14 @@ PenWork -> _currPen . _penSet $ pinfo HighlighterWork -> _currHighlighter . _penSet $ pinfo EraserWork -> _currEraser . _penSet $ pinfo- TextWork -> _currText . _penSet $ pinfo + -- TextWork -> _currText . _penSet $ pinfo setter pinfo wcs = let pset = _penSet pinfo psetnew = case _penType pinfo of PenWork -> pset { _currPen = wcs } HighlighterWork -> pset { _currHighlighter = wcs } EraserWork -> pset { _currEraser = wcs }- TextWork -> pset { _currText = wcs }+ -- TextWork -> pset { _currText = wcs } in pinfo { _penSet = psetnew } -- | @@ -373,17 +411,21 @@ , _variableWidthPen = False } -makeLenses ''PenDraw--- makeLenses ''ViewInfo-makeLenses ''PenInfo-makeLenses ''PenHighlighterEraserSet-makeLenses ''WidthColorStyle +++++-- makeLenses ''PenDraw+-- makeLenses ''PenInfo+-- makeLenses ''PenHighlighterEraserSet+-- makeLenses ''WidthColorStyle + -- | updateCanvasDimForSingle :: CanvasDimension -> CanvasInfo SinglePage - -> CanvasInfo SinglePage -updateCanvasDimForSingle cdim@(CanvasDimension (Dim w' h')) cinfo = + -> IO (CanvasInfo SinglePage)+updateCanvasDimForSingle cdim@(CanvasDimension (Dim w' h')) cinfo = do let zmode = view (viewInfo.zoomMode) cinfo SingleArrangement _ pdim (ViewPortBBox bbox) = view (viewInfo.pageArrangement) cinfo@@ -391,15 +433,23 @@ (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy) arr' = SingleArrangement cdim pdim (ViewPortBBox nbbox)- in set (viewInfo.pageArrangement) arr' cinfo+ maybe (return ()) surfaceFinish $ view mDrawSurface cinfo + msfc <- fmap Just $ do + sfc <- createImageSurface FormatARGB32 (floor w') (floor h')+ renderWith sfc $ do + setSourceRGBA 0.5 0.5 0.5 1 + rectangle 0 0 w' h' + fill + return sfc + return $ (set (viewInfo.pageArrangement) arr' . set mDrawSurface msfc) cinfo -- | updateCanvasDimForContSingle :: PageDimension -> CanvasDimension -> CanvasInfo ContinuousPage - -> CanvasInfo ContinuousPage -updateCanvasDimForContSingle pdim cdim@(CanvasDimension (Dim w' h')) cinfo = + -> IO (CanvasInfo ContinuousPage) +updateCanvasDimForContSingle pdim cdim@(CanvasDimension (Dim w' h')) cinfo = do let zmode = view (viewInfo.zoomMode) cinfo ContinuousArrangement _ ddim func (ViewPortBBox bbox) = view (viewInfo.pageArrangement) cinfo@@ -407,5 +457,13 @@ (sinvx,sinvy) = getRatioPageCanvas zmode pdim cdim nbbox = BBox (x,y) (x+w'/sinvx,y+h'/sinvy) arr' = ContinuousArrangement cdim ddim func (ViewPortBBox nbbox)- in set (viewInfo.pageArrangement) arr' cinfo+ maybe (return ()) surfaceFinish $ view mDrawSurface cinfo + msfc <- fmap Just $ do + sfc <- createImageSurface FormatARGB32 (floor w') (floor h')+ renderWith sfc $ do + setSourceRGBA 0.5 0.5 0.5 1 + rectangle 0 0 w' h' + fill + return sfc + return $ (set (viewInfo.pageArrangement) arr'.set mDrawSurface msfc) cinfo
src/Hoodle/Type/Clipboard.hs view
@@ -52,4 +52,8 @@ } deriving (Show) -makeLenses ''SelectInfo++selectType :: Simple Lens SelectInfo SelectType +selectType = lens _selectType (\f a -> f { _selectType = a })++-- makeLenses ''SelectInfo
src/Hoodle/Type/Coroutine.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE GADTs, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- |@@ -18,9 +22,10 @@ import Control.Applicative import Control.Concurrent import Control.Lens -import Control.Monad.Error+-- import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Trans.Either -- import Data.IORef -- from hoodle-platform import Control.Monad.Trans.Crtn @@ -32,6 +37,7 @@ -- from this package import Hoodle.Type.Event import Hoodle.Type.HoodleState +import Hoodle.Util -- -- |@@ -41,13 +47,17 @@ doEvent :: (Monad m) => MyEvent -> CObjT MainOp m () doEvent ev = request (Arg DoEvent ev) >> return () +instance (Monad m) => MonadState HoodleState (EStT HoodleState m) where+ get = lift get+ put = lift . put + -- | type MainCoroutine = MainObjB -type MainObjB = SObjBT MainOp (StateT HoodleState WorldObjB)+type MainObjB = SObjBT MainOp (EStT HoodleState WorldObjB) -- | -type MainObj = SObjT MainOp (StateT HoodleState WorldObjB)+type MainObj = SObjT MainOp (EStT HoodleState WorldObjB) -- | nextevent :: MainCoroutine MyEvent @@ -62,34 +72,39 @@ -- | world :: HoodleState -> MainObj () -> WorldObj ()+-- world :: HoodleState -> (ReaderT (Arg MainOp) MainCoroutine ()) -> WorldObj () world xstate initmc = ReaderT staction where - staction req = runStateT (go initmc req) xstate >> return ()- go :: MainObj () + staction req = runStateT erract xstate >> return ()+ -- where erract = go initmc req + where erract = do r <- runEitherT (go initmc req) + case r of + Left e -> liftIO (errorlog (show e)) + Right _r' -> return () -- return r' + go :: MainObj() -> Arg (WorldOp MyEvent DriverB) - -> StateT HoodleState WorldObjB () + -> EStT HoodleState WorldObjB () go mcobj (Arg GiveEvent ev) = do - Right mcobj' <- runErrorT $ liftM fst (mcobj <==| doEvent ev)- req <- lift $ request (Res GiveEvent ())+ Right mcobj' <- liftM (fmap fst) (mcobj <==| doEvent ev)+ req <- lift . lift $ request (Res GiveEvent ()) go mcobj' req go mcobj (Arg FlushLog logobj) = do logf <- (^. tempLog) <$> get let msg = logf "" if ((not.null) msg) then do - Right logobj' <- lift . lift $ runErrorT $ - liftM fst (logobj <==| writeLog msg)+ Right logobj' <- lift . lift . lift $ liftM (fmap fst) (logobj <==| writeLog msg) modify (tempLog .~ id)- req <- lift $ request (Res FlushLog logobj')+ req <- lift . lift $ request (Res FlushLog logobj') go mcobj req else do - req <- lift $ request Ign + req <- lift . lift $ request Ign go mcobj req go mcobj (Arg FlushQueue ()) = do q <- (^. tempQueue) <$> get let lst = fqueue q ++ reverse (bqueue q) modify (tempQueue .~ emptyQueue)- req <- lift $ request (Res FlushQueue lst)+ req <- lift . lift $ request (Res FlushQueue lst) go mcobj req @@ -104,6 +119,12 @@ -- | type EventVar = MVar (Maybe (Driver ())) ++++-- | +maybeError :: String -> Maybe a -> MainCoroutine a+maybeError str = maybe (lift . hoistEither . Left . Other $ str) return
src/Hoodle/Type/Enum.hs view
@@ -17,6 +17,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import Data.Maybe +-- import Numeric (showHex) -- import Data.Hoodle.Predefined @@ -34,9 +35,10 @@ data PenType = PenWork | HighlighterWork | EraserWork - | TextWork deriving (Show,Eq,Ord) +-- TextWork + -- | data PenColor = ColorBlack | ColorBlue @@ -52,6 +54,12 @@ | ColorRGBA Double Double Double Double deriving (Show,Eq,Ord) +data BackgroundStyle = BkgStylePlain + | BkgStyleLined+ | BkgStyleRuled+ | BkgStyleGraph+ deriving (Show,Eq,Ord)+ penColorNameMap :: M.Map PenColor B.ByteString penColorNameMap = M.fromList [ (ColorBlack, "black") , (ColorBlue , "blue")@@ -72,4 +80,23 @@ convertPenColorToRGBA :: PenColor -> (Double,Double,Double,Double) convertPenColorToRGBA (ColorRGBA r g b a) = (r,g,b,a) convertPenColorToRGBA c = fromJust (M.lookup c penColorRGBAmap)++convertRGBAToHex :: (Double,Double,Double,Double) -> B.ByteString +convertRGBAToHex = B.pack . rgbaToHEX +++convertPenColorToByteString :: PenColor-> B.ByteString +convertPenColorToByteString pcol = + let mpcolname = M.lookup pcol penColorNameMap + pcolname = case mpcolname of + Nothing -> (convertRGBAToHex . convertPenColorToRGBA) pcol+ Just n -> n+ in pcolname +++convertBackgroundStyleToByteString :: BackgroundStyle -> B.ByteString +convertBackgroundStyleToByteString BkgStylePlain = "plain"+convertBackgroundStyleToByteString BkgStyleLined = "lined"+convertBackgroundStyleToByteString BkgStyleRuled = "ruled"+convertBackgroundStyleToByteString BkgStyleGraph = "graph"
src/Hoodle/Type/Event.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Hoodle.Type.Event --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,6 +12,7 @@ module Hoodle.Type.Event where +import Data.ByteString -- from other package import Graphics.UI.Gtk -- from hoodle-platform@@ -21,6 +22,8 @@ import Hoodle.Device import Hoodle.Type.Clipboard import Hoodle.Type.Enum+import Hoodle.Type.Canvas+import Hoodle.Type.PageArrangement -- | @@ -33,6 +36,7 @@ | PenColorChanged PenColor | PenWidthChanged Int -- (PenType -> Double) | AssignPenMode (Either PenType SelectType) + | BackgroundStyleChanged BackgroundStyle | HScrollBarMoved Int Double | VScrollBarMoved Int Double | VScrollBarStart Int Double@@ -48,7 +52,12 @@ | GotOk | OkCancel Bool | FileChosen (Maybe FilePath)+ | ColorChosen (Maybe PenColor) | GotClipboardContent (Maybe [Item])+ | ContextMenuCreated+ | GotContextMenuSignal ContextMenuEvent+ | LaTeXInput (Maybe (ByteString,ByteString))+ | TextInput (Maybe String) -- | EventConnected | EventDisconnected deriving (Show,Eq,Ord)@@ -57,12 +66,15 @@ -- | data MenuEvent = MenuNew | MenuAnnotatePDF- | MenuLoadImage | MenuOpen | MenuSave | MenuSaveAs | MenuReload | MenuRecentDocument+ | MenuLoadPNGorJPG+ | MenuLoadSVG+ | MenuLaTeX+ | MenuEmbedPredefinedImage | MenuPrint | MenuExport | MenuQuit @@ -95,6 +107,7 @@ | MenuNewPageAfter | MenuNewPageAtEnd | MenuDeletePage+ | MenuExportPageSVG | MenuNewLayer | MenuNextLayer | MenuPrevLayer @@ -108,6 +121,7 @@ | MenuBackgroundScreenshot | MenuDefaultPaper | MenuSetAsDefaultPaper+ | MenuText | MenuShapeRecognizer | MenuRuler | MenuSelectRegion@@ -118,6 +132,7 @@ | MenuEraserOptions | MenuHighlighterOptions | MenuTextFont+ | MenuColorPicker | MenuDefaultPen | MenuDefaultEraser | MenuDefaultHighlighter@@ -125,6 +140,9 @@ | MenuSetAsDefaultOption | MenuRelaunch | MenuUseXInput+ | MenuSmoothScroll+ | MenuUsePopUpMenu+ | MenuEmbedImage | MenuDiscardCoreEvents | MenuEraserTip | MenuPressureSensitivity@@ -143,7 +161,21 @@ | MenuAbout | MenuDefault deriving (Show, Ord, Eq)- ++-- |+data ImgType = SVG | PDF + deriving (Show, Ord, Eq) + +-- | +data ContextMenuEvent = CMenuSaveSelectionAs ImgType+ | CMenuCut + | CMenuCopy+ | CMenuDelete+ | CMenuCanvasView CanvasId PageNum Double Double + | CMenuCustom+ deriving (Show, Ord, Eq) ++-- | viewModeToMyEvent :: RadioAction -> IO MyEvent viewModeToMyEvent a = do v <- radioActionGetCurrentValue a
src/Hoodle/Type/HoodleState.hs view
@@ -33,6 +33,12 @@ , gtkUIManager , isSaved , undoTable+, backgroundStyle +, isFullScreen +, doesUseXInput +, doesSmoothScroll +, doesUsePopUpMenu+, doesEmbedImage , isOneTimeSelectMode , pageModeSignal , lastTimeCanvasConfigure@@ -81,6 +87,7 @@ -- from this package import Hoodle.Device import Hoodle.Script.Hook+import Hoodle.Type.Enum import Hoodle.Type.Event import Hoodle.Type.Canvas import Hoodle.Type.Clipboard@@ -125,6 +132,12 @@ , _gtkUIManager :: UIManager , _isSaved :: Bool , _undoTable :: UndoTable HoodleModeState+ , _backgroundStyle :: BackgroundStyle + , _isFullScreen :: Bool + , _doesUseXInput :: Bool + , _doesSmoothScroll :: Bool + , _doesUsePopUpMenu :: Bool + , _doesEmbedImage :: Bool , _isOneTimeSelectMode :: IsOneTimeSelectMode , _pageModeSignal :: Maybe (ConnectId RadioAction) , _lastTimeCanvasConfigure :: Maybe UTCTime @@ -133,9 +146,121 @@ , _tempLog :: String -> String } +-- | lens for hoodleModeState+hoodleModeState :: Simple Lens HoodleState HoodleModeState+hoodleModeState = lens _hoodleModeState (\f a -> f { _hoodleModeState = a } ) -makeLenses ''HoodleState +-- | lens for currFileName+currFileName :: Simple Lens HoodleState (Maybe FilePath)+currFileName = lens _currFileName (\f a -> f { _currFileName = a } ) +-- | lens for cvsInfoMap+cvsInfoMap :: Simple Lens HoodleState CanvasInfoMap+cvsInfoMap = lens _cvsInfoMap (\f a -> f { _cvsInfoMap = a } )++-- | lens for currentCanvas+currentCanvas :: Simple Lens HoodleState (CanvasId,CanvasInfoBox)+currentCanvas = lens _currentCanvas (\f a -> f { _currentCanvas = a } )++-- | lens for frameState+frameState :: Simple Lens HoodleState WindowConfig+frameState = lens _frameState (\f a -> f { _frameState = a } )++-- | lens for rootWindow+rootWindow :: Simple Lens HoodleState Widget+rootWindow = lens _rootWindow (\f a -> f { _rootWindow = a } )++-- | lens for rootContainer+rootContainer :: Simple Lens HoodleState Box+rootContainer = lens _rootContainer (\f a -> f { _rootContainer = a } )++-- | lens for rootOfRootWindow+rootOfRootWindow :: Simple Lens HoodleState Window+rootOfRootWindow = lens _rootOfRootWindow (\f a -> f { _rootOfRootWindow = a } )++-- | lens for currentPenDraw+currentPenDraw :: Simple Lens HoodleState PenDraw+currentPenDraw = lens _currentPenDraw (\f a -> f { _currentPenDraw = a } )++-- | lens for callBack+callBack :: Simple Lens HoodleState (MyEvent -> IO ())+callBack = lens _callBack (\f a -> f { _callBack = a } )++-- | lens for deviceList+deviceList :: Simple Lens HoodleState DeviceList +deviceList = lens _deviceList (\f a -> f { _deviceList = a } )++-- | lens for penInfo+penInfo :: Simple Lens HoodleState PenInfo+penInfo = lens _penInfo (\f a -> f { _penInfo = a } )++-- | lens for selectInfo+selectInfo :: Simple Lens HoodleState SelectInfo+selectInfo = lens _selectInfo (\f a -> f { _selectInfo = a } )++-- | lens for gtkUIManager+gtkUIManager :: Simple Lens HoodleState UIManager+gtkUIManager = lens _gtkUIManager (\f a -> f { _gtkUIManager = a } )++-- | lens for isSaved+isSaved :: Simple Lens HoodleState Bool+isSaved = lens _isSaved (\f a -> f { _isSaved = a } )++-- | lens for undoTable+undoTable :: Simple Lens HoodleState (UndoTable HoodleModeState)+undoTable = lens _undoTable (\f a -> f { _undoTable = a } )++-- | background style = plain, lined, ruled, graph+backgroundStyle :: Simple Lens HoodleState BackgroundStyle+backgroundStyle = lens _backgroundStyle (\f a -> f { _backgroundStyle = a } )++-- | lens for isFullScreen+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 } )++-- | flag for embedding image as base64 in hdl file +doesEmbedImage :: Simple Lens HoodleState Bool+doesEmbedImage = lens _doesEmbedImage (\f a -> f { _doesEmbedImage = 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 } )++-- | lens for hookSet+hookSet :: Simple Lens HoodleState (Maybe Hook)+hookSet = lens _hookSet (\f a -> f { _hookSet = a } )++-- | lens for tempQueue+tempQueue :: Simple Lens HoodleState (Queue (Either (ActionOrder MyEvent) MyEvent))+tempQueue = lens _tempQueue (\f a -> f { _tempQueue = a } )++-- | lens for tempLog+tempLog :: Simple Lens HoodleState (String -> String)+tempLog = lens _tempLog (\f a -> f { _tempLog = a } )+++-- makeLenses ''HoodleState + emptyHoodleState :: HoodleState emptyHoodleState = HoodleState @@ -157,6 +282,12 @@ , _isSaved = False , _undoTable = emptyUndo 1 -- , _isEventBlocked = False + , _backgroundStyle = BkgStyleLined+ , _isFullScreen = False+ , _doesUseXInput = False+ , _doesSmoothScroll = False+ , _doesUsePopUpMenu = True + , _doesEmbedImage = True , _isOneTimeSelectMode = NoOneTimeSelectMode , _pageModeSignal = Nothing , _lastTimeCanvasConfigure = Nothing @@ -212,19 +343,22 @@ cmap' = M.adjust (const a) cid (_cvsInfoMap f) in f { _currentCanvas = (cid,a), _cvsInfoMap = cmap' } +-- | resetHoodleModeStateBuffers :: HoodleModeState -> IO HoodleModeState resetHoodleModeStateBuffers hdlmodestate1 = case hdlmodestate1 of ViewAppendState hdl -> liftIO . liftM ViewAppendState . updateHoodleBuf $ hdl _ -> return hdlmodestate1 ++ -- | getCanvasInfo :: CanvasId -> HoodleState -> CanvasInfoBox getCanvasInfo cid xstate = let cinfoMap = getCanvasInfoMap xstate maybeCvs = M.lookup cid cinfoMap- in maybeError ("no canvas with id = " ++ show cid) maybeCvs+ in maybeError' ("no canvas with id = " ++ show cid) maybeCvs -- | @@ -297,16 +431,14 @@ SelectState thdl -> Right thdl -- | - getCurrentPageFromHoodleModeState :: (ViewMode a) => CanvasInfo a -> HoodleModeState -> Page EditMode getCurrentPageFromHoodleModeState cinfo hdlmodst = let cpn = view currentPageNum cinfo pagemap = getPageMapFromHoodleModeState hdlmodst - in maybeError "updatePageFromCanvasToHoodle" $ M.lookup cpn pagemap + in maybeError' "updatePageFromCanvasToHoodle" $ M.lookup cpn pagemap -- | - getCurrentPageDimFromHoodleModeState :: (ViewMode a) => CanvasInfo a -> HoodleModeState -> PageDimension getCurrentPageDimFromHoodleModeState cinfo =
src/Hoodle/Type/PageArrangement.hs view
@@ -17,9 +17,10 @@ -- from other packages import Control.Applicative import Control.Category ((.))+-- import Control.Error.Util (note) import Control.Lens import Data.Foldable (toList)-import Data.Maybe (fromJust)+-- import Data.Maybe (fromJust) -- from hoodle-platform import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic@@ -143,7 +144,6 @@ -- | data DesktopConstraint = DesktopWidthConstrained Double - -- | makeContinuousArrangement :: ZoomMode -> CanvasDimension @@ -155,10 +155,10 @@ 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 + (PageOrigin (x0,y0),_) = maybeError' "makeContArr" (pageArrFuncCont cnstrnt hdl pnum)+ ddim@(DesktopDimension (Dim w h)) = deskDimCont cnstrnt hdl (x1,y1) = (xpos+x0,ypos+y0) (x2,y2) = (xpos+x0+cw/sinvx,ypos+y0+ch/sinvy) - ddim@(DesktopDimension (Dim w h)) = deskDimCont cnstrnt hdl (x1',x2') | x2>w && w-(x2-x1)>0 = (w-(x2-x1),w) | x2>w && w-(x2-x1)<=0 = (0,x2-x1) @@ -168,7 +168,7 @@ | 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 + in ContinuousArrangement cdim ddim (pageArrFuncCont cnstrnt hdl) vport -- | pageArrFuncCont :: DesktopConstraint@@ -176,8 +176,8 @@ -> PageNum -> Maybe (PageOrigin,PageDimension) pageArrFuncCont (DesktopWidthConstrained w') hdl (PageNum n)- | n < 0 = Nothing - | n >= len = Nothing + | n < 0 = Nothing+ | n >= len = Nothing | otherwise = Just (PageOrigin (xys !! n), PageDimension (pdims !! n)) where addf (x,y) (w,h) = if x+2*w+predefinedPageSpacing < w' then (x+w+predefinedPageSpacing,y)@@ -190,10 +190,11 @@ -- | deskDimCont :: DesktopConstraint -> Hoodle EditMode -> DesktopDimension -deskDimCont cnstrnt hdl = +deskDimCont cnstrnt hdl = let pgs = toList . view gpages $ hdl len = length pgs - olst = map (fromJust . pageArrFuncCont cnstrnt hdl . PageNum) [0..len-1]+ olst = maybeError' "deskDimCont" $+ mapM (pageArrFuncCont cnstrnt hdl . PageNum) [0..len-1] f (PageOrigin (x,y),PageDimension (Dim w h)) (Dim w' h') = let w'' = if w' < x+w then x+w else w' h'' = if h' < y+h then y+h else h'
src/Hoodle/Type/Predefined.hs view
@@ -47,5 +47,5 @@ -- | predefinedZoomStepFactor :: Double-predefinedZoomStepFactor = 1.5+predefinedZoomStepFactor = 1.10
src/Hoodle/Util.hs view
@@ -15,9 +15,13 @@ import Data.Maybe import Data.Hoodle.Simple --- import Data.Time.Clock --- import Data.Time.Format--- import System.Locale+import System.Directory +import System.Environment +import System.FilePath+import System.IO+import Data.Time.Clock +import Data.Time.Format+import System.Locale -- for test -- import Blaze.ByteString.Builder@@ -49,8 +53,6 @@ maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads -maybeError :: String -> Maybe a -> a-maybeError str = maybe (error str) id getLargestWidth :: Hoodle -> Double getLargestWidth hdl = @@ -70,6 +72,23 @@ else waitUntil p act -- | for debugging+errorlog :: String -> IO ()+errorlog str = do + homepath <- getEnv "HOME"+ let dir = homepath </> ".hoodle.d"+ createDirectoryIfMissing False dir+ outh <- openFile (dir </> "error.log") AppendMode + utctime <- getCurrentTime + let timestr = formatTime defaultTimeLocale "%F %H:%M:%S %Z" utctime+ hPutStr outh (timestr ++ " : " ) + hPutStrLn outh str+ hClose outh ++-- | +maybeError' :: String -> Maybe a -> a+maybeError' str = maybe (error str) id++ {- timeShow :: String -> IO () timeShow msg =
− src/Hoodle/Util/Verbatim.hs
@@ -1,26 +0,0 @@---------------------------------------------------------------------------------- |--- Module : Hoodle.Util.Verbatim --- Copyright : (c) 2011, 2012 Ian-Woo Kim------ License : BSD3--- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>--- Stability : experimental--- Portability : GHC----module Hoodle.Util.Verbatim where--import Language.Haskell.TH.Quote--import Language.Haskell.TH.Lib--verbatim :: QuasiQuoter-verbatim = QuasiQuoter { quoteExp = litE . stringL- , quotePat = undefined- , quoteType = undefined - , quoteDec = undefined- }--- , quotePat = litP . stringP--- } -
src/Hoodle/View/Draw.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE GADTs, Rank2Types, TypeFamilies #-}+{-# LANGUAGE GADTs, Rank2Types, TypeFamilies, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Hoodle.View.Draw --- Copyright : (c) 2011, 2012 Ian-Woo Kim+-- Copyright : (c) 2011-2013 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,8 +14,12 @@ module Hoodle.View.Draw where --- import Control.Applicative ((<$>))-import Graphics.UI.Gtk hiding (get)+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) import Graphics.Rendering.Cairo import Control.Category ((.)) import Control.Lens@@ -46,11 +50,12 @@ import Hoodle.Type.Enum import Hoodle.View.Coordinate -- -import Prelude hiding ((.),id,mapM_,concatMap)+import Prelude hiding ((.),id,mapM_,concatMap,foldr) -- | -data DrawFlag = Clear | Efficient-+data DrawFlag = Clear | BkgEfficient | Efficient+ deriving (Eq,Ord,Show)+ -- | type family DrawingFunction v :: * -> * @@ -58,7 +63,7 @@ newtype SinglePageDraw a = SinglePageDraw { unSinglePageDraw :: Bool - -> DrawingArea + -> (DrawingArea, Maybe Surface) -> (PageNum, Page a) -> ViewInfo SinglePage -> Maybe BBox @@ -85,7 +90,6 @@ type instance DrawingFunction ContinuousPage = ContPageDraw -- | - getCanvasViewPort :: CanvasGeometry -> ViewPortBBox getCanvasViewPort geometry = let DeskCoord (x0,y0) = canvas2Desktop geometry (CvsCoord (0,0)) @@ -94,14 +98,12 @@ in ViewPortBBox (BBox (x0,y0) (x1,y1)) -- | - getBBoxInPageCoord :: CanvasGeometry -> PageNum -> BBox -> BBox getBBoxInPageCoord geometry pnum bbox = let DeskCoord (x0,y0) = page2Desktop geometry (pnum,PageCoord (0,0)) in moveBBoxByOffset (-x0,-y0) bbox -- | - getViewableBBox :: CanvasGeometry -> Maybe BBox -- ^ in desktop coordinate -> IntersectBBox@@ -110,35 +112,46 @@ in (fromMaybe mbbox :: IntersectBBox) `mappend` (Intersect (Middle vportbbox)) -- | common routine for double buffering --doubleBufferDraw :: DrawWindow -> CanvasGeometry -> Render () -> Render a +doubleBufferDraw :: (DrawWindow, Maybe Surface) + -> CanvasGeometry -> Render () -> Render a -> IntersectBBox -> IO (Maybe a)-doubleBufferDraw win geometry _xform rndr (Intersect ibbox) = do +doubleBufferDraw (win,msfc) geometry _xform rndr (Intersect ibbox) = do let Dim cw ch = unCanvasDimension . canvasDim $ geometry mbbox' = case ibbox of Top -> Just (BBox (0,0) (cw,ch)) Middle bbox -> Just (xformBBox (unCvsCoord . desktop2Canvas geometry . DeskCoord) bbox) Bottom -> Nothing - let action = withImageSurface FormatARGB32 (floor cw) (floor ch) $ - \tempsurface -> do - renderWith tempsurface $ do - setSourceRGBA 0.5 0.5 0.5 1- rectangle 0 0 cw ch - fill - rndr - renderWithDrawable win $ do - clipBBox mbbox'- setSourceSurface tempsurface 0 0 - setOperator OperatorSource - paint + let action = do + case msfc of + Nothing -> do + renderWithDrawable win $ do + clipBBox mbbox'+ setSourceRGBA 0.5 0.5 0.5 1+ rectangle 0 0 cw ch + fill + rndr + -- return () + Just sfc -> do + r <- renderWith sfc $ do + clipBBox (fmap (flip inflate (-1.0)) mbbox')+ setSourceRGBA 0.5 0.5 0.5 1+ rectangle 0 0 cw ch + fill+ clipBBox mbbox' + rndr + renderWithDrawable win $ do + setSourceSurface sfc 0 0 + setOperator OperatorSource + paint + return r + -- return () case ibbox of- Top -> action >> return Nothing - Middle _ -> action >> return Nothing + Top -> Just <$> action -- >> return Nothing + Middle _ -> Just <$> action -- >> return Nothing Bottom -> return Nothing -- | - cairoXform4PageCoordinate :: CanvasGeometry -> PageNum -> Render () cairoXform4PageCoordinate geometry pnum = do let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0))@@ -153,7 +166,7 @@ -- | drawCurvebitGen :: PressureMode - -> DrawingArea + -> (DrawingArea, Maybe Surface) -> CanvasGeometry -> Double -> (Double,Double,Double,Double) @@ -161,7 +174,7 @@ -> ((Double,Double),Double) -> ((Double,Double),Double) -> IO () -drawCurvebitGen pmode canvas geometry wdth (r,g,b,a) pnum ((x0,y0),z0) ((x,y),z) = do +drawCurvebitGen pmode (canvas,_msfc) geometry wdth (r,g,b,a) pnum ((x0,y0),z0) ((x,y),z) = do win <- widgetGetDrawWindow canvas renderWithDrawable win $ do cairoXform4PageCoordinate geometry pnum @@ -188,7 +201,7 @@ -> ((PageNum,Page em) -> Maybe BBox -> DrawFlag -> Render (Page em)) -> DrawingFunction SinglePage em drawFuncGen _typ render = SinglePageDraw func - where func isCurrentCvs canvas (pnum,page) vinfo mbbox flag = do + where func isCurrentCvs (canvas,msfc) (pnum,page) vinfo mbbox flag = do let arr = view pageArrangement vinfo geometry <- makeCanvasGeometry pnum arr canvas win <- widgetGetDrawWindow canvas@@ -202,7 +215,7 @@ when isCurrentCvs (emphasisCanvasRender ColorBlue geometry) resetClip return pg - doubleBufferDraw win geometry xformfunc renderfunc ibboxnew + doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew >>= maybe (return page) return @@ -219,20 +232,36 @@ let CanvasDimension (Dim cw ch) = canvasDim geometry let (r,g,b,a) = convertPenColorToRGBA pcolor setSourceRGBA r g b a - setLineWidth 10+ setLineWidth 2 rectangle 0 0 cw ch stroke +emphasisPageRender :: CanvasGeometry -> (PageNum,Page EditMode) -> Render ()+emphasisPageRender geometry (pn,pg) = do + save+ identityMatrix + cairoXform4PageCoordinate geometry pn + let Dim w h = view gdimension pg + setSourceRGBA 0 0 1.0 1 + setLineWidth 2 + rectangle 0 0 w h + stroke+ restore ++ -- |-drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render ()) +drawContPageGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page EditMode)) -> DrawingFunction ContinuousPage EditMode drawContPageGen render = ContPageDraw func - where func isCurrentCvs cinfo mbbox hdl flag = do + where func :: Bool -> CanvasInfo ContinuousPage ->Maybe BBox -> Hoodle EditMode -> DrawFlag -> IO (Hoodle EditMode)+ func isCurrentCvs cinfo mbbox hdl flag = do let arr = view (viewInfo.pageArrangement) cinfo pnum = PageNum . view currentPageNum $ cinfo canvas = view drawArea cinfo + msfc = view mDrawSurface cinfo geometry <- makeCanvasGeometry pnum arr canvas let pgs = view gpages hdl + mcpg = view (at (unPageNum pnum)) pgs let drawpgs = catMaybes . map f $ (getPagesInViewPortRange geometry hdl) where f k = maybe Nothing (\a->Just (k,a)) @@ -249,34 +278,35 @@ render (pn,pg) pgmbbox flag renderfunc = do xformfunc - mapM_ onepagerender drawpgs + -- mapM_ onepagerender drawpgs + ndrawpgs <- mapM onepagerender drawpgs + let npgs = foldr rfunc pgs ndrawpgs + 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 when isCurrentCvs (emphasisCanvasRender ColorRed geometry) resetClip - doubleBufferDraw win geometry xformfunc renderfunc ibboxnew- return hdl + return nhdl + doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew+ >>= maybe (return hdl) return -- |-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---- |-drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render ()) - -> ((PageNum, Page SelectMode) -> Maybe BBox -> DrawFlag -> Render ())+drawContPageSelGen :: ((PageNum,Page EditMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page EditMode)) + -> ((PageNum, Page SelectMode) -> Maybe BBox -> DrawFlag -> Render (Int,Page SelectMode)) -> DrawingFunction ContinuousPage SelectMode drawContPageSelGen rendergen rendersel = ContPageDraw func - where func isCurrentCvs cinfo mbbox thdl flag = do + where func :: Bool -> CanvasInfo ContinuousPage ->Maybe BBox -> Hoodle SelectMode ->DrawFlag -> IO (Hoodle SelectMode) + func isCurrentCvs cinfo mbbox thdl flag = do let arr = view (viewInfo.pageArrangement) cinfo pnum = PageNum . view currentPageNum $ cinfo mtpage = view gselSelected thdl canvas = view drawArea cinfo - geometry <- makeCanvasGeometry pnum arr canvas- let pgs = view gselAll thdl + msfc = view mDrawSurface cinfo + pgs = view gselAll thdl + mcpg = view (at (unPageNum pnum)) pgs hdl = GHoodle (view gselTitle thdl) pgs + geometry <- makeCanvasGeometry pnum arr canvas let drawpgs = catMaybes . map f $ (getPagesInViewPortRange geometry hdl) where f k = maybe Nothing (\a->Just (k,a)) @@ -289,18 +319,29 @@ identityMatrix cairoXform4PageCoordinate geometry pn rendergen (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag+ selpagerender :: (PageNum, Page SelectMode) -> Render (Int, Page SelectMode) selpagerender (pn,pg) = do identityMatrix cairoXform4PageCoordinate geometry pn- rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag + rendersel (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag+ renderfunc :: Render (Hoodle SelectMode) renderfunc = do xformfunc - mapM_ onepagerender drawpgs - maybe (return ()) (\(n,tpage)-> selpagerender (PageNum n,tpage)) mtpage+ ndrawpgs <- mapM onepagerender drawpgs + let npgs = foldr rfunc pgs ndrawpgs + where rfunc (k,pg) m = M.adjust (const pg) k m + let nthdl :: Hoodle SelectMode + nthdl = set gselAll npgs thdl + 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 when isCurrentCvs (emphasisCanvasRender ColorGreen geometry) resetClip - doubleBufferDraw win geometry xformfunc renderfunc ibboxnew- return thdl+ return nthdl2 + doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew+ >>= maybe (return thdl) return -- |@@ -309,6 +350,9 @@ where f (_,page) _ Clear = do pg' <- cairoRenderOption (RBkgDrawPDF,DrawFull) page return pg' + f(_,page) mbbox BkgEfficient = do + InBBoxBkgBuf pg' <- cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf page) + return pg' f (_,page) mbbox Efficient = do InBBox pg' <- cairoRenderOption (InBBoxOption mbbox) (InBBox page) return pg' @@ -320,6 +364,7 @@ let pg' = hPage2RPage tpg case flag of Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) pg' >> return ()+ BkgEfficient -> cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf pg') >> return () Efficient -> cairoRenderOption (InBBoxOption mbbox) (InBBox pg') >> return () return () renderselect (_pnum,tpg) mbbox _flag = do @@ -329,44 +374,22 @@ -- | drawContHoodle :: DrawingFunction ContinuousPage EditMode drawContHoodle = drawContPageGen f - where f (_,page) _ Clear = cairoRenderOption (RBkgDrawPDF,DrawFull) page - >> return ()- f (_,page) mbbox Efficient = cairoRenderOption (InBBoxOption mbbox) (InBBox page) - >> return ()+ where f (PageNum n,page) _ Clear = (,) n <$> cairoRenderOption (RBkgDrawPDF,DrawFull) page + f (PageNum n,page) mbbox BkgEfficient = (,) n . unInBBoxBkgBuf <$> cairoRenderOption (InBBoxOption mbbox) (InBBoxBkgBuf page) + f (PageNum n,page) mbbox Efficient = (,) n . unInBBox <$> cairoRenderOption (InBBoxOption mbbox) (InBBox page) + -- | drawContHoodleSel :: DrawingFunction ContinuousPage SelectMode drawContHoodleSel = drawContPageSelGen renderother renderselect - where renderother (_,page) mbbox flag = do+ where renderother (PageNum n,page) mbbox flag = do case flag of - Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) page >> return ()- Efficient -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) >> return () - return ()- renderselect (_pnum,tpg) mbbox _flag = do+ 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 - return ()---{---- |-drawBuf :: DrawingFunction SinglePage EditMode-drawBuf = drawFuncGen EditMode $ \(_,page) mbbox _ -> cairoRenderOption (InBBoxOption mbbox) (InBBox page) - --- |-drawSelBuf :: DrawingFunction SinglePage SelectMode-drawSelBuf = drawFuncSelGen rencont rensel - where rencont (_pnum,tpg) mbbox _ = do - let page = hPage2RPage tpg - cairoRenderOption (InBBoxOption mbbox) (InBBox page)- rensel (_pnum,tpg) mbbox _ = do - cairoHittedBoxDraw tpg mbbox - --- | -drawContHoodleBuf :: DrawingFunction ContinuousPage EditMode-drawContHoodleBuf = - drawContPageGen $ \(_,page) mbbox _ -> - cairoRenderOption (InBBoxOption mbbox) (InBBox page) --}+ return (n,tpg) -- | cairoHittedBoxDraw :: Page SelectMode -> Maybe BBox -> Render () @@ -388,7 +411,6 @@ Left _ -> return () -- | - renderLasso :: Seq (Double,Double) -> Render () renderLasso lst = do setLineWidth predefinedLassoWidth@@ -401,7 +423,6 @@ stroke -- |- renderBoxSelection :: BBox -> Render () renderBoxSelection bbox = do setLineWidth predefinedLassoWidth@@ -461,3 +482,12 @@ rectangle (0.5*(x1+x2)-3) (y2-3) 6 6 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+-}