diff --git a/Graphics/Dynamic/Plot/Colour.hs b/Graphics/Dynamic/Plot/Colour.hs --- a/Graphics/Dynamic/Plot/Colour.hs +++ b/Graphics/Dynamic/Plot/Colour.hs @@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2013 -- License : GPL v3 -- --- Maintainer : (@) sagemuej $ smail.uni-koeln.de +-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : requires GHC>6 extensions diff --git a/Graphics/Dynamic/Plot/Internal/Types.hs b/Graphics/Dynamic/Plot/Internal/Types.hs --- a/Graphics/Dynamic/Plot/Internal/Types.hs +++ b/Graphics/Dynamic/Plot/Internal/Types.hs @@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2015 -- License : GPL v3 -- --- Maintainer : (@) sagemueller $ geo.uni-koeln.de +-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : requires GHC>6 extensions @@ -512,13 +512,18 @@ _xResV, _yResV :: Int , _prerenderScaling :: PrerenderScaling , _plotContentZoomFactor :: Double + , _plotBackground :: Maybe (Dia.Colour Double) + , _graphicsPostprocessing :: PlainGraphicsR2 -> PlainGraphicsR2 } makeLenses ''ViewportConfig instance Default ViewportConfig where - def = ViewportConfig 640 480 ValuespaceScaling (6/7) + def = ViewportConfig 640 480 ValuespaceScaling (6/7) Nothing id +setSolidBackground :: Dia.Colour Double -> ViewportConfig -> ViewportConfig +setSolidBackground c = plotBackground .~ Just c + data LegendDisplayConfig = LegendDisplayConfig { _legendPrerenderSize :: Dia.SizeSpec Dia.V2 Double } @@ -533,4 +538,5 @@ data MouseEvent x = MouseEvent { _clickLocation, _releaseLocation :: x } + deriving (Eq) makeLenses ''MouseEvent diff --git a/Graphics/Dynamic/Plot/R2.hs b/Graphics/Dynamic/Plot/R2.hs --- a/Graphics/Dynamic/Plot/R2.hs +++ b/Graphics/Dynamic/Plot/R2.hs @@ -1,9 +1,9 @@ -- | -- Module : Graphics.Dynamic.Plot.R2 --- Copyright : (c) Justus Sagemüller 2013-2017 +-- Copyright : (c) Justus Sagemüller 2013-2019 -- License : GPL v3 -- --- Maintainer : (@) sagemueller $ geo.uni-koeln.de +-- Maintainer : (@) jsag $ hvl.no -- Stability : experimental -- Portability : requires GHC>6 extensions @@ -34,7 +34,7 @@ -- ** Static plotPrerender -- ** Interactive - , plotWindow + , plotWindow, plotWindow' -- * Plottable objects -- ** Class , Plottable(..) @@ -59,7 +59,7 @@ , legendName , plotLegendPrerender -- ** Animation - , plotDelay + , plotDelay, freezeAnim, startFrozen -- * Viewport -- ** View selection , xInterval, yInterval, forceXRange, forceYRange @@ -68,7 +68,7 @@ -- $interactiveExplanation -- *** Mouse , MousePressed (..), MousePress(..), MouseClicks(..) - , clickThrough, mouseInteractive + , clickThrough, withDraggablePoints, mouseInteractive , MouseEvent, clickLocation, releaseLocation -- *** Displayed range , ViewXCenter(..), ViewYCenter(..), ViewWidth(..), ViewHeight(..) @@ -84,11 +84,15 @@ , ViewportConfig -- *** Resolution , xResV, yResV + -- *** Background + , setSolidBackground -- *** Output scaling , prerenderScaling , PrerenderScaling(..) , LegendDisplayConfig , legendPrerenderSize + -- *** General + , graphicsPostprocessing ) where import Graphics.Dynamic.Plot.Colour @@ -124,6 +128,7 @@ import qualified System.Glib.Signals (on) import Control.Monad.Trans (liftIO, lift) +import Control.Monad.Trans.State (evalState, get, put) import Control.Monad.ST import Control.Applicative ((<|>)) import Data.STRef @@ -150,7 +155,7 @@ import Data.Maybe import Data.Semigroup import Data.Default -import Data.Foldable (fold, foldMap) +import Data.Foldable (fold, foldMap, minimumBy) import qualified Data.Foldable as Hask import Data.Function (on) import Data.Ord (comparing) @@ -202,6 +207,7 @@ _mouseClicksCompleted :: [MouseEvent x] , _currentDragEndpoints :: Maybe (MouseEvent x) } + deriving (Eq) instance Semigroup (Interactions x) where Interactions cca cda<>Interactions ccb cdb = Interactions (cca<>ccb) (cda<|>cdb) instance Monoid (Interactions x) where @@ -1020,12 +1026,16 @@ & Dia.moveTo (Dia.P $ V2 lBound tBound) :: PlainGraphicsR2) prs -> normaliseView viewport + >>> (vpc^.graphicsPostprocessing) >>> Dia.withEnvelope (Dia.rect 2 2 :: PlainGraphicsR2) >>> case prs of NormalisedScaling -> id OutputCoordsScaling -> Dia.translate (1 ^& (-1)) >>> Dia.scaleX (fromInt xResolution / 2) >>> Dia.scaleY (fromInt yResolution / 2) + >>> case vpc^.plotBackground of + Nothing -> id + Just bgc -> Dia.bg bgc where viewport@(GraphWindowSpecR2{..}) = autoDefaultView vpc plotObjs' w = rBound - lBound; h = tBound - bBound plotObjs' = plotObjs ++ if axesNeed>0 @@ -1062,18 +1072,22 @@ -- At the moment, we can recommend no better solution than to abort and restart ghci -- (or what else you use – iHaskell kernel, process, ...) if this occurs. plotWindow :: [DynamicPlottable] -> IO GraphWindowSpec -plotWindow [] = plotWindow [dynamicAxes] -plotWindow givenPlotObjs = runInBoundThread $ do +plotWindow = plotWindow' def + +-- | Like 'plotWindow', but with explicit specification how the window is supposed +-- to show up. ('plotWindow' uses the default configuration, i.e. 'def'.) +plotWindow' :: ViewportConfig -> [DynamicPlottable] -> IO GraphWindowSpec +plotWindow' viewportConfig [] = plotWindow' viewportConfig [dynamicAxes] +plotWindow' viewportConfig givenPlotObjs = runInBoundThread $ do let defColourScheme = defaultColourScheme tintedPlotObjs = chooseAutoTints givenPlotObjs - viewportConfig = def :: ViewportConfig viewState <- newIORef $ autoDefaultView viewportConfig tintedPlotObjs viewTgt <- newIORef =<< readIORef viewState let objAxisLabels = concat $ _axisLabelRequests<$>givenPlotObjs viewTgtGlobal <- newMVar . (,objAxisLabels) =<< readIORef viewState - screenResolution <- newIORef (640, 480) + screenResolution <- newIORef (viewportConfig^.xResV, viewportConfig^.yResV) let viewConstraint = flip (foldr _viewportConstraint) givenPlotObjs let screenCoordsToData (sx,sy) = do @@ -1123,11 +1137,14 @@ dia <- readIORef dgStore - let scaledDia = Dia.bg Dia.black + let scaledDia = Dia.bg (case viewportConfig^.plotBackground of + Just bgc -> bgc + Nothing -> Dia.black) . Dia.scaleX (fromInt canvasX / 2) . Dia.scaleY (-fromInt canvasY / 2) . Dia.translate (1 ^& (-1)) . Dia.withEnvelope (Dia.rect 2 2 :: PlainGraphicsR2) + . (viewportConfig^.graphicsPostprocessing) $ dia drawWindow <- GTK.widgetGetDrawWindow drawA BGTK.renderToGtk drawWindow $ scaledDia @@ -1911,8 +1928,38 @@ Interactions _ (Just drag) -> pure . go $ upd drag s +indexedT :: Hask.Traversable t => t a -> t (Int,a) +indexedT v = (`evalState`0) . Hask.forM v $ \x -> do + i <- get + put $ i+1 + return (i,x) +updateAt :: Hask.Traversable t => Int -> (a->a) -> t a -> t a +updateAt iM f v = (`evalState`0) . Hask.forM v $ \x -> do + i <- get + put $ i+1 + return $ if i==iM then f x + else x +-- | Plot something dependent on points that the user can interactively move around. +-- The nearest point (Euclidean distance) is always picked to be dragged. +withDraggablePoints :: ∀ p list . (Plottable p, Traversable list) + => list (ℝ,ℝ) -> (list (ℝ,ℝ) -> p) -> DynamicPlottable +withDraggablePoints pts₀ f = go pts₀ + where go :: list (ℝ,ℝ) -> DynamicPlottable + go pts = addInterrupt . plot $ f pts + where addInterrupt :: DynamicPlottable -> DynamicPlottable + addInterrupt pl = pl + & futurePlots %~ \anim -> \case + Interactions _ Nothing -> return $ go pts + Interactions _ (Just drag) + -> let p = drag^.releaseLocation + grabbed = fst . minimumBy + (comparing $ magnitude . (^-^p) . snd) + $ indexedT pts + in return . go $ updateAt grabbed (const p) pts + + atExtendOf :: PlainGraphicsR2 -> PlainGraphicsR2 -> PlainGraphicsR2 atExtendOf d₁ = atExtendOf' d₁ 1 @@ -1940,3 +1987,14 @@ -- library soon. plotDelay :: NominalDiffTime -> DynamicPlottable -> DynamicPlottable plotDelay dly = sustained frameDelay .~ dly + +-- | Disable an animation, i.e. take an animated plot and show only the first frame. +freezeAnim :: DynamicPlottable -> DynamicPlottable +freezeAnim = futurePlots .~ const Nothing + +-- | Wait with starting the animation until the user has clicked on it. +startFrozen :: DynamicPlottable -> DynamicPlottable +startFrozen = futurePlots %~ \f inta -> if inta==mempty + then Nothing + else f inta + diff --git a/Graphics/Text/Annotation.hs b/Graphics/Text/Annotation.hs --- a/Graphics/Text/Annotation.hs +++ b/Graphics/Text/Annotation.hs @@ -3,7 +3,7 @@ -- Copyright : (c) Justus Sagemüller 2015 -- License : GPL v3 -- --- Maintainer : (@) sagemueller $ geo.uni-koeln.de +-- Maintainer : (@) jsage $ hvl.no -- Stability : experimental -- Portability : requires GHC>6 extensions diff --git a/dynamic-plot.cabal b/dynamic-plot.cabal --- a/dynamic-plot.cabal +++ b/dynamic-plot.cabal @@ -1,5 +1,5 @@ Name: dynamic-plot -Version: 0.4.0.0 +Version: 0.4.1.0 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions @@ -15,7 +15,7 @@ You can then zoom in to a shown diagram and it will automatically calculate the features more detailedly, or zoom out and discover previosly unexpected features. You don't need to worry about specifying the range and/or resolution beforehand: - the program will try to find a suitable default view based on /all/ data your displaying, + the program will try to find a suitable default view based on /all/ data you're displaying, and you can always still zoom, resize or move later. . are used as the “pre-rendered” type. This @@ -24,7 +24,7 @@ License: GPL-3 License-file: COPYING Author: Justus Sagemüller -Maintainer: (@) jsagemue $ uni-koeln.de +Maintainer: (@) jsag $ hvl.no Homepage: https://github.com/leftaroundabout/dynamic-plot Build-Type: Simple Cabal-Version: >=1.18