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 @@ -15,6 +15,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE FlexibleContexts #-} @@ -41,6 +42,8 @@ , PlainGraphicsR2 , shapePlot , diagramPlot + -- ** Legend captions + , legendName -- ** View selection , xInterval, yInterval, forceXRange, forceYRange -- ** View dependance @@ -93,18 +96,21 @@ import Control.DeepSeq -import Data.List (foldl', sort, intercalate, isPrefixOf, isInfixOf, find, zip4) +import Data.List (foldl', sort, sortBy, intercalate, isPrefixOf, isInfixOf, find, zip4) import qualified Data.Vector as Arr import Data.Maybe import Data.Semigroup +import Data.Default import Data.Foldable (fold, foldMap) import Data.Function (on) +import Data.Ord (comparing) import Data.VectorSpace import Data.Basis import Data.AffineSpace import Data.LinearMap.HerMetric import Data.Manifold.PseudoAffine +import Data.Manifold.Types import Data.Manifold.TreeCover import qualified Data.Map.Lazy as Map @@ -147,12 +153,10 @@ -- {-# RULES "plot/R->R" plot = fnPlot #-} instance Plottable (Double :--> Double) where - plot f = DynamicPlottable{ - relevantRange_x = mempty - , relevantRange_y = otherDimDependence yRangef - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot } + plot f = def { relevantRange_y = otherDimDependence yRangef + , isTintableMonochromic = True + , axesNecessity = 1 + , dynamicPlot = plot } where yRangef (Interval l r) = uncurry Interval . (minimum &&& maximum) . map snd $ 𝓒⁰.finiteGraphContinℝtoℝ (𝓒⁰.GraphWindowSpec l r fgb fgt 9 9) f @@ -171,12 +175,9 @@ c = realToFrac instance Plottable (Double :--> (Double, Double)) where - plot f = DynamicPlottable{ - relevantRange_x = mempty - , relevantRange_y = mempty - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot } + plot f = def { isTintableMonochromic = True + , axesNecessity = 1 + , dynamicPlot = plot } where plot (GraphWindowSpecR2{..}) = curves `deepseq` mkPlot (foldMap trace curves) where curves :: [[P2]] curves = map (map convℝ²) $ 𝓒⁰.finiteGraphContinℝtoℝ² mWindow f @@ -190,20 +191,12 @@ instance (Plottable p) => Plottable [p] where - plot l0 = DynamicPlottable{ - relevantRange_x = foldMap relevantRange_x l - , relevantRange_y = foldMap relevantRange_y l - , isTintableMonochromic = or $ isTintableMonochromic <$> l - , axesNecessity = sum $ axesNecessity <$> l - , dynamicPlot = foldMap dynamicPlot l - } - where l = map plot l0 + plot = foldMap plot instance Plottable PlainGraphics where - plot (PlainGraphics d) = DynamicPlottable{ + plot (PlainGraphics d) = def { relevantRange_x = atLeastInterval rlx , relevantRange_y = atLeastInterval rly - , isTintableMonochromic = False , axesNecessity = -1 , dynamicPlot = plot } @@ -229,11 +222,46 @@ +instance Plottable (R-->R) where + plot f = def { relevantRange_y = mempty -- otherDimDependence yRangef + , isTintableMonochromic = True + , axesNecessity = 1 + , dynamicPlot = plot } + where yRangef (Interval l r) = undefined + plot gs@(GraphWindowSpecR2{..}) = curves `deepseq` + mkPlot (foldMap trace curves) + where curves :: [[P2]] + curves = map (map $ convℝ² . snd) + $ discretisePathSegs xResolution (resolutionFunction gs) + (id&&&f <<< alg(+point x₀)) + x₀ = (lBound + rBound)/2 + trace (p:q:ps) = simpleLine p q <> trace (q:ps) + trace _ = mempty + + convℝ² = Dia.p2 + c = realToFrac +resolutionFunction :: GraphWindowSpecR2 -> RieMetric ℝ² +resolutionFunction GraphWindowSpecR2{..} = resoFunc + where x₀ = (lBound + rBound)/2 + w = rBound - lBound; h = tBound - bBound + ε = projector (recip δx, 0) + projector (0, recip δy) + δx = w / fromIntegral xResolution + δy = h / fromIntegral yResolution + resoFunc (x,y) + | x > lBound, x < rBound, y > bBound, y < tBound = ε + | otherwise = projector (qx,0) + projector (0,qy) + where qx | x < lBound = lBound - x + | x > rBound = x - rBound + | otherwise = δx * qy/δy + qy | y < bBound = bBound - y + | y > tBound = y - tBound + | otherwise = δy * qx/δx + instance Plottable (R-.^>R) where plot rPCM@(RecursivePCM gPFit gDetails gFitDevs (PCMRange x₀ wsp) gSplN ()) - = DynamicPlottable{ + = def { relevantRange_x = atLeastInterval $ Interval x₀ xr , relevantRange_y = otherDimDependence $ rPCMLinFitRange rPCM , isTintableMonochromic = True @@ -273,7 +301,7 @@ instance Plottable (RecursiveSamples Int P2 (DevBoxes P2)) where plot rPCM@(RecursivePCM gPFit gDetails gFitDevs (PCMRange t₀ τsp) gSplN ()) - = DynamicPlottable{ + = def { relevantRange_x = atLeastInterval xRange , relevantRange_y = atLeastInterval yRange , isTintableMonochromic = True @@ -334,7 +362,7 @@ -- Beware that this will always slow down the performance when the list is large; -- there is no Éc;statistic optimisationÉd; as in 'tracePlot'. lineSegPlot :: [(Double, Double)] -> DynamicPlottable -lineSegPlot ps = DynamicPlottable{ +lineSegPlot ps = def { relevantRange_x = atLeastInterval' $ foldMap (pure . spInterval . fst) ps , relevantRange_y = atLeastInterval' $ foldMap (pure . spInterval . snd) ps , isTintableMonochromic = True @@ -402,7 +430,7 @@ instance Plottable (Shade P2) where - plot shade = DynamicPlottable{ + plot shade = def { relevantRange_x = atLeastInterval xRange , relevantRange_y = atLeastInterval yRange , isTintableMonochromic = True @@ -419,7 +447,7 @@ instance Plottable (SimpleTree P2) where plot (GenericTree Nothing) = plot ([] :: [SimpleTree P2]) plot (GenericTree (Just (ctr, root))) - = DynamicPlottable{ + = def{ relevantRange_x = atLeastInterval xRange , relevantRange_y = atLeastInterval yRange , isTintableMonochromic = True @@ -489,10 +517,26 @@ data DynamicPlottable = DynamicPlottable { relevantRange_x, relevantRange_y :: RangeRequest R , isTintableMonochromic :: Bool + , occlusiveness :: Double + -- ^ How surface-occupying the plot is. + -- Use positive values for opaque 2D plots that would tend to obscure + -- other objects, negative values for sparse/small point plots. + -- The z-order will be chosen accordingly. , axesNecessity :: Necessity + , legendEntries :: [LegendEntry] , dynamicPlot :: GraphWindowSpec -> Plot } +instance Semigroup DynamicPlottable where + DynamicPlottable rx₁ ry₁ tm₁ oc₁ ax₁ le₁ dp₁ + <> DynamicPlottable rx₂ ry₂ tm₂ oc₂ ax₂ le₂ dp₂ + = DynamicPlottable + (rx₁<>rx₂) (ry₁<>ry₂) (tm₁||tm₂) (oc₁+oc₂) (ax₁+ax₂) (le₁++le₂) (dp₁<>dp₂) +instance Monoid DynamicPlottable where + mempty = DynamicPlottable mempty mempty False 0 0 [] mempty + mappend = (<>) +instance Default DynamicPlottable where def = mempty + data GraphViewState = GraphViewState { lastStableView :: Maybe (GraphWindowSpec, Plot) , realtimeView, nextTgtView :: Async Plot @@ -501,6 +545,10 @@ +legendName :: String -> DynamicPlottable -> DynamicPlottable +legendName n d = d { legendEntries = LegendEntry (PlainText n) mempty : legendEntries d } + + data RangeRequest r = OtherDimDependantRange (Option (Interval r) -> Option (Interval r)) | MustBeThisRange (Interval r) @@ -522,6 +570,9 @@ atLeastInterval' :: Option (Interval r) -> RangeRequest r atLeastInterval' = OtherDimDependantRange . const + + + -- | Plot some plot objects to a new interactive GTK window. Useful for a quick @@ -574,8 +625,9 @@ assignGrViews [] _ axesNeed | axesNeed > 0 = assignGrViews [dynamicAxes] [grey] (-1) | otherwise = return [] + graphs'' = sortBy (comparing occlusiveness) graphs' w <- mapM newIORef $ replicate 2 window₀ - gs <- newIORef =<< assignGrViews graphs' defaultColourSeq 0 + gs <- newIORef =<< assignGrViews graphs'' defaultColourSeq 0 return (w,gs) @@ -685,6 +737,7 @@ 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 renderComp (DynamicPlottable{..}, GraphViewState{..}) = do plt <- poll realtimeView >>= \case Just (Right pl) -> return $ Just pl @@ -695,8 +748,7 @@ Nothing -> return mempty Just Plot{..} -> let antTK = DiagramTK { viewScope = currentView - , textTools = TextTK defaultTxtStyle - txtSize aspect 0.2 0.2 } + , textTools = textTK txtSize aspect } txtSize = h * fontPts / fromIntegral yResolution aspect = w * fromIntegral yResolution / (h * fromIntegral xResolution) @@ -711,9 +763,15 @@ gvStates <- readIORef graphs waitAny $ map (realtimeView . snd) gvStates + + thePlot <- (mconcat . reverse) <$> mapM renderComp (reverse gvStates) + theLegend <- prerenderLegend (textTK 10 1) colourScheme + $ (\(p,g) -> (,) <$> legendEntries p <*> [graphColor g]) =<< gvStates - writeIORef dgStore - . mconcat . reverse =<< mapM renderComp (reverse gvStates) + writeIORef dgStore $ ( theLegend & Dia.scaleX (0.1 / sqrt (fromIntegral xResolution)) + & Dia.scaleY (0.1 / sqrt (fromIntegral yResolution)) + & (`Dia.place`(0.75^&0.75)) ) + <> thePlot refreshDraw @@ -833,9 +891,8 @@ -- the resolution so the plot is guaranteed accurate (but it's not usable yet for -- a lot of real applications). continFnPlot :: (Double -> Double) -> DynamicPlottable -continFnPlot f = DynamicPlottable{ - relevantRange_x = mempty - , relevantRange_y = otherDimDependence yRangef +continFnPlot f = def{ + relevantRange_y = otherDimDependence yRangef , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot } @@ -850,6 +907,44 @@ l!n | (x:_)<-drop n l = x | otherwise = error "Function appears to yield NaN most of the time. Cannot be plotted." +type (-->) = RWDiffable ℝ + +diffableFnPlot :: (∀ m . ( WithField ℝ PseudoAffine m + , HasMetric (Needle (Interior m)) ) + => AgentVal (-->) m ℝ -> AgentVal (-->) m ℝ ) + -> DynamicPlottable +diffableFnPlot f = plot fd + where fd :: ℝ --> ℝ + fd = alg f + +scrutiniseDiffability :: (∀ m . ( WithField ℝ PseudoAffine m + , HasMetric (Needle (Interior m)) ) + => AgentVal (-->) m ℝ -> AgentVal (-->) m ℝ ) + -> DynamicPlottable +scrutiniseDiffability f = plot [{-plot fd, -}dframe 0.2, dframe 0.02] + where fd :: ℝ --> ℝ + fd = alg f + fscrut = analyseLocalBehaviour fd + dframe rfh = def{ + isTintableMonochromic = True + , dynamicPlot = mkFrame + } + where mkFrame (GraphWindowSpecR2{..}) = case fscrut xm of + Option (Just ((ym,y'm), δOδx²)) + | Option (Just δx) <- δOδx² δy + -> δx `seq` let frame = mconcat + [ simpleLine ((xm-δx)^&(ym+yo-δx*y'm)) + ((xm+δx)^&(ym+yo+δx*y'm)) + | yo <- [-δy, δy] ] + in mkPlot frame + | otherwise + -> y'm `seq` mkPlot + ( simpleLine ((xm-δxdef)^&(ym-δxdef*y'm)) + ((xm+δxdef)^&(ym+δxdef*y'm)) ) + where xm = (rBound + lBound) / 2 + δxdef = (rBound - lBound) / 10 + δy = rfh * (tBound - bBound) + -- | Plot a continuous function in the usual way, taking arguments from the -- x-Coordinate and results to the y one. @@ -858,7 +953,7 @@ -- @'fnPlot' (\\x -> sin x / exp (x^2))@ will work (but the view must not contain -- singularities). -- --- Under the hood this uses the category of continuous functions, ':-->', to proove +-- Under the hood this uses the category of continuous functions, ':-->', to prove -- that no details are omitted (like small high-frequency bumps). The flip side is that -- this does not always work very efficiently, in fact it can easily become exponentially -- slow for some parameters. @@ -888,7 +983,21 @@ fc = alg1to2 f - +continColourSurfaceFnPlot :: ((Double,Double) -> DCol.Colour Double) -> DynamicPlottable +continColourSurfaceFnPlot f = def { + axesNecessity = 1 + , occlusiveness = 4 + , dynamicPlot = plot } + where plot (GraphWindowSpecR2{..}) = mkPlot + $ Dia.place + ( Dia.rasterDia cf (xResolution`div`4) (yResolution`div`4) + & Dia.scaleX wPix & Dia.scaleY hPix + ) ( ((lBound+rBound-wPix)/2) ^& ((tBound+bBound+hPix)/2) ) + where cf i j = f ( lBound + wPix * fromIntegral i, tBound - hPix * fromIntegral j ) + `Dia.withOpacity` 0.2 + w = rBound - lBound; h = tBound - bBound + wPix = w*4 / fromIntegral xResolution + hPix = h*4 / fromIntegral yResolution data AxesStyle = DynamicAxesStyle data DynamicAxes = DynamicAxes { yAxisClasses, xAxisClasses :: [AxisClass] } @@ -922,11 +1031,9 @@ -- | Coordinate axes with labels. For many plottable objects, these will be added -- automatically, by default (unless inhibited with 'noDynamicAxes'). dynamicAxes :: DynamicPlottable -dynamicAxes = DynamicPlottable { - relevantRange_x = mempty - , relevantRange_y = mempty - , isTintableMonochromic = False - , axesNecessity = superfluent +dynamicAxes = def { + axesNecessity = superfluent + , occlusiveness = 1 , dynamicPlot = plot } where plot gwSpec@(GraphWindowSpecR2{..}) = Plot labels lines where (DynamicAxes yAxCls xAxCls) = crtDynamicAxes gwSpec @@ -953,12 +1060,7 @@ noDynamicAxes :: DynamicPlottable -noDynamicAxes = DynamicPlottable { - relevantRange_x = mempty - , relevantRange_y = mempty - , isTintableMonochromic = False - , axesNecessity = superfluent - , dynamicPlot = const mempty } +noDynamicAxes = def { axesNecessity = superfluent } @@ -989,26 +1091,10 @@ yInterval, forceYRange :: (Double, Double) -> DynamicPlottable -xInterval (l,r) = DynamicPlottable { - relevantRange_x = atLeastInterval $ Interval l r - , relevantRange_y = mempty - , isTintableMonochromic = False, axesNecessity = 0, dynamicPlot = plot } - where plot _ = Plot mempty mempty -forceXRange (l,r) = DynamicPlottable { - relevantRange_x = MustBeThisRange $ Interval l r - , relevantRange_y = mempty - , isTintableMonochromic = False, axesNecessity = 0, dynamicPlot = plot } - where plot _ = Plot mempty mempty -yInterval (b,t) = DynamicPlottable { - relevantRange_x = mempty - , relevantRange_y = atLeastInterval $ Interval b t - , isTintableMonochromic = False, axesNecessity = 0, dynamicPlot = plot } - where plot _ = Plot mempty mempty -forceYRange (b,t) = DynamicPlottable { - relevantRange_x = mempty - , relevantRange_y = MustBeThisRange $ Interval b t - , isTintableMonochromic = False, axesNecessity = 0, dynamicPlot = plot } - where plot _ = Plot mempty mempty +xInterval (l,r) = mempty { relevantRange_x = atLeastInterval $ Interval l r } +forceXRange (l,r) = mempty { relevantRange_x = MustBeThisRange $ Interval l r } +yInterval (b,t) = mempty { relevantRange_y = atLeastInterval $ Interval b t } +forceYRange (b,t) = mempty { relevantRange_y = MustBeThisRange $ Interval b t } @@ -1028,13 +1114,11 @@ -- <> newtype ViewXCenter = ViewXCenter { getViewXCenter :: Double } instance (Plottable p) => Plottable (ViewXCenter -> p) where - plot f = DynamicPlottable { - relevantRange_x = mempty - , relevantRange_y = OtherDimDependantRange $ - \g -> deescalate relevantRange_y g . plot . f . cxI =<< g - , isTintableMonochromic = isTintableMonochromic fcxVoid - , axesNecessity = axesNecessity fcxVoid - , dynamicPlot = \g -> dynamicPlot (plot . f $ cx g) g } + plot f = def { relevantRange_y = OtherDimDependantRange $ + \g -> deescalate relevantRange_y g . plot . f . cxI =<< g + , isTintableMonochromic = isTintableMonochromic fcxVoid + , axesNecessity = axesNecessity fcxVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ cx g) 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. @@ -1043,13 +1127,11 @@ OtherDimDependantRange ifr -> ifr otherdim newtype ViewYCenter = ViewYCenter { getViewYCenter :: Double } instance (Plottable p) => Plottable (ViewYCenter -> p) where - plot f = DynamicPlottable { - relevantRange_x = OtherDimDependantRange $ - \g -> deescalate relevantRange_x g . plot . f . cyI =<< g - , relevantRange_y = mempty - , isTintableMonochromic = isTintableMonochromic fcyVoid - , axesNecessity = axesNecessity fcyVoid - , dynamicPlot = \g -> dynamicPlot (plot . f $ cy g) g } + plot f = def { relevantRange_x = OtherDimDependantRange $ + \g -> deescalate relevantRange_x g . plot . f . cyI =<< g + , isTintableMonochromic = isTintableMonochromic fcyVoid + , axesNecessity = axesNecessity fcyVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ cy g) 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. @@ -1058,13 +1140,11 @@ OtherDimDependantRange ifr -> ifr otherdim newtype ViewWidth = ViewWidth { getViewWidth :: Double } instance (Plottable p) => Plottable (ViewWidth -> p) where - plot f = DynamicPlottable { - relevantRange_x = mempty - , relevantRange_y = OtherDimDependantRange $ - \g -> deescalate relevantRange_y g . plot . f . wI =<< g - , isTintableMonochromic = isTintableMonochromic fwVoid - , axesNecessity = axesNecessity fwVoid - , dynamicPlot = \g -> dynamicPlot (plot . f $ w g) g } + plot f = def { relevantRange_y = OtherDimDependantRange $ + \g -> deescalate relevantRange_y g . plot . f . wI =<< g + , isTintableMonochromic = isTintableMonochromic fwVoid + , axesNecessity = axesNecessity fwVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ w g) g } where w (GraphWindowSpecR2{..}) = ViewWidth $ rBound - lBound wI (Interval l r) = ViewWidth $ r - l fwVoid = plot . f $ ViewWidth 2.142349 @@ -1073,13 +1153,11 @@ OtherDimDependantRange ifr -> ifr otherdim newtype ViewHeight = ViewHeight { getViewHeight :: Double } instance (Plottable p) => Plottable (ViewHeight -> p) where - plot f = DynamicPlottable { - relevantRange_x = OtherDimDependantRange $ - \g -> deescalate relevantRange_x g . plot . f . hI =<< g - , relevantRange_y = mempty - , isTintableMonochromic = isTintableMonochromic fhVoid - , axesNecessity = axesNecessity fhVoid - , dynamicPlot = \g -> dynamicPlot (plot . f $ h g) g } + plot f = def { relevantRange_x = OtherDimDependantRange $ + \g -> deescalate relevantRange_x g . plot . f . hI =<< g + , isTintableMonochromic = isTintableMonochromic fhVoid + , axesNecessity = axesNecessity fhVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ h g) g } where h (GraphWindowSpecR2{..}) = ViewHeight $ tBound - bBound hI (Interval b t) = ViewHeight $ t - b fhVoid = plot . f $ ViewHeight 1.494213 @@ -1090,5 +1168,17 @@ newtype ViewYResolution = ViewYResolution { getViewYResolution :: Int } + + +atExtendOf :: PlainGraphicsR2 -> PlainGraphicsR2 -> PlainGraphicsR2 +atExtendOf d₁ = atExtendOf' d₁ 1 + +atExtendOf' :: PlainGraphicsR2 -> Double -> PlainGraphicsR2 -> PlainGraphicsR2 +atExtendOf' d₁ q d₂ = d₂ + & Dia.translate ((pux+plx-lux-llx)/2 ^& (puy+ply-luy-lly)/2) + & Dia.scaleX (q*(pux-plx)/(lux-llx)) + & Dia.scaleY (q*(puy-ply)/(luy-lly)) + where (Just (plx,pux)) = Dia.extentX d₁; (Just (ply,puy)) = Dia.extentY d₁ + (Just (llx,lux)) = Dia.extentX d₂; (Just (lly,luy)) = Dia.extentY d₂ diff --git a/Graphics/Text/Annotation.hs b/Graphics/Text/Annotation.hs --- a/Graphics/Text/Annotation.hs +++ b/Graphics/Text/Annotation.hs @@ -34,7 +34,7 @@ import qualified Prelude -import Diagrams.Prelude ((^&), (&), _x, _y) +import Diagrams.Prelude ((^&), (&), _x, _y, (|||), (===)) import qualified Diagrams.Prelude as Dia import qualified Diagrams.TwoD.Size as Dia import qualified Diagrams.TwoD.Types as DiaTypes @@ -48,7 +48,7 @@ import qualified Control.Category.Hask as Hask import Control.Category.Constrained.Prelude hiding ((^)) -import Control.Arrow.Constrained +import Control.Arrow.Constrained hiding ((|||)) import Control.Monad.Constrained import Control.Lens hiding ((...), (<.>)) @@ -82,12 +82,22 @@ | preci >= 0, preci < 4 = show $ round x | preci < 0, preci > -2 = printf "%.1f" x | otherwise = case ceiling (0.01 + lg (abs x/10^^(preci+1))) + preci of - 0 | preci < 0 -> printf ("%."++show(-preci)++"f") x - expn | expn>preci -> printf ("%."++show(expn-preci)++"f*10^%i") - (x/10^^expn) expn - | otherwise -> printf ("%i*10^%i") - (round $ x/10^^expn :: Int) expn + 0 | preci < 0 -> printf "%.*f" + (-preci) + x + expn | expn>preci -> printf "%.*f×₁₀%s" + (expn-preci) + (x/10^^expn) + (showExponentAsSuperscript expn) + | otherwise -> printf "%i×₁₀%s" + (round $ x/10^^expn :: Int) + (showExponentAsSuperscript expn) +showExponentAsSuperscript :: Int -> String +showExponentAsSuperscript = map sup . show + where sup ch = case lookup ch $ zip "0123456789-" + "⁰¹²³⁴⁵⁶⁷⁸⁹⁻" of + Just ch -> ch maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads @@ -173,3 +183,35 @@ lg :: Floating a => a -> a lg = logBase 10 + + + + +data LegendEntry = LegendEntry { + plotObjectTitle :: TextObj + , customLegendObject :: Option () + } + + +prerenderLegend :: TextTK -> ColourScheme + -> [(LegendEntry, Maybe AColour)] -> 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 + txtR <- CairoTxt.textVisualBoundedIO txtCairoStyle + $ DiaTxt.Text mempty (DiaTxt.BoxAlignedText 0 0.5) str + let h = Dia.height txtR + return $ Dia.hsep 5 [ Dia.rect h h & Dia.fcA (maybe defColour id c) + , txtR + ] & Dia.centerXY + & Dia.frame 2 + & Dia.alignL + let w = Dia.width lRends + h = Dia.height lRends + return $ ( lRends & Dia.centerXY & Dia.translate (3^&3) ) + <> ( Dia.rect (w+1) (h+1) & Dia.fcA (cscm $ paler grey) ) + 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.1.1.0 +Version: 0.1.1.1 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions @@ -45,6 +45,7 @@ , tagged , containers , semigroups + , data-default , random , MonadRandom , time @@ -59,8 +60,8 @@ , gtk > 0.10 && < 0.15 , glib , colour >= 2 && < 3 - , manifolds >= 0.1.5 && < 0.1.6 - , lens < 4.12.3 + , manifolds > 0.1.5.0 && < 0.1.6 + , lens < 4.12.4 Other-Extensions: FlexibleInstances , TypeFamilies , FlexibleContexts