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 @@ -52,12 +52,13 @@ import qualified Data.Vector as Arr import Data.List (sort) +import Data.List.NonEmpty (NonEmpty(..)) import Data.VectorSpace import Data.Basis +import Math.LinearMap.Category import Data.AffineSpace import Data.VectorSpace.Free () -import Data.LinearMap.HerMetric import Data.Manifold.PseudoAffine import Data.Manifold.TreeCover import Data.Semigroup @@ -68,46 +69,8 @@ type R2 = Dia.V2 Double type P2 = Dia.P2 Double -instance FiniteDimensional R2 where - dimension = Tagged 2 - basisIndex = Tagged bi where bi b = if (basisValue b::R2)^._x > 0.5 then 0 else 1 - indexBasis = Tagged ib - where ib 0 = bx; ib 1 = by - [(bx,_), (by,_)] = decompose (1^&1 :: R2) - completeBasis = Tagged . fmap fst $ decompose (1^&1 :: R2) -instance HasMetric' R2 where - type DualSpace R2 = R2 - (<.>^) = (<.>) - functional f = f(1^&0) ^& f(0^&1) - doubleDual = id; doubleDual' = id -instance Semimanifold R2 where - type Needle R2 = R2 - fromInterior = id - toInterior = pure - translateP = Tagged (^+^) - (.+~^) = (^+^) -instance PseudoAffine R2 where - p.-~.q = pure(p^-^q) -instance LocallyCoercible R2 (R,R) where - locallyTrivialDiffeomorphism v = (v^._x, v^._y) -instance LocallyCoercible (R,R) R2 where - locallyTrivialDiffeomorphism = DiaTypes.r2 -instance Semimanifold P2 where - type Needle P2 = R2 - fromInterior = id - toInterior = pure - translateP = Tagged (.+^) - (.+~^) = (.+^) -instance PseudoAffine P2 where - p.-~.q = pure(p.-.q) -instance LocallyCoercible P2 (R,R) where - locallyTrivialDiffeomorphism v = (v^._x, v^._y) -instance LocallyCoercible (R,R) P2 where - locallyTrivialDiffeomorphism = DiaTypes.p2 - - (^) :: Num n => n -> Int -> n (^) = (Prelude.^) @@ -181,7 +144,7 @@ -data DevBoxes y = DevBoxes { deviations :: HerMetric' (Diff y) +data DevBoxes y = DevBoxes { deviations :: Metric' y , maxDeviation :: Scalar (Diff y) } @@ -215,7 +178,7 @@ recursiveSamples' :: forall x y v t . ( VectorSpace x, Real (Scalar x) - , AffineSpace y, v~Diff y, InnerSpace v, HasMetric v, RealFloat (Scalar v) ) + , AffineManifold y, v~Needle y, HilbertSpace v, RealFloat (Scalar v) ) => PCMRange x -> [(y,t)] -> RecursiveSamples x y t recursiveSamples' xrng_g ys = calcDeviations . go xrng_g $ presplitList ys where go :: PCMRange x -> SplitList (y,t) -> RecursiveSamples' (Arr.Vector y) x y t @@ -247,8 +210,8 @@ where cdvs lPFits rPFits rPCM@( RecursivePCM pFit dtls _ sSpc@(PCMRange xl wsp) slLn pts ) = RecursivePCM pFit dtls' (DevBoxes stdDev maxDev) sSpc slLn () - where stdDev = (^/ fromIntegral slLn) . sumV $ projector' <$> msqs - maxDev = sqrt . maximum $ magnitudeSq <$> msqs + where stdDev = scaleNorm (1/ fromIntegral slLn) $ spanNorm msqs + maxDev = sqrt . maximum $ magnitudeSq <$> msqs msqs = [ (y .-. ff x) | (x,y) <- normlsdIdd $ SplitList pts ] ff = l₀splineRep (Pair lPFits rPFits) rPCM @@ -267,12 +230,12 @@ recursiveSamples :: - ( AffineSpace y, v~Diff y, InnerSpace v, HasMetric v, RealFloat (Scalar v) ) + ( AffineManifold y, v~Needle y, HilbertSpace v, RealFloat (Scalar v) ) => [(y,t)] -> RecursiveSamples Int y t recursiveSamples = recursiveSamples' (PCMRange 0 1) recursivePCM :: ( VectorSpace x, Real (Scalar x) - , AffineSpace y, v~Diff y, InnerSpace v, HasMetric v, RealFloat (Scalar v) ) + , AffineManifold y, v~Needle y, HilbertSpace v, RealFloat (Scalar v) ) => PCMRange x -> [y] -> x-.^>y recursivePCM xrng_g = recursiveSamples' xrng_g . fmap (,()) @@ -321,7 +284,7 @@ -rPCMSample :: (AffineSpace y, v~Diff y, InnerSpace v, HasMetric v, RealFloat (Scalar v)) +rPCMSample :: (AffineManifold y, v~Needle y, HilbertSpace v, RealFloat (Scalar v)) => Interval R -> R -> (R->y) -> R-.^>y rPCMSample (Interval l r) δx f = recursivePCM (PCMRange l δx) [f x | x<-[l, l+δx .. r]] @@ -334,7 +297,7 @@ -*| Interval (yb - uy*2) (yt + uy*2) where pm = constCoeff pFit p₀ = pm .-^ linCoeff pFit; pe = pm .+^ linCoeff pFit - ux = metric' dev $ 1^&0; uy = metric' dev $ 0^&1 + ux = dev |$| 1^&0; uy = dev |$| 0^&1 [xl,xr] = sort[p₀^._x, pe^._x]; [yb,yt] = sort[p₀^._y, pe^._y] @@ -456,8 +419,8 @@ shadeExtends :: Shade P2 -> (Interval R, Interval R) shadeExtends shade - = ( (ctr^._x) ± sqrt (metric' expa $ 1^&0) - , (ctr^._y) ± sqrt (metric' expa $ 0^&1) ) + = ( (ctr^._x) ± (expa |$| 1^&0) + , (ctr^._y) ± (expa |$| 0^&1) ) where ctr = shade^.shadeCtr; expa = shade^.shadeExpanse @@ -488,5 +451,10 @@ fromInt = fromIntegral + + + +newtype Latest a = Latest { getLatestOf :: NonEmpty a } + deriving (Hask.Functor) 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 @@ -27,6 +27,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} module Graphics.Dynamic.Plot.R2 ( -- * Interactive display @@ -42,19 +43,24 @@ , PlainGraphicsR2 , shapePlot , diagramPlot + -- ** Computation in progress + , plotLatest + -- * Plot-object attributes + -- ** Colour + , tint, autoTint -- ** Legend captions , legendName + -- * Viewport -- ** View selection , xInterval, yInterval, forceXRange, forceYRange - -- ** View dependance + -- ** View dependence , ViewXCenter(..), ViewYCenter(..), ViewWidth(..), ViewHeight(..) , ViewXResolution(..), ViewYResolution(..) - -- ** Auxiliary plot objects + -- * Auxiliary plot objects , dynamicAxes, noDynamicAxes - -- ** Plot type + -- * The plot type , DynamicPlottable - -- ** Legacy - , PlainGraphics(..) + , tweakPrerendered ) where import Graphics.Dynamic.Plot.Colour @@ -90,14 +96,18 @@ import Control.Monad.Constrained import Control.Lens hiding ((...), (<.>)) +import Control.Lens.TH(makeLenses) -import Control.Concurrent.Async +import Control.Concurrent (runInBoundThread, threadDelay, ThreadId, forkIO, killThread) +import Control.Concurrent.MVar import Control.DeepSeq +import Control.Exception (evaluate) import Data.List (foldl', sort, sortBy, partition, zip4) import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Vector as Arr import Data.Maybe import Data.Semigroup @@ -108,9 +118,9 @@ import Data.Ord (comparing) import Data.VectorSpace +import Math.LinearMap.Category import Data.Basis import Data.AffineSpace -import Data.LinearMap.HerMetric import Data.Manifold.PseudoAffine import Data.Function.Differentiable import Data.Manifold.Types @@ -118,6 +128,8 @@ import Data.Manifold.Web import qualified Data.Map.Lazy as Map +import qualified Data.Colour.Manifold as CSp + import Data.Tagged import Text.Printf @@ -131,8 +143,44 @@ +data Plot = Plot { + _plotAnnotations :: [Annotation] + , _getPlot :: PlainGraphicsR2 + } +makeLenses ''Plot +data RangeRequest r + = OtherDimDependantRange (Option (Interval r) -> Option (Interval r)) + | MustBeThisRange (Interval r) + +type GraphWindowSpec = GraphWindowSpecR2 + +data DynamicPlottable = DynamicPlottable { + _relevantRange_x, _relevantRange_y :: RangeRequest R + , _inherentColours :: [DCol.Colour ℝ] + , _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] + , _futurePlots :: Maybe DynamicPlottable + , _dynamicPlot :: GraphWindowSpec -> Plot + } +makeLenses ''DynamicPlottable + + +data ObjInPlot = ObjInPlot { + _lastStableView :: IORef (Maybe (GraphWindowSpec, Plot)) + , _newPlotView :: MVar (GraphWindowSpec, Plot) + , _plotObjColour :: Maybe AColour + , _originalPlotObject :: DynamicPlottable + } +makeLenses ''ObjInPlot + + newtype PlainGraphics = PlainGraphics { getPlainGraphics :: PlainGraphicsR2 } deriving (Semigroup, Monoid) @@ -159,12 +207,11 @@ plot = foldMap plot instance Plottable PlainGraphics where - plot (PlainGraphics d) = def { - relevantRange_x = atLeastInterval rlx - , relevantRange_y = atLeastInterval rly - , axesNecessity = -1 - , dynamicPlot = plot - } + plot (PlainGraphics d) = def + & relevantRange_x .~ atLeastInterval rlx + & relevantRange_y .~ atLeastInterval rly + & axesNecessity .~ -1 + & dynamicPlot .~ plot where bb = DiaBB.boundingBox d (rlx,rly) = case DiaBB.getCorners bb of Just (c1, c2) @@ -179,19 +226,23 @@ -- tinted to be distinguishable from other plot objects in the same window. -- Use 'diagramPlot' instead, if you want to view the diagram as-is. shapePlot :: PlainGraphicsR2 -> DynamicPlottable -shapePlot d = (diagramPlot d) { isTintableMonochromic = True, axesNecessity = 0 } +shapePlot d = diagramPlot d + & inherentColours .~ [] + & axesNecessity .~ 0 -- | Plot a generic 'Dia.Diagram'. diagramPlot :: PlainGraphicsR2 -> DynamicPlottable diagramPlot d = plot $ PlainGraphics d +metricFromLength :: RealFrac' s => s -> Norm s +metricFromLength l | l>0 = spanNorm [1 / l] instance Plottable (R-->R) where - plot f = def { relevantRange_y = OtherDimDependantRange yRangef - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot } + plot f = def & relevantRange_y .~ OtherDimDependantRange yRangef + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where yRangef (Option Nothing) = Option Nothing yRangef (Option (Just (Interval l r))) = case intervalImages @@ -207,10 +258,10 @@ where curves :: [[P2]] curves = map (map $ convℝ² . snd) . gatherSides $ discretisePathSegs - 1000 + 10000 ( const . metricFromLength $ (rBound-lBound)/fromIntegral xResolution - , resolutionFunction gs ) + , coerceMetric $ resolutionFunction gs ) ((id&&&f) . alg (\x -> ( point lBound? x ))) trace (p:q:ps) = simpleLine p q <> trace (q:ps) @@ -221,10 +272,10 @@ c = realToFrac instance Plottable (R-->(R,R)) where - plot f = def { relevantRange_y = mempty - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot } + plot f = def & relevantRange_y .~ mempty + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot gs@(GraphWindowSpecR2{..}) = curves `deepseq` mkPlot (foldMap trace curves) where curves :: [[P2]] @@ -232,7 +283,7 @@ $ discretisePathSegs 1000 ( const . metricFromLength $ 1/100 - , resolutionFunction gs ) + , coerceMetric $ resolutionFunction gs ) f trace (p:q:ps) = simpleLine p q <> trace (q:ps) trace _ = mempty @@ -245,12 +296,12 @@ resolutionFunction :: GraphWindowSpecR2 -> RieMetric ℝ² resolutionFunction GraphWindowSpecR2{..} = resoFunc where w = rBound - lBound; h = tBound - bBound - ε = projector (recip δx, 0) ^+^ projector (0, recip δy) + ε = spanNorm [(recip δx^&0), (0^&recip δy)] δx = w / fromIntegral xResolution δy = h / fromIntegral yResolution - resoFunc (x,y) + resoFunc (DiaTypes.V2 x y) | x >= lBound, x <= rBound, y >= bBound, y <= tBound = ε - | otherwise = projector (recip qx,0) ^+^ projector (0,recip qy) + | otherwise = spanNorm [(recip qx^&0), (0^&recip qy)] where qx | x < lBound = lBound - x | x > rBound = x - rBound | otherwise = δx * qy/δy @@ -261,13 +312,12 @@ instance Plottable (R-.^>R) where plot rPCM@(RecursivePCM gPFit gDetails gFitDevs (PCMRange x₀ wsp) gSplN ()) - = def { - relevantRange_x = atLeastInterval $ Interval x₀ xr - , relevantRange_y = otherDimDependence $ rPCMLinFitRange rPCM - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + = def + & relevantRange_x .~ atLeastInterval (Interval x₀ xr) + & relevantRange_y .~ otherDimDependence (rPCMLinFitRange rPCM) + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where xr = wsp * fromIntegral gSplN plot (GraphWindowSpecR2{..}) = mkPlot . trace $ flattenPCM_resoCut bb δx rPCM @@ -287,7 +337,7 @@ [_y+~δq $ q, _y+~δp $ p, _y-~δp $ p, _y-~δq $ q ,_y+~δq $ q ])) ) <> trStRange (qd:ps) - where [σp,σq] = map (`metric'`1) [σp', σq'] + where [σp,σq] = map (|$|1) [σp', σq'] trStRange _ = mempty trMBound l = Dia.fromVertices l & Dia.dashingO [2,2] 0 @@ -301,13 +351,12 @@ instance Plottable (RecursiveSamples Int P2 (DevBoxes P2)) where plot rPCM@(RecursivePCM gPFit gDetails gFitDevs (PCMRange t₀ τsp) gSplN ()) - = def { - relevantRange_x = atLeastInterval xRange - , relevantRange_y = atLeastInterval yRange - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + = def + & relevantRange_x .~ atLeastInterval xRange + & relevantRange_y .~ atLeastInterval yRange + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot (GraphWindowSpecR2{..}) = mkPlot . foldMap trStRange $ flattenPCM_P2_resoCut bbView [(1/δxl)^&0, 0^&(1/δyl)] rPCM @@ -319,11 +368,11 @@ )) <> trSR (qd:ps) trSR _ = mempty calcNormDev ((p,v), DevBoxes σ _) = (p .+^ d, p .-^ d) - where d = metriScale' σ $ turnLeft v + where d = let v' = turnLeft v in v' ^* (σ|$|v') trStRange (Right pts) = (`foldMap`pts) $ \(p, DevBoxes dv _) - -> let δxm = metric' dv $ 1^&0 - δym = metric' dv $ 0^&1 + -> let δxm = dv |$| 1^&0 + δym = dv |$| 0^&1 in if δxm > δx && δym > δy then simpleLine (_x +~ δxm $ p) (_x -~ δxm $ p) <> simpleLine (_y +~ δym $ p) (_y -~ δym $ p) @@ -340,7 +389,7 @@ instance Plottable (Int -.^> P2) where - plot = plot . fmap (\() -> DevBoxes zeroV zeroV :: DevBoxes P2) + plot = plot . fmap (\() -> DevBoxes mempty zeroV :: DevBoxes P2) @@ -363,13 +412,15 @@ -- there is no Éc;statistic optimisationÉd; as in 'tracePlot'. lineSegPlot :: [(Double, Double)] -> DynamicPlottable lineSegPlot ps' - | null ps = mempty { isTintableMonochromic = True } - | otherwise = def { - relevantRange_x = atLeastInterval' $ foldMap (pure . spInterval . fst) (concat ps) - , relevantRange_y = atLeastInterval' $ foldMap (pure . spInterval . snd) (concat ps) - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot } + | null ps = mempty & autoTint + | otherwise = def + & relevantRange_x .~ atLeastInterval' + ( foldMap (pure . spInterval . fst) (concat ps) ) + & relevantRange_y .~ atLeastInterval' + ( foldMap (pure . spInterval . snd) (concat ps) ) + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot (GraphWindowSpecR2{..}) = mkPlot (foldMap trace ps) where trace (p:q:ps) = simpleLine (Dia.p2 p) (Dia.p2 q) <> trace (q:ps) trace _ = mempty @@ -402,7 +453,7 @@ xRange_norm'd = max (-1) ((lCorn^._x - xm)/w) ... min 1 ((rCorn^._x - xm)/w) -flattenPCM_P2_resoCut :: R2Box -> [DualSpace R2] +flattenPCM_P2_resoCut :: R2Box -> [DualVector R2] -> (RecursiveSamples x P2 t) -> [ Either [((P2, R2), DevBoxes P2)] [(P2, t)] ] @@ -414,7 +465,7 @@ | DiaBB.isEmptyBox $ DiaBB.intersection bb (rPCM_R2_boundingBox rPCM) = \case l@(Left [] : _) -> l l -> Left [] : l - | metrics' dev δs > 0.5 || (sum $ ((^2).(pa<.>^)) <$> δs) > 3 + | sum (normSq dev<$>δs) > 1/4 || (sum $ ((^2).(pa<.>^)) <$> δs) > 3 , Left (Pair s1 s2) <- details = go s1 . go s2 | Right pts <- details = (Right (Arr.toList pts) :) @@ -436,61 +487,65 @@ instance Plottable (Shade P2) where - plot shade = def { - relevantRange_x = atLeastInterval xRange - , relevantRange_y = atLeastInterval yRange - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + plot shade = def + & relevantRange_x .~ atLeastInterval xRange + & relevantRange_y .~ atLeastInterval yRange + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot _ = mkPlot $ foldMap axLine eigVs where axLine eigV = simpleLine (ctr .-~^ eigV) (ctr .+~^ eigV) (xRange,yRange) = shadeExtends shade ctr = shade^.shadeCtr - eigVs = eigenSpan $ shade^.shadeExpanse + eigVs = normSpanningSystem $ shade^.shadeExpanse +instance Plottable (Shade ℝ²) where + plot (Shade v e) = plot (Shade (Dia.P v) e :: Shade P2) + instance Plottable (Shade (R,R)) where - plot sh = plot (coerceShade sh :: Shade P2) + plot sh = plot (coerceShade sh :: Shade R2) instance Plottable (Shade' (R,R)) where - plot shade = def { - isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + plot shade = def + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot _ = mkPlot $ Dia.circle 1 & Dia.scaleX w₁ & Dia.scaleY w₂ & Dia.rotate ϑ & Dia.opacity 0.2 & Dia.moveTo ctr ctr = Dia.p2 $ shade^.shadeCtr - [ev₁@(e₁x,e₁y),ev₂] = eigenSpan' $ shade^.shadeNarrowness + Norm expanr = shade^.shadeNarrowness + [ev₁@(_,(e₁x,e₁y)),ev₂] = eigen $ arr expanr ϑ = atan2 e₁y e₁x Dia.@@ Dia.rad - w₁ = recip $ magnitude ev₁; w₂ = recip $ magnitude ev₂ + [w₁,w₂] = recip . sqrt . fst <$> [ev₁, ev₂] instance Plottable (ConvexSet (R,R)) where plot EmptyConvex = mempty plot (ConvexSet hull intersects) = plot [ plot intersects - & tweakDiagram (Dia.opacity + & tweakPrerendered (Dia.opacity (1 / fromIntegral (length intersects)) ) , plot hull - & tweakDiagram ( Dia.lwO 3 + & tweakPrerendered ( Dia.lwO 3 >>> Dia.opacity 1 >>> Dia.fcA (Dia.withOpacity Dia.grey 0.01) ) ] +instance Plottable (Shade' ℝ²) where + plot sh = plot (coerceShade sh :: Shade' (ℝ,ℝ)) + instance Plottable (Shade' P2) where - plot sh = plot (coerceShade sh :: Shade' (R,R)) + plot (Shade' (Dia.P v) e) = plot (Shade' v e :: Shade' ℝ²) instance Plottable (Shaded ℝ ℝ) where plot tr | length trivs' >= 2 - = def { relevantRange_x = atLeastInterval $ Interval xmin xmax - , relevantRange_y = atLeastInterval $ Interval ymin ymax - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + = def & relevantRange_x .~ atLeastInterval (Interval xmin xmax) + & relevantRange_y .~ atLeastInterval (Interval ymin ymax) + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $ foldMap parallelogram trivs <> (foldMap (singlePointFor grWS) leafPoints @@ -522,12 +577,11 @@ instance Plottable (PointsWeb ℝ (Shade' ℝ)) where plot web | length locals >= 2 - = def { relevantRange_x = atLeastInterval $ Interval xmin xmax - , relevantRange_y = atLeastInterval $ Interval ymin ymax - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + = def & relevantRange_x .~ atLeastInterval (Interval xmin xmax) + & relevantRange_y .~ atLeastInterval (Interval ymin ymax) + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $ foldMap parallelogram trivs <> foldMap vbar divis @@ -545,21 +599,24 @@ trivs :: [((ℝ, (Diff ℝ,Diff ℝ)), ((ℝ, Diff ℝ), LocalLinear ℝ ℝ))] divis :: [(ℝ, (Diff ℝ,Diff ℝ))] (trivs,divis) = concat***concat $ unzip (map mkTriv locals) - where mkTriv ((xc,Shade' yc yce), [(δxo, Shade' yo _)]) - = case tryMetricAsLength yce of - Option (Just ry) -> + where mkTriv :: ((ℝ, Shade' ℝ), [(ℝ, Shade' ℝ)]) + -> ( [((ℝ, (Diff ℝ,Diff ℝ)), ((ℝ, Diff ℝ), LocalLinear ℝ ℝ))] + , [(ℝ, (Diff ℝ,Diff ℝ))] ) + mkTriv ((xc,Shade' yc yce), [(δxo, Shade' yo _)]) + = case findNormalLength yce of + Just ry -> ( [ ( (xc, dirSort 0 δxo) , ( (yc, ry) - , denseLinear $ \δx -> δx * (yo-yc)/δxo ) ) ], [] ) - Option Nothing -> + , id ^* ((yo-yc)/δxo) ) ) ], [] ) + Nothing -> ( [], [(xc, dirSort 0 δxo)] ) mkTriv ((xc,Shade' yc yce), [(δxl, Shade' yl _), (δxr, Shade' yr _)]) - = case tryMetricAsLength yce of - Option (Just ry) -> + = case findNormalLength yce of + Just ry -> ( [ ( (xc, dirSort δxl δxr) , ( (yc, ry) - , denseLinear $ \δx -> δx * η ) ) ], [] ) - Option Nothing -> + , id ^* η ) ) ], [] ) + Nothing -> ( [], [(xc, dirSort δxl δxr)] ) where δxg = (δxr - δxl)/2 η = (yr - yl)/(2*δxg) @@ -578,16 +635,29 @@ locals = Hask.toList $ localFocusWeb web plot _ = def +instance Plottable (PointsWeb ℝ² (CSp.Colour ℝ)) where + + +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) + + +plotLatest :: Plottable x => [x] -> DynamicPlottable +plotLatest (x:xs) = plot $ Latest (x:|xs) +plotLatest l = plot l + + instance Plottable (SimpleTree P2) where plot (GenericTree Nothing) = plot ([] :: [SimpleTree P2]) plot (GenericTree (Just (ctr, root))) - = def{ - relevantRange_x = atLeastInterval xRange - , relevantRange_y = atLeastInterval yRange - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot - } + = def + & relevantRange_x .~ atLeastInterval xRange + & relevantRange_y .~ atLeastInterval yRange + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where plot _ = mkPlot $ go 4 ctr (treeBranches root) where go w bctr = foldMap (\(c,GenericTree b) -> autoDashLine w bctr c @@ -600,6 +670,8 @@ tree = GenericTree [(ctr,root)] instance Plottable (Trees P2) where plot (GenericTree ts) = plot $ (GenericTree . Just) <$> ts +instance Plottable (Trees R2) where + plot = plot . fmap Dia.P instance Plottable (SimpleTree (R,R)) where plot = plot . fmap (\(x,y) -> DiaTypes.p2 (x,y)) @@ -621,8 +693,6 @@ circ = Dia.circle 1 & Dia.scaleX pxw & Dia.scaleY pxh -type GraphWindowSpec = GraphWindowSpecR2 - moveStepRel :: (R, R) -- ^ Relative translation @(Δx/w, Δy/h)@. -> (R, R) -- ^ Relative zoom. -> GraphWindowSpec -> GraphWindowSpec @@ -645,10 +715,6 @@ -data Plot = Plot { - plotAnnotations :: [Annotation] - , getPlot :: PlainGraphicsR2 - } instance Semigroup Plot where Plot a1 d1 <> Plot a2 d2 = Plot (a1<>a2) (d1<>d2) instance Monoid Plot where @@ -661,45 +727,35 @@ mkAnnotatedPlot :: [Annotation] -> PlainGraphicsR2 -> Plot mkAnnotatedPlot ans = Plot ans -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₁ ry₁ tm₁ oc₁ ax₁ le₁ fu₁ dp₁ + <> DynamicPlottable rx₂ ry₂ tm₂ oc₂ ax₂ le₂ fu₂ dp₂ = DynamicPlottable - (rx₁<>rx₂) (ry₁<>ry₂) (tm₁||tm₂) (oc₁+oc₂) (ax₁+ax₂) (le₁++le₂) (dp₁<>dp₂) + (rx₁<>rx₂) (ry₁<>ry₂) (tm₁++tm₂) (oc₁+oc₂) (ax₁+ax₂) + (le₁++le₂) ((<>)<$>fu₁<*>fu₂) (dp₁<>dp₂) instance Monoid DynamicPlottable where - mempty = DynamicPlottable mempty mempty False 0 0 [] mempty + mempty = DynamicPlottable mempty mempty [] 0 0 [] mempty mempty mappend = (<>) instance Default DynamicPlottable where def = mempty -data GraphViewState = GraphViewState { - lastStableView :: Maybe (GraphWindowSpec, Plot) - , realtimeView, nextTgtView :: Async Plot - , graphColor :: Maybe AColour - } - +-- | Set the caption for this plot object that should appear in the +-- plot legend. legendName :: String -> DynamicPlottable -> DynamicPlottable -legendName n d = d { legendEntries = LegendEntry (PlainText n) mempty : legendEntries d } +legendName n = legendEntries %~ (LegendEntry (PlainText n) mempty :) +-- | Colour this plot object in a fixed shade. +tint :: DCol.Colour ℝ -> DynamicPlottable -> DynamicPlottable +tint col = inherentColours .~ [col] + >>> dynamicPlot %~ fmap (getPlot %~ Dia.lc col . Dia.fc col) -data RangeRequest r - = OtherDimDependantRange (Option (Interval r) -> Option (Interval r)) - | MustBeThisRange (Interval r) +-- | 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 .~ [] + instance (Ord r) => Semigroup (RangeRequest r) where MustBeThisRange r <> _ = MustBeThisRange r _ <> MustBeThisRange r = MustBeThisRange r @@ -750,42 +806,41 @@ -- ATTENTION: the window may sometimes freeze, especially when displaying -- complicated functions with 'fnPlot` from ghci. This is apparently -- a kind of deadlock problem with one of the C libraries that are invoked, --- in particular, 'fnPlot' makes heavy use of --- and thus . -- At the moment, we can recommend no better solution than to abort and restart ghci -- (or what else you use – iHaskell kernel, process, ...) if this occurs. plotWindow :: [DynamicPlottable] -> IO GraphWindowSpec plotWindow [] = plotWindow [dynamicAxes] -plotWindow graphs' = do - - dgStore <- newIORef $ mempty - +plotWindow givenPlotObjs = runInBoundThread $ do let defColourScheme = defaultColourScheme + viewState <- newIORef $ autoDefaultView givenPlotObjs + viewTgt <- newIORef =<< readIORef viewState + viewTgtGlobal <- newMVar =<< readIORef viewState + screenResolution <- newIORef (640, 480) - ([viewTgt, viewState], graphs) <- do - let window₀ = autoDefaultView graphs' - assignGrViews :: [DynamicPlottable] -> [Colour] -> Double - -> IO [(DynamicPlottable, GraphViewState)] - assignGrViews (g@DynamicPlottable{..}:gs) (c:cs) axn = do - v <- async $ return $! dynamicPlot window₀ - fmap ((g, GraphViewState { lastStableView = Nothing - , realtimeView = v, nextTgtView = v - , graphColor = cl } - ) : ) $ assignGrViews gs cs' (axn + axesNecessity) - where (cl, cs') - | isTintableMonochromic = (Just $ defColourScheme c, cs) - | otherwise = (Nothing, c:cs) - 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 - return (w,gs) + dgStore <- newIORef mempty + (plotObjs, cancelWorkers) :: ([ObjInPlot], IO ()) <- do + let assignPlObjPropties :: [DynamicPlottable] -> [Colour] -> Necessity + -> IO [(ObjInPlot, ThreadId)] + assignPlObjPropties [] _ axesNeed + | axesNeed > 0 = assignPlObjPropties [dynamicAxes] [grey] (-1) + | otherwise = return [] + assignPlObjPropties (o:os) (c:cs) 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 + return ( sortBy (comparing $ _occlusiveness . _originalPlotObject) pObs + , forM_ workerId killThread ) + GTK.initGUI window <- GTK.windowNew @@ -797,9 +852,10 @@ (canvasX,canvasY) <- GTK.widgetGetSize drawA modifyIORef viewTgt $ \view -> view{ xResolution = fromIntegral canvasX , yResolution = fromIntegral canvasY } + dia <- readIORef dgStore - let oldSize = Dia.size dia - scaledDia = Dia.bg Dia.black + + let scaledDia = Dia.bg Dia.black . Dia.scaleX (fromInt canvasX / 2) . Dia.scaleY (-fromInt canvasY / 2) . Dia.translate (1 ^& (-1)) @@ -876,35 +932,6 @@ return $ GTK.widgetQueueDraw drawA - let updateRTView, updateTgtView :: (GraphWindowSpec -> GraphWindowSpec) -> IO () - updateRTView updRealView = do - vstOld <- readIORef viewState - let newRealView = updRealView vstOld - grViewsOld <- readIORef graphs - writeIORef graphs <=< forM grViewsOld $ - \(o@DynamicPlottable{..}, gv) -> do - newRt <- async $ return $! dynamicPlot newRealView - poll (realtimeView gv) >>= \case - Just(Right vw) -> return (o - , gv{ realtimeView = newRt, lastStableView = Just (vstOld, vw) }) - _ -> do - cancel $ realtimeView gv - poll (nextTgtView gv) >>= \case - Just(Right vw) -> do - ttvn <- readIORef viewTgt - return (o, gv{ realtimeView = newRt, lastStableView = Just (ttvn, vw) }) - _ -> return (o, gv{ realtimeView = newRt }) - writeIORef viewState newRealView - updateTgtView updTgtView = do - newTgtView <- updTgtView <$> readIORef viewTgt - grViewsOld <- readIORef graphs - writeIORef graphs <=< forM grViewsOld $ - \(o@DynamicPlottable{..}, gv) -> do - newTt <- async $ return $! dynamicPlot newTgtView - cancel $ nextTgtView gv - return (o, gv{ nextTgtView = newTt }) - writeIORef viewTgt newTgtView - t₀ <- getCurrentTime lastFrameTime <- newIORef t₀ @@ -919,12 +946,12 @@ 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 - _ -> case lastStableView of - Just (_, vw) -> return $ Just vw - _ -> poll nextTgtView >> return Nothing + renderComp plotObj = do + plt <- tryTakeMVar (plotObj^.newPlotView) >>= \case + Nothing -> fmap snd <$> readIORef (plotObj^.lastStableView) + newDia -> do + writeIORef (plotObj^.lastStableView) newDia + return $ snd <$> newDia case plt of Nothing -> return mempty Just Plot{..} -> let @@ -936,18 +963,18 @@ fontPts = 12 transform :: PlainGraphicsR2 -> PlainGraphicsR2 transform = normaliseView . clr - where clr | Just c <- graphColor = Dia.lcA c . Dia.fcA c - | otherwise = id + 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 + renderedAnnot <- mapM (prerenderAnnotation antTK) _plotAnnotations + return . transform $ fold renderedAnnot <> _getPlot - gvStates <- readIORef graphs - waitAny $ map (realtimeView . snd) gvStates - - thePlot <- (mconcat . reverse) <$> mapM renderComp (reverse gvStates) + thePlot <- (mconcat . reverse) <$> mapM renderComp (reverse plotObjs) theLegend <- prerenderLegend (textTK 10 1) colourScheme - $ (\(p,g) -> (,) <$> legendEntries p <*> [graphColor g]) =<< gvStates + $ (\g -> (,) <$> g^.originalPlotObject.legendEntries + <*> [g^.plotObjColour] + ) =<< plotObjs writeIORef dgStore $ ( theLegend & Dia.scaleX (0.1 / sqrt (fromIntegral xResolution)) & Dia.scaleY (0.1 / sqrt (fromIntegral yResolution)) @@ -962,7 +989,8 @@ writeIORef lastFrameTime t do vt <- readIORef viewTgt - updateRTView $ \vo -> + modifyMVar_ viewTgtGlobal . const $ return 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) (bBound vt % bBound vo) (tBound vt % tBound vo) @@ -974,8 +1002,7 @@ return True GTK.onDestroy window $ do - (readIORef graphs >>=) . mapM_ -- cancel remaining threads - $ \(_, GraphViewState{..}) -> cancel realtimeView >> cancel nextTgtView + cancelWorkers GTK.mainQuit @@ -987,9 +1014,28 @@ readIORef viewState + + +objectPlotterThread :: DynamicPlottable + -> MVar GraphWindowSpec + -> MVar (GraphWindowSpec, Plot) + -> IO () +objectPlotterThread pl₀ viewVar diaVar = loop pl₀ where + loop pl = do + threadDelay $ 50 * milliseconds + view <- readMVar viewVar + diagram <- evaluate $ pl^.dynamicPlot $ view + putMVar diaVar (view, diagram) + case pl^.futurePlots of + Just pl' -> loop pl' + Nothing -> loop pl + + + + autoDefaultView :: [DynamicPlottable] -> GraphWindowSpec autoDefaultView graphs = GraphWindowSpecR2 l r b t defResX defResY defaultColourScheme - where (xRange, yRange) = foldMap (relevantRange_x &&& relevantRange_y) graphs + where (xRange, yRange) = foldMap (_relevantRange_x &&& _relevantRange_y) graphs ((l,r), (b,t)) = ( xRange `dependentOn` yRange , yRange `dependentOn` xRange ) @@ -1028,7 +1074,6 @@ - -- | Plot an (assumed continuous) function in the usual way. -- Since this uses functions of actual 'Double' values, you have more liberty -- of defining functions with range-pattern-matching etc., which is at the moment @@ -1045,11 +1090,11 @@ -- 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 = def{ - relevantRange_y = otherDimDependence yRangef - , isTintableMonochromic = True - , axesNecessity = 1 - , dynamicPlot = plot } +continFnPlot f = def + & relevantRange_y .~ otherDimDependence yRangef + & autoTint + & axesNecessity .~ 1 + & dynamicPlot .~ plot where yRangef = onInterval $ \(l, r) -> ((!%0.1) &&& (!%0.9)) . sort . pruneOutlyers $ map f [l, l + (r-l)/80 .. r] plot (GraphWindowSpecR2{..}) = curve `deepseq` mkPlot (trace curve) @@ -1083,7 +1128,7 @@ -- -- This function is equivalent to using 'plot' on an 'RWDiffable' arrow. fnPlot :: (∀ m . ( WithField ℝ PseudoAffine m - , HasMetric (Needle (Interior m)) ) + , SimpleSpace (Needle m) ) => AgentVal (-->) m ℝ -> AgentVal (-->) m ℝ ) -> DynamicPlottable fnPlot f = plot fd @@ -1092,7 +1137,7 @@ -- | Plot a continuous, “parametric function”, i.e. mapping the real line to a path in ℝ². paramPlot :: (∀ m . ( WithField ℝ PseudoAffine m - , HasMetric (Needle (Interior m)) ) + , LSpace (Needle (Interior m)) ) => AgentVal (-->) m ℝ -> (AgentVal (-->) m ℝ, AgentVal (-->) m ℝ) ) -> DynamicPlottable paramPlot f = plot fd @@ -1100,17 +1145,16 @@ fd = alg1to2 f scrutiniseDiffability :: (∀ m . ( WithField ℝ PseudoAffine m - , HasMetric (Needle (Interior m)) ) + , SimpleSpace (Needle 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 - } + dframe rfh = def + & autoTint + & dynamicPlot .~ mkFrame where mkFrame (GraphWindowSpecR2{..}) = case fscrut xm of Option (Just ((ym,y'm), δOδx²)) | Option (Just δx) <- δOδx² δy @@ -1131,10 +1175,10 @@ continColourSurfaceFnPlot :: ((Double,Double) -> DCol.Colour Double) -> DynamicPlottable -continColourSurfaceFnPlot f = def { - axesNecessity = 1 - , occlusiveness = 4 - , dynamicPlot = plot } +continColourSurfaceFnPlot f = def + & axesNecessity .~ 1 + & occlusiveness .~ 4 + & dynamicPlot .~ plot where plot (GraphWindowSpecR2{..}) = mkPlot $ Dia.place ( Dia.rasterDia cf (xResolution`div`4) (yResolution`div`4) @@ -1178,10 +1222,10 @@ -- | Coordinate axes with labels. For many plottable objects, these will be added -- automatically, by default (unless inhibited with 'noDynamicAxes'). dynamicAxes :: DynamicPlottable -dynamicAxes = def { - axesNecessity = superfluent - , occlusiveness = 1 - , dynamicPlot = plot } +dynamicAxes = def + & axesNecessity .~ superfluent + & occlusiveness .~ 1 + & dynamicPlot .~ plot where plot gwSpec@(GraphWindowSpecR2{..}) = Plot labels lines where (DynamicAxes yAxCls xAxCls) = crtDynamicAxes gwSpec lines = zeroLine (lBound^&0) (rBound^&0) `provided`(bBound<0 && tBound>0) @@ -1207,7 +1251,7 @@ noDynamicAxes :: DynamicPlottable -noDynamicAxes = def { axesNecessity = superfluent } +noDynamicAxes = def & axesNecessity .~ superfluent @@ -1222,12 +1266,12 @@ & if w < 1 then Dia.dashingO [w*6, 3] 0 else id -tweakDiagram :: (PlainGraphicsR2->PlainGraphicsR2) -> DynamicPlottable->DynamicPlottable -tweakDiagram f fig = fig { dynamicPlot = tweak . dynamicPlot fig } - where tweak pl = pl { getPlot = f $ getPlot pl } +tweakPrerendered :: (PlainGraphicsR2->PlainGraphicsR2) -> DynamicPlottable->DynamicPlottable +tweakPrerendered f = dynamicPlot %~ (tweak .) + where tweak = getPlot %~ f opacityFactor :: Double -> DynamicPlottable -> DynamicPlottable -opacityFactor = tweakDiagram . Dia.opacity +opacityFactor = tweakPrerendered . Dia.opacity -- | When you “plot” 'xInterval' / 'yInterval', it is ensured that the (initial) view encompasses @@ -1245,10 +1289,10 @@ yInterval, forceYRange :: (Double, Double) -> DynamicPlottable -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 } +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) @@ -1268,54 +1312,54 @@ -- <> newtype ViewXCenter = ViewXCenter { getViewXCenter :: Double } instance (Plottable p) => Plottable (ViewXCenter -> p) where - 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 } + plot f = def & relevantRange_y .~ OtherDimDependantRange + (\g -> deescalate relevantRange_y g . plot . f . cxI =<< g) + & inherentColours .~ fcxVoid^.inherentColours + & axesNecessity .~ fcxVoid^.axesNecessity + & 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. - deescalate rfind otherdim p = case rfind p of + deescalate rfind otherdim p = case p^.rfind of MustBeThisRange i -> pure i OtherDimDependantRange ifr -> ifr otherdim newtype ViewYCenter = ViewYCenter { getViewYCenter :: Double } instance (Plottable p) => Plottable (ViewYCenter -> p) where - 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 } + plot f = def & relevantRange_x .~ OtherDimDependantRange + (\g -> deescalate relevantRange_x g . plot . f . cyI =<< g) + & inherentColours .~ fcyVoid^.inherentColours + & axesNecessity .~ fcyVoid^.axesNecessity + & 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. - deescalate rfind otherdim p = case rfind p of + deescalate rfind otherdim p = case p^.rfind of MustBeThisRange i -> pure i OtherDimDependantRange ifr -> ifr otherdim newtype ViewWidth = ViewWidth { getViewWidth :: Double } instance (Plottable p) => Plottable (ViewWidth -> p) where - 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 } + plot f = def & relevantRange_y .~ OtherDimDependantRange + (\g -> deescalate relevantRange_y g . plot . f . wI =<< g) + & inherentColours .~ fwVoid^.inherentColours + & axesNecessity .~ fwVoid^.axesNecessity + & 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 - deescalate rfind otherdim p = case rfind p of + deescalate rfind otherdim p = case p^.rfind of MustBeThisRange i -> pure i OtherDimDependantRange ifr -> ifr otherdim newtype ViewHeight = ViewHeight { getViewHeight :: Double } instance (Plottable p) => Plottable (ViewHeight -> p) where - 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 } + plot f = def & relevantRange_x .~ OtherDimDependantRange + (\g -> deescalate relevantRange_x g . plot . f . hI =<< g) + & inherentColours .~ fhVoid^.inherentColours + & axesNecessity .~ fhVoid^.axesNecessity + & 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 - deescalate rfind otherdim p = case rfind p of + deescalate rfind otherdim p = case p^.rfind of MustBeThisRange i -> pure i OtherDimDependantRange ifr -> ifr otherdim newtype ViewXResolution = ViewXResolution { getViewXResolution :: Int } @@ -1336,3 +1380,5 @@ (Just (llx,lux)) = Dia.extentX d₂; (Just (lly,luy)) = Dia.extentY d₂ + +milliseconds = 1000 :: Int diff --git a/Graphics/Text/Annotation.hs b/Graphics/Text/Annotation.hs --- a/Graphics/Text/Annotation.hs +++ b/Graphics/Text/Annotation.hs @@ -64,7 +64,6 @@ import Data.VectorSpace import Data.Basis import Data.AffineSpace -import Data.LinearMap.HerMetric import Data.Manifold.PseudoAffine import Data.Manifold.TreeCover import qualified Data.Map.Lazy as Map 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.4.0 +Version: 0.2.0.0 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions @@ -49,11 +49,11 @@ , random , MonadRandom , time - , async , deepseq , process , constrained-categories >= 0.2 , 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 @@ -61,7 +61,8 @@ , gtk > 0.10 && < 0.15 , glib , colour >= 2 && < 3 - , manifolds >= 0.2.3 && < 0.2.4 + , manifolds >= 0.3 && < 0.4 + , colour-space , lens < 4.15 Other-Extensions: FlexibleInstances , TypeFamilies