diff --git a/Data/LinearMap/HerMetric.hs b/Data/LinearMap/HerMetric.hs deleted file mode 100644 --- a/Data/LinearMap/HerMetric.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ConstraintKinds #-} - - - - -module Data.LinearMap.HerMetric ( - HasMetric(..) - , (^<.>) - , HerMetric - , projector - , metricSq, metric, metrics - , metriScale - ) where - - - - -import Data.VectorSpace -import Data.LinearMap -import Data.Basis -import Data.MemoTrie - - -import Diagrams.Prelude - - -infixr 7 <.>^, ^<.> - -class ( HasBasis v, RealFloat (Scalar v), HasTrie (Basis v) - , VectorSpace (DualSpace v), HasBasis (DualSpace v) - , Scalar v ~ Scalar (DualSpace v), Basis v ~ Basis (DualSpace v) ) - => HasMetric v where - type DualSpace v :: * - type DualSpace v = v - (<.>^) :: DualSpace v -> v -> Scalar v - - -(^<.>) :: HasMetric v => v -> DualSpace v -> Scalar v -ket ^<.> bra = bra <.>^ ket - -instance HasMetric Double where - (<.>^) = (<.>) -instance (HasMetric v, HasMetric w, Scalar v ~ Scalar w) => HasMetric (v,w) where - type DualSpace (v,w) = (DualSpace v, DualSpace w) - (v,w)<.>^(v',w') = v<.>^v' + w<.>^w' -instance HasMetric R2 where - (<.>^) = (<.>) - - --- | 'HerMetric' is a portmanteau of /Hermitian/ and /metric/ (in the sense as used --- in e.g. general relativity). -newtype HerMetric v = HerMetric { getHerMetric :: DualSpace v :-* v } - -instance HasMetric v => AdditiveGroup (HerMetric v) where - zeroV = HerMetric zeroV - negateV (HerMetric m) = HerMetric $ negateV m - HerMetric m ^+^ HerMetric n = HerMetric $ m ^+^ n -instance HasMetric v => VectorSpace (HerMetric v) where - type Scalar (HerMetric v) = Scalar v - s *^ (HerMetric m) = HerMetric $ s *^ m - -projector :: HasMetric v => v -> HerMetric v -projector v = HerMetric (linear $ \u -> v ^* (v^<.>u)) - - -metricSq, metric :: HasMetric v => HerMetric v -> DualSpace v -> Scalar v -metricSq (HerMetric m) v = v <.>^ lapply m v -metric (HerMetric m) v = sqrt $ v <.>^ lapply m v - - -metriScale :: HasMetric v => HerMetric v -> DualSpace v -> DualSpace v -metriScale m v = metric m v *^ v - - -metrics :: HasMetric v => HerMetric v -> [DualSpace v] -> Scalar v -metrics m vs = sqrt . sum $ metricSq m <$> vs - - - - 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 @@ -37,6 +37,11 @@ , tracePlot -- ** View selection , xInterval, yInterval + -- ** View dependance + , ViewXCenter(..), ViewYCenter(..), ViewWidth(..), ViewHeight(..) + , ViewXResolution(..), ViewYResolution(..) + -- ** Auxiliary plot objects + , dynamicAxes, noDynamicAxes -- ** Plot type , DynamicPlottable ) where @@ -76,7 +81,7 @@ import Control.Arrow.Constrained import Control.Monad.Constrained -import Control.Lens hiding ((...)) +import Control.Lens hiding ((...), (<.>)) import Control.Concurrent.Async @@ -109,6 +114,13 @@ + +instance HasMetric R2 where + type DualSpace R2 = R2 + (<.>^) = (<.>) + functional f = f(1^&0) ^& f(0^&1) + doubleDual = id; doubleDual' = id + (^) :: Num n => n -> Int -> n (^) = (Prelude.^) @@ -123,7 +135,10 @@ class Plottable p where plot :: p -> DynamicPlottable -instance (RealFloat r₁, RealFloat r₂) => Plottable (r₁ -> r₂) where +instance Plottable DynamicPlottable where + plot = id + +instance Plottable (R -> R) where plot f = continFnPlot $ realToFrac . f . realToFrac -- {-# RULES "plot/R->R" plot = fnPlot #-} @@ -252,8 +267,8 @@ -data DevBoxes y = DevBoxes { deviations :: HerMetric (Diff y) - , maxDeviation :: Scalar (Diff y) } +data DevBoxes y = DevBoxes { deviations :: HerMetric' (Diff y) + , maxDeviation :: Scalar (Diff y) } @@ -318,7 +333,7 @@ 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 + where stdDev = (^/ fromIntegral slLn) . sumV $ projector' <$> msqs maxDev = sqrt . maximum $ magnitudeSq <$> msqs msqs = [ (y .-. ff x) | (x,y) <- normlsdIdd $ SplitList pts ] @@ -425,7 +440,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 (`metric'`1) [σp', σq'] trStRange _ = mempty trMBound l = Dia.fromVertices l & Dia.dashingO [2,2] 0 @@ -457,11 +472,11 @@ )) <> trSR (qd:ps) trSR _ = mempty calcNormDev ((p,v), DevBoxes σ _) = (p .+^ d, p .-^ d) - where d = metriScale σ $ turnLeft v + where d = metriScale' σ $ turnLeft v trStRange (Right pts) = (`foldMap`pts) $ \(p, DevBoxes dv _) - -> let δxm = metric dv $ 1^&0 - δym = metric dv $ 0^&1 + -> let δxm = metric' dv $ 1^&0 + δym = metric' dv $ 0^&1 in if δxm > δx && δym > δy then simpleLine (_x +~ δxm $ p) (_x -~ δxm $ p) <> simpleLine (_y +~ δym $ p) (_y -~ δym $ p) @@ -529,7 +544,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 + | metrics' dev δs > 0.5 || (sum $ ((^2).(pa<.>^)) <$> δs) > 3 , Left (Pair s1 s2) <- details = go s1 . go s2 | Right pts <- details = (Right (Arr.toList pts) :) @@ -549,7 +564,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 = metric' dev $ 1^&0; uy = metric' dev $ 0^&1 [xl,xr] = sort[p₀^._x, pe^._x]; [yb,yt] = sort[p₀^._y, pe^._y] @@ -716,7 +731,7 @@ -- -- And that can with the mouse wheel be zoomed/browsed, like -- --- <> +-- <> -- -- The individual objects you want to plot can be evaluated in multiple threads, so -- a single hard calculatation won't freeze the responsitivity of the whole window. @@ -1070,7 +1085,7 @@ -- functions. That wouldn't suffer from said problems, and should -- also generally be more efficient. (That category is not yet implemented in Haskell.) fnPlot :: (forall m . 𝓒⁰.Manifold m - => ProxyVal (:-->) m Double -> ProxyVal (:-->) m Double) + => AgentVal (:-->) m Double -> AgentVal (:-->) m Double) -> DynamicPlottable fnPlot f = plot fc where fc :: Double :--> Double @@ -1079,8 +1094,8 @@ -- | Plot a continuous, “parametric function”, i.e. mapping the real -- line to a path in ℝ². paramPlot :: (forall m . 𝓒⁰.Manifold m - => ProxyVal (:-->) m Double - -> (ProxyVal (:-->) m Double, ProxyVal (:-->) m Double)) + => AgentVal (:-->) m Double + -> (AgentVal (:-->) m Double, AgentVal (:-->) m Double)) -> DynamicPlottable paramPlot f = plot fc where fc :: Double :--> (Double, Double) @@ -1119,6 +1134,8 @@ +-- | 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 = const mempty @@ -1150,7 +1167,15 @@ & Dia.lcA (Dia.grey `DCol.withOpacity` strength) +noDynamicAxes :: DynamicPlottable +noDynamicAxes = DynamicPlottable { + relevantRange_x = const mempty + , relevantRange_y = const mempty + , isTintableMonochromic = False + , axesNecessity = superfluent + , dynamicPlot = const mempty } + type Necessity = Double superfluent = -1e+32 :: Necessity @@ -1265,6 +1290,66 @@ $ Dia.lc Dia.grey fullText + + +-- | 'ViewXCenter', 'ViewYResolution' etc. can be used as arguments to some object +-- you 'plot', if its rendering is to depend explicitly on the screen's visible range. +-- You should not need to do that manually except for special applications (the +-- standard plot objects like 'fnPlot' already take the range into account anyway) +-- – e.g. comparing with the linear regression /of all visible points/ +-- from some sample with some function's tangent /at the screen center/. +-- +-- @ +-- plotWindow [fnPlot sin, plot $ \\(ViewXCenter xc) x -> sin xc + (x-xc) * cos xc] +-- @ +-- +-- <> +newtype ViewXCenter = ViewXCenter { getViewXCenter :: Double } +instance (Plottable p) => Plottable (ViewXCenter -> p) where + plot f = DynamicPlottable { + relevantRange_x = const mempty + , relevantRange_y = \g -> (`relevantRange_y`g) . plot . f . cxI =<< g + , isTintableMonochromic = isTintableMonochromic fcxVoid + , axesNecessity = axesNecessity fcxVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ cx g) g } + where cx (GraphWindowSpec{..}) = ViewXCenter $ (lBound+rBound)/2 + cxI (Interval l r) = ViewXCenter $ (l+r)/2 + fcxVoid = plot . f $ ViewXCenter 0.23421 -- Yup, it's magic. +newtype ViewYCenter = ViewYCenter { getViewYCenter :: Double } +instance (Plottable p) => Plottable (ViewYCenter -> p) where + plot f = DynamicPlottable { + relevantRange_x = \g -> (`relevantRange_x`g) . plot . f . cyI =<< g + , relevantRange_y = const mempty + , isTintableMonochromic = isTintableMonochromic fcyVoid + , axesNecessity = axesNecessity fcyVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ cy g) g } + where cy (GraphWindowSpec{..}) = 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. +newtype ViewWidth = ViewWidth { getViewWidth :: Double } +instance (Plottable p) => Plottable (ViewWidth -> p) where + plot f = DynamicPlottable { + relevantRange_x = const mempty + , relevantRange_y = \g -> (`relevantRange_y`g) . plot . f . wI =<< g + , isTintableMonochromic = isTintableMonochromic fwVoid + , axesNecessity = axesNecessity fwVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ w g) g } + where w (GraphWindowSpec{..}) = ViewWidth $ rBound - lBound + wI (Interval l r) = ViewWidth $ r - l + fwVoid = plot . f $ ViewWidth 2.142349 +newtype ViewHeight = ViewHeight { getViewHeight :: Double } +instance (Plottable p) => Plottable (ViewHeight -> p) where + plot f = DynamicPlottable { + relevantRange_x = \g -> (`relevantRange_x`g) . plot . f . hI =<< g + , relevantRange_y = const mempty + , isTintableMonochromic = isTintableMonochromic fhVoid + , axesNecessity = axesNecessity fhVoid + , dynamicPlot = \g -> dynamicPlot (plot . f $ h g) g } + where h (GraphWindowSpec{..}) = ViewHeight $ tBound - bBound + hI (Interval b t) = ViewHeight $ t - b + fhVoid = plot . f $ ViewHeight 1.494213 +newtype ViewXResolution = ViewXResolution { getViewXResolution :: Int } +newtype ViewYResolution = ViewYResolution { getViewYResolution :: Int } 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.0.0 +Version: 0.1.0.1 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions @@ -29,6 +29,7 @@ Build-Type: Simple Cabal-Version: >=1.10 Extra-Doc-Files: images/examples/*.png + , images/examples/*.gif Source-Repository head type: git @@ -49,7 +50,7 @@ , async , deepseq , process - , constrained-categories + , constrained-categories >= 0.2 , diagrams-core == 1.2.0.2 , diagrams-lib >= 1 && < 1.4 , diagrams-cairo == 1.2.0.2 @@ -57,7 +58,7 @@ , gtk > 0.10 && < 0.15 , glib , colour >= 2 && < 3 - , manifolds < 0.1.1 + , manifolds >= 0.1.0.1 && < 0.2 , lens Other-Extensions: FlexibleInstances , TypeFamilies @@ -73,4 +74,3 @@ default-language: Haskell2010 Exposed-modules: Graphics.Dynamic.Plot.R2 Other-modules: Graphics.Dynamic.Plot.Colour - , Data.LinearMap.HerMetric diff --git a/images/examples/cos-encircle-points.gif b/images/examples/cos-encircle-points.gif new file mode 100644 # file too large to diff: images/examples/cos-encircle-points.gif diff --git a/images/examples/sin-ctrd-tangents.gif b/images/examples/sin-ctrd-tangents.gif new file mode 100644 Binary files /dev/null and b/images/examples/sin-ctrd-tangents.gif differ