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 @@ -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 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 @@ -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: --- --- <> --- --- And that can with the mouse wheel be zoomed/browsed, like --- --- <> +-- <> -- -- 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 ] +-- @ +-- +-- <> +-- +-- 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) --- – 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 @@ -- from the -- library soon. plotDelay :: NominalDiffTime -> DynamicPlottable -> DynamicPlottable -plotDelay dly = frameDelay .~ dly - >>> futurePlots %~ fmap (plotDelay dly) +plotDelay dly = sustained frameDelay .~ dly diff --git a/Graphics/Image/Resample.hs b/Graphics/Image/Resample.hs new file mode 100644 --- /dev/null +++ b/Graphics/Image/Resample.hs @@ -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) diff --git a/Graphics/Text/Annotation.hs b/Graphics/Text/Annotation.hs --- a/Graphics/Text/Annotation.hs +++ b/Graphics/Text/Annotation.hs @@ -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 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.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 diff --git a/images/examples/HelloWorld.gif b/images/examples/HelloWorld.gif new file mode 100644 # file too large to diff: images/examples/HelloWorld.gif diff --git a/images/examples/propeller.png b/images/examples/propeller.png new file mode 100644 Binary files /dev/null and b/images/examples/propeller.png differ