dynamic-plot 0.2.2.0 → 0.3.0.0

raw patch · 5 files changed

+295/−88 lines, 5 filesdep ~diagrams-cairodep ~diagrams-libdep ~lensPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: diagrams-cairo, diagrams-lib, lens, manifolds

API changes (from Hackage documentation)

Files

• Graphics/Dynamic/Plot/Colour.hs +20/−1
• Graphics/Dynamic/Plot/Internal/Types.hs +27/−0
• Graphics/Dynamic/Plot/R2.hs +220/−68
• Graphics/Text/Annotation.hs +22/−13
• dynamic-plot.cabal +6/−6

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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