dynamic-plot 0.3.0.0 → 0.4.0.0

raw patch · 7 files changed

+521/−95 lines, 7 filesdep ~linearmap-categorybinary-addedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: linearmap-category

API changes (from Hackage documentation)

Files

• Graphics/Dynamic/Plot/Internal/Types.hs +31/−1
• Graphics/Dynamic/Plot/R2.hs +328/−82
• Graphics/Image/Resample.hs +136/−0
• Graphics/Text/Annotation.hs +21/−8
• dynamic-plot.cabal +5/−4
• images/examples/HelloWorld.gif too large to diff
• images/examples/propeller.png binary

@@ -496,11 +496,41 @@   +data PrerenderScaling+       = ValuespaceScaling   -- ^ The diagram has the original coordinates of+                             --   the data that's plotted in it. E.g. if you've+                             --   plotted an oscillation with amplitude 1e-4, the+                             --   height of the plot will be indicated as only 0.0002.+                             --   Mostly useful when you want to juxtapose multiple+                             --   plots with correct scale matching.+       | NormalisedScaling   -- ^ The diagram is scaled to have a range of @[-1, 1]@+                             --   in both x- and y-direction.+       | OutputCoordsScaling -- ^ Scaled to pixel coordinates, i.e. the x range is+                             --   @[0, xResV-1]@ and the y range @[0, yResV-1]@.  data ViewportConfig = ViewportConfig {       _xResV, _yResV :: Int+    , _prerenderScaling :: PrerenderScaling+    , _plotContentZoomFactor :: Double     } makeLenses ''ViewportConfig  instance Default ViewportConfig where-  def = ViewportConfig 640 480+  def = ViewportConfig 640 480 ValuespaceScaling (6/7)+++data LegendDisplayConfig = LegendDisplayConfig {+      _legendPrerenderSize :: Dia.SizeSpec Dia.V2 Double+    }+makeLenses ''LegendDisplayConfig++defaultLegendLineHeight :: Double+defaultLegendLineHeight = 16++instance Default LegendDisplayConfig where+  def = LegendDisplayConfig $ Dia.mkSizeSpec2D Nothing (Just defaultLegendLineHeight)++data MouseEvent x = MouseEvent {+      _clickLocation, _releaseLocation :: x+    }+makeLenses ''MouseEvent

@@ -44,6 +44,7 @@         , tracePlot         , lineSegPlot         , linregressionPlot+        , colourPaintPlot         , PlainGraphicsR2         , shapePlot         , diagramPlot@@ -56,14 +57,22 @@         , tint, autoTint         -- ** Legend captions         , legendName+        , plotLegendPrerender         -- ** Animation         , plotDelay         -- * Viewport         -- ** View selection         , xInterval, yInterval, forceXRange, forceYRange         , unitAspect-        -- ** View dependence+        -- ** Interactive content+        -- $interactiveExplanation+        -- *** Mouse+        , MousePressed (..), MousePress(..), MouseClicks(..)+        , clickThrough, mouseInteractive+        , MouseEvent, clickLocation, releaseLocation+        -- *** Displayed range         , ViewXCenter(..), ViewYCenter(..), ViewWidth(..), ViewHeight(..)+        -- *** Resolution         , ViewXResolution(..), ViewYResolution(..)         -- * Auxiliary plot objects         , dynamicAxes, noDynamicAxes, xAxisLabel, yAxisLabel@@ -73,7 +82,13 @@         , tweakPrerendered         -- ** Viewport choice         , ViewportConfig+        -- *** Resolution         , xResV, yResV+        -- *** Output scaling+        , prerenderScaling+        , PrerenderScaling(..)+        , LegendDisplayConfig+        , legendPrerenderSize         ) where  import Graphics.Dynamic.Plot.Colour@@ -95,10 +110,13 @@ import qualified Diagrams.Backend.Cairo.Text as CairoTxt      import qualified Data.Colour as DCol+import qualified Data.Colour.SRGB as DCol (toSRGB24, RGB(..)) import qualified Data.Colour.Names as DCol import qualified Codec.Picture as JPix import qualified Codec.Picture.Types as JPix +import Graphics.Image.Resample (refiningScaleX2Bilinear)+ import qualified Diagrams.Backend.Gtk as BGTK import qualified Graphics.UI.Gtk as GTK import Graphics.UI.Gtk ( AttrOp((:=)) )@@ -107,6 +125,7 @@  import Control.Monad.Trans (liftIO, lift) import Control.Monad.ST+import Control.Applicative ((<|>)) import Data.STRef  import qualified Control.Category.Hask as Hask@@ -179,6 +198,16 @@  type AxisLabel = (ℝ², String) +data Interactions x = Interactions {+        _mouseClicksCompleted :: [MouseEvent x]+      , _currentDragEndpoints :: Maybe (MouseEvent x)+      }+instance Semigroup (Interactions x) where+  Interactions cca cda<>Interactions ccb cdb = Interactions (cca<>ccb) (cda<|>cdb)+instance Monoid (Interactions x) where+  mempty = Interactions [] Nothing+  mappend = (<>)+ data DynamicPlottable' m = DynamicPlottable {          _relevantRange_x, _relevantRange_y :: RangeRequest R       , _viewportConstraint :: GraphWindowSpec -> GraphWindowSpec@@ -192,7 +221,7 @@       , _frameDelay :: NominalDiffTime       , _legendEntries :: [LegendEntry]       , _axisLabelRequests :: [AxisLabel]-      , _futurePlots :: Maybe (DynamicPlottable' m)+      , _futurePlots :: Interactions (ℝ,ℝ) -> Maybe (DynamicPlottable' m)       , _dynamicPlotWithAxisLabels :: [AxisLabel] -> GraphWindowSpec -> m Plot   } makeLenses ''DynamicPlottable'@@ -203,7 +232,7 @@ sustained :: Hask.Functor m          => Setter' (DynamicPlottable' m) a -> Setter' (DynamicPlottable' m) a sustained q = sets $ \f p -> p & q %~ f-                               & futurePlots %~ fmap (sustained q %~ f)+                               & futurePlots %~ fmap (fmap $ sustained q %~ f)  allDynamicPlot :: Hask.Functor m => Setter' (DynamicPlottable' m)                                             (GraphWindowSpec -> m Plot)@@ -217,6 +246,7 @@ data ObjInPlot = ObjInPlot {         _lastStableView :: IORef (Maybe (GraphWindowSpec, AnnotPlot))       , _newPlotView :: MVar (GraphWindowSpec, AnnotPlot)+      , _mouseEventsForObj :: MVar (Interactions (ℝ,ℝ))       , _plotObjColour :: Maybe AColour       , _originalPlotObject :: DynamicPlottable    }@@ -253,17 +283,16 @@   plot = foldMap plot  instance Plottable PlainGraphics where-  plot (PlainGraphics d) = def+  plot (PlainGraphics d) = case DiaBB.getCorners bb of+     Just (c1, c2) -> let (rlx,rly) = ( c1^._x ... c2^._x+                                      , c1^._y ... c2^._y ) in def            & relevantRange_x .~ atLeastInterval rlx            & relevantRange_y .~ atLeastInterval rly            & inherentColours .~ [TrueColour DCol.grey]            & axesNecessity .~ -1            & dynamicPlot .~ pure.plot+     Nothing -> mempty    where bb = DiaBB.boundingBox d-         (rlx,rly) = case DiaBB.getCorners bb of-                       Just (c1, c2)-                        -> ( c1^._x ... c2^._x-                           , c1^._y ... c2^._y )          plot _ = mkPlot d  @@ -794,7 +823,7 @@ instance (Plottable x) => Plottable (Latest x) where   plot (Latest (ev₀ :| [])) = plot ev₀   plot (Latest (ev₀ :| ev₁:evs))-     = plot ev₀ & futurePlots .~ (Just . plot . Latest $ ev₁:|evs)+     = plot ev₀ & futurePlots .~ (const . Just . plot . Latest $ ev₁:|evs)  -- | Lazily consume the list, always plotting the latest value available as they --   arrive.@@ -912,9 +941,8 @@ -- | Set the caption for this plot object that should appear in the --   plot legend. legendName :: String -> DynamicPlottable -> DynamicPlottable-legendName n obj = legendEntries %~ (LegendEntry (PlainText n) colour mempty :)-           >>> futurePlots %~ fmap (legendName n)-                           $ obj+legendName n obj = sustained legendEntries %~ (LegendEntry (PlainText n) colour mempty :)+                   $ obj  where colour = case obj^.inherentColours of           (c₀:_) -> Just c₀           _ -> Nothing@@ -977,46 +1005,52 @@ --   If the objects contain animations, only the initial frame will be rendered. plotPrerender :: ViewportConfig -> [DynamicPlottable] -> IO PlainGraphicsR2 plotPrerender vpc [] = plotPrerender vpc [dynamicAxes]-plotPrerender vpc l = do-   renderd <- Random.runRVar ((plotMultiple l' ^. dynamicPlotWithAxisLabels)+plotPrerender vpc plotObjs = do+   renderd <- Random.runRVar ((getPlot%~Dia.lwO defLineWidth)+                          <$>(plotMultiple plotObjs' ^. dynamicPlotWithAxisLabels)                                    axLabels-                                   viewport{ xResolution = vpc^.xResV-                                           , yResolution = vpc^.yResV })+                                   viewport)                              Random.StdRandom    annot <- renderAnnotationsForView viewport (renderd^.plotAnnotations)    return $ annot <> renderd^.getPlot-          & Dia.withEnvelope (Dia.rect w h+          & case vpc^.prerenderScaling of+             ValuespaceScaling ->+              Dia.withEnvelope (Dia.rect w h                                & Dia.alignTL                                & Dia.moveTo (Dia.P $ V2 lBound tBound)                                    :: PlainGraphicsR2)- where viewport@(GraphWindowSpecR2{..}) = autoDefaultView l'+             prs -> normaliseView viewport+                >>> 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)+ where viewport@(GraphWindowSpecR2{..}) = autoDefaultView vpc plotObjs'        w = rBound - lBound; h = tBound - bBound-       l' = l ++ if axesNeed>0-                  then [dynamicAxes]-                  else []-       axLabels = concat $ _axisLabelRequests<$>l-       axesNeed = sum $ _axesNecessity<$>l+       plotObjs' = plotObjs ++ if axesNeed>0+                                then [dynamicAxes]+                                else []+       axLabels = concat $ _axisLabelRequests<$>plotObjs+       axesNeed = sum $ _axesNecessity<$>plotObjs +-- | Render the legend (if any) belonging to a collection of plottable objects.+plotLegendPrerender :: LegendDisplayConfig -> [DynamicPlottable]+                               -> IO (Maybe PlainGraphicsR2)+plotLegendPrerender ldc [] = pure Nothing+plotLegendPrerender ldc l = prerenderLegend (TextTK defaultTxtStyle 10 1 0.2 0.2)+                          colourScheme ldc entries+ where tintedl = chooseAutoTints l+       entries = (^.legendEntries) =<< tintedl+       GraphWindowSpecR2{..} = autoDefaultView def $ tintedl+ -- | Plot some plot objects to a new interactive GTK window. Useful for a quick --   preview of some unknown data or real-valued functions; things like selection --   of reasonable view range and colourisation are automatically chosen. --    --   Example: -- --- @---     plotWindow [ fnPlot cos---                , tracePlot [(x,y) | x<-[-1,-0.96..1]---                                   , y<-[0,0.01..1]---                                   , abs (x^2 + y^2 - 1) < 0.01 ]]--- @--- ---   This gives such a plot window:--- ---   <<images/examples/cos-encircle-points.png>>--- ---   And that can with the mouse wheel be zoomed/browsed, like--- ---   <<images/examples/cos-encircle-points.gif>>+--   <<images/examples/HelloWorld.gif>> --   --   The individual objects you want to plot can be evaluated in multiple threads, so --   a single hard calculatation won't freeze the responsitivity of the whole window.@@ -1033,13 +1067,20 @@        let defColourScheme = defaultColourScheme        tintedPlotObjs = chooseAutoTints givenPlotObjs+       viewportConfig = def :: ViewportConfig    -   viewState <- newIORef $ autoDefaultView tintedPlotObjs+   viewState <- newIORef $ autoDefaultView viewportConfig tintedPlotObjs    viewTgt <- newIORef =<< readIORef viewState    let objAxisLabels = concat $ _axisLabelRequests<$>givenPlotObjs    viewTgtGlobal <- newMVar . (,objAxisLabels) =<< readIORef viewState    screenResolution <- newIORef (640, 480)    let viewConstraint = flip (foldr _viewportConstraint) givenPlotObjs++   let screenCoordsToData (sx,sy) = do+         GraphWindowSpecR2{..} <- readIORef viewState+         let snx = sx / fromIntegral xResolution+             sny = sy / fromIntegral yResolution+         return (lBound + snx*(rBound-lBound), tBound - sny*(tBound-bBound))        dgStore <- newIORef mempty    @@ -1051,9 +1092,10 @@               | otherwise     = return []            assignPlObjPropties (o:os) axn = do               newDia <- newEmptyMVar-              workerId <- forkIO $ objectPlotterThread o viewTgtGlobal newDia+              newMouseEvs <- newEmptyMVar+              workerId <- forkIO $ objectPlotterThread o viewTgtGlobal newMouseEvs newDia               stableView <- newIORef Nothing-              ((ObjInPlot stableView newDia cl o, workerId) :)+              ((ObjInPlot stableView newDia newMouseEvs cl o, workerId) :)                      <$> assignPlObjPropties os (axn + o^.axesNecessity)             where cl | TrueColour c₀:_ <- o^.inherentColours                                   = Just $ Dia.opaque c₀@@ -1069,6 +1111,7 @@    window <- GTK.windowNew        mouseAnchor <- newIORef Nothing+   mousePressedAt <- newIORef Nothing                      refreshDraw <- do        drawA <- GTK.drawingAreaNew@@ -1098,6 +1141,30 @@             Event.eventButton >>= guard.(==defaultDragButton)             liftIO . writeIORef mouseAnchor $ Nothing        +       GTK.on drawA GTK.buttonPressEvent . Event.tryEvent $ do+            Event.eventButton >>= guard.(==defaultEditButton)+            (pressX,pressY) <- liftIO . screenCoordsToData =<< Event.eventCoordinates+            liftIO . writeIORef mousePressedAt $ Just (pressX,pressY)+            let event = MouseEvent (pressX^&pressY) (pressX^&pressY)+            liftIO . forM_ plotObjs $ _mouseEventsForObj >>> \mevs -> do+                   tryTakeMVar mevs >>= \case+                      Nothing -> putMVar mevs $ Interactions [] (Just event)+                      Just (Interactions qe _)+                              -> putMVar mevs $ Interactions qe (Just event)+       GTK.on drawA GTK.buttonReleaseEvent . Event.tryEvent $ do+            Event.eventButton >>= guard.(==defaultEditButton)+            (relX,relY) <- liftIO . screenCoordsToData =<< Event.eventCoordinates+            liftIO (readIORef mousePressedAt) >>= \case+             Just (pressX,pressY) -> liftIO $ do+                let event = MouseEvent (pressX^&pressY) (relX^&relY)+                forM_ plotObjs $ _mouseEventsForObj >>> \mevs -> do+                   tryTakeMVar mevs >>= \case+                      Nothing -> putMVar mevs $ Interactions [event] Nothing+                      Just (Interactions qe _)+                              -> putMVar mevs $ Interactions (event:qe) Nothing+             Nothing -> mzero+            liftIO . writeIORef mouseAnchor $ Nothing+               GTK.on drawA GTK.motionNotifyEvent . Event.tryEvent $ do           liftIO (readIORef mouseAnchor) >>= \case              Just (oldX,oldY) -> do@@ -1114,7 +1181,16 @@                            , bBound = bBound + h * ηY                            }                 liftIO . modifyIORef mouseAnchor . fmap $ const (mvX,mvY)-             Nothing -> mzero+             Nothing -> liftIO (readIORef mousePressedAt) >>= \case+                Just (pressX,pressY) -> do+                  (curX,curY) <- liftIO . screenCoordsToData =<< Event.eventCoordinates+                  let event = MouseEvent (pressX^&pressY) (curX^&curY)+                  liftIO . forM_ plotObjs $ _mouseEventsForObj >>> \mevs -> do+                    tryTakeMVar mevs >>= \case+                      Nothing -> putMVar mevs $ Interactions [] (Just event)+                      Just (Interactions qe _)+                              -> putMVar mevs $ Interactions qe (Just event)+                Nothing -> mzero        GTK.widgetAddEvents drawA [GTK.ButtonMotionMask]                GTK.on drawA GTK.scrollEvent . Event.tryEvent $ do@@ -1147,8 +1223,8 @@                                        GTK.set window [ GTK.windowTitle := "Plot"-                      , GTK.windowDefaultWidth := defResX-                      , GTK.windowDefaultHeight := defResY+                      , GTK.windowDefaultWidth := viewportConfig^.xResV+                      , GTK.windowDefaultHeight := viewportConfig^.yResV                       , GTK.containerChild := drawA                       ]        @@ -1163,14 +1239,7 @@        let refreshScreen = do            currentView@(GraphWindowSpecR2{..}) <- readIORef viewState-           let normaliseView :: PlainGraphicsR2 -> PlainGraphicsR2-               normaliseView = (Dia.scaleX xUnZ :: PlainGraphicsR2->PlainGraphicsR2)-                                  . Dia.scaleY yUnZ-                                . Dia.translate (Dia.r2(-x₀,-y₀))-                  where xUnZ = 1/w; yUnZ = 1/h-               w = (rBound - lBound)/2; h = (tBound - bBound)/2-               x₀ = lBound + w; y₀ = bBound + h-               textTK txSiz asp = TextTK defaultTxtStyle txSiz asp 0.2 0.2+           let textTK txSiz asp = TextTK defaultTxtStyle txSiz asp 0.2 0.2                renderComp plotObj = do                    plt <- tryTakeMVar (plotObj^.newPlotView) >>= \case                        Nothing -> fmap snd <$> readIORef (plotObj^.lastStableView)@@ -1182,17 +1251,20 @@                     Just (Plot{..}, objLegend) -> do                        renderedAnnot                            <- renderAnnotationsForView currentView _plotAnnotations-                       return (normaliseView $ renderedAnnot <> _getPlot, objLegend)+                       return (normaliseView currentView+                                     $ renderedAnnot <> _getPlot, objLegend)             (thisPlots, thisLegends)                  <- unzip . reverse <$> mapM renderComp (reverse plotObjs)            let thePlot = mconcat thisPlots            theLegend <- prerenderLegend (textTK 10 1) colourScheme+                           (LegendDisplayConfig Dia.absolute)                                    $ concat (fst<$>thisLegends)                    -           writeIORef dgStore $ ( theLegend & Dia.scaleX (0.1 / sqrt (fromIntegral xResolution))-                                            & Dia.scaleY (0.1 / sqrt (fromIntegral yResolution)) -                                            & (`Dia.place`(0.75^&0.75)) )+           writeIORef dgStore $ maybe mempty+                            (\l -> l & Dia.scaleX (0.1 / sqrt (fromIntegral xResolution))+                                     & Dia.scaleY (0.1 / sqrt (fromIntegral yResolution)) +                                     & (`Dia.place`(0.75^&0.75)) ) theLegend                                 <> thePlot                                                                 refreshDraw@@ -1232,21 +1304,35 @@  objectPlotterThread :: DynamicPlottable                        -> MVar (GraphWindowSpec, [AxisLabel])+                       -> MVar (Interactions (ℝ,ℝ))                        -> MVar (GraphWindowSpec, AnnotPlot)                        -> IO ()-objectPlotterThread pl₀ viewVar diaVar = loop pl₀ where- loop pl = do+objectPlotterThread pl₀ viewVar mouseVar diaVar = loop Nothing pl₀ where+ loop lastMousePressed pl = do     tPrev <- getCurrentTime     (view, labels) <- readMVar viewVar-    diagram <- evaluate =<< Random.runRVar+    newMice <- tryTakeMVar mouseVar+    let mice = case (newMice, lastMousePressed) of+          (Just m, _) -> m+          (Nothing, p) -> Interactions [] p+    diagram <- evaluate . (getPlot %~ Dia.lwO defLineWidth) =<< Random.runRVar                  ((pl^.dynamicPlotWithAxisLabels) labels view)                  Random.StdRandom     putMVar diaVar (view, (diagram, (pl^.legendEntries, pl^.axisLabelRequests)))     waitTill $ addUTCTime (pl^.frameDelay) tPrev-    case pl^.futurePlots of-       Just pl' -> loop pl'-       Nothing  -> loop pl+    loop (_currentDragEndpoints mice) $ case pl^.futurePlots $ mice of+       Just pl' -> pl'+       Nothing  -> pl     +    +normaliseView :: GraphWindowSpecR2 -> PlainGraphicsR2 -> PlainGraphicsR2+normaliseView currentView@(GraphWindowSpecR2{..})+      = (Dia.scaleX xUnZ :: PlainGraphicsR2->PlainGraphicsR2)+                   . Dia.scaleY yUnZ+                 . Dia.translate (Dia.r2(-x₀,-y₀))+   where xUnZ = 1/w; yUnZ = 1/h+         w = (rBound - lBound)/2; h = (tBound - bBound)/2+         x₀ = lBound + w; y₀ = bBound + h  -- | Require that both coordinate axes are zoomed the same way, such that e.g. --   the unit circle will appear as an actual circle.@@ -1254,10 +1340,11 @@ unitAspect = def & viewportConstraint . mapped . windowDataAspect .~ 1  -autoDefaultView :: [DynamicPlottable] -> GraphWindowSpec-autoDefaultView graphs =+autoDefaultView :: ViewportConfig -> [DynamicPlottable] -> GraphWindowSpec+autoDefaultView vpConf graphs =          foldr _viewportConstraint-            (GraphWindowSpecR2 l r b t defResX defResY defaultColourScheme)+            (GraphWindowSpecR2 l r b t+                               (vpConf^.xResV) (vpConf^.yResV) defaultColourScheme)             graphs   where (xRange, yRange) = foldMap (_relevantRange_x &&& _relevantRange_y) graphs         ((l,r), (b,t)) = ( xRange `dependentOn` yRange@@ -1274,7 +1361,7 @@                   = Interval a b         defRng _  = Interval (-1) 1   -- ad-hoc hack to catch NaNs etc..         addMargin (Interval a b) = (a - q, b + q)-            where q = (b - a) / 6+            where q = (b - a) * (1/(vpConf^.plotContentZoomFactor) - 1)     renderAnnotationsForView :: GraphWindowSpecR2 -> [Annotation] -> IO PlainGraphicsR2@@ -1290,11 +1377,7 @@   -defResX, defResY :: Integral i => i-defResX = 640-defResY = 480 - data ScrollAction = ScrollZoomIn | ScrollZoomOut  defaultScrollBehaviour :: Event.ScrollDirection -> ScrollAction@@ -1304,6 +1387,9 @@ defaultDragButton :: Event.MouseButton defaultDragButton = Event.MiddleButton +defaultEditButton :: Event.MouseButton+defaultEditButton = Event.LeftButton+ scrollZoomStrength :: Double scrollZoomStrength = 1/20 @@ -1336,7 +1422,9 @@        plot (GraphWindowSpecR2{..}) = curve `deepseq` mkPlot (trace curve)         where δx = (rBound - lBound) * 2 / fromIntegral xResolution               curve = [ (x ^& f x) | x<-[lBound, lBound+δx .. rBound] ]-              trace (p:q:ps) = simpleLine p q <> trace (q:ps)+              trace (p:q:ps) = (if not $ any (isNaN . (^._y)) [p, q]+                                 then simpleLine p q else mempty+                                ) <> trace (q:ps)               trace _ = mempty        pruneOutlyers = filter (not . isNaN)         l!%η = case length l of@@ -1345,6 +1433,84 @@             | otherwise -> l !! floor (fromIntegral ll * η)  +-- | Plot a function that assigns every point in view a colour value.+--+-- @+-- > plotWindow [colourPaintPlot $ \(x,y) -> case (x^2+y^2, atan2 y x) of (r,φ) -> guard (sin (7*φ-2*r) > r) >> Just (Dia.blend (tanh r) Dia.red Dia.green), unitAspect ]+-- @+-- +--   <<images/examples/propeller.png>>+-- +--   We try to evaluate that function no more often than necessary, but since it's a+--   plain function with no differentiability information there's only so much that can+--   be done; this requires a tradeoff between rasterisation fineness and performance.+--   It works well for simple, smooth functions, but may not be adequate for+--   functions with strong edges/transients, nor for expensive to compute functions.+colourPaintPlot :: ((Double,Double) -> Maybe (DCol.Colour Double)) -> DynamicPlottable+colourPaintPlot f = def & dynamicPlot .~ pure . plot+                        & axesNecessity .~ 0.5+ where plot graSpec = mkPlot . Dia.image $ Dia.DImage+                            (Dia.ImageRaster $ JPix.ImageRGBA8 pixRendered)+                            renderWidth renderHeight+                            placement+        where preSeekWidth = round $ fromIntegral (xResolution graSpec) / 12+              preSeekHeight = round $ fromIntegral (yResolution graSpec) / 12+              roughRenderWidth = fromIntegral preSeekWidth * 2 - 1+              roughRenderHeight = fromIntegral preSeekHeight * 2 - 1+              renderWidth, renderHeight :: Num n => n+              renderWidth = fromIntegral roughRenderWidth * 2 - 1+              renderHeight = fromIntegral roughRenderHeight * 2 - 1+              x₀ = lBound graSpec+              x₁ = rBound graSpec+              y₀ = bBound graSpec+              y₁ = tBound graSpec+              xc = (x₀+x₁)/2+              yc = (y₀+y₁)/2+              wPix = (x₁ - x₀)/renderWidth+              wRoughPix = (x₁+wPix - x₀)/fromIntegral roughRenderWidth+              wPreSeekPix = (x₁+wRoughPix - x₀)/fromIntegral preSeekWidth+              hPix = (y₁ - y₀)/renderHeight+              hRoughPix = (y₁+hPix - y₀)/fromIntegral roughRenderHeight+              hPreSeekPix = (y₁+hRoughPix - y₀)/fromIntegral preSeekHeight+              placement+                  = Dia.translation (xc^&yc) <> Dia.scalingX wPix <> Dia.scalingY hPix+              +              pixRendered = runST (do+                 +                 hits <- newSTRef ([] :: [(Int,Int)])+                 +                 rough² <- JPix.withImage preSeekWidth preSeekHeight+                  `id`\ix iy -> do+                        let x = x₀ + wPreSeekPix*fromIntegral ix+                            y = y₁ - hPreSeekPix*fromIntegral iy+                        case f (x,y) of+                            Just fxy -> do+                              modifySTRef hits ((ix,iy):)+                              pure `id` JPix.promotePixel+                                          (CSp.quantiseColour fxy :: JPix.PixelRGB8)+                            Nothing ->+                              pure `id` JPix.PixelRGBA8 0 0 0 0+                 +                 allHits <- readSTRef hits+                 +                 let (intermediate, gradientHotSpots)+                      = refiningScaleX2Bilinear allHits+                         (\(ix,iy) -> case f ( x₀ + wRoughPix*fromIntegral ix+                                             , y₁ - hRoughPix*fromIntegral iy ) of+                           Just fxy -> JPix.promotePixel+                                    (CSp.quantiseColour fxy :: JPix.PixelRGB8)+                           Nothing -> JPix.PixelRGBA8 0 0 0 0 )+                         rough²+                 +                 pure . fst . refiningScaleX2Bilinear gradientHotSpots+                         (\(ix,iy) -> case f ( x₀ + wPix*fromIntegral ix+                                             , y₁ - hPix*fromIntegral iy ) of+                           Just fxy -> JPix.promotePixel+                                    (CSp.quantiseColour fxy :: JPix.PixelRGB8)+                           Nothing -> JPix.PixelRGBA8 0 0 0 0 )+                         $ intermediate+                )+ type (-->) = RWDiffable ℝ  -- | Plot a continuous function in the usual way, taking arguments from the@@ -1533,9 +1699,9 @@                                 yFar = if tBound > abs bBound/2                                         then tBound else bBound                           ]-       zeroLine p1 p2 = simpleLine p1 p2 & Dia.lc Dia.grey+       zeroLine p1 p2 = simpleLine' defLineWidth p1 p2 & Dia.lc Dia.grey        renderClass crd (AxisClass axes strength _)-          = foldMap (uncurry simpleLine . crd . axisPosition) axes+          = foldMap (uncurry (simpleLine' defLineWidth) . crd . axisPosition) axes              & Dia.lcA (Dia.grey `DCol.withOpacity` strength)  @@ -1544,14 +1710,19 @@  xAxisLabel :: String -> DynamicPlottable xAxisLabel str = def & axisLabelRequests .~ [(1^&0, str)]+                     & axesNecessity .~ 2  yAxisLabel :: String -> DynamicPlottable yAxisLabel str = def & axisLabelRequests .~ [(0^&1, str)]+                     & axesNecessity .~ 2   simpleLine :: P2 -> P2 -> PlainGraphicsR2-simpleLine = simpleLine' 2+simpleLine p q = Dia.fromVertices [p,q] +defLineWidth :: Double+defLineWidth = 2+ simpleLine' :: Double -> P2 -> P2 -> PlainGraphicsR2 simpleLine' w p q = Dia.fromVertices [p,q] & Dia.lwO w @@ -1592,13 +1763,12 @@   --- | 'ViewXCenter', 'ViewYResolution' etc. can be used as arguments to some object---   you 'plot', if its rendering is to depend explicitly on the screen's visible range.---   You should not need to do that manually except for special applications (the---   standard plot objects like 'fnPlot' already take the range into account anyway)---   &#x2013; e.g. comparing  with the linear regression /of all visible points/---   from some sample with some function's tangent /at the screen center/.---   +-- $interactiveExplanation+--   'MouseClicks', 'ViewXCenter', 'ViewYResolution' etc. can be used as arguments to some object+--   you 'plot', if you want to plot stuff that depends on user interaction+--   or just on the screen's visible range, for instance to calculate a tangent+--   at the middle of the screen:+--  -- @ -- plotWindow [fnPlot sin, plot $ \\(ViewXCenter xc) x -> sin xc + (x-xc) * cos xc] -- @@@ -1663,9 +1833,86 @@ newtype ViewXResolution = ViewXResolution { getViewXResolution :: Int } newtype ViewYResolution = ViewYResolution { getViewYResolution :: Int } +newtype MouseClicks = MouseClicks {+      getClickPositions :: [(ℝ,ℝ)] -- ^ A history of all clicks that were done+                                   --   in this window; more specifically, of all+                                   --   /left mouse-button release events/ recorded.+    }+instance (Plottable p) => Plottable (MouseClicks -> p) where+  plot f = go []+   where go oldClicks = addInterrupt . plot . f $ MouseClicks oldClicks+          where addInterrupt :: DynamicPlottable -> DynamicPlottable+                addInterrupt pl = pl+                     & futurePlots %~ \anim -> \case+                         interac@(Interactions [] _) -> fmap addInterrupt $ anim interac+                         Interactions newClicks _ -> pure . go+                              $ (_releaseLocation<$>newClicks) ++ oldClicks +newtype MousePress = MousePress {+      lastMousePressedLocation :: (ℝ,ℝ)+    }+instance (Plottable p) => Plottable (MousePress -> p) where+  plot f = go Nothing+   where go :: Maybe (ℝ,ℝ) -> DynamicPlottable+         go Nothing = mempty & futurePlots .~ pure . \case+              Interactions [] Nothing -> go Nothing+              Interactions (click:_) Nothing -> go . Just $ click^.releaseLocation+              Interactions _ (Just current) -> go . Just $ current^.releaseLocation+         go (Just lastPressed) = addInterrupt . plot . f $ MousePress lastPressed+          where addInterrupt :: DynamicPlottable -> DynamicPlottable+                addInterrupt pl = pl+                     & futurePlots %~ \anim -> \case+                  Interactions [] Nothing -> fmap addInterrupt $ anim mempty+                  Interactions (click:_) Nothing+                                  -> pure . go . Just $ click^.releaseLocation+                  Interactions _ (Just drag)+                                  -> pure . go . Just $ drag^.releaseLocation +newtype MousePressed = MousePressed {+      mouseIsPressedAt :: Maybe (ℝ,ℝ)+    }+instance (Plottable p) => Plottable (MousePressed -> p) where+  plot f = go Nothing+   where go :: Maybe (ℝ,ℝ) -> DynamicPlottable+         go lastInt = addInterrupt . plot . f $ MousePressed lastInt+          where addInterrupt :: DynamicPlottable -> DynamicPlottable+                addInterrupt pl = pl+                     & futurePlots %~ \anim -> \case+                  Interactions _ Nothing+                    | isNothing lastInt  -> fmap addInterrupt $ anim mempty+                    | otherwise          -> return $ go Nothing+                  Interactions _ (Just drag)+                                  -> pure . go . Just $ drag^.releaseLocation +-- | Move through a sequence of plottable objects, switching to the next+--   whenever a click is received anywhere on the screen. Similar to 'plotLatest',+--   but does not proceed automatically.+clickThrough :: Plottable p => [p] -> DynamicPlottable+clickThrough [] = mempty+clickThrough [final] = plot final+clickThrough (v:vs) = addInterrupt $ plot v+ where addInterrupt :: DynamicPlottable -> DynamicPlottable+       addInterrupt pl = pl & futurePlots %~ \anim -> \case+           interac@(Interactions [] _) -> fmap addInterrupt $ anim interac+           Interactions (_:_) _ -> Just $ clickThrough vs++mouseInteractive :: Plottable p+       => (MouseEvent (ℝ,ℝ) -> s -> s)+       -> s+       -> (s -> p)+       -> DynamicPlottable+mouseInteractive upd initl f = go initl+ where go s = addInterrupt . plot $ f s+        where addInterrupt :: DynamicPlottable -> DynamicPlottable+              addInterrupt pl = pl+                   & futurePlots %~ \anim -> \case+                Interactions _ Nothing+                       -> fmap addInterrupt $ anim mempty+                Interactions _ (Just drag)+                       -> pure . go $ upd drag s+++ atExtendOf :: PlainGraphicsR2 -> PlainGraphicsR2 -> PlainGraphicsR2 atExtendOf d₁ = atExtendOf' d₁ 1 @@ -1692,5 +1939,4 @@ --   <http://hackage.haskell.org/package/thyme-0.3.5.5/docs/Data-Thyme-Clock.html#t:NominalDiffTime NominalDiffTime> from the <http://hackage.haskell.org/package/thyme thyme> --   library soon. plotDelay :: NominalDiffTime -> DynamicPlottable -> DynamicPlottable-plotDelay dly = frameDelay .~ dly-            >>> futurePlots %~ fmap (plotDelay dly)+plotDelay dly = sustained frameDelay .~ dly

@@ -0,0 +1,136 @@+-- |+-- Module      : Graphics.Image.Resample+-- Copyright   : (c) Justus Sagemüller 2018+-- License     : GPL v3+-- +-- Maintainer  : (@) sagemuej $ smail.uni-koeln.de+-- Stability   : experimental+-- Portability : requires GHC>6 extensions++{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Graphics.Image.Resample where++import qualified Codec.Picture as JPix+import qualified Codec.Picture.Types as JPix++import qualified Data.Vector.Storable as SArr++import Control.Monad+import Control.Monad.ST+import Data.STRef+++scaleX2Bilinear :: JPix.Image JPix.PixelRGBA8 -> JPix.Image JPix.PixelRGBA8+scaleX2Bilinear img@(JPix.Image _ _ imgData) = runST $ do+   buf@(JPix.MutableImage _ _ bufData) <- JPix.newMutableImage wScaled hScaled++   let pbc = JPix.componentCount (undefined :: JPix.PixelRGBA8)+   +   forM_ [0 .. hOrig-2] $ \j -> do+      forM_ [0 .. wOrig-2] $ \k -> do+         let linIndex = JPix.pixelBaseIndex img k j+             orig₀₀ = JPix.unsafePixelAt imgData linIndex+             orig₀₁ = JPix.unsafePixelAt imgData (linIndex+pbc)+             orig₁₀ = JPix.unsafePixelAt imgData (linIndex+pbc*wOrig)+             linIndexScaled = JPix.mutablePixelBaseIndex buf (k*2) (j*2)+         JPix.unsafeWritePixel bufData linIndexScaled+                   $ orig₀₀+         JPix.unsafeWritePixel bufData (linIndexScaled+pbc)+                   $ between orig₀₀ orig₀₁+         JPix.unsafeWritePixel bufData (linIndexScaled+pbc*wScaled)+                   $ between orig₀₀ orig₁₀+         JPix.unsafeWritePixel bufData (linIndexScaled+pbc+pbc*wScaled)+                   $ between orig₁₀ orig₀₁+   +   forM_ [0 .. hOrig-2] $ \j -> do+      forM_ [wOrig-1] $ \k -> do+         let orig₀₀ = JPix.pixelAt img k j+             orig₁₀ = JPix.pixelAt img k (j+1)+         JPix.writePixel buf (k*2)   (j*2)   $ orig₀₀+         JPix.writePixel buf (k*2)   (j*2+1) $ between orig₀₀ orig₁₀+   +   forM_ [hOrig-1] $ \j -> do+      forM_ [0 .. wOrig-2] $ \k -> do+         let orig₀₀ = JPix.pixelAt img k     j+             orig₀₁ = JPix.pixelAt img (k+1) j+         JPix.writePixel buf (k*2)   (j*2)   $ orig₀₀+         JPix.writePixel buf (k*2+1) (j*2)   $ between orig₀₀ orig₀₁+         +   forM_ [hOrig-1] $ \j -> do+      forM_ [wOrig-1] $ \k -> do+         let orig₀₀ = JPix.pixelAt img k j+         JPix.writePixel buf (k*2) (j*2) $ orig₀₀++   JPix.unsafeFreezeImage buf+         + where wOrig = JPix.imageWidth img+       wScaled = 2 * wOrig - 1+       hOrig = JPix.imageHeight img+       hScaled = 2 * hOrig - 1++refiningScaleX2Bilinear ::+     [(Int,Int)] -> ((Int,Int) -> JPix.PixelRGBA8)+    -> JPix.Image JPix.PixelRGBA8 -> (JPix.Image JPix.PixelRGBA8, [(Int,Int)])+refiningScaleX2Bilinear hotSpots refineFn loRes = runST (do+    intermediate <- JPix.unsafeThawImage $ scaleX2Bilinear loRes++    alreadyDone <- JPix.unsafeThawImage+           $ JPix.generateImage (\_ _ -> 0::JPix.Pixel8)+                        renderWidth renderHeight++    alterations <- newSTRef []+    +    let refineAt (ix,iy) = do+           roughVal <- JPix.readPixel intermediate ix iy+           let refinedVal = refineFn (ix,iy)+           JPix.writePixel intermediate ix iy refinedVal+           JPix.writePixel alreadyDone ix iy 1+           notablyDifferent refinedVal roughVal ==> modifySTRef alterations ((ix,iy):)+        refineBack (ix,iy) = do+           doneBefore <- JPix.readPixel alreadyDone ix iy+           doneBefore==0 ==> refineAt (ix,iy)+    +    forM_ hotSpots $ \(irx,iry) -> do+       irx > 0 ==> do+          refineBack (2*irx - 1, 2*iry)+          iry > 0 ==> refineBack (2*irx - 1, 2*iry - 1)+          iry < loResHeight-1 ==> refineBack (2*irx - 1, 2*iry + 1)+       irx < loResWidth-1 ==> do+          refineAt (2*irx + 1, 2*iry)+          iry > 0 ==> refineBack (2*irx + 1, 2*iry - 1)+          iry < loResHeight-1 ==> refineAt (2*irx + 1, 2*iry + 1)+       iry > 0 ==> refineBack (2*irx, 2*iry - 1)+       iry < loResHeight-1 ==> refineAt (2*irx, 2*iry + 1)+    +    alterationsDone <- readSTRef alterations+    +    result <- JPix.unsafeFreezeImage intermediate++    return (result, alterationsDone)+   )+ where loResWidth = JPix.imageWidth loRes+       loResHeight = JPix.imageHeight loRes+       renderWidth = loResWidth * 2 - 1+       renderHeight = loResHeight * 2 - 1+       infixr 1 ==>+       (==>) = when+++notablyDifferent :: JPix.PixelRGBA8 -> JPix.PixelRGBA8 -> Bool+notablyDifferent (JPix.PixelRGBA8 r₀ g₀ b₀ a₀) (JPix.PixelRGBA8 r₁ g₁ b₁ a₁)+   = ( abs (fromIntegral r₀ - fromIntegral r₁)+     + abs (fromIntegral g₀ - fromIntegral g₁)+     + abs (fromIntegral b₀ - fromIntegral b₁)+     + abs (fromIntegral a₀ - fromIntegral a₁) :: Int )+     > 16+    ++between :: JPix.PixelRGBA8 -> JPix.PixelRGBA8 -> JPix.PixelRGBA8+between (JPix.PixelRGBA8 r₀ g₀ b₀ a₀) (JPix.PixelRGBA8 r₁ g₁ b₁ a₁)+       = JPix.PixelRGBA8 (r₀`quot`2 + r₁`quot`2)+                         (g₀`quot`2 + g₁`quot`2)+                         (b₀`quot`2 + b₁`quot`2)+                         (a₀`quot`2 + a₁`quot`2)

@@ -202,12 +202,12 @@   asAColourWith sch = asAColourWith sch . _plotObjRepresentativeColour  -prerenderLegend :: TextTK -> ColourScheme-                     -> [LegendEntry] -> IO PlainGraphicsR2-prerenderLegend _ _ [] = return mempty-prerenderLegend TextTK{..} cscm l = do+prerenderLegend :: TextTK -> ColourScheme -> LegendDisplayConfig+                     -> [LegendEntry] -> IO (Maybe PlainGraphicsR2)+prerenderLegend _ _ _ [] = return mempty+prerenderLegend TextTK{..} cscm layoutSpec l = do    let bgColour = cscm neutral-   lRends <- fmap Dia.vcat $ forM l `id`\legEntry -> do+   lRends <- forM l `id`\legEntry -> do           txtR <- CairoTxt.textVisualBoundedIO txtCairoStyle                        $ DiaTxt.Text mempty (DiaTxt.BoxAlignedText 0 0.5)                                             (fromPlaintextObj $ legEntry^.plotObjectTitle)@@ -218,8 +218,21 @@                               ] & Dia.centerXY                                 & Dia.frame 2                                 & Dia.alignL-   let w = Dia.width lRends-       h = Dia.height lRends-   return $ ( lRends & Dia.centerXY & Dia.translate (3^&3) )+   let szSpec = Dia.getSpec (layoutSpec ^. legendPrerenderSize)+       hLine = maximum $ Dia.height <$> lRends+       nLines = case szSpec of+           DiaTypes.V2 _ Nothing -> length l+           DiaTypes.V2 _ (Just hMax) -> max 1 . floor $ hMax / hLine+       lRends2D = Dia.hsep (txtSize*2) $ Dia.vcat <$> takes nLines lRends+       w = case szSpec of+           DiaTypes.V2 Nothing _ -> Dia.width lRends2D+           DiaTypes.V2 (Just wM) _ -> wM+       h = Dia.height lRends2D+   return . pure+          $ ( lRends2D & Dia.centerXY & Dia.translate (3^&3) )          <> ( Dia.rect (w+1) (h+1) & Dia.fcA (cscm $ paler grey) )+ where takes :: Int -> [a] -> [[a]]+       takes n [] = []+       takes n l = case splitAt n l of+            (h,r) -> h : takes n r 

@@ -1,5 +1,5 @@ Name:                dynamic-plot-Version:             0.3.0.0+Version:             0.4.0.0 Category:            graphics Synopsis:            Interactive diagram windows Description:         Haskell excels at handling data like continuous functions@@ -24,7 +24,7 @@ License:             GPL-3 License-file:        COPYING Author:              Justus Sagemüller-Maintainer:          (@) sagemuej $ smail.uni-koeln.de+Maintainer:          (@) jsagemue $ uni-koeln.de Homepage:            https://github.com/leftaroundabout/dynamic-plot Build-Type:          Simple Cabal-Version:       >=1.18@@ -52,7 +52,7 @@                      , process                      , constrained-categories >= 0.2                      , free-vector-spaces >= 0.1 && < 0.2-                     , linearmap-category+                     , linearmap-category >=0.3.5                      , diagrams-core                      , diagrams-lib >= 1.3 && < 1.5                      , diagrams-cairo@@ -60,7 +60,7 @@                      , gtk > 0.10 && < 0.15                      , glib                      , colour >= 2 && < 3-                     , manifolds >= 0.4.2 && < 0.5+                     , manifolds >= 0.4.2 && < 0.6                      , manifold-random                      , colour-space                      , JuicyPixels > 3 && < 4@@ -81,3 +81,4 @@   Other-modules:     Graphics.Dynamic.Plot.Colour                      , Graphics.Dynamic.Plot.Internal.Types                      , Graphics.Text.Annotation+                     , Graphics.Image.Resample

file too large to diff

binary file changed (absent → 58155 bytes)