From 7e85f22a92f3e53a50abbc4266df9ac45f0738e4 Mon Sep 17 00:00:00 2001 From: YoEight Date: Fri, 16 May 2014 18:14:31 +0200 Subject: [PATCH] Align tops to upper #104 --- Dhek/Engine/Interpreter.hs | 171 +++++++++++++++++++++---------------- Dhek/Engine/Type.hs | 39 ++++++--- Dhek/GUI.hs | 11 ++- Dhek/Mode/Selection.hs | 110 +++++++++++++++++++----- resources/top.png | Bin 0 -> 1967 bytes 5 files changed, 217 insertions(+), 114 deletions(-) create mode 100644 resources/top.png diff --git a/Dhek/Engine/Interpreter.hs b/Dhek/Engine/Interpreter.hs index 4d4a587..76cac58 100644 --- a/Dhek/Engine/Interpreter.hs +++ b/Dhek/Engine/Interpreter.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Dhek.Engine.Interpreter @@ -40,33 +42,43 @@ import Dhek.Mode.Selection import Dhek.Types -------------------------------------------------------------------------------- -data Interpreter = - Interpreter - { _internal :: IORef (Maybe Viewer) - , _state :: IORef EngineState - , _env :: IORef EngineEnv - , _gui :: GUI - } +data Interpreter + = Interpreter + { _internal :: IORef (Maybe Viewer) + , _state :: IORef EngineState + , _env :: IORef EngineEnv + , _gui :: GUI + , _modes :: Modes + , _curModeMgr :: IORef ModeManager + } + +-------------------------------------------------------------------------------- +data Modes + = Modes + { modeDraw :: IO ModeManager + , modeDuplication :: IO ModeManager + , modeSelection :: IO ModeManager + } -------------------------------------------------------------------------------- drawInterpret :: (DrawEnv -> M a) -> Interpreter -> Pos -> IO () drawInterpret k i (x,y) = do s <- readIORef $ _state i opt <- readIORef $ _internal i - e <- readIORef $ _env i + mgr <- readIORef $ _curModeMgr i for_ opt $ \v -> do - let gui = _gui i - ratio = _engineRatio s v - pid = s ^. engineCurPage - ModeManager mode _ = s ^. engineModeMgr - opts = DrawEnv{ drawOverlap = s ^. engineOverlap - , drawPointer = (x/ratio, y/ratio) - , drawRects = getRects s - , drawRatio = ratio - } - - s2 <- runMode mode s (k opts) + let gui = _gui i + ratio = _engineRatio s v + pid = s ^. engineCurPage + opts = DrawEnv + { drawOverlap = s ^. engineOverlap + , drawPointer = (x/ratio, y/ratio) + , drawRects = getRects s + , drawRatio = ratio + } + + s2 <- runMode (mgrMode mgr) s (k opts) writeIORef (_state i) s2 liftIO $ Gtk.widgetQueueDraw $ guiDrawingArea gui @@ -75,13 +87,12 @@ engineRunDraw :: Interpreter -> IO () engineRunDraw i = do s <- readIORef $ _state i opt <- readIORef $ _internal i - + mgr <- readIORef $ _curModeMgr i for_ opt $ \v -> do let pages = v ^. viewerPages page = pages ! (s ^. engineCurPage) - ModeManager mode _ = s ^. engineModeMgr ratio = _engineRatio s v - s2 <- runMode mode s (drawing page ratio) + s2 <- runMode (mgrMode mgr) s (drawing page ratio) writeIORef (_state i) s2 -------------------------------------------------------------------------------- @@ -130,20 +141,23 @@ engineDrawingArea = guiDrawingArea . _gui -- the new @ModeManager@ engineSetMode :: DhekMode -> Interpreter -> IO () engineSetMode m i = do - s <- readIORef $ _state i - e <- readIORef $ _env i - let ModeManager _ cleanup = s ^. engineModeMgr + s <- readIORef $ _state i + e <- readIORef $ _env i + prevMgr <- readIORef $ _curModeMgr i + let cleanup = mgrCleanup prevMgr s2 <- execStateT cleanup s - mgr <- (_engineModes e) ! midx - writeIORef (_state i) (s2 & engineModeMgr .~ mgr) + mgr <- selector modes + writeIORef (_state i) s2 + writeIORef (_curModeMgr i) mgr Gtk.widgetQueueDraw area where - area = guiDrawingArea $ _gui i - midx = case m of - DhekNormal -> 1 - DhekDuplication -> 2 - DhekSelection -> 3 + modes = _modes i + area = guiDrawingArea $ _gui i + selector = case m of + DhekNormal -> modeDraw + DhekDuplication -> modeDuplication + DhekSelection -> modeSelection -------------------------------------------------------------------------------- -- | Returns the current page ratio. Returns Nothing if no PDF has been loaded @@ -167,52 +181,48 @@ _engineRatio s v = -------------------------------------------------------------------------------- makeInterpreter :: GUI -> IO Interpreter makeInterpreter gui = do - let env = envNew gui + let env = EngineEnv { _engineFilename = "" } eRef <- newIORef env - s <- stateNew gui env - sRef <- newIORef s + sRef <- newIORef stateNew vRef <- newIORef Nothing - return Interpreter{ _internal = vRef - , _state = sRef - , _env = eRef - , _gui = gui - } --------------------------------------------------------------------------------- -envNew :: GUI -> EngineEnv -envNew gui = - EngineEnv{ _engineFilename = "" - , _engineRects = [] - , _engineOverRect = Nothing - , _engineOverArea = Nothing - , _engineModes = modes - } - where - modes = array (1,3) [ (1, normalModeManager gui) - , (2, duplicateModeManager gui) - , (3, selectionModeManager gui) - ] + -- Instanciates ModeManagers + let mgrNormal = normalModeManager gui + mgrDuplication = duplicateModeManager gui + mgrSelection = selectionModeManager (withContext sRef) gui + modes = Modes + { modeDraw = mgrNormal + , modeDuplication = mgrDuplication + , modeSelection = mgrSelection + } + + curMgr <- mgrNormal + cRef <- newIORef curMgr + return Interpreter{ _internal = vRef + , _state = sRef + , _env = eRef + , _gui = gui + , _modes = modes + , _curModeMgr = cRef + } -------------------------------------------------------------------------------- -stateNew :: GUI -> EngineEnv -> IO EngineState -stateNew gui env = do - mgr <- modes ! 1 - return EngineState{ _engineCurPage = 1 - , _engineCurZoom = 3 - , _engineRectId = 0 - , _engineOverlap = False - , _engineDraw = False - , _enginePropLabel = "" - , _enginePropType = Nothing - , _enginePrevPos = (negate 1, negate 1) - , _engineDrawState = drawStateNew - , _engineBoards = boardsNew 1 - , _engineModeMgr = mgr - , _engineBaseWidth = 777 - , _engineThick = 1 - } - where - modes = _engineModes env +stateNew :: EngineState +stateNew + = EngineState + { _engineCurPage = 1 + , _engineCurZoom = 3 + , _engineRectId = 0 + , _engineOverlap = False + , _engineDraw = False + , _enginePropLabel = "" + , _enginePropType = Nothing + , _enginePrevPos = (negate 1, negate 1) + , _engineDrawState = drawStateNew + , _engineBoards = boardsNew 1 + , _engineBaseWidth = 777 + , _engineThick = 1 + } -------------------------------------------------------------------------------- runProgram :: Interpreter -> DhekProgram a -> IO (Maybe a) @@ -224,6 +234,13 @@ runProgram i p = do for opt $ \ v -> evalStateT (_evalProgram env (_gui i) (_state i) p v) s +-------------------------------------------------------------------------------- +withContext :: IORef EngineState -> (forall m. EngineCtx m => m a) -> IO () +withContext ref state = do + s <- readIORef ref + s' <- execStateT state s + writeIORef ref s' + -------------------------------------------------------------------------------- _evalProgram :: EngineEnv -> GUI @@ -233,7 +250,6 @@ _evalProgram :: EngineEnv -> StateT EngineState IO a _evalProgram env gui ref prg v= foldFree end susp prg where nb = v ^. viewerPageCount - modes = _engineModes env susp (GetCurPage k) = (use engineCurPage) >>= k susp (GetPageCount k) = k (v ^. viewerPageCount) @@ -453,7 +469,12 @@ loadPdf i path = do ev <- readIORef $ _env i case opt of Nothing -> do - let env = (envNew gui) { _engineFilename = takeFileName path } + let modes = array (1,3) + [ (1, normalModeManager gui) + , (2, duplicateModeManager gui) + , (3, selectionModeManager (withContext $ _state i) gui) + ] + env = EngineEnv { _engineFilename = takeFileName path } name = _engineFilename env nb = v ^. viewerPageCount s' = s & engineBoards .~ boardsNew nb diff --git a/Dhek/Engine/Type.hs b/Dhek/Engine/Type.hs index 2ebc65b..8a6df72 100644 --- a/Dhek/Engine/Type.hs +++ b/Dhek/Engine/Type.hs @@ -11,12 +11,12 @@ module Dhek.Engine.Type where -------------------------------------------------------------------------------- import Control.Applicative -import Data.Array (Array) -------------------------------------------------------------------------------- -import Control.Lens -import Control.Monad.State -import Graphics.UI.Gtk (CursorType) +import Control.Lens +import Control.Monad.State +import qualified Data.IntMap as I +import Graphics.UI.Gtk (CursorType) -------------------------------------------------------------------------------- import Dhek.Types @@ -47,7 +47,7 @@ newtype Mode = Mode (forall a. M a -> EngineState -> IO EngineState) -------------------------------------------------------------------------------- -- | We expect from a cleanup handler to handle @EngineState@ state and -- IO actions -type ModeCtx m = (MonadIO m, MonadState EngineState m) +type EngineCtx m = (MonadIO m, MonadState EngineState m) -------------------------------------------------------------------------------- -- | Holds a Engine mode and a cleanup handler. @ModeManager@ manages anything @@ -55,7 +55,7 @@ type ModeCtx m = (MonadIO m, MonadState EngineState m) data ModeManager = ModeManager { mgrMode :: Mode - , mgrCleanup :: forall m. ModeCtx m => m () + , mgrCleanup :: forall m. EngineCtx m => m () } -------------------------------------------------------------------------------- @@ -101,19 +101,14 @@ data EngineState = EngineState , _enginePrevPos :: !(Double, Double) , _engineBoards :: !Boards , _engineDrawState :: !DrawState - , _engineModeMgr :: !ModeManager , _engineBaseWidth :: !Int , _engineThick :: !Double } -------------------------------------------------------------------------------- -data EngineEnv = EngineEnv - { _engineFilename :: !String - , _engineRects :: ![Rect] - , _engineOverRect :: !(Maybe Rect) - , _engineOverArea :: !(Maybe Area) - , _engineModes :: !(Array Int (IO ModeManager)) - } +data EngineEnv + = EngineEnv + { _engineFilename :: !String } -------------------------------------------------------------------------------- -- | Constructors @@ -185,3 +180,19 @@ release = M mRelease drawing :: PageItem -> Ratio -> M () drawing p r = M $ mDrawing p r + +-------------------------------------------------------------------------------- +-- | Helpers +-------------------------------------------------------------------------------- +engineStateGetRects :: MonadState EngineState m => m [Rect] +engineStateGetRects = do + pid <- use engineCurPage + use $ engineBoards.boardsMap.at pid.traverse.boardRects.to I.elems + +-------------------------------------------------------------------------------- +engineStateSetRects :: MonadState EngineState m => [Rect] -> m () +engineStateSetRects rs = do + pid <- use engineCurPage + forM_ rs $ \r -> do + let rid = r ^. rectId + engineBoards.boardsMap.at pid.traverse.boardRects.at rid ?= r diff --git a/Dhek/GUI.hs b/Dhek/GUI.hs index 0e31321..9305e90 100644 --- a/Dhek/GUI.hs +++ b/Dhek/GUI.hs @@ -16,8 +16,6 @@ import qualified Graphics.UI.Gtk as Gtk import System.FilePath (joinPath, dropFileName) import System.Environment.Executable (getExecutablePath) -import Debug.Trace (trace) - -------------------------------------------------------------------------------- import Dhek.I18N import Dhek.Types @@ -56,6 +54,7 @@ data GUI = , guiWindowHBox :: Gtk.HBox , guiVRulerAdjustment :: Gtk.Adjustment , guiHRulerAdjustment :: Gtk.Adjustment + , guiModeToolbar :: Gtk.HButtonBox } -------------------------------------------------------------------------------- @@ -175,6 +174,13 @@ makeGUI = do Gtk.containerAdd toolbar msb Gtk.boxPackStart vbox align Gtk.PackNatural 0 + -- Mode toolbar + mtoolbar <- Gtk.hButtonBoxNew + mtalign <- Gtk.alignmentNew 0 1 0 0 + Gtk.containerAdd mtalign mtoolbar + Gtk.boxPackStart vbox mtalign Gtk.PackNatural 0 + Gtk.widgetSetSizeRequest mtoolbar (-1) 32 + -- Drawing Area area <- Gtk.drawingAreaNew vruler <- Gtk.vRulerNew @@ -320,6 +326,7 @@ makeGUI = do , guiWindowHBox = hbox , guiVRulerAdjustment = vadj , guiHRulerAdjustment = hadj + , guiModeToolbar = mtoolbar } -------------------------------------------------------------------------------- diff --git a/Dhek/Mode/Selection.hs b/Dhek/Mode/Selection.hs index 85a2a56..b069620 100644 --- a/Dhek/Mode/Selection.hs +++ b/Dhek/Mode/Selection.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} -------------------------------------------------------------------------------- -- | -- Module : Dhek.Mode.Selection @@ -17,10 +20,11 @@ import Data.Traversable import Control.Lens import Control.Monad.RWS hiding (mapM_) import Control.Monad.Trans -import qualified Data.IntMap as I import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.Poppler.Page as Poppler +import System.FilePath (joinPath, dropFileName) +import System.Environment.Executable (getExecutablePath) -------------------------------------------------------------------------------- import Dhek.Engine.Type @@ -30,13 +34,20 @@ import Dhek.GUI.Action import Dhek.Mode.Common.Draw import Dhek.Types +-------------------------------------------------------------------------------- +data Input + = Input + { inputGUI :: GUI + , inputTop :: Gtk.Button + } + -------------------------------------------------------------------------------- newtype SelectionMode a - = SelectionMode (RWST GUI () EngineState IO a) + = SelectionMode (RWST Input () EngineState IO a) deriving ( Functor , Applicative , Monad - , MonadReader GUI + , MonadReader Input , MonadState EngineState , MonadIO ) @@ -58,29 +69,31 @@ instance ModeMonad SelectionMode where engineDrawState.drawSelection ?= newSelection engineDrawState.drawMultiSel .= [] - gui <- ask + gui <- asks inputGUI liftIO $ do gtkSetCursor (Just Gtk.Crosshair) gui Gtk.treeSelectionUnselectAll $ guiRectTreeSelection gui mRelease = do - gui <- ask - sOpt <- use $ engineDrawState.drawSelection + input <- ask + sOpt <- use $ engineDrawState.drawSelection engineDrawState.drawSelection .= Nothing for_ (fmap normalize sOpt) $ \r -> do - pid <- use engineCurPage - rs <- use $ - engineBoards.boardsMap.at pid.traverse.boardRects.to I.elems + rs <- engineStateGetRects -- get rectangles located in selection area let crs = foldMap (collectSelected r) rs + -- if no area is selected, we disable 'top' button + liftIO $ Gtk.widgetSetSensitive (inputTop input) + (not $ null crs) + for_ crs $ \cr -> - liftIO $ gtkSelectRect cr gui + liftIO $ gtkSelectRect cr $ inputGUI input engineDrawState.drawMultiSel .= crs - liftIO $ gtkSetCursor Nothing gui + liftIO $ gtkSetCursor Nothing $ inputGUI input where collectSelected r c @@ -89,12 +102,11 @@ instance ModeMonad SelectionMode where mDrawing page ratio = do - gui <- ask + gui <- asks inputGUI ds <- use $ engineDrawState gds <- use $ engineBoards.boardsGuides gd <- use $ engineBoards.boardsCurGuide - pid <- use $ engineCurPage - rs <- use $ engineBoards.boardsMap.at pid.traverse.boardRects.to I.elems + rs <- engineStateGetRects liftIO $ do frame <- Gtk.widgetGetDrawWindow $ guiDrawingArea gui @@ -136,22 +148,74 @@ instance ModeMonad SelectionMode where selectionColor = rgbGreen -------------------------------------------------------------------------------- -runSelection :: GUI -> SelectionMode a -> EngineState -> IO EngineState -runSelection gui (SelectionMode m) s = do - (s', _) <- execRWST m gui s +-- | Called when 'Top' button, located in mode's toolbar, is clicked +topButtonActivated :: GUI -> EngineCtx m => m () +topButtonActivated gui = do + rs <- use $ engineDrawState.drawMultiSel + case rs of + [] -> return () + x:xs -> do + let toppest = foldr cmp x xs + topY = toppest ^. rectY + toppedRs = fmap (updY topY) rs + + -- TODO: better mulitiselection management + engineStateSetRects toppedRs + engineDrawState.drawMultiSel .= toppedRs + liftIO $ Gtk.widgetQueueDraw $ guiDrawingArea gui + where + cmp r1 r2 + | r1 ^. rectY < r2 ^. rectY = r1 + | otherwise = r2 + + updY y r = r & rectY .~ y + +-------------------------------------------------------------------------------- +runSelection :: GUI + -> Gtk.Button + -> SelectionMode a + -> EngineState + -> IO EngineState +runSelection gui btop (SelectionMode m) s = do + (s', _) <- execRWST m input s return s' + where + input + = Input + { inputGUI = gui + , inputTop = btop + } -------------------------------------------------------------------------------- -selectionMode :: GUI -> Mode -selectionMode gui = Mode (runSelection gui . runM) +selectionMode :: GUI -> Gtk.Button -> Mode +selectionMode gui btop = Mode (runSelection gui btop . runM) -------------------------------------------------------------------------------- -selectionModeManager :: GUI -> IO ModeManager -selectionModeManager gui = do +selectionModeManager :: ((forall m. EngineCtx m => m ()) -> IO ()) + -> GUI + -> IO ModeManager +selectionModeManager handler gui = do Gtk.treeSelectionSetMode (guiRectTreeSelection gui) Gtk.SelectionMultiple - return $ ModeManager (selectionMode gui) $ liftIO $ + btop <- Gtk.buttonNew + execPath <- getExecutablePath + let resDir = joinPath [dropFileName execPath, "resources"] + bimg <- Gtk.imageNewFromFile $ joinPath [resDir, "top.png"] + Gtk.buttonSetImage btop bimg + Gtk.containerAdd toolbar btop + Gtk.widgetSetSensitive btop False + + -- listen to button event + cid <- Gtk.on btop Gtk.buttonActivated $ handler $ topButtonActivated gui + + Gtk.widgetShowAll btop + + return $ ModeManager (selectionMode gui btop) $ liftIO $ do + Gtk.signalDisconnect cid + Gtk.widgetDestroy btop Gtk.treeSelectionSetMode (guiRectTreeSelection gui) - Gtk.SelectionSingle + Gtk.SelectionSingle + where + toolbar = guiModeToolbar gui -------------------------------------------------------------------------------- -- | Utilities diff --git a/resources/top.png b/resources/top.png new file mode 100644 index 0000000000000000000000000000000000000000..8495662b4db3a2408d252b768952e7826567b8b7 GIT binary patch literal 1967 zcmV;g2T=HlP)=2H8bsK@p0+yQB377<$Ne-ju(YP zb(K>eAjCCfB>>)zc zR=_~61)O{30A%d^i|G5qcGI6-oCm-fhyl4lAA&ZNfs~k3;z~$~DN#2C6Dp2Cq$2;c zEt(Jr`Yf24A+Wev1Rz5LU@rd2sq-Nlr7=fGc2FWG2uL9yJQ0@=aJlQjIJI$?5DGrr z#t1Jm;a%e}mmhd|WeyiSPjTCYQ@x zii~gx)kbiKD-*+QBl=xsP7L)c;{t#fGSeTSB-)IDHx24f|+^w!KDtRK-o$Nckv;U)K{tO^V z@H9qTH7-Fg?dnfNT%$~X@YT;t`1e)ZG%j%8lF2yI(1inkX+-Rki!b#b+xnDxIySbq zp@hcD%!glJCZzHD+Iw!a*WP&pwjF54n=J#F7!YWE^CLLn_8rj^KiUEyOgJM=Rg#KAspArlvN4xW5^^H@#jV-df3{oj{s zroI3E6;tfh3yVjHXW9nxLM94JaxtO05@yEuuiDd}_!)p4!bfP=W#HDw-(I1c{{1T# zO|X~VT7YH0N{Q>52HVn*9WanX2F7KWm^39HRrkz;6)IZio4hHViS!1lHoZsUc5QW4 zk-eZi7hnGEX>>#wEM3Fgk~~ZZ`4RFP$g;^qFlA!q%p$B@w+LpaaGhTI?Po@r7`uVn zwj5olTlW52%5v>lQ?u~RU1!l1WiT}j6?qwuf+N{_2JWRU1bsR(Y#q5F69t(TX3r|Y z{f{n%6)Jofg&Tf8%0zkt3%`H-E)uW3adOB%wKRw)_qCySki!5l!`8r)N%S+5Ahxm(>)H=PVMgFeXkO=b4ZI;*NkGv=J=MM_W_( z&C*{n9)lkqQhS6Ly$qFj<0^Xc*Mc_p=Vu$(cf1eLq<}62N}^#{wgr>Bh;=m7UHr%9 z7Xfq-{n?d|Ei)%x6>WiWJj2a*1mi@wVYXIn0z`L#n3iSFI#{>`QH>S~mALC7zw;7=%i-66WKXja$3@}-(J|2Y!mF&msixs@D|`Em26ROjdZHZR z7)LbjLeC$Eyrl~Of59619M4|)IdmmH-|z+g6nB&UC`;n4)&azrfW|p8&z>Q17uh*k zNc5bnYpeUNC$8ux;zT5R@`XKopt+{$a0`3?Z;fPt(bIG9EkwwKla&k1y@h1SM8P9J z0FX_X-o8%(18Jj1V8S)0sqOV9GZh zkoL6a$5l?ZvMZ7;2xCbYq@pCWj5tmzQx{tT8e}B+~-YECPhi6AmaIh>tYkT-dQk#!l75n@%z3R+Zs+DCM-jT)k?UhF5FC>aKo&~Uim_$IIQ2n*igR62 z$?9#5$(av6w+q1C#GGr3r#FF|yB|Q&cTS*WtMn**>;%k$wE*T51yIFLjL$D$wshi> z4eR|mrC$WFn3zQrrV&qPB8Qj;d&Vm0!Ic1(5>>