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 @@ -7,8 +7,10 @@ -- Stability : experimental -- Portability : requires GHC>6 extensions +{-# LANGUAGE FlexibleInstances #-} + module Graphics.Dynamic.Plot.Colour ( module Graphics.Dynamic.Plot.Colour - , Colour, AColour, FColour, ColourScheme + , Colour, AColour, FColour, PColour, ColourScheme ) where @@ -68,3 +70,20 @@ hueInvert c = let (l,a,b) = cieLABView i c in cieLAB i l (1-a) (1-b) where i = Illum.a + + + + +class HasColour c where + asAColourWith :: ColourScheme -> c -> AColour + +instance HasColour AColour where asAColourWith _ = id +instance HasColour FColour where asAColourWith _ = DCol.opaque +instance HasColour Colour where asAColourWith = ($) +instance HasColour PColour where + asAColourWith sch (TrueColour c) = asAColourWith sch c + asAColourWith sch (SymbolicColour c) = asAColourWith sch c + +instance (HasColour a) => HasColour (Maybe a) where + asAColourWith sch Nothing = sch $ paler contrast + asAColourWith sch (Just c) = asAColourWith sch c 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 @@ -26,6 +26,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Graphics.Dynamic.Plot.Internal.Types where @@ -49,6 +50,7 @@ import Control.Monad.Constrained import Control.Lens hiding ((...), (<.>)) +import Control.Lens.TH import qualified Data.Vector as Arr import Data.List (sort) @@ -65,6 +67,7 @@ import Data.Tagged import Control.DeepSeq +import Data.Default type R2 = Dia.V2 Double type P2 = Dia.P2 Double @@ -351,6 +354,9 @@ type ColourScheme = Colour -> AColour +data PColour = TrueColour FColour | SymbolicColour Colour + + data GraphWindowSpecR2 = GraphWindowSpecR2 { lBound, rBound, bBound, tBound :: R , xResolution, yResolution :: Int @@ -384,6 +390,18 @@ in GraphWindowSpecR2 (cx - η*rx) (cx + η*rx) (cy - η*ry) (cy + η*ry) xRes yRes colSch ) +windowDataAspect :: Lens' GraphWindowSpecR2 R +windowDataAspect = lens + (\(GraphWindowSpecR2 l r b t xRes yRes _) -> (r-l)/(t-b) + * fromIntegral yRes/fromIntegral xRes) + (\(GraphWindowSpecR2 l r b t xRes yRes colSch) βNew + -> let cx = (l+r)/2; rx = (r-l)/2 + cy = (b+t)/2; ry = (t-b)/2 + βOld = (r-l)/(t-b) * fromIntegral yRes/fromIntegral xRes + ψ = sqrt $ βNew / βOld + in GraphWindowSpecR2 (cx - rx*ψ) (cx + rx*ψ) (cy - ry/ψ) (cy + ry/ψ) + xRes yRes colSch + ) @@ -477,3 +495,12 @@ deriving (Hask.Functor) + + +data ViewportConfig = ViewportConfig { + _xResV, _yResV :: Int + } +makeLenses ''ViewportConfig + +instance Default ViewportConfig where + def = ViewportConfig 640 480 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,6 +1,6 @@ -- | -- Module : Graphics.Dynamic.Plot.R2 --- Copyright : (c) Justus Sagemüller 2013-2015 +-- Copyright : (c) Justus Sagemüller 2013-2017 -- License : GPL v3 -- -- Maintainer : (@) sagemueller $ geo.uni-koeln.de @@ -30,8 +30,11 @@ {-# LANGUAGE TemplateHaskell #-} module Graphics.Dynamic.Plot.R2 ( - -- * Interactive display - plotWindow + -- * Display + -- ** Static + plotPrerender + -- ** Interactive + , plotWindow -- * Plottable objects -- ** Class , Plottable(..) @@ -44,6 +47,8 @@ , PlainGraphicsR2 , shapePlot , diagramPlot + -- ** Multiple objects in one plot + , plotMultiple -- ** Computation in progress , plotLatest -- * Plot-object attributes @@ -56,14 +61,19 @@ -- * Viewport -- ** View selection , xInterval, yInterval, forceXRange, forceYRange + , unitAspect -- ** View dependence , ViewXCenter(..), ViewYCenter(..), ViewWidth(..), ViewHeight(..) , ViewXResolution(..), ViewYResolution(..) -- * Auxiliary plot objects - , dynamicAxes, noDynamicAxes - -- * The plot type + , dynamicAxes, noDynamicAxes, xAxisLabel, yAxisLabel + -- * Types + -- ** The plot type , DynamicPlottable , tweakPrerendered + -- ** Viewport choice + , ViewportConfig + , xResV, yResV ) where import Graphics.Dynamic.Plot.Colour @@ -78,6 +88,7 @@ import qualified Diagrams.Prelude as Dia import qualified Diagrams.TwoD.Size as Dia import qualified Diagrams.TwoD.Types as DiaTypes +import Diagrams.TwoD.Types (V2(V2)) import Diagrams.BoundingBox (BoundingBox) import qualified Diagrams.BoundingBox as DiaBB import qualified Diagrams.Backend.Cairo as Cairo @@ -166,9 +177,12 @@ type GraphWindowSpec = GraphWindowSpecR2 +type AxisLabel = (ℝ², String) + data DynamicPlottable' m = DynamicPlottable { _relevantRange_x, _relevantRange_y :: RangeRequest R - , _inherentColours :: [DCol.Colour ℝ] + , _viewportConstraint :: GraphWindowSpec -> GraphWindowSpec + , _inherentColours :: [PColour] , _occlusiveness :: Double -- ^ How surface-occupying the plot is. -- Use positive values for opaque 2D plots that would tend to obscure @@ -177,14 +191,28 @@ , _axesNecessity :: Necessity , _frameDelay :: NominalDiffTime , _legendEntries :: [LegendEntry] + , _axisLabelRequests :: [AxisLabel] , _futurePlots :: Maybe (DynamicPlottable' m) - , _dynamicPlot :: GraphWindowSpec -> m Plot + , _dynamicPlotWithAxisLabels :: [AxisLabel] -> GraphWindowSpec -> m Plot } makeLenses ''DynamicPlottable' +dynamicPlot :: Setter' (DynamicPlottable' m) (GraphWindowSpec -> m Plot) +dynamicPlot = dynamicPlotWithAxisLabels . mapped + +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) + +allDynamicPlot :: Hask.Functor m => Setter' (DynamicPlottable' m) + (GraphWindowSpec -> m Plot) +allDynamicPlot = sustained dynamicPlot + + type DynamicPlottable = DynamicPlottable' Random.RVar -type AnnotPlot = (Plot, [LegendEntry]) +type AnnotPlot = (Plot, ([LegendEntry],[AxisLabel])) data ObjInPlot = ObjInPlot { _lastStableView :: IORef (Maybe (GraphWindowSpec, AnnotPlot)) @@ -228,7 +256,7 @@ plot (PlainGraphics d) = def & relevantRange_x .~ atLeastInterval rlx & relevantRange_y .~ atLeastInterval rly - & inherentColours .~ [DCol.grey] + & inherentColours .~ [TrueColour DCol.grey] & axesNecessity .~ -1 & dynamicPlot .~ pure.plot where bb = DiaBB.boundingBox d @@ -599,10 +627,10 @@ = ((x,δx),yq) : ((x',δx),yq') : tail (ccδs xyqs) where δx = (x'' - x)/4 [xmin, ymin, xmax, ymax] - = [minimum, maximum]<*>[_topological<$>allLeaves, _untopological<$>allLeaves] + = [minimum, maximum]<*>[fst<$>allLeaves, snd<$>allLeaves] lLoop ps@(p:_) = Dia.fromVertices $ ps++[p] leafPoints = sortBy (comparing (^._x)) - $ (\(x`WithAny`y) -> y^&x) <$> allLeaves + $ (\(x,y) -> y^&x) <$> allLeaves allLeaves = onlyLeaves tr plot _ = def @@ -685,6 +713,25 @@ <$> Random.rvar c toRGBA _ = return $ JPix.PixelRGBA8 0 0 0 0 +instance Plottable (Cutplane (ℝ,ℝ)) where + plot (Cutplane (x₀,y₀) (Stiefel1 (dy,dx))) + = plot (Cutplane (V2 x₀ y₀) (Stiefel1 (V2 dy dx))) + +instance Plottable (Cutplane ℝ²) where + plot (Cutplane (V2 x₀ y₀) (Stiefel1 (V2 dy dx))) + = def & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ pure . plot + where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $ simpleLine p q + where [p,q] + | abs (dy*(rBound-lBound)) > abs (dx*(tBound-bBound)) + = [xf bBound ^& bBound, xf tBound ^& tBound] + | otherwise + = [lBound ^& yf lBound, rBound ^& yf rBound] + yf x = y₀ - dy/dx * (x-x₀) + xf y = x₀ - dx/dy * (y-y₀) + + webbedSurfPlot :: Geodesic a => (Maybe a -> Random.RVar JPix.PixelRGBA8) -> PointsWeb (ℝ,ℝ) a -> DynamicPlottable @@ -736,12 +783,23 @@ +-- | Combine multiple objects in a single plot. Each will get an individual 'tint' +-- (if applicable). This is also the default behaviour of 'plotWindow'. +-- +-- To plot a family objects all with the /same/ (but automatically-chosen) tint, +-- simply use 'plot' on the list, or combine them monoidally with '<>'. +plotMultiple :: Plottable x => [x] -> DynamicPlottable +plotMultiple = fold . chooseAutoTints . map plot + 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) - +-- | Lazily consume the list, always plotting the latest value available as they +-- arrive. +-- Useful for displaying results of expensive computations that iteratively improve +-- some result, but also for making simple animations (see 'plotDelay'). plotLatest :: Plottable x => [x] -> DynamicPlottable plotLatest (x:xs) = plot $ Latest (x:|xs) plotLatest l = plot l @@ -826,22 +884,26 @@ mkAnnotatedPlot ans = Plot ans instance Semigroup DynamicPlottable where - DynamicPlottable rx₁ ry₁ tm₁ oc₁ ax₁ dl₁ le₁ fu₁ dp₁ - <> DynamicPlottable rx₂ ry₂ tm₂ oc₂ ax₂ dl₂ le₂ fu₂ dp₂ + DynamicPlottable rx₁ ry₁ vpc₁ tm₁ oc₁ ax₁ dl₁ le₁ al₁ fu₁ dp₁ + <> DynamicPlottable rx₂ ry₂ vpc₂ tm₂ oc₂ ax₂ dl₂ le₂ al₂ fu₂ dp₂ = DynamicPlottable - (rx₁<>rx₂) (ry₁<>ry₂) (tm₁++tm₂) (oc₁+oc₂) (ax₁+ax₂) (max dl₁ dl₂) - (le₁++le₂) ((<>)<$>fu₁<*>fu₂) (liftA2(<>)<$>dp₁<*>dp₂) + (rx₁<>rx₂) (ry₁<>ry₂) (vpc₁.vpc₂) (tm₁++tm₂) + (oc₁+oc₂) (ax₁+ax₂) (max dl₁ dl₂) + (le₁++le₂) (al₁++al₂) + ((<>)<$>fu₁<*>fu₂) (liftA2(liftA2(<>))<$>dp₁<*>dp₂) instance Monoid DynamicPlottable where mempty = DynamicPlottable mempty -- don't request any range mempty + id -- don't enforce anything about the viewport [] -- no colours 0 -- neither obscures anything nor has details that could be obscured 0 -- don't need axis (but don't mind them either) (1/20) -- 20 fps is at the moment the fastest enabled refresh rate anyway [] -- no legend entries + [] -- no axis labels mempty -- no time-evolution - (const $ pure mempty) + (const . const $ pure mempty) mappend = (<>) instance Default DynamicPlottable where def = mempty @@ -850,20 +912,43 @@ -- | Set the caption for this plot object that should appear in the -- plot legend. legendName :: String -> DynamicPlottable -> DynamicPlottable -legendName n = legendEntries %~ (LegendEntry (PlainText n) mempty :) +legendName n obj = legendEntries %~ (LegendEntry (PlainText n) colour mempty :) >>> futurePlots %~ fmap (legendName n) + $ obj + where colour = case obj^.inherentColours of + (c₀:_) -> Just c₀ + _ -> Nothing -- | Colour this plot object in a fixed shade. tint :: DCol.Colour ℝ -> DynamicPlottable -> DynamicPlottable -tint col = inherentColours .~ [col] - >>> dynamicPlot %~ fmap (fmap $ getPlot %~ Dia.lc col . Dia.fc col) +tint col = sustained inherentColours .~ [TrueColour col] + >>> allDynamicPlot %~ fmap (fmap $ getPlot %~ Dia.lc col . Dia.fc col) + >>> sustained legendEntries %~ map + (plotObjRepresentativeColour ?~ TrueColour col) -- | Allow the object to be automatically assigned a colour that's otherwise -- unused in the plot. (This is the default for most plot objects.) autoTint :: DynamicPlottable -> DynamicPlottable -autoTint = inherentColours .~ [] +autoTint = sustained inherentColours .~ [] +-- | Assign each object an individual colour, if applicable. +chooseAutoTints :: [DynamicPlottable] -> [DynamicPlottable] +chooseAutoTints = go defaultColourSeq + where go (c:cs) (o:os) + | null $ o^.inherentColours + = (o & sustained inherentColours.~[SymbolicColour c] + & allDynamicPlot %~ + (\plotF gwSpec -> + let ac = asAColourWith (colourScheme gwSpec) c + in fmap (getPlot %~ Dia.lcA ac . Dia.fcA ac) $ plotF gwSpec) + & sustained legendEntries %~ map + (plotObjRepresentativeColour ?~ SymbolicColour c) + ) : go cs os + go cs (o:os) = o : go cs os + go _ [] = [] + + instance (Ord r) => Semigroup (RangeRequest r) where MustBeThisRange r <> _ = MustBeThisRange r _ <> MustBeThisRange r = MustBeThisRange r @@ -885,6 +970,32 @@ +-- | Render a single view of a collection of plottable objects. This can be +-- used the same way as 'plotWindow', but does not open any GTK but gives +-- the result as-is. +-- +-- 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) + axLabels + viewport{ xResolution = vpc^.xResV + , yResolution = vpc^.yResV }) + Random.StdRandom + annot <- renderAnnotationsForView viewport (renderd^.plotAnnotations) + return $ annot <> renderd^.getPlot + & Dia.withEnvelope (Dia.rect w h + & Dia.alignTL + & Dia.moveTo (Dia.P $ V2 lBound tBound) + :: PlainGraphicsR2) + where viewport@(GraphWindowSpecR2{..}) = autoDefaultView l' + w = rBound - lBound; h = tBound - bBound + l' = l ++ if axesNeed>0 + then [dynamicAxes] + else [] + axLabels = concat $ _axisLabelRequests<$>l + axesNeed = sum $ _axesNecessity<$>l -- | 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 @@ -921,30 +1032,35 @@ plotWindow givenPlotObjs = runInBoundThread $ do let defColourScheme = defaultColourScheme + tintedPlotObjs = chooseAutoTints givenPlotObjs - viewState <- newIORef $ autoDefaultView givenPlotObjs + viewState <- newIORef $ autoDefaultView tintedPlotObjs viewTgt <- newIORef =<< readIORef viewState - viewTgtGlobal <- newMVar =<< readIORef viewState + let objAxisLabels = concat $ _axisLabelRequests<$>givenPlotObjs + viewTgtGlobal <- newMVar . (,objAxisLabels) =<< readIORef viewState screenResolution <- newIORef (640, 480) + let viewConstraint = flip (foldr _viewportConstraint) givenPlotObjs dgStore <- newIORef mempty (plotObjs, cancelWorkers) :: ([ObjInPlot], IO ()) <- do - let assignPlObjPropties :: [DynamicPlottable] -> [Colour] -> Necessity + let assignPlObjPropties :: [DynamicPlottable] -> Necessity -> IO [(ObjInPlot, ThreadId)] - assignPlObjPropties [] _ axesNeed - | axesNeed > 0 = assignPlObjPropties [dynamicAxes] [grey] (-1) + assignPlObjPropties [] axesNeed + | axesNeed > 0 = assignPlObjPropties [tint Dia.grey dynamicAxes] (-1) | otherwise = return [] - assignPlObjPropties (o:os) (c:cs) axn = do + assignPlObjPropties (o:os) axn = do newDia <- newEmptyMVar workerId <- forkIO $ objectPlotterThread o viewTgtGlobal newDia stableView <- newIORef Nothing ((ObjInPlot stableView newDia cl o, workerId) :) - <$> assignPlObjPropties os cs' (axn + o^.axesNecessity) - where (cl, cs') - | null (o^.inherentColours) = (Just $ defColourScheme c, cs) - | otherwise = (Nothing, c:cs) - (pObs, workerId) <- unzip <$> assignPlObjPropties givenPlotObjs defaultColourSeq 0 + <$> assignPlObjPropties os (axn + o^.axesNecessity) + where cl | TrueColour c₀:_ <- o^.inherentColours + = Just $ Dia.opaque c₀ + | SymbolicColour c₀:_ <- o^.inherentColours + = Just $ defColourScheme c₀ + | otherwise = Nothing + (pObs, workerId) <- unzip <$> assignPlObjPropties tintedPlotObjs 0 return ( sortBy (comparing $ _occlusiveness . _originalPlotObject) pObs , forM_ workerId killThread ) @@ -958,7 +1074,8 @@ drawA <- GTK.drawingAreaNew GTK.onExpose drawA $ \_ -> do (canvasX,canvasY) <- GTK.widgetGetSize drawA - modifyIORef viewTgt $ \view -> view{ xResolution = fromIntegral canvasX + modifyIORef viewTgt + $ \view -> viewConstraint $ view{ xResolution = fromIntegral canvasX , yResolution = fromIntegral canvasY } dia <- readIORef dgStore @@ -1062,28 +1179,16 @@ return $ snd <$> newDia case plt of Nothing -> return mempty - Just (Plot{..}, objLegend) -> let - antTK = DiagramTK { viewScope = currentView - , textTools = textTK txtSize aspect } - txtSize = h * fontPts / fromIntegral yResolution - aspect = w * fromIntegral yResolution - / (h * fromIntegral xResolution) - fontPts = 12 - transform :: PlainGraphicsR2 -> PlainGraphicsR2 - transform = normaliseView . clr - where clr | Just c <- plotObj^.plotObjColour - = Dia.lcA c . Dia.fcA c - | otherwise = id - in do - renderedAnnot <- mapM (prerenderAnnotation antTK) _plotAnnotations - return (transform $ fold renderedAnnot <> _getPlot, objLegend) + Just (Plot{..}, objLegend) -> do + renderedAnnot + <- renderAnnotationsForView currentView _plotAnnotations + return (normaliseView $ renderedAnnot <> _getPlot, objLegend) (thisPlots, thisLegends) <- unzip . reverse <$> mapM renderComp (reverse plotObjs) let thePlot = mconcat thisPlots theLegend <- prerenderLegend (textTK 10 1) colourScheme - $ (\(g,l) -> (,) <$> l <*> [g^.plotObjColour] - ) =<< zip plotObjs thisLegends + $ concat (fst<$>thisLegends) writeIORef dgStore $ ( theLegend & Dia.scaleX (0.1 / sqrt (fromIntegral xResolution)) & Dia.scaleY (0.1 / sqrt (fromIntegral yResolution)) @@ -1098,7 +1203,7 @@ writeIORef lastFrameTime t do vt <- readIORef viewTgt - modifyMVar_ viewTgtGlobal . const $ return vt + modifyMVar_ viewTgtGlobal $ return . first (const vt) modifyIORef viewState $ \vo -> let a%b = let η = min 1 $ 2 * realToFrac δt in η*a + (1-η)*b in GraphWindowSpecR2 (lBound vt % lBound vo) (rBound vt % rBound vo) @@ -1126,25 +1231,34 @@ objectPlotterThread :: DynamicPlottable - -> MVar GraphWindowSpec - -> MVar (GraphWindowSpec, (Plot, [LegendEntry])) + -> MVar (GraphWindowSpec, [AxisLabel]) + -> MVar (GraphWindowSpec, AnnotPlot) -> IO () objectPlotterThread pl₀ viewVar diaVar = loop pl₀ where loop pl = do tPrev <- getCurrentTime - view <- readMVar viewVar - diagram <- evaluate =<< Random.runRVar (pl^.dynamicPlot $ view) Random.StdRandom - putMVar diaVar (view, (diagram, pl^.legendEntries)) + (view, labels) <- readMVar viewVar + diagram <- evaluate =<< 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 +-- | Require that both coordinate axes are zoomed the same way, such that e.g. +-- the unit circle will appear as an actual circle. +unitAspect :: DynamicPlottable +unitAspect = def & viewportConstraint . mapped . windowDataAspect .~ 1 autoDefaultView :: [DynamicPlottable] -> GraphWindowSpec -autoDefaultView graphs = GraphWindowSpecR2 l r b t defResX defResY defaultColourScheme +autoDefaultView graphs = + foldr _viewportConstraint + (GraphWindowSpecR2 l r b t defResX defResY defaultColourScheme) + graphs where (xRange, yRange) = foldMap (_relevantRange_x &&& _relevantRange_y) graphs ((l,r), (b,t)) = ( xRange `dependentOn` yRange , yRange `dependentOn` xRange ) @@ -1163,7 +1277,19 @@ where q = (b - a) / 6 +renderAnnotationsForView :: GraphWindowSpecR2 -> [Annotation] -> IO PlainGraphicsR2 +renderAnnotationsForView viewport@GraphWindowSpecR2{..} + = fmap mconcat . mapM (prerenderAnnotation antTK) + where antTK = DiagramTK { viewScope = viewport + , textTools = TextTK defaultTxtStyle txtSize aspect 0.2 0.2 } + txtSize = h * fontPts / fromIntegral yResolution + aspect = w * fromIntegral yResolution + / (h * fromIntegral xResolution) + w = (rBound - lBound)/2; h = (tBound - bBound)/2 + fontPts = 12 + + defResX, defResY :: Integral i => i defResX = 640 defResY = 480 @@ -1272,14 +1398,14 @@ :: Shade (ℝ,ℝ)) | (x, Shade' y ey) <- dataPts ]) (uncertainFnPlot mfun shm) - where (mBest, mDevs) = linearRegressionWVar (mfun . (bcx.+~^)) + where mBest = linearFit_bestModel regResult + regResult = linearRegression (mfun . (bcx.+~^)) [ (δx,(fromInterior y,ey)) | (x,Shade' y ey)<-dataPts , let Just δx = x.-~.bcx ] Just bcx = (pointsBarycenter . NE.fromList $ fst<$>dataPts) shm :: Shade' m - shm@(Shade' _ em) = dualShade . coverAllAround mBest - $ convexPolytopeRepresentatives mDevs + shm = Shade' mBest $ linearFit_modelUncertainty regResult -- | Plot a continuous, “parametric function”, i.e. mapping the real line to a path in ℝ². paramPlot :: (∀ m . ( WithField ℝ PseudoAffine m, SimpleSpace (Needle m) ) @@ -1371,14 +1497,15 @@ dynamicAxes = def & axesNecessity .~ superfluent & occlusiveness .~ 1 - & dynamicPlot .~ pure . plot - where plot gwSpec@(GraphWindowSpecR2{..}) = Plot labels lines + & dynamicPlotWithAxisLabels .~ \lbls -> pure . plot lbls + where plot poLabels gwSpec@(GraphWindowSpecR2{..}) = Plot (dirLabels++tickLabels) lines where (DynamicAxes yAxCls xAxCls) = crtDynamicAxes gwSpec lines = zeroLine (lBound^&0) (rBound^&0) `provided`(bBound<0 && tBound>0) <> zeroLine (0^&bBound) (0^&tBound) `provided`(lBound<0 && rBound>0) <> foldMap (renderClass $ \x -> (x^&bBound, x^&tBound)) yAxCls <> foldMap (renderClass $ \y -> (lBound^&y, rBound^&y)) xAxCls - labels = do (dirq, hAlign, vAlign, acl) <- zip4 [\x -> x^&0, \y -> 0^&y ] + tickLabels + = do (dirq, hAlign, vAlign, acl) <- zip4 [\x -> x^&0, \y -> 0^&y ] [AlignMid , AlignTop ] [AlignTop , AlignMid ] [yAxCls , xAxCls ] @@ -1390,6 +1517,22 @@ place = ExactPlace $ dirq z align = TextAlignment hAlign vAlign prepAnnotation =<< vaxs + dirLabels = [ if dir^._x > dir^._y + then Annotation (TextAnnotation txt + $ TextAlignment AlignMid AlignBottom) + (ExactPlace $ xFar^&0) + False + else Annotation (TextAnnotation txt + $ TextAlignment AlignBottom AlignMid) + (ExactPlace $ 0^&yFar) + False + | (dir,lbl) <- poLabels + , let txt = PlainText lbl + xFar = if rBound > abs lBound/2 + then rBound else lBound + yFar = if tBound > abs bBound/2 + then tBound else bBound + ] zeroLine p1 p2 = simpleLine p1 p2 & Dia.lc Dia.grey renderClass crd (AxisClass axes strength _) = foldMap (uncurry simpleLine . crd . axisPosition) axes @@ -1399,8 +1542,13 @@ noDynamicAxes :: DynamicPlottable noDynamicAxes = def & axesNecessity .~ superfluent +xAxisLabel :: String -> DynamicPlottable +xAxisLabel str = def & axisLabelRequests .~ [(1^&0, str)] +yAxisLabel :: String -> DynamicPlottable +yAxisLabel str = def & axisLabelRequests .~ [(0^&1, str)] + simpleLine :: P2 -> P2 -> PlainGraphicsR2 simpleLine = simpleLine' 2 @@ -1413,7 +1561,7 @@ tweakPrerendered :: (PlainGraphicsR2->PlainGraphicsR2) -> DynamicPlottable->DynamicPlottable -tweakPrerendered f = dynamicPlot %~ (fmap tweak .) +tweakPrerendered f = allDynamicPlot %~ (fmap tweak .) where tweak = getPlot %~ f opacityFactor :: Double -> DynamicPlottable -> DynamicPlottable @@ -1462,7 +1610,8 @@ (\g -> deescalate relevantRange_y g . plot . f . cxI =<< g) & inherentColours .~ fcxVoid^.inherentColours & axesNecessity .~ fcxVoid^.axesNecessity - & dynamicPlot .~ \g -> _dynamicPlot (plot . f $ cx g) g + & dynamicPlotWithAxisLabels .~ + \lbls g -> _dynamicPlotWithAxisLabels (plot . f $ cx g) lbls g where cx (GraphWindowSpecR2{..}) = ViewXCenter $ (lBound+rBound)/2 cxI (Interval l r) = ViewXCenter $ (l+r)/2 fcxVoid = plot . f $ ViewXCenter 0.23421 -- Yup, it's magic. @@ -1475,7 +1624,8 @@ (\g -> deescalate relevantRange_x g . plot . f . cyI =<< g) & inherentColours .~ fcyVoid^.inherentColours & axesNecessity .~ fcyVoid^.axesNecessity - & dynamicPlot .~ \g -> _dynamicPlot (plot . f $ cy g) g + & dynamicPlotWithAxisLabels .~ + \lbls g -> _dynamicPlotWithAxisLabels (plot . f $ cy g) lbls g where cy (GraphWindowSpecR2{..}) = ViewYCenter $ (bBound+tBound)/2 cyI (Interval b t) = ViewYCenter $ (b+t)/2 fcyVoid = plot . f $ ViewYCenter 0.319421 -- Alright, alright... the idea is to avoid exact equality with zero or any other number that might come up in some plot object, since such an equality can lead to div-by-zero problems. @@ -1488,7 +1638,8 @@ (\g -> deescalate relevantRange_y g . plot . f . wI =<< g) & inherentColours .~ fwVoid^.inherentColours & axesNecessity .~ fwVoid^.axesNecessity - & dynamicPlot .~ \g -> _dynamicPlot (plot . f $ w g) g + & dynamicPlotWithAxisLabels .~ + \lbls g -> _dynamicPlotWithAxisLabels (plot . f $ w g) lbls g where w (GraphWindowSpecR2{..}) = ViewWidth $ rBound - lBound wI (Interval l r) = ViewWidth $ r - l fwVoid = plot . f $ ViewWidth 2.142349 @@ -1501,7 +1652,8 @@ (\g -> deescalate relevantRange_x g . plot . f . hI =<< g) & inherentColours .~ fhVoid^.inherentColours & axesNecessity .~ fhVoid^.axesNecessity - & dynamicPlot .~ \g -> _dynamicPlot (plot . f $ h g) g + & dynamicPlotWithAxisLabels .~ + \lbls g -> _dynamicPlotWithAxisLabels (plot . f $ h g) lbls g where h (GraphWindowSpecR2{..}) = ViewHeight $ tBound - bBound hI (Interval b t) = ViewHeight $ t - b fhVoid = plot . f $ ViewHeight 1.494213 diff --git a/Graphics/Text/Annotation.hs b/Graphics/Text/Annotation.hs --- a/Graphics/Text/Annotation.hs +++ b/Graphics/Text/Annotation.hs @@ -25,6 +25,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Graphics.Text.Annotation where @@ -52,6 +53,7 @@ import Control.Monad.Constrained import Control.Lens hiding ((...), (<.>)) +import Control.Lens.TH import Data.List (foldl', sort, intercalate, isPrefixOf, isInfixOf, find, zip4) @@ -110,6 +112,9 @@ data AnnotationPlace = ExactPlace R2 data TextObj = PlainText String +fromPlaintextObj :: TextObj -> String +fromPlaintextObj (PlainText t) = t + data TextAlignment = TextAlignment { hAlign, vAlign :: Alignment } -- , blockSpread :: Bool } data Alignment = AlignBottom | AlignMid | AlignTop @@ -168,10 +173,10 @@ AlignMid -> (lBound + w/2, rBound - w/2) AlignTop -> (lBound + w , rBound ) (b', t') = case vAlign of - AlignBottom -> (bBound' , tBound - h ) - AlignMid -> (bBound' + h/2, tBound - h/2) - AlignTop -> (bBound' + h , tBound ) - w = ζx * width; h = ζy * height + AlignBottom -> (bBound' , tBound - 2*h ) + AlignMid -> (bBound' + h/2, tBound - 3*h/2) + AlignTop -> (bBound' + h , tBound - h ) + w = ζx * width; h = 1.5 * ζy * height bBound' = bBound + lineHeight*ζy return . Dia.translate p . Dia.scaleX ζx . Dia.scaleY ζy $ Dia.lc Dia.grey fullText @@ -187,24 +192,28 @@ data LegendEntry = LegendEntry { - plotObjectTitle :: TextObj - , customLegendObject :: Option () + _plotObjectTitle :: TextObj + , _plotObjRepresentativeColour :: Maybe PColour + , _customLegendObject :: Option () } +makeLenses ''LegendEntry +instance HasColour LegendEntry where + asAColourWith sch = asAColourWith sch . _plotObjRepresentativeColour + prerenderLegend :: TextTK -> ColourScheme - -> [(LegendEntry, Maybe AColour)] -> IO PlainGraphicsR2 + -> [LegendEntry] -> IO PlainGraphicsR2 prerenderLegend _ _ [] = return mempty prerenderLegend TextTK{..} cscm l = do let bgColour = cscm neutral - defColour = cscm (paler contrast) - lRends <- fmap Dia.vcat $ forM l `id` - \( LegendEntry{ plotObjectTitle = PlainText str - , customLegendObject = Option Nothing }, c ) -> do + lRends <- fmap Dia.vcat $ forM l `id`\legEntry -> do txtR <- CairoTxt.textVisualBoundedIO txtCairoStyle - $ DiaTxt.Text mempty (DiaTxt.BoxAlignedText 0 0.5) str + $ DiaTxt.Text mempty (DiaTxt.BoxAlignedText 0 0.5) + (fromPlaintextObj $ legEntry^.plotObjectTitle) let h = Dia.height txtR - return $ Dia.hsep 5 [ Dia.rect h h & Dia.fcA (maybe defColour id c) + return $ Dia.hsep 5 [ Dia.rect h h & Dia.fcA + (asAColourWith cscm legEntry) , txtR ] & Dia.centerXY & Dia.frame 2 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.2.2.0 +Version: 0.3.0.0 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions @@ -27,7 +27,7 @@ Maintainer: (@) sagemuej $ smail.uni-koeln.de Homepage: https://github.com/leftaroundabout/dynamic-plot Build-Type: Simple -Cabal-Version: >=1.10 +Cabal-Version: >=1.18 Extra-Doc-Files: images/examples/*.png , images/examples/*.gif @@ -54,17 +54,17 @@ , free-vector-spaces >= 0.1 && < 0.2 , linearmap-category , diagrams-core - , diagrams-lib >= 1.3 && < 1.4 - , diagrams-cairo > 1.3.0.5 && < 1.4 + , diagrams-lib >= 1.3 && < 1.5 + , diagrams-cairo , diagrams-gtk , gtk > 0.10 && < 0.15 , glib , colour >= 2 && < 3 - , manifolds >= 0.4.1 && < 0.5 + , manifolds >= 0.4.2 && < 0.5 , manifold-random , colour-space , JuicyPixels > 3 && < 4 - , lens < 4.15 + , lens < 5.0 Other-Extensions: FlexibleInstances , TypeFamilies , FlexibleContexts