diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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: diff --git a/hoodle-core.cabal b/hoodle-core.cabal --- a/hoodle-core.cabal +++ b/hoodle-core.cabal @@ -1,5 +1,5 @@ Name: hoodle-core -Version: 0.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: diff --git a/resource/menu.xml b/resource/menu.xml new file mode 100644 --- /dev/null +++ b/resource/menu.xml @@ -0,0 +1,223 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/Hoodle/Accessor.hs b/src/Hoodle/Accessor.hs --- a/src/Hoodle/Accessor.hs +++ b/src/Hoodle/Accessor.hs @@ -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] diff --git a/src/Hoodle/Coroutine/Callback.hs b/src/Hoodle/Coroutine/Callback.hs --- a/src/Hoodle/Coroutine/Callback.hs +++ b/src/Hoodle/Coroutine/Callback.hs @@ -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 - diff --git a/src/Hoodle/Coroutine/ContextMenu.hs b/src/Hoodle/Coroutine/ContextMenu.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/ContextMenu.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.ContextMenu +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) + diff --git a/src/Hoodle/Coroutine/Default.hs b/src/Hoodle/Coroutine/Default.hs --- a/src/Hoodle/Coroutine/Default.hs +++ b/src/Hoodle/Coroutine/Default.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Draw.hs b/src/Hoodle/Coroutine/Draw.hs --- a/src/Hoodle/Coroutine/Draw.hs +++ b/src/Hoodle/Coroutine/Draw.hs @@ -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 @@ -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) +-} -- | diff --git a/src/Hoodle/Coroutine/Eraser.hs b/src/Hoodle/Coroutine/Eraser.hs --- a/src/Hoodle/Coroutine/Eraser.hs +++ b/src/Hoodle/Coroutine/Eraser.hs @@ -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 @@ -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) diff --git a/src/Hoodle/Coroutine/File.hs b/src/Hoodle/Coroutine/File.hs --- a/src/Hoodle/Coroutine/File.hs +++ b/src/Hoodle/Coroutine/File.hs @@ -1,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 diff --git a/src/Hoodle/Coroutine/Mode.hs b/src/Hoodle/Coroutine/Mode.hs --- a/src/Hoodle/Coroutine/Mode.hs +++ b/src/Hoodle/Coroutine/Mode.hs @@ -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 - -} diff --git a/src/Hoodle/Coroutine/Page.hs b/src/Hoodle/Coroutine/Page.hs --- a/src/Hoodle/Coroutine/Page.hs +++ b/src/Hoodle/Coroutine/Page.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Pen.hs b/src/Hoodle/Coroutine/Pen.hs --- a/src/Hoodle/Coroutine/Pen.hs +++ b/src/Hoodle/Coroutine/Pen.hs @@ -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 ) diff --git a/src/Hoodle/Coroutine/Scroll.hs b/src/Hoodle/Coroutine/Scroll.hs --- a/src/Hoodle/Coroutine/Scroll.hs +++ b/src/Hoodle/Coroutine/Scroll.hs @@ -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 diff --git a/src/Hoodle/Coroutine/Select.hs b/src/Hoodle/Coroutine/Select.hs --- a/src/Hoodle/Coroutine/Select.hs +++ b/src/Hoodle/Coroutine/Select.hs @@ -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 -> diff --git a/src/Hoodle/Coroutine/TextInput.hs b/src/Hoodle/Coroutine/TextInput.hs new file mode 100644 --- /dev/null +++ b/src/Hoodle/Coroutine/TextInput.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Hoodle.Coroutine.TextInput +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) -} + diff --git a/src/Hoodle/Coroutine/Window.hs b/src/Hoodle/Coroutine/Window.hs --- a/src/Hoodle/Coroutine/Window.hs +++ b/src/Hoodle/Coroutine/Window.hs @@ -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)) + + + diff --git a/src/Hoodle/Device.hsc b/src/Hoodle/Device.hsc --- a/src/Hoodle/Device.hsc +++ b/src/Hoodle/Device.hsc @@ -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 diff --git a/src/Hoodle/GUI.hs b/src/Hoodle/GUI.hs --- a/src/Hoodle/GUI.hs +++ b/src/Hoodle/GUI.hs @@ -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 diff --git a/src/Hoodle/GUI/Menu.hs b/src/Hoodle/GUI/Menu.hs --- a/src/Hoodle/GUI/Menu.hs +++ b/src/Hoodle/GUI/Menu.hs @@ -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| - - - - - - - - - -|] - -- | - -uiDecl :: String -uiDecl = [verbatim| - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -|] +-- 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 "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 diff --git a/src/Hoodle/ModelAction/Adjustment.hs b/src/Hoodle/ModelAction/Adjustment.hs --- a/src/Hoodle/ModelAction/Adjustment.hs +++ b/src/Hoodle/ModelAction/Adjustment.hs @@ -38,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 diff --git a/src/Hoodle/ModelAction/File.hs b/src/Hoodle/ModelAction/File.hs --- a/src/Hoodle/ModelAction/File.hs +++ b/src/Hoodle/ModelAction/File.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Layer.hs b/src/Hoodle/ModelAction/Layer.hs --- a/src/Hoodle/ModelAction/Layer.hs +++ b/src/Hoodle/ModelAction/Layer.hs @@ -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) diff --git a/src/Hoodle/ModelAction/Page.hs b/src/Hoodle/ModelAction/Page.hs --- a/src/Hoodle/ModelAction/Page.hs +++ b/src/Hoodle/ModelAction/Page.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Pen.hs b/src/Hoodle/ModelAction/Pen.hs --- a/src/Hoodle/ModelAction/Pen.hs +++ b/src/Hoodle/ModelAction/Pen.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Select.hs b/src/Hoodle/ModelAction/Select.hs --- a/src/Hoodle/ModelAction/Select.hs +++ b/src/Hoodle/ModelAction/Select.hs @@ -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 diff --git a/src/Hoodle/ModelAction/Window.hs b/src/Hoodle/ModelAction/Window.hs --- a/src/Hoodle/ModelAction/Window.hs +++ b/src/Hoodle/ModelAction/Window.hs @@ -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) diff --git a/src/Hoodle/Script/Coroutine.hs b/src/Hoodle/Script/Coroutine.hs --- a/src/Hoodle/Script/Coroutine.hs +++ b/src/Hoodle/Script/Coroutine.hs @@ -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 diff --git a/src/Hoodle/Script/Hook.hs b/src/Hoodle/Script/Hook.hs --- a/src/Hoodle/Script/Hook.hs +++ b/src/Hoodle/Script/Hook.hs @@ -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 + } diff --git a/src/Hoodle/Type/Canvas.hs b/src/Hoodle/Type/Canvas.hs --- a/src/Hoodle/Type/Canvas.hs +++ b/src/Hoodle/Type/Canvas.hs @@ -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 diff --git a/src/Hoodle/Type/Clipboard.hs b/src/Hoodle/Type/Clipboard.hs --- a/src/Hoodle/Type/Clipboard.hs +++ b/src/Hoodle/Type/Clipboard.hs @@ -52,4 +52,8 @@ } deriving (Show) -makeLenses ''SelectInfo + +selectType :: Simple Lens SelectInfo SelectType +selectType = lens _selectType (\f a -> f { _selectType = a }) + +-- makeLenses ''SelectInfo diff --git a/src/Hoodle/Type/Coroutine.hs b/src/Hoodle/Type/Coroutine.hs --- a/src/Hoodle/Type/Coroutine.hs +++ b/src/Hoodle/Type/Coroutine.hs @@ -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 diff --git a/src/Hoodle/Type/Enum.hs b/src/Hoodle/Type/Enum.hs --- a/src/Hoodle/Type/Enum.hs +++ b/src/Hoodle/Type/Enum.hs @@ -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" diff --git a/src/Hoodle/Type/Event.hs b/src/Hoodle/Type/Event.hs --- a/src/Hoodle/Type/Event.hs +++ b/src/Hoodle/Type/Event.hs @@ -1,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 @@ -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 diff --git a/src/Hoodle/Type/HoodleState.hs b/src/Hoodle/Type/HoodleState.hs --- a/src/Hoodle/Type/HoodleState.hs +++ b/src/Hoodle/Type/HoodleState.hs @@ -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 = diff --git a/src/Hoodle/Type/PageArrangement.hs b/src/Hoodle/Type/PageArrangement.hs --- a/src/Hoodle/Type/PageArrangement.hs +++ b/src/Hoodle/Type/PageArrangement.hs @@ -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' diff --git a/src/Hoodle/Type/Predefined.hs b/src/Hoodle/Type/Predefined.hs --- a/src/Hoodle/Type/Predefined.hs +++ b/src/Hoodle/Type/Predefined.hs @@ -47,5 +47,5 @@ -- | predefinedZoomStepFactor :: Double -predefinedZoomStepFactor = 1.5 +predefinedZoomStepFactor = 1.10 diff --git a/src/Hoodle/Util.hs b/src/Hoodle/Util.hs --- a/src/Hoodle/Util.hs +++ b/src/Hoodle/Util.hs @@ -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 = diff --git a/src/Hoodle/Util/Verbatim.hs b/src/Hoodle/Util/Verbatim.hs deleted file mode 100644 --- a/src/Hoodle/Util/Verbatim.hs +++ /dev/null @@ -1,26 +0,0 @@ - ------------------------------------------------------------------------------ --- | --- Module : Hoodle.Util.Verbatim --- Copyright : (c) 2011, 2012 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- 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 --- } - diff --git a/src/Hoodle/View/Draw.hs b/src/Hoodle/View/Draw.hs --- a/src/Hoodle/View/Draw.hs +++ b/src/Hoodle/View/Draw.hs @@ -1,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 @@ -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 +-}