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 @@ -56,6 +56,7 @@ import Data.VectorSpace import Data.Basis import Data.AffineSpace +import Data.VectorSpace.Free () import Data.LinearMap.HerMetric import Data.Manifold.PseudoAffine import Data.Manifold.TreeCover @@ -67,26 +68,6 @@ type R2 = Dia.V2 Double type P2 = Dia.P2 Double -instance AffineSpace R2 where - type Diff R2 = R2 - (.-.) = (Dia.^-^) - (.+^) = (Dia.^+^) -instance AdditiveGroup R2 where - (^+^) = (Dia.^+^) - zeroV = Dia.zero - negateV = Dia.negated -instance VectorSpace R2 where - type Scalar R2 = Double - (*^) = (Dia.*^) -instance HasBasis R2 where - type Basis R2 = Either () () - basisValue (Left ()) = 1^&0 - basisValue (Right ()) = 0^&1 - decompose v = [(Left(), v^._x), (Right(), v^._y)] - decompose' v (Left ()) = v^._x - decompose' v (Right ()) = v^._y -instance InnerSpace R2 where - (<.>) = Dia.dot instance FiniteDimensional R2 where dimension = Tagged 2 basisIndex = Tagged bi where bi b = if (basisValue b::R2)^._x > 0.5 then 0 else 1 @@ -112,10 +93,6 @@ instance LocallyCoercible (R,R) R2 where locallyTrivialDiffeomorphism = DiaTypes.r2 -instance AffineSpace P2 where - type Diff P2 = R2 - (.-.) = (Dia..-.) - (.+^) = (Dia..+^) instance Semimanifold P2 where type Needle P2 = R2 fromInterior = id 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 @@ -96,7 +96,7 @@ import Control.DeepSeq -import Data.List (foldl', sort, sortBy, intercalate, isPrefixOf, isInfixOf, find, zip4) +import Data.List (foldl', sort, sortBy, partition, zip4) import qualified Data.List.NonEmpty as NE import qualified Data.Vector as Arr import Data.Maybe @@ -467,6 +467,17 @@ [ev₁@(e₁x,e₁y),ev₂] = eigenSpan' $ shade^.shadeNarrowness ϑ = atan2 e₁y e₁x Dia.@@ Dia.rad w₁ = recip $ magnitude ev₁; w₂ = recip $ magnitude ev₂ + +instance Plottable (ConvexSet (R,R)) where + plot EmptyConvex = mempty + plot (ConvexSet hull intersects) + = plot [ plot intersects + & tweakDiagram (Dia.opacity + (1 / fromIntegral (length intersects)) ) + , plot hull + & tweakDiagram ( Dia.lwO 3 + >>> Dia.opacity 1 + >>> Dia.fcA (Dia.withOpacity Dia.grey 0.01) ) ] instance Plottable (Shade' P2) where plot sh = plot (coerceShade sh :: Shade' (R,R)) @@ -519,28 +530,44 @@ } where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $ foldMap parallelogram trivs - where parallelogram ((x,δx), ((y,δy), j)) - = lLoop [ (x+δx)^&(y+δy+jδx), (x-δx)^&(y+δy-jδx) - , (x-δx)^&(y-δy-jδx), (x+δx)^&(y-δy+jδx) ] + <> foldMap vbar divis + where parallelogram ((x,(δxl,δxr)), ((y,δy), j)) + = lLoop [ (x+δxr)^&(y+δy+jδxr), (x-δxl)^&(y+δy-jδxl) + , (x-δxl)^&(y-δy-jδxl), (x+δxr)^&(y-δy+jδxr) ] & Dia.strokeLocLoop & Dia.opacity 0.3 - where jδx = j $ δx + where jδxl = j $ δxl + jδxr = j $ δxr + vbar (x,(δxl,δxr)) = Dia.fromVertices + [ (x-δxl)^&tBound, (x-δxl)^&bBound + , (x+δxr)^&bBound, (x+δxr)^&tBound ] - trivs :: [((ℝ, Diff ℝ), ((ℝ, Diff ℝ), LocalLinear ℝ ℝ))] - trivs = map mkTriv locals - where mkTriv ((xc,Shade' yc yce), [(xo, Shade' yo _)]) - = ( (xc, xo-xc) - , ( (yc, metricAsLength yce) - , denseLinear $ \δx -> δx * (yo-yc)/(xo-xc) ) ) - mkTriv ((xc,Shade' yc yce), [(xl, Shade' yl _), (xr, Shade' yr _)]) - = ( (xc, δxg) - , ( (yc, metricAsLength yce) - , denseLinear $ \δx -> δx * η ) ) - where δxg = (xr - xl)/2 + 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) -> + ( [ ( (xc, dirSort 0 δxo) + , ( (yc, ry) + , denseLinear $ \δx -> δx * (yo-yc)/δxo ) ) ], [] ) + Option Nothing -> + ( [], [(xc, dirSort 0 δxo)] ) + mkTriv ((xc,Shade' yc yce), [(δxl, Shade' yl _), (δxr, Shade' yr _)]) + = case tryMetricAsLength yce of + Option (Just ry) -> + ( [ ( (xc, dirSort δxl δxr) + , ( (yc, ry) + , denseLinear $ \δx -> δx * η ) ) ], [] ) + Option Nothing -> + ( [], [(xc, dirSort δxl δxr)] ) + where δxg = (δxr - δxl)/2 η = (yr - yl)/(2*δxg) - mkTriv (_,l) = error $ "Encountered point in web with " - ++show(length l)++" neighbours. Any point in 1D " - ++"should have either one or two neighbours!" + mkTriv (p,lrs) = concat***concat $ unzip [mkTriv (p,[l,r]) | l<-ls, r<-rs] + where (ls,rs) = partition ((<0) . fst) lrs + + dirSort δ₁ δ₂ | δ₁ < δ₂ = (-δ₁, δ₂) + | otherwise = (-δ₂, δ₁) lLoop ps@(p:_) = Dia.fromVertices $ ps++[p] @@ -1023,7 +1050,7 @@ , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot } - where yRangef = onInterval $ \(l, r) -> ((!10) &&& (!70)) . sort . pruneOutlyers + 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) where δx = (rBound - lBound) * 2 / fromIntegral xResolution @@ -1031,8 +1058,10 @@ trace (p:q:ps) = simpleLine p q <> trace (q:ps) trace _ = mempty pruneOutlyers = filter (not . isNaN) - l!n | (x:_)<-drop n l = x - | otherwise = error "Function appears to yield NaN most of the time. Cannot be plotted." + l!%η = case length l of + ll | ll<2 -> error + "Function appears to yield NaN most of the time. Cannot be plotted." + | otherwise -> l !! floor (fromIntegral ll * η) type (-->) = RWDiffable ℝ @@ -1192,6 +1221,13 @@ autoDashLine w p q = simpleLine' (max 1 w) p q & 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 } + +opacityFactor :: Double -> DynamicPlottable -> DynamicPlottable +opacityFactor = tweakDiagram . Dia.opacity -- | When you “plot” 'xInterval' / 'yInterval', it is ensured that the (initial) view encompasses 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.3.0 +Version: 0.1.4.0 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions @@ -53,6 +53,7 @@ , deepseq , process , constrained-categories >= 0.2 + , free-vector-spaces >= 0.1 && < 0.2 , diagrams-core , diagrams-lib >= 1.3 && < 1.4 , diagrams-cairo > 1.3.0.5 && < 1.4 @@ -60,7 +61,7 @@ , gtk > 0.10 && < 0.15 , glib , colour >= 2 && < 3 - , manifolds >= 0.2.2 && < 0.2.3 + , manifolds >= 0.2.3 && < 0.2.4 , lens < 4.15 Other-Extensions: FlexibleInstances , TypeFamilies