dynamic-plot 0.1.0.1 → 0.1.1.0
raw patch · 5 files changed
+941/−559 lines, 5 filesdep +taggeddep ~constrained-categoriesdep ~diagrams-cairodep ~diagrams-core
Dependencies added: tagged
Dependency ranges changed: constrained-categories, diagrams-cairo, diagrams-core, diagrams-lib, lens, manifolds
Files
- Graphics/Dynamic/Plot/Colour.hs +4/−18
- Graphics/Dynamic/Plot/Internal/Types.hs +506/−0
- Graphics/Dynamic/Plot/R2.hs +247/−535
- Graphics/Text/Annotation.hs +175/−0
- dynamic-plot.cabal +9/−6
Graphics/Dynamic/Plot/Colour.hs view
@@ -7,7 +7,9 @@ -- Stability : experimental -- Portability : requires GHC>6 extensions -module Graphics.Dynamic.Plot.Colour where+module Graphics.Dynamic.Plot.Colour ( module Graphics.Dynamic.Plot.Colour+ , Colour, AColour, FColour, ColourScheme+ ) where import qualified Data.Colour as DCol@@ -16,25 +18,10 @@ import Data.Colour.CIE hiding (Colour) import qualified Data.Colour.CIE.Illuminant as Illum +import Graphics.Dynamic.Plot.Internal.Types -type FColour = DCol.Colour Double-type AColour = DCol.AlphaColour Double --- | Unlike the typical types such as 'Draw.Color', this one has /semantic/ --- more than physical meaning.-data Colour = BaseColour BaseColour- | Contrast BaseColour- | Paler Colour- | CustomColour FColour- deriving (Eq)-data BaseColour = Neutral -- ^ Either black or white, depending on the context.- | Red -- ^ Contrast cyan.- | Yellow -- ^ Contrast violet.- | Green -- ^ Contrast magenta.- | Blue -- ^ Contrast orange.- deriving (Eq, Show, Enum) - neutral, contrast, grey , magenta, red, orange, yellow, green, cyan, blue, violet :: Colour neutral = BaseColour Neutral@@ -56,7 +43,6 @@ opposite (Paler c) = Paler $ opposite c opposite (CustomColour c) = CustomColour $ hueInvert c -type ColourScheme = Colour -> AColour defaultColourScheme :: ColourScheme defaultColourScheme (BaseColour Neutral) = opaque N.black
+ Graphics/Dynamic/Plot/Internal/Types.hs view
@@ -0,0 +1,506 @@+-- |+-- Module : Graphics.Dynamic.Plot.Internal.Types+-- Copyright : (c) Justus Sagemüller 2015+-- License : GPL v3+-- +-- Maintainer : (@) sagemueller $ geo.uni-koeln.de+-- Stability : experimental+-- Portability : requires GHC>6 extensions+++{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}++module Graphics.Dynamic.Plot.Internal.Types where+++import qualified Prelude++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+import Diagrams.BoundingBox (BoundingBox)+import qualified Diagrams.BoundingBox as DiaBB+import qualified Diagrams.Backend.Cairo as Cairo+import qualified Diagrams.Backend.Cairo.Text as CairoTxt+ +import qualified Data.Colour as DCol++import qualified Control.Category.Hask as Hask+import Control.Category.Constrained.Prelude hiding ((^))+import Control.Arrow.Constrained+import Control.Monad.Constrained++import Control.Lens hiding ((...), (<.>))++import qualified Data.Vector as Arr+import Data.List (sort)++import Data.VectorSpace+import Data.Basis+import Data.AffineSpace+import Data.LinearMap.HerMetric+import Data.Manifold.PseudoAffine+import Data.Manifold.TreeCover+import Data.Semigroup+import Data.Tagged++import Control.DeepSeq++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+ 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 AffineSpace P2 where+ type Diff P2 = R2+ (.-.) = (Dia..-.)+ (.+^) = (Dia..+^)+instance Semimanifold P2 where+ type Needle P2 = R2+ fromInterior = id+ toInterior = pure+ translateP = Tagged (.+^)+ (.+~^) = (.+^)+instance PseudoAffine P2 where+ p.-~.q = pure(p.-.q)++++(^) :: Num n => n -> Int -> n+(^) = (Prelude.^)+++type R = Double++-- | Use 'Graphics.Dynamic.Plot.R2.plot' to directly include any 'Dia.Diagram'.+-- (All 'Graphics.Dynamic.Plot.R2.DynamicPlottable'+-- is internally rendered to that type.)+-- +-- The exact type may change in the future: we'll probably stay with @diagrams@,+-- but when document output is introduced the backend might become variable +-- or something else but 'Cairo.Cairo'.+type PlainGraphicsR2 = Dia.Diagram Cairo.B++++++ ++data Pair p = Pair !p !p+ deriving (Hask.Functor, Show, Eq, Ord)+data Triple p = Triple !p !p !p+ deriving (Hask.Functor, Show, Eq, Ord)++data DiffList a = DiffList { getDiffList :: [a]->[a], diffListLen :: Int }+diffList :: Arr.Vector a -> DiffList a+diffList l = DiffList (Arr.toList l++) (Arr.length l)++instance Semigroup (DiffList a) where+ DiffList dl n <> DiffList dl' n' = DiffList (dl . dl') (n+n')+instance Monoid (DiffList a) where+ mappend = (<>); mempty = DiffList id 0+++newtype SplitList a = SplitList { getSplList :: Arr.Vector a }+ deriving (Hask.Functor, Monoid)+presplitList :: [a] -> SplitList a+presplitList = SplitList . Arr.fromList++splitEvenly :: Int -> SplitList a -> Either (Arr.Vector a) [SplitList a]+splitEvenly k _ | k < 1 = error "Can't split a list to less than one part."+splitEvenly k (SplitList v)+ | k >= n = Left v+ | otherwise = Right $ splits splitIs 0+ where splitIs = take k . map round . tail+ $ iterate (+ (fromIntegral n/fromIntegral k :: Double)) 0+ splits [_] i₀ = [SplitList $ Arr.drop i₀ v]+ splits (i:is) i₀ = SplitList (Arr.slice i₀ (i-i₀) v) : splits is i+ n = Arr.length v++instance Semigroup (SplitList a) where+ SplitList l <> SplitList l' = SplitList (l Arr.++ l')++fromDiffList :: DiffList a -> SplitList a+fromDiffList (DiffList f _) = SplitList . Arr.fromList $ f[]+++++data LinFitParams y = LinFitParams { constCoeff :: y+ , linCoeff :: Diff y }+deriving instance (AffineSpace y, Show y, Show (Diff y)) => Show (LinFitParams y)+++linFitMeanInCtrdUnitIntv ::+ (AffineSpace y, v~Diff y, VectorSpace v, Fractional (Scalar v))+ => LinFitParams y -> y+linFitMeanInCtrdUnitIntv (LinFitParams{..}) = constCoeff++++data DevBoxes y = DevBoxes { deviations :: HerMetric' (Diff y)+ , maxDeviation :: Scalar (Diff y) }+ +++++data PCMRange x = PCMRange { pcmStart, pcmSampleDuration :: x } deriving (Show)+ +data RecursiveSamples' n x y t+ = RecursivePCM { rPCMlinFit :: LinFitParams y+ , details :: Either (Pair (RecursiveSamples' n x y t))+ (Arr.Vector (y,t))+ , pFitDeviations :: DevBoxes y+ , samplingSpec :: PCMRange x+ , splIdLen :: Int+ , rPCMNodeInfo :: n+ }+instance Hask.Functor (RecursiveSamples' n x y) where+ fmap f (RecursivePCM l d v s n i) = RecursivePCM l d' v s n i+ where d' = case d of Left rs' -> Left (fmap (fmap f) rs')+ Right ps -> Right $ fmap (second f) ps++fmapRPCMNodeInfo :: (n->n') -> RecursivePCM n x y -> RecursivePCM n' x y+fmapRPCMNodeInfo f (RecursivePCM l d v s n i) = RecursivePCM l d' v s n $ f i+ where d' = case d of Left rs' -> Left (fmap (fmapRPCMNodeInfo f) rs')+ Right ps -> Right ps++type RecursiveSamples = RecursiveSamples' ()+type RecursivePCM n x y = RecursiveSamples' n x y ()+type (x-.^>y) = RecursivePCM () x y++recursiveSamples' :: forall x y v t .+ ( VectorSpace x, Real (Scalar x)+ , AffineSpace y, v~Diff y, InnerSpace v, HasMetric 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+ go xrng@(PCMRange xl wsp) l@(SplitList arr) = case splitEvenly 2 l of+ Right sps+ | [sp1, sp2] <- lIndThru xl sps+ -> let pFit = solveToLinFit+ $ (linFitMeanInCtrdUnitIntv.rPCMlinFit) <$> [sp1,sp2]+ in RecursivePCM pFit+ (Left $ Pair sp1 sp2)+ (undefined)+ xrng (Arr.length arr)+ (fmap fst arr)+ Right _ -> evenSplitErr+ Left pSpls -> RecursivePCM (solveToLinFit $ Arr.toList (fmap fst pSpls))+ (Right $ pSpls)+ (undefined)+ xrng (Arr.length arr)+ (fmap fst arr)+ where lIndThru _ [] = []+ lIndThru x₀₁ (sp₁@(SplitList arr₁):sps)+ = let x₀₂ = x₀₁ ^+^ fromIntegral (Arr.length arr₁) *^ wsp+ in go (PCMRange x₀₁ wsp) sp₁ : lIndThru x₀₂ sps + evenSplitErr = error "'splitEvenly' returned wrong number of slices."+ + calcDeviations :: RecursiveSamples' (Arr.Vector y) x y t+ -> RecursiveSamples x y t+ calcDeviations = cdvs Nothing Nothing+ 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+ msqs = [ (y .-. ff x)+ | (x,y) <- normlsdIdd $ SplitList pts ]+ ff = l₀splineRep (Pair lPFits rPFits) rPCM+ dtls' = case dtls of+ Left (Pair r₁ r₂)+ -> let r₁' = cdvs (rRoute=<<lPFits) (Just r₂) r₁+ r₂' = cdvs (Just r₁) (lRoute=<<rPFits) r₂+ in Left $ Pair r₁' r₂'+ Right pSpls -> Right pSpls+ (LinFitParams b a) = pFit+lRoute, rRoute :: RecursiveSamples' n x y t -> Maybe (RecursiveSamples' n x y t)+lRoute (RecursivePCM {details = Right _}) = Nothing+lRoute (RecursivePCM {details = Left (Pair l _)}) = Just l+rRoute (RecursivePCM {details = Right _}) = Nothing+rRoute (RecursivePCM {details = Left (Pair _ r)}) = Just r+ ++recursiveSamples :: + ( AffineSpace y, v~Diff y, InnerSpace v, HasMetric 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) )+ => PCMRange x -> [y] -> x-.^>y+recursivePCM xrng_g = recursiveSamples' xrng_g . fmap (,())+++splineRep :: ( AffineSpace y, v~Diff y, InnerSpace v, Floating (Scalar v), Ord (Scalar v) )+ => Int -- ^ Number of subdivisions to \"go down\".+ -> (R-.^>y) -> R -> y+splineRep n₀ rPCM@(RecursivePCM _ _ _ (PCMRange xl wsp) slLn ())+ = go n₀ Nothing Nothing rPCM . normaliseR+ where go n lPFits rPFits (RecursivePCM _ (Left (Pair r₁ r₂)) _ _ slLn ())+ | n>0, f₁ <- go (n-1) (rRoute=<<lPFits) (Just r₂) r₁+ , f₂ <- go (n-1) (Just r₁) (lRoute=<<rPFits) r₂+ = \x -> if x<0.5 then f₁ $ x*2+ else f₂ $ x*2 - 1+ go _ lPFits rPFits rPCM = l₀splineRep (Pair lPFits rPFits) rPCM+ + normaliseR x = (x - xl)/(wsp * fromIntegral slLn)++l₀splineRep ::+ ( VectorSpace x, Num (Scalar x)+ , AffineSpace y, v~Diff y, VectorSpace v, Floating (Scalar v), Ord (Scalar v) )+ => Pair (Maybe (RecursiveSamples' n x y t'))+ -> (RecursiveSamples' n x y t)+ -> R{-Sample position normalised to [0,1]-} -> y+l₀splineRep (Pair lPFits rPFits)+ (RecursivePCM{ rPCMlinFit=LinFitParams b a+ , samplingSpec=PCMRange x₀ wsp+ , splIdLen = n })+ = f+ where f x | x < 0.5, t <- realToFrac $ 0.5 - x+ , Just(RecursivePCM{rPCMlinFit=LinFitParams b'l a'l}) <- lPFits+ = b .+^ (b'l.-.b) ^* h₀₁ t+ .-^ a ^* h₁₀ t+ .-^ a'l ^* h₁₁ t+ | x > 0.5, t <- realToFrac $ x - 0.5+ , Just(RecursivePCM{rPCMlinFit=LinFitParams b'r a'r}) <- rPFits+ = b .+^ (b'r.-.b) ^* h₀₁ t+ .+^ a ^* h₁₀ t+ .+^ a'r ^* h₁₁ t+ | t <- realToFrac $ x-0.5+ = b .+^ t*^a+ h₀₀ t = (1 + 2*t) * (1 - t)^2 -- Cubic Hermite splines+ h₀₁ t = t^2 * (3 - 2*t)+ h₁₀ t = t * (1 - t)^2+ h₁₁ t = t^2 * (t - 1)++++rPCMSample :: (AffineSpace y, v~Diff y, InnerSpace v, HasMetric 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]] + ++type R2Box = Dia.BoundingBox Dia.V2 Double++rPCM_R2_boundingBox :: (RecursiveSamples x P2 t) -> R2Box+rPCM_R2_boundingBox rPCM@(RecursivePCM pFit _ (DevBoxes dev _) _ _ ())+ = Interval (xl - ux*2) (xr + ux*2)+ -*| 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+ [xl,xr] = sort[p₀^._x, pe^._x]; [yb,yt] = sort[p₀^._y, pe^._y]++++++rPCMLinFitRange :: (R-.^>R) -> Interval R -> Interval R+rPCMLinFitRange rPCM@(RecursivePCM _ _ (DevBoxes _ δ) _ _ ()) ix+ = let (Interval b t) = rppm rPCM ix in Interval (b-δ) (t+δ)+ where rppm rPCM@(RecursivePCM (LinFitParams b a) _ _ _ _ ()) (Interval l r)+ | r < (-1) = spInterval $ b - a+ | l > 1 = spInterval $ b + a+ | l < (-1) = rppm rPCM $ Interval (-1) r+ | r > 1 = rppm rPCM $ Interval l 1+ | otherwise = (b + l*a) ... (b + r*a)+++solveToLinFit :: (AffineSpace y, v~Diff y, VectorSpace v, Floating (Scalar v))+ => [y] -> LinFitParams y+solveToLinFit [] = error+ "LinFit solve under-specified (need at least one reference point)."+solveToLinFit [y] = LinFitParams { constCoeff=y, linCoeff=zeroV }+solveToLinFit [y₁,y₂] -- @[x₁, x₂] ≡ [-½, ½]@, and @f(½) = (y₁+y₂)/2 + ½·(y₂-y₁) = y₂@.+ -- (Likewise for @f(-½) = y₁@).+ = LinFitParams { constCoeff = alerp y₁ y₂ 0.5+ , linCoeff = y₂ .-. y₁ }+solveToLinFit _ = error "LinFit solve over-specified (can't solve more than two points)."+++normlsdIdd :: Fractional x => SplitList y -> [(x, y)]+normlsdIdd (SplitList l) = zip [ (k+1/2)/fromIntegral (Arr.length l)+ | k<-iterate(+1)0] $ Arr.toList l+++type FColour = DCol.Colour Double+type AColour = DCol.AlphaColour Double++-- | Unlike the typical types such as 'Draw.Color', this one has /semantic/ +-- more than physical meaning.+data Colour = BaseColour BaseColour+ | Contrast BaseColour+ | Paler Colour+ | CustomColour FColour+ deriving (Eq)+data BaseColour = Neutral -- ^ Either black or white, depending on the context.+ | Red -- ^ Contrast cyan.+ | Yellow -- ^ Contrast violet.+ | Green -- ^ Contrast magenta.+ | Blue -- ^ Contrast orange.+ deriving (Eq, Show, Enum)++type ColourScheme = Colour -> AColour++data GraphWindowSpecR2 = GraphWindowSpecR2 {+ lBound, rBound, bBound, tBound :: R+ , xResolution, yResolution :: Int+ , colourScheme :: ColourScheme+ }+instance Show GraphWindowSpecR2 where+ show (GraphWindowSpecR2{..}) = "GraphWindowSpecR2{\+ \lBound="++show lBound++", \+ \rBound="++show rBound++", \+ \bBound="++show bBound++", \+ \tBound="++show tBound++", \+ \xResolution="++show xResolution++", \+ \yResolution="++show yResolution++"}"+++++data Interval r = Interval !r !r deriving (Show)+instance (Ord r) => Semigroup (Interval r) where -- WRT closed hull of the union.+ Interval l₁ u₁ <> Interval l₂ u₂ = Interval (min l₁ l₂) (max u₁ u₂)++realInterval :: Real r => Interval r -> Interval R+realInterval (Interval a b) = Interval (realToFrac a) (realToFrac b)++onInterval :: ((R,R) -> (R,R)) -> Interval R -> Interval R+onInterval f (Interval l r) = uncurry Interval $ f (l, r)++infixl 6 ...+-- | Build an interval from specified boundary points. No matter which of these+-- points is higher, the result will always be the interval in between (i.e.,+-- @3 '...' 1@ will yield the interval [1,3], not an empty set or some \"oriented+-- interval\" [3,1]).+-- The fixity @infixl 6@ was chosen so you can write 2D bounding-boxes as e.g.+-- @-1...4 -*| -1...1@.+(...) :: (Ord r) => r -> r -> Interval r+x1...x2 | x1 < x2 = Interval x1 x2+ | otherwise = Interval x2 x1++infixl ±+(±) :: Real v => v -> v -> Interval v+c ± δ | δ>0 = Interval (c-δ) (c+δ)+ | otherwise = Interval (c+δ) (c-δ)++spInterval :: r -> Interval r+spInterval x = Interval x x++intersects :: Ord r => Interval r -> Interval r -> Bool+intersects (Interval a b) (Interval c d) = a<=d && b>=c++includes :: Ord r => Interval r -> r -> Bool+Interval a b `includes` x = x>=a && x<=b++infix 5 -*|++-- | Cartesian product of intervals.+(-*|) :: Interval R -> Interval R -> R2Box+Interval l r -*| Interval b t = DiaBB.fromCorners (l^&b) (r^&t)++-- | Inverse of @uncurry ('-*|')@. /This is a partial function/, since+-- 'BoundingBox'es can be empty.+xyRanges :: R2Box -> (Interval R, Interval R)+xyRanges bb = let Just (c₁, c₂) = DiaBB.getCorners bb+ in (c₁^._x ... c₂^._x, c₁^._y ... c₂^._y)++++shadeExtends :: Shade P2 -> (Interval R, Interval R)+shadeExtends shade+ = ( (ctr^._x) ± sqrt (metric' expa $ 1^&0)+ , (ctr^._y) ± sqrt (metric' expa $ 0^&1) )+ where ctr = shade^.shadeCtr; expa = shade^.shadeExpanse++++++++type Necessity = Double+superfluent = -1e+32 :: Necessity+++++++infixl 7 `provided`+provided :: Monoid m => m -> Bool -> m+provided m True = m+provided m False = mempty+++ceil, flor :: R -> R+ceil = fromInt . ceiling+flor = fromInt . floor++fromInt :: Num a => Int -> a+fromInt = fromIntegral++++
Graphics/Dynamic/Plot/R2.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Graphics.Dynamic.Plot.R2--- Copyright : (c) Justus Sagemüller 2013-2014+-- Copyright : (c) Justus Sagemüller 2013-2015 -- License : GPL v3 -- -- Maintainer : (@) sagemueller $ geo.uni-koeln.de@@ -16,7 +16,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -35,8 +37,12 @@ , fnPlot, paramPlot , continFnPlot , tracePlot+ , lineSegPlot+ , PlainGraphicsR2+ , shapePlot+ , diagramPlot -- ** View selection- , xInterval, yInterval+ , xInterval, yInterval, forceXRange, forceYRange -- ** View dependance , ViewXCenter(..), ViewYCenter(..), ViewWidth(..), ViewHeight(..) , ViewXResolution(..), ViewYResolution(..)@@ -44,20 +50,19 @@ , dynamicAxes, noDynamicAxes -- ** Plot type , DynamicPlottable+ -- ** Legacy+ , PlainGraphics(..) ) where import Graphics.Dynamic.Plot.Colour+import Graphics.Dynamic.Plot.Internal.Types+import Graphics.Text.Annotation import qualified Prelude --- import Graphics.DrawingCombinators ((%%), R, R2)--- import qualified Graphics.DrawingCombinators as Draw--- import qualified Graphics.UI.GLFW as GLFW--- import qualified Graphics.Rendering.OpenGL as OpenGL--- import Graphics.Rendering.OpenGL (($=))-import Diagrams.Prelude (R2, P2, (^&), (&), _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@@ -96,10 +101,15 @@ import Data.Function (on) 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 +import Data.Tagged+ import Data.Manifold ((:-->)) import qualified Data.Manifold as 𝓒⁰ @@ -115,23 +125,16 @@ -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.^)---type R = Double--type Diagram = Dia.Diagram Cairo.B R2+newtype PlainGraphics = PlainGraphics { getPlainGraphics :: PlainGraphicsR2 }+ deriving (Semigroup, Monoid) +-- | Class for types that can be plotted in some canonical, “obvious”+-- way. If you want to display something and don't know about any specific caveats,+-- try just using 'plot'! class Plottable p where plot :: p -> DynamicPlottable @@ -145,8 +148,8 @@ instance Plottable (Double :--> Double) where plot f = DynamicPlottable{- relevantRange_x = const mempty- , relevantRange_y = fmap yRangef+ relevantRange_x = mempty+ , relevantRange_y = otherDimDependence yRangef , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot }@@ -156,8 +159,8 @@ where (fgb, fgt) = (minimum &&& maximum) [f $ l, f $ m, f $ r] m = l + (r-l) * 0.352479608143 - plot (GraphWindowSpec{..}) = curve `deepseq` Plot [] (trace curve)- where curve :: [Dia.P2]+ plot (GraphWindowSpecR2{..}) = curve `deepseq` mkPlot (trace curve)+ where curve :: [P2] curve = map convℝ² $ 𝓒⁰.finiteGraphContinℝtoℝ mWindow f mWindow = 𝓒⁰.GraphWindowSpec (c lBound) (c rBound) (c bBound) (c tBound) xResolution yResolution@@ -169,13 +172,13 @@ instance Plottable (Double :--> (Double, Double)) where plot f = DynamicPlottable{- relevantRange_x = const mempty- , relevantRange_y = const mempty+ relevantRange_x = mempty+ , relevantRange_y = mempty , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot }- where plot (GraphWindowSpec{..}) = curves `deepseq` Plot [] (foldMap trace curves)- where curves :: [[Dia.P2]]+ where plot (GraphWindowSpecR2{..}) = curves `deepseq` mkPlot (foldMap trace curves)+ where curves :: [[P2]] curves = map (map convℝ²) $ 𝓒⁰.finiteGraphContinℝtoℝ² mWindow f mWindow = 𝓒⁰.GraphWindowSpec (c lBound) (c rBound) (c bBound) (c tBound) xResolution yResolution@@ -188,18 +191,18 @@ instance (Plottable p) => Plottable [p] where plot l0 = DynamicPlottable{- relevantRange_x = \ry -> foldMap (($ry) . relevantRange_x) l- , relevantRange_y = \rx -> foldMap (($rx) . relevantRange_y) l+ 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 -instance Plottable Diagram where- plot d = DynamicPlottable{- relevantRange_x = const $ Option rlx- , relevantRange_y = const $ Option rly+instance Plottable PlainGraphics where+ plot (PlainGraphics d) = DynamicPlottable{+ relevantRange_x = atLeastInterval rlx+ , relevantRange_y = atLeastInterval rly , isTintableMonochromic = False , axesNecessity = -1 , dynamicPlot = plot@@ -207,223 +210,39 @@ where bb = DiaBB.boundingBox d (rlx,rly) = case DiaBB.getCorners bb of Just (c1, c2)- -> ( Just $ c1^._x ... c2^._x- , Just $ c1^._y ... c2^._y )- plot _ = Plot [] d---- --data Pair p = Pair !p !p- deriving (Hask.Functor, Show, Eq, Ord)-data Triple p = Triple !p !p !p- deriving (Hask.Functor, Show, Eq, Ord)--data DiffList a = DiffList { getDiffList :: [a]->[a], diffListLen :: Int }-diffList :: Arr.Vector a -> DiffList a-diffList l = DiffList (Arr.toList l++) (Arr.length l)--instance Semigroup (DiffList a) where- DiffList dl n <> DiffList dl' n' = DiffList (dl . dl') (n+n')-instance Monoid (DiffList a) where- mappend = (<>); mempty = DiffList id 0---newtype SplitList a = SplitList { getSplList :: Arr.Vector a }- deriving (Hask.Functor, Monoid)-presplitList :: [a] -> SplitList a-presplitList = SplitList . Arr.fromList--splitEvenly :: Int -> SplitList a -> Either (Arr.Vector a) [SplitList a]-splitEvenly k _ | k < 1 = error "Can't split a list to less than one part."-splitEvenly k (SplitList v)- | k >= n = Left v- | otherwise = Right $ splits splitIs 0- where splitIs = take k . map round . tail- $ iterate (+ (fromIntegral n/fromIntegral k :: Double)) 0- splits [_] i₀ = [SplitList $ Arr.drop i₀ v]- splits (i:is) i₀ = SplitList (Arr.slice i₀ (i-i₀) v) : splits is i- n = Arr.length v--instance Semigroup (SplitList a) where- SplitList l <> SplitList l' = SplitList (l Arr.++ l')--fromDiffList :: DiffList a -> SplitList a-fromDiffList (DiffList f _) = SplitList . Arr.fromList $ f[]-----data LinFitParams y = LinFitParams { constCoeff :: y- , linCoeff :: Diff y }-deriving instance (AffineSpace y, Show y, Show (Diff y)) => Show (LinFitParams y)---linFitMeanInCtrdUnitIntv ::- (AffineSpace y, v~Diff y, VectorSpace v, Fractional (Scalar v))- => LinFitParams y -> y-linFitMeanInCtrdUnitIntv (LinFitParams{..}) = constCoeff----data DevBoxes y = DevBoxes { deviations :: HerMetric' (Diff y)- , maxDeviation :: Scalar (Diff y) }- --+ -> ( c1^._x ... c2^._x+ , c1^._y ... c2^._y )+ plot _ = mkPlot d -data PCMRange x = PCMRange { pcmStart, pcmSampleDuration :: x } deriving (Show)- -data RecursiveSamples' n x y t- = RecursivePCM { rPCMlinFit :: LinFitParams y- , details :: Either (Pair (RecursiveSamples' n x y t))- (Arr.Vector (y,t))- , pFitDeviations :: DevBoxes y- , samplingSpec :: PCMRange x- , splIdLen :: Int- , rPCMNodeInfo :: n- }-instance Hask.Functor (RecursiveSamples' n x y) where- fmap f (RecursivePCM l d v s n i) = RecursivePCM l d' v s n i- where d' = case d of Left rs' -> Left (fmap (fmap f) rs')- Right ps -> Right $ fmap (second f) ps--fmapRPCMNodeInfo :: (n->n') -> RecursivePCM n x y -> RecursivePCM n' x y-fmapRPCMNodeInfo f (RecursivePCM l d v s n i) = RecursivePCM l d' v s n $ f i- where d' = case d of Left rs' -> Left (fmap (fmapRPCMNodeInfo f) rs')- Right ps -> Right ps--type RecursiveSamples = RecursiveSamples' ()-type RecursivePCM n x y = RecursiveSamples' n x y ()-type (x-.^>y) = RecursivePCM () x y--recursiveSamples' :: forall x y v t .- ( VectorSpace x, Real (Scalar x)- , AffineSpace y, v~Diff y, InnerSpace v, HasMetric 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- go xrng@(PCMRange xl wsp) l@(SplitList arr) = case splitEvenly 2 l of- Right sps- | [sp1, sp2] <- lIndThru xl sps- -> let pFit = solveToLinFit- $ (linFitMeanInCtrdUnitIntv.rPCMlinFit) <$> [sp1,sp2]- in RecursivePCM pFit- (Left $ Pair sp1 sp2)- (undefined)- xrng (Arr.length arr)- (fmap fst arr)- Right _ -> evenSplitErr- Left pSpls -> RecursivePCM (solveToLinFit $ Arr.toList (fmap fst pSpls))- (Right $ pSpls)- (undefined)- xrng (Arr.length arr)- (fmap fst arr)- where lIndThru _ [] = []- lIndThru x₀₁ (sp₁@(SplitList arr₁):sps)- = let x₀₂ = x₀₁ ^+^ fromIntegral (Arr.length arr₁) *^ wsp- in go (PCMRange x₀₁ wsp) sp₁ : lIndThru x₀₂ sps - evenSplitErr = error "'splitEvenly' returned wrong number of slices."- - calcDeviations :: RecursiveSamples' (Arr.Vector y) x y t- -> RecursiveSamples x y t- calcDeviations = cdvs Nothing Nothing- 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- msqs = [ (y .-. ff x)- | (x,y) <- normlsdIdd $ SplitList pts ]- ff = l₀splineRep (Pair lPFits rPFits) rPCM- dtls' = case dtls of- Left (Pair r₁ r₂)- -> let r₁' = cdvs (rRoute=<<lPFits) (Just r₂) r₁- r₂' = cdvs (Just r₁) (lRoute=<<rPFits) r₂- in Left $ Pair r₁' r₂'- Right pSpls -> Right pSpls- (LinFitParams b a) = pFit-lRoute, rRoute :: RecursiveSamples' n x y t -> Maybe (RecursiveSamples' n x y t)-lRoute (RecursivePCM {details = Right _}) = Nothing-lRoute (RecursivePCM {details = Left (Pair l _)}) = Just l-rRoute (RecursivePCM {details = Right _}) = Nothing-rRoute (RecursivePCM {details = Left (Pair _ r)}) = Just r- --recursiveSamples :: - ( AffineSpace y, v~Diff y, InnerSpace v, HasMetric v, RealFloat (Scalar v) )- => [(y,t)] -> RecursiveSamples Int y t-recursiveSamples = recursiveSamples' (PCMRange 0 1)+-- | Use a generic diagram within a plot.+-- +-- Like with the various specialised function plotters, this will get automatically+-- 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 } -recursivePCM :: ( VectorSpace x, Real (Scalar x)- , AffineSpace y, v~Diff y, InnerSpace v, HasMetric v, RealFloat (Scalar v) )- => PCMRange x -> [y] -> x-.^>y-recursivePCM xrng_g = recursiveSamples' xrng_g . fmap (,())+-- | Plot a generic 'Dia.Diagram'.+diagramPlot :: PlainGraphicsR2 -> DynamicPlottable+diagramPlot d = plot $ PlainGraphics d -splineRep :: ( AffineSpace y, v~Diff y, InnerSpace v, Floating (Scalar v), Ord (Scalar v) )- => Int -- ^ Number of subdivisions to \"go down\".- -> (R-.^>y) -> R -> y-splineRep n₀ rPCM@(RecursivePCM _ _ _ (PCMRange xl wsp) slLn ())- = go n₀ Nothing Nothing rPCM . normaliseR- where go n lPFits rPFits (RecursivePCM _ (Left (Pair r₁ r₂)) _ _ slLn ())- | n>0, f₁ <- go (n-1) (rRoute=<<lPFits) (Just r₂) r₁- , f₂ <- go (n-1) (Just r₁) (lRoute=<<rPFits) r₂- = \x -> if x<0.5 then f₁ $ x*2- else f₂ $ x*2 - 1- go _ lPFits rPFits rPCM = l₀splineRep (Pair lPFits rPFits) rPCM- - normaliseR x = (x - xl)/(wsp * fromIntegral slLn)--l₀splineRep ::- ( VectorSpace x, Num (Scalar x)- , AffineSpace y, v~Diff y, VectorSpace v, Floating (Scalar v), Ord (Scalar v) )- => Pair (Maybe (RecursiveSamples' n x y t'))- -> (RecursiveSamples' n x y t)- -> R{-Sample position normalised to [0,1]-} -> y-l₀splineRep (Pair lPFits rPFits)- (RecursivePCM{ rPCMlinFit=LinFitParams b a- , samplingSpec=PCMRange x₀ wsp- , splIdLen = n })- = f- where f x | x < 0.5, t <- realToFrac $ 0.5 - x- , Just(RecursivePCM{rPCMlinFit=LinFitParams b'l a'l}) <- lPFits- = b .+^ (b'l.-.b) ^* h₀₁ t- .-^ a ^* h₁₀ t- .-^ a'l ^* h₁₁ t- | x > 0.5, t <- realToFrac $ x - 0.5- , Just(RecursivePCM{rPCMlinFit=LinFitParams b'r a'r}) <- rPFits- = b .+^ (b'r.-.b) ^* h₀₁ t- .+^ a ^* h₁₀ t- .+^ a'r ^* h₁₁ t- | t <- realToFrac $ x-0.5- = b .+^ t*^a- h₀₀ t = (1 + 2*t) * (1 - t)^2 -- Cubic Hermite splines- h₀₁ t = t^2 * (3 - 2*t)- h₁₀ t = t * (1 - t)^2- h₁₁ t = t^2 * (t - 1)-+ -rPCMSample :: (AffineSpace y, v~Diff y, InnerSpace v, HasMetric 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]] - - instance Plottable (R-.^>R) where plot rPCM@(RecursivePCM gPFit gDetails gFitDevs (PCMRange x₀ wsp) gSplN ()) = DynamicPlottable{- relevantRange_x = const . pure $ Interval x₀ xr- , relevantRange_y = fmap $ rPCMLinFitRange rPCM+ relevantRange_x = atLeastInterval $ Interval x₀ xr+ , relevantRange_y = otherDimDependence $ rPCMLinFitRange rPCM , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot } where xr = wsp * fromIntegral gSplN- plot (GraphWindowSpec{..}) = Plot [] . trace $ flattenPCM_resoCut bb δx rPCM+ plot (GraphWindowSpecR2{..}) = mkPlot . trace $ flattenPCM_resoCut bb δx rPCM where trace dPath = fold [ trMBound [ p & _y +~ s*δ | (p, DevBoxes _ δ) <- dPath ]@@ -455,13 +274,13 @@ instance Plottable (RecursiveSamples Int P2 (DevBoxes P2)) where plot rPCM@(RecursivePCM gPFit gDetails gFitDevs (PCMRange t₀ τsp) gSplN ()) = DynamicPlottable{- relevantRange_x = const $ pure xRange- , relevantRange_y = const $ pure yRange+ relevantRange_x = atLeastInterval xRange+ , relevantRange_y = atLeastInterval yRange , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot }- where plot (GraphWindowSpec{..}) = Plot []+ where plot (GraphWindowSpecR2{..}) = mkPlot . foldMap trStRange $ flattenPCM_P2_resoCut bbView [(1/δxl)^&0, 0^&(1/δyl)] rPCM where trStRange (Left appr) = trSR $ map calcNormDev appr@@ -510,9 +329,25 @@ -- isn't efficient enough and will get slow for more than some 100000 data points. tracePlot :: [(Double, Double)] -> DynamicPlottable tracePlot = plot . recursiveSamples . map ((,()) . Dia.p2)++-- | Simply connect the points by straight line segments, in the given order.+-- 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{+ relevantRange_x = atLeastInterval' $ foldMap (pure . spInterval . fst) ps+ , relevantRange_y = atLeastInterval' $ foldMap (pure . spInterval . snd) ps+ , isTintableMonochromic = True+ , axesNecessity = 1+ , dynamicPlot = plot }+ where plot (GraphWindowSpecR2{..}) = mkPlot (trace ps)+ where trace (p:q:ps) = simpleLine (Dia.p2 p) (Dia.p2 q) <> trace (q:ps)+ trace _ = mempty++ -flattenPCM_resoCut :: BoundingBox R2 -> R -> (R-.^>R) -> [(P2, DevBoxes R)]+flattenPCM_resoCut :: R2Box -> R -> (R-.^>R) -> [(P2, DevBoxes R)] flattenPCM_resoCut bb δx = case DiaBB.getCorners bb of Nothing -> const [] Just cs -> ($[]) . go' cs@@ -532,7 +367,7 @@ xRange_norm'd = max (-1) ((lCorn^._x - xm)/w) ... min 1 ((rCorn^._x - xm)/w) -flattenPCM_P2_resoCut :: BoundingBox R2 -> [DualSpace R2]+flattenPCM_P2_resoCut :: R2Box -> [DualSpace R2] -> (RecursiveSamples x P2 t) -> [ Either [((P2, R2), DevBoxes P2)] [(P2, t)] ]@@ -555,77 +390,69 @@ where dir = case magnitude pa of 0 -> zeroV; m -> pa ^/ m turnLeft :: R2 -> R2-turnLeft (DiaTypes.R2 x y) = DiaTypes.R2 (-y) x+turnLeft (DiaTypes.V2 x y) = DiaTypes.V2 (-y) x -rPCM_R2_boundingBox :: (RecursiveSamples x P2 t) -> BoundingBox R2-rPCM_R2_boundingBox rPCM@(RecursivePCM pFit _ (DevBoxes dev _) _ _ ())- = Interval (xl - ux*2) (xr + ux*2)- -*| 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- [xl,xr] = sort[p₀^._x, pe^._x]; [yb,yt] = sort[p₀^._y, pe^._y] -solveToLinFit :: (AffineSpace y, v~Diff y, VectorSpace v, Floating (Scalar v))- => [y] -> LinFitParams y-solveToLinFit [] = error- "LinFit solve under-specified (need at least one reference point)."-solveToLinFit [y] = LinFitParams { constCoeff=y, linCoeff=zeroV }-solveToLinFit [y₁,y₂] -- @[x₁, x₂] ≡ [-½, ½]@, and @f(½) = (y₁+y₂)/2 + ½·(y₂-y₁) = y₂@.- -- (Likewise for @f(-½) = y₁@).- = LinFitParams { constCoeff = alerp y₁ y₂ 0.5- , linCoeff = y₂ .-. y₁ }-solveToLinFit _ = error "LinFit solve over-specified (can't solve more than two points)."---normlsdIdd :: Fractional x => SplitList y -> [(x, y)]-normlsdIdd (SplitList l) = zip [ (k+1/2)/fromIntegral (Arr.length l)- | k<-iterate(+1)0] $ Arr.toList l---rPCMLinFitRange :: (R-.^>R) -> Interval R -> Interval R-rPCMLinFitRange rPCM@(RecursivePCM _ _ (DevBoxes _ δ) _ _ ()) ix- = let (Interval b t) = rppm rPCM ix in Interval (b-δ) (t+δ)- where rppm rPCM@(RecursivePCM (LinFitParams b a) _ _ _ _ ()) (Interval l r)- | r < (-1) = spInterval $ b - a- | l > 1 = spInterval $ b + a- | l < (-1) = rppm rPCM $ Interval (-1) r- | r > 1 = rppm rPCM $ Interval l 1- | otherwise = (b + l*a) ... (b + r*a)+rPCMPlot :: [R] -> DynamicPlottable+rPCMPlot = plot . recursivePCM (PCMRange (0 :: Double) 1) -rPCMPlot :: [R] -> DynamicPlottable-rPCMPlot = plot . recursivePCM (PCMRange (0 :: Double) 1)+instance Plottable (Shade P2) where+ plot shade = DynamicPlottable{+ relevantRange_x = atLeastInterval xRange+ , relevantRange_y = atLeastInterval yRange+ , isTintableMonochromic = True+ , axesNecessity = 1+ , dynamicPlot = plot+ }+ where plot grWS@(GraphWindowSpecR2{..}) = mkPlot $ foldMap axLine eigVs + where (pixWdth, pixHght) = pixelDim grWS+ axLine eigV = simpleLine (ctr .-~^ eigV) (ctr .+~^ eigV)+ (xRange,yRange) = shadeExtends shade+ ctr = shade^.shadeCtr+ eigVs = eigenSpan $ shade^.shadeExpanse --- plotSamples :: [R2]+instance Plottable (SimpleTree P2) where+ plot (GenericTree Nothing) = plot ([] :: [SimpleTree P2])+ plot (GenericTree (Just (ctr, root)))+ = DynamicPlottable{+ relevantRange_x = atLeastInterval xRange+ , relevantRange_y = atLeastInterval yRange+ , isTintableMonochromic = True+ , axesNecessity = 1+ , dynamicPlot = plot+ }+ where plot _ = mkPlot $ go 4 ctr (treeBranches root)+ where go w bctr = foldMap (\(c,GenericTree b)+ -> autoDashLine w bctr c+ <> go (w*0.6) c b )+ (xRange, yRange) = let allPoints = gPts tree+ (xmin,xmax) = (minimum&&&maximum) $ (^._x) <$> allPoints+ (ymin,ymax) = (minimum&&&maximum) $ (^._y) <$> allPoints+ in (xmin ... xmax, ymin ... ymax)+ where gPts (GenericTree brchs) = foldr (\(c,b) r -> c : gPts b ++ r) [] brchs+ tree = GenericTree [(ctr,root)] +instance Plottable (Trees P2) where+ plot (GenericTree ts) = plot $ (GenericTree . Just) <$> ts +pixelDim :: GraphWindowSpecR2 -> (R, R)+pixelDim grWS = ( graphWindowWidth grWS / fromIntegral (xResolution grWS)+ , graphWindowHeight grWS / fromIntegral (yResolution grWS) ) -data GraphWindowSpec = GraphWindowSpec {- lBound, rBound, bBound, tBound :: R- , xResolution, yResolution :: Int- , colourScheme :: ColourScheme- }-instance Show GraphWindowSpec where- show (GraphWindowSpec{..}) = "GraphWindowSpec{\- \lBound="++show lBound++", \- \rBound="++show rBound++", \- \bBound="++show bBound++", \- \tBound="++show tBound++", \- \xResolution="++show xResolution++", \- \yResolution="++show yResolution++"}"+type GraphWindowSpec = GraphWindowSpecR2 moveStepRel :: (R, R) -- ^ Relative translation @(Δx/w, Δy/h)@. -> (R, R) -- ^ Relative zoom. -> GraphWindowSpec -> GraphWindowSpec-moveStepRel (δx,δy) (ζx,ζy) (GraphWindowSpec l r b t xRes yRes clSchm)- = GraphWindowSpec l' r' b' t' xRes yRes clSchm+moveStepRel (δx,δy) (ζx,ζy) (GraphWindowSpecR2 l r b t xRes yRes clSchm)+ = GraphWindowSpecR2 l' r' b' t' xRes yRes clSchm where qx = (r-l)/2 ; qy = (t-b)/2 mx'= l + qx*(1+δx) ; my'= b + qy*(1+δy) qx'= zoomSafeGuard mx' $ qx/ζx; qy'= zoomSafeGuard my' $ qy/ζy@@ -633,50 +460,9 @@ r' = mx' + qx' ; t' = my' + qy' zoomSafeGuard m = max (1e-250 + abs m*1e-6) . min 1e+250 ---data Interval r = Interval !r !r deriving (Show)-instance (Ord r) => Semigroup (Interval r) where -- WRT closed hull of the union.- Interval l₁ u₁ <> Interval l₂ u₂ = Interval (min l₁ l₂) (max u₁ u₂)--realInterval :: Real r => Interval r -> Interval R-realInterval (Interval a b) = Interval (realToFrac a) (realToFrac b)--onInterval :: ((R,R) -> (R,R)) -> Interval R -> Interval R-onInterval f (Interval l r) = uncurry Interval $ f (l, r)--infixl 6 ...--- | Build an interval from specified boundary points. No matter which of these--- points is higher, the result will always be the interval in between (i.e.,--- @3 '...' 1@ will yield the interval [1,3], not an empty set or some \"oriented--- interval\" [3,1]).--- The fixity @infixl 6@ was chosen so you can write 2D bounding-boxes as e.g.--- @-1...4 -*| -1...1@.-(...) :: (Ord r) => r -> r -> Interval r-x1...x2 | x1 < x2 = Interval x1 x2- | otherwise = Interval x2 x1--spInterval :: r -> Interval r-spInterval x = Interval x x--intersects :: Ord r => Interval r -> Interval r -> Bool-intersects (Interval a b) (Interval c d) = a<=d && b>=c--includes :: Ord r => Interval r -> r -> Bool-Interval a b `includes` x = x>=a && x<=b--infix 5 -*|---- | Cartesian product of intervals.-(-*|) :: Interval R -> Interval R -> BoundingBox R2-Interval l r -*| Interval b t = DiaBB.fromCorners (l^&b) (r^&t)---- | Inverse of @uncurry ('-*|')@. /This is a partial function/, since--- 'BoundingBox'es can be empty.-xyRanges :: BoundingBox R2 -> (Interval R, Interval R)-xyRanges bb = let Just (c₁, c₂) = DiaBB.getCorners bb- in (c₁^._x ... c₂^._x, c₁^._y ... c₂^._y)-+graphWindowWidth, graphWindowHeight :: GraphWindowSpec -> R+graphWindowWidth grWS = rBound grWS - lBound grWS+graphWindowHeight grWS = tBound grWS - bBound grWS @@ -686,7 +472,7 @@ data Plot = Plot { plotAnnotations :: [Annotation]- , getPlot :: Diagram+ , getPlot :: PlainGraphicsR2 } instance Semigroup Plot where Plot a1 d1 <> Plot a2 d2 = Plot (a1<>a2) (d1<>d2)@@ -694,8 +480,14 @@ mempty = Plot mempty mempty mappend = (<>) +mkPlot :: PlainGraphicsR2 -> Plot+mkPlot = Plot mempty++mkAnnotatedPlot :: [Annotation] -> PlainGraphicsR2 -> Plot+mkAnnotatedPlot ans = Plot ans+ data DynamicPlottable = DynamicPlottable { - relevantRange_x, relevantRange_y :: Option (Interval R) -> Option (Interval R)+ relevantRange_x, relevantRange_y :: RangeRequest R , isTintableMonochromic :: Bool , axesNecessity :: Necessity , dynamicPlot :: GraphWindowSpec -> Plot@@ -709,7 +501,27 @@ +data RangeRequest r + = OtherDimDependantRange (Option (Interval r) -> Option (Interval r))+ | MustBeThisRange (Interval r) +instance (Ord r) => Semigroup (RangeRequest r) where+ MustBeThisRange r <> _ = MustBeThisRange r+ _ <> MustBeThisRange r = MustBeThisRange r+ OtherDimDependantRange r1 <> OtherDimDependantRange r2 = OtherDimDependantRange $ r1<>r2+instance (Ord r) => Monoid (RangeRequest r) where+ mempty = OtherDimDependantRange $ const mempty+ mappend = (<>)++otherDimDependence :: (Interval r->Interval r) -> RangeRequest r+otherDimDependence = OtherDimDependantRange . fmap++atLeastInterval :: Interval r -> RangeRequest r+atLeastInterval = atLeastInterval' . pure++atLeastInterval' :: Option (Interval r) -> RangeRequest r+atLeastInterval' = OtherDimDependantRange . const+ -- | Plot some plot objects to a new interactive GTK window. Useful for a quick@@ -777,18 +589,15 @@ modifyIORef viewTgt $ \view -> view{ xResolution = fromIntegral canvasX , yResolution = fromIntegral canvasY } dia <- readIORef dgStore- let oldSize = Dia.size2D dia+ let oldSize = Dia.size dia scaledDia = Dia.bg Dia.black . Dia.scaleX (fromInt canvasX / 2) . Dia.scaleY (-fromInt canvasY / 2) . Dia.translate (1 ^& (-1))- . Dia.withEnvelope (Dia.rect 2 2 :: Diagram)+ . Dia.withEnvelope (Dia.rect 2 2 :: PlainGraphicsR2) $ dia drawWindow <- GTK.widgetGetDrawWindow drawA- -- putStrLn $ "redrawing"++show(canvasX,canvasY)- -- putStrLn . ("with state now:\n"++) . show =<< readIORef viewState BGTK.renderToGtk drawWindow $ scaledDia- -- putStrLn $ "redrawn." return True GTK.on drawA GTK.scrollEvent . Event.tryEvent $ do@@ -799,7 +608,7 @@ scrollD <- Event.eventScrollDirection case defaultScrollBehaviour scrollD of ScrollZoomIn -> liftIO $ do- modifyIORef viewTgt $ \view@GraphWindowSpec{..}+ modifyIORef viewTgt $ \view@GraphWindowSpecR2{..} -> let w = rBound - lBound h = tBound - bBound in view{ lBound = lBound + w * (rcX + 1)^2 * scrollZoomStrength@@ -808,7 +617,7 @@ , bBound = bBound + h * (rcY + 1)^2 * scrollZoomStrength } ScrollZoomOut -> liftIO $ do- modifyIORef viewTgt $ \view@GraphWindowSpec{..}+ modifyIORef viewTgt $ \view@GraphWindowSpecR2{..} -> let w = rBound - lBound h = tBound - bBound in view{ lBound = lBound - w * (rcX - 1)^2 * scrollZoomStrength@@ -868,9 +677,10 @@ let refreshScreen = do- currentView@(GraphWindowSpec{..}) <- readIORef viewState- let normaliseView :: Diagram -> Diagram- normaliseView = (Dia.scaleX xUnZ :: Diagram->Diagram) . Dia.scaleY yUnZ+ currentView@(GraphWindowSpecR2{..}) <- readIORef viewState+ let normaliseView :: PlainGraphicsR2 -> PlainGraphicsR2+ normaliseView = (Dia.scaleX xUnZ :: PlainGraphicsR2->PlainGraphicsR2)+ . Dia.scaleY yUnZ . Dia.translate (Dia.r2(-x₀,-y₀)) where xUnZ = 1/w; yUnZ = 1/h w = (rBound - lBound)/2; h = (tBound - bBound)/2@@ -881,8 +691,8 @@ _ -> case lastStableView of Just (_, vw) -> return $ Just vw _ -> poll nextTgtView >> return Nothing- return $ case plt of- Nothing -> mempty+ case plt of+ Nothing -> return mempty Just Plot{..} -> let antTK = DiagramTK { viewScope = currentView , textTools = TextTK defaultTxtStyle@@ -891,12 +701,13 @@ aspect = w * fromIntegral yResolution / (h * fromIntegral xResolution) fontPts = 12- transform :: Diagram -> Diagram+ transform :: PlainGraphicsR2 -> PlainGraphicsR2 transform = normaliseView . clr where clr | Just c <- graphColor = Dia.lcA c . Dia.fcA c | otherwise = id- in transform $ foldMap (prerenderAnnotation antTK) plotAnnotations- <> getPlot+ in do+ renderedAnnot <- mapM (prerenderAnnotation antTK) plotAnnotations+ return . transform $ fold renderedAnnot <> getPlot gvStates <- readIORef graphs waitAny $ map (realtimeView . snd) gvStates@@ -914,10 +725,10 @@ do vt <- readIORef viewTgt updateRTView $ \vo -> let a%b = let η = min 1 $ 2 * realToFrac δt in η*a + (1-η)*b - in GraphWindowSpec (lBound vt % lBound vo) (rBound vt % rBound vo)- (bBound vt % bBound vo) (tBound vt % tBound vo)- (xResolution vt) (yResolution vt)- defColourScheme+ in GraphWindowSpecR2 (lBound vt % lBound vo) (rBound vt % rBound vo)+ (bBound vt % bBound vo) (tBound vt % tBound vo)+ (xResolution vt) (yResolution vt)+ defColourScheme -- GTK.sleep 0.01 refreshScreen -- GTK.pollEvents@@ -932,60 +743,36 @@ ) key return impact --- GLFW.keyCallback $= \key state -> do--- let keyStepSize = 0.1--- (state==GLFW.Press) `when` do--- case defaultKeyMap key of--- Just QuitProgram -> writeIORef done True--- Just movement -> do--- impact <- keyImpact movement--- updateTgtView $ case movement of--- MoveUp -> moveStepRel (0, impact) (1, 1)--- MoveDown -> moveStepRel (0, -impact) (1, 1)--- MoveLeft -> moveStepRel (-impact, 0) (1, 1)--- MoveRight -> moveStepRel (impact , 0) (1, 1)--- ZoomIn_x -> moveStepRel (0, 0) (1+impact, 1)--- ZoomOut_x -> moveStepRel (0, 0) (1-impact/2, 1)--- ZoomIn_y -> moveStepRel (0, 0) (1, 1+impact/2)--- ZoomOut_y -> moveStepRel (0, 0) (1, 1-impact/2)--- _ -> return ()--- GTK.onDestroy window $ do (readIORef graphs >>=) . mapM_ -- cancel remaining threads $ \(_, GraphViewState{..}) -> cancel realtimeView >> cancel nextTgtView GTK.mainQuit - -- putStrLn "Enter Main loop..."- --- mainLoop GTK.timeoutAdd mainLoop 100 GTK.mainGUI - -- putStrLn "Done."- - -- GTK.mainQuit- readIORef viewState autoDefaultView :: [DynamicPlottable] -> GraphWindowSpec-autoDefaultView graphs = GraphWindowSpec l r b t defResX defResY defaultColourScheme+autoDefaultView graphs = GraphWindowSpecR2 l r b t defResX defResY defaultColourScheme where (xRange, yRange) = foldMap (relevantRange_x &&& relevantRange_y) graphs ((l,r), (b,t)) = ( xRange `dependentOn` yRange , yRange `dependentOn` xRange )- ξ`dependentOn`υ = addMargin . defRng . ξ . return . defRng $ υ mempty+ MustBeThisRange (Interval a b) `dependentOn` _ = (a,b)+ OtherDimDependantRange ξ `dependentOn` MustBeThisRange i+ = addMargin . defRng . ξ $ pure i+ OtherDimDependantRange ξ `dependentOn` OtherDimDependantRange υ+ = addMargin . defRng . ξ . pure . defRng $ υ mempty defRng = Interval (-1) 1 `option` id addMargin (Interval a b) = (a - q, b + q) where q = (b - a) / 6 --- render :: Diagram -> IO()--- render = Dia.clearRender- defResX, defResY :: Integral i => i defResX = 640 defResY = 480@@ -1028,7 +815,6 @@ -- defaultKeyMap (GLFW.SpecialKey GLFW.ESC) = Just QuitProgram defaultKeyMap _ = Nothing --- instance NFData Draw.R -- | Plot an (assumed continuous) function in the usual way.@@ -1048,14 +834,14 @@ -- a lot of real applications). continFnPlot :: (Double -> Double) -> DynamicPlottable continFnPlot f = DynamicPlottable{- relevantRange_x = const mempty- , relevantRange_y = yRangef+ relevantRange_x = mempty+ , relevantRange_y = otherDimDependence yRangef , isTintableMonochromic = True , axesNecessity = 1 , dynamicPlot = plot }- where yRangef = fmap . onInterval $ \(l, r) -> ((!10) &&& (!70)) . sort . pruneOutlyers+ where yRangef = onInterval $ \(l, r) -> ((!10) &&& (!70)) . sort . pruneOutlyers $ map f [l, l + (r-l)/80 .. r]- plot (GraphWindowSpec{..}) = curve `deepseq` Plot [] (trace curve)+ plot (GraphWindowSpecR2{..}) = curve `deepseq` mkPlot (trace curve) where δx = (rBound - lBound) * 2 / fromIntegral xResolution curve = [ (x ^& f x) | x<-[lBound, lBound+δx .. rBound] ] trace (p:q:ps) = simpleLine p q <> trace (q:ps)@@ -1110,7 +896,7 @@ data Axis = Axis { axisPosition :: R } crtDynamicAxes :: GraphWindowSpec -> DynamicAxes-crtDynamicAxes (GraphWindowSpec {..}) = DynamicAxes yAxCls xAxCls+crtDynamicAxes (GraphWindowSpecR2 {..}) = DynamicAxes yAxCls xAxCls where [yAxCls, xAxCls] = zipWith3 directional [lBound, bBound] [rBound, tBound] [xResolution, yResolution] directional l u res = map lvl lvlSpecs@@ -1124,8 +910,7 @@ strength (floor $ lg laSpc) where laSpc = upDecaSpan / luDSdiv- luDSdiv = ll -- maybe 1 id . listToMaybe - . takeWhile (\d -> pixelScale * minSpc < 1/d )+ luDSdiv = ll . takeWhile (\d -> pixelScale * minSpc < 1/d ) . join $ iterate (map(*10)) [1, 2, 5] ll [] = error $ "pixelScale = "++show pixelScale ++"; minSpc = "++show minSpc@@ -1138,12 +923,12 @@ -- automatically, by default (unless inhibited with 'noDynamicAxes'). dynamicAxes :: DynamicPlottable dynamicAxes = DynamicPlottable { - relevantRange_x = const mempty- , relevantRange_y = const mempty + relevantRange_x = mempty+ , relevantRange_y = mempty , isTintableMonochromic = False , axesNecessity = superfluent , dynamicPlot = plot }- where plot gwSpec@(GraphWindowSpec{..}) = Plot labels lines+ where plot gwSpec@(GraphWindowSpecR2{..}) = Plot labels 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)@@ -1169,20 +954,23 @@ noDynamicAxes :: DynamicPlottable noDynamicAxes = DynamicPlottable { - relevantRange_x = const mempty- , relevantRange_y = const mempty + relevantRange_x = mempty+ , relevantRange_y = mempty , isTintableMonochromic = False , axesNecessity = superfluent , dynamicPlot = const mempty } -type Necessity = Double-superfluent = -1e+32 :: Necessity +simpleLine :: P2 -> P2 -> PlainGraphicsR2+simpleLine = simpleLine' 2 +simpleLine' :: Double -> P2 -> P2 -> PlainGraphicsR2+simpleLine' w p q = Dia.fromVertices [p,q] & Dia.lwO w -simpleLine :: Dia.P2 -> Dia.P2 -> Diagram-simpleLine p q = Dia.fromVertices [p,q] & Dia.lwO 2+autoDashLine :: Double -> P2 -> P2 -> PlainGraphicsR2+autoDashLine w p q = simpleLine' (max 1 w) p q+ & if w < 1 then Dia.dashingO [w*6, 3] 0 else id @@ -1191,107 +979,41 @@ -- Note there is nothing special about these “flag” objects: /any/ 'Plottable' can request a -- certain view, e.g. for a discrete point cloud it's obvious and a function defines at least -- a @y@-range for a given @x@-range. Only use explicit range when necessary.-xInterval, yInterval :: (Double, Double) -> DynamicPlottable+xInterval :: (Double, Double) -> DynamicPlottable++-- | Like 'xInterval', this only affects what range is plotted. However, it doesn't merely+-- request that a certain interval /should be visible/, but actually enforces particular+-- values for the left and right boundary. Nothing outside the range will be plotted+-- (unless there is another, contradicting 'forceXRange').+forceXRange :: (Double, Double) -> DynamicPlottable++yInterval, forceYRange :: (Double, Double) -> DynamicPlottable+ xInterval (l,r) = DynamicPlottable { - relevantRange_x = const . return $ Interval l r- , relevantRange_y = const mempty- , isTintableMonochromic = False- , axesNecessity = 0- , dynamicPlot = plot }+ 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 = const mempty- , relevantRange_y = const . return $ Interval b t- , isTintableMonochromic = False- , axesNecessity = 0- , dynamicPlot = plot }+ 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 -prettyFloatShow :: Int -> Double -> String-prettyFloatShow _ 0 = "0"-prettyFloatShow preci x- | 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- --maybeRead :: Read a => String -> Maybe a-maybeRead = fmap fst . listToMaybe . reads--data Annotation = Annotation {- getAnnotation :: AnnotationObj - , placement :: AnnotationPlace- , isOptional :: Bool- }-data AnnotationObj = TextAnnotation TextObj TextAlignment-data AnnotationPlace = ExactPlace R2--data TextObj = PlainText String-data TextAlignment = TextAlignment { hAlign, vAlign :: Alignment } -- , blockSpread :: Bool }-data Alignment = AlignBottom | AlignMid | AlignTop--data DiagramTK = DiagramTK { textTools :: TextTK, viewScope :: GraphWindowSpec }-data TextTK = TextTK { txtCairoStyle :: Dia.Style R2 -- Draw.Font- , txtSize, xAspect, padding, extraTopPad :: R }--defaultTxtStyle :: Dia.Style R2-defaultTxtStyle = mempty & Dia.fontSizeO 9- & Dia.fc Dia.grey- & Dia.lc Dia.grey---prerenderAnnotation :: DiagramTK -> Annotation -> Diagram-prerenderAnnotation (DiagramTK{ textTools = TextTK{..}, viewScope = GraphWindowSpec{..} }) - (Annotation{..})- | TextAnnotation (PlainText str) (TextAlignment{..}) <- getAnnotation- , ExactPlace p₀ <- placement- = let rnTextLines = map (CairoTxt.textVisualBounded txtCairoStyle) $ lines str- lineWidths = map ((/4 {- Magic number ??? -})- . Dia.width) rnTextLines- nLines = length lineWidths- lineHeight = 1 + extraTopPad + 2*padding- ζx = ζy * xAspect- ζy = txtSize -- / lineHeight- width = (maximum $ 0 : lineWidths) + 2*padding- height = fromIntegral nLines * lineHeight- y₀ = case vAlign of- AlignBottom -> padding + height - lineHeight- AlignMid -> height/2 - lineHeight- AlignTop -> - (lineHeight + padding)- fullText = mconcat $ zipWith3 ( \n w -> - let y = n*lineHeight- in (Dia.translate $ Dia.r2 (case hAlign of - AlignBottom -> (padding , y₀-y)- AlignMid -> (- w/2 , y₀-y)- AlignTop -> (-(w + padding), y₀-y)- ) ) ) [0..] lineWidths rnTextLines- p = px ^& py- where px = max l' . min r' $ p₀^._x- py = max b' . min t' $ p₀^._y- (l', r') = case hAlign of- AlignBottom -> (lBound , rBound - w )- 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- in Dia.translate p . Dia.scaleX ζx . Dia.scaleY ζy - $ 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@@ -1307,76 +1029,66 @@ 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+ 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 }- where cx (GraphWindowSpec{..}) = ViewXCenter $ (lBound+rBound)/2+ 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+ MustBeThisRange i -> pure i+ OtherDimDependantRange ifr -> ifr otherdim 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+ 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 }- where cy (GraphWindowSpec{..}) = ViewYCenter $ (bBound+tBound)/2+ 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+ MustBeThisRange i -> pure i+ OtherDimDependantRange ifr -> ifr otherdim 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+ 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 }- where w (GraphWindowSpec{..}) = ViewWidth $ rBound - lBound+ 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+ MustBeThisRange i -> pure i+ OtherDimDependantRange ifr -> ifr otherdim 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+ 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 }- where h (GraphWindowSpec{..}) = ViewHeight $ tBound - bBound+ 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+ MustBeThisRange i -> pure i+ OtherDimDependantRange ifr -> ifr otherdim newtype ViewXResolution = ViewXResolution { getViewXResolution :: Int } newtype ViewYResolution = ViewYResolution { getViewYResolution :: Int } --infixl 7 `provided`-provided :: Monoid m => m -> Bool -> m-provided m True = m-provided m False = mempty---lg :: Floating a => a -> a-lg x = log x / log 10----- instance (Monoid v) => Semigroup (Draw.Image v) where--- (<>) = mappend--- instance Semigroup (Draw.Affine) where--- (<>) = mappend--- -ceil, flor :: R -> R-ceil = fromInt . ceiling-flor = fromInt . floor--fromInt :: Num a => Int -> a-fromInt = fromIntegral----instance NFData Dia.P2
+ Graphics/Text/Annotation.hs view
@@ -0,0 +1,175 @@+-- |+-- Module : Graphics.Text.Annotation+-- Copyright : (c) Justus Sagemüller 2015+-- License : GPL v3+-- +-- Maintainer : (@) sagemueller $ geo.uni-koeln.de+-- Stability : experimental+-- Portability : requires GHC>6 extensions+++{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}++module Graphics.Text.Annotation where++import Graphics.Dynamic.Plot.Colour+import Graphics.Dynamic.Plot.Internal.Types+++import qualified Prelude++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+import qualified Diagrams.TwoD.Text as DiaTxt+import Diagrams.BoundingBox (BoundingBox)+import qualified Diagrams.BoundingBox as DiaBB+import qualified Diagrams.Backend.Cairo as Cairo+import qualified Diagrams.Backend.Cairo.Text as CairoTxt+ +import Control.Monad.Trans (liftIO)++import qualified Control.Category.Hask as Hask+import Control.Category.Constrained.Prelude hiding ((^))+import Control.Arrow.Constrained+import Control.Monad.Constrained++import Control.Lens hiding ((...), (<.>))++ +import Data.List (foldl', sort, intercalate, isPrefixOf, isInfixOf, find, zip4)+import qualified Data.Vector as Arr+import Data.Maybe+import Data.Semigroup+import Data.Foldable (fold, foldMap)+import Data.Function (on)++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++import Data.Tagged++import Text.Printf+++ ++prettyFloatShow :: Int -> Double -> String+prettyFloatShow _ 0 = "0"+prettyFloatShow preci x+ | 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+ ++maybeRead :: Read a => String -> Maybe a+maybeRead = fmap fst . listToMaybe . reads++data Annotation = Annotation {+ getAnnotation :: AnnotationObj + , placement :: AnnotationPlace+ , isOptional :: Bool+ }+data AnnotationObj = TextAnnotation TextObj TextAlignment+data AnnotationPlace = ExactPlace R2++data TextObj = PlainText String+data TextAlignment = TextAlignment { hAlign, vAlign :: Alignment } -- , blockSpread :: Bool }+data Alignment = AlignBottom | AlignMid | AlignTop++type TxtStyle = Dia.Style Dia.V2 R++data DiagramTK = DiagramTK { textTools :: TextTK, viewScope :: GraphWindowSpecR2 }+data TextTK = TextTK { txtCairoStyle :: TxtStyle+ , txtSize, xAspect, padding, extraTopPad :: R }++defaultTxtStyle :: TxtStyle+defaultTxtStyle = mempty & Dia.fontSizeO 9+ & Dia.fc Dia.grey+ & Dia.lc Dia.grey+++prerenderAnnotation :: DiagramTK -> Annotation -> IO PlainGraphicsR2+prerenderAnnotation (DiagramTK{ textTools = TextTK{..}, viewScope = GraphWindowSpecR2{..} }) + (Annotation{..})+ | TextAnnotation (PlainText str) (TextAlignment{..}) <- getAnnotation+ , ExactPlace p₀ <- placement = do + let dtxAlign = DiaTxt.BoxAlignedText+ (case hAlign of {AlignBottom -> 0; AlignMid -> 0.5; AlignTop -> 1})+ (case vAlign of {AlignBottom -> 0; AlignMid -> 0.5; AlignTop -> 1})++ rnTextLines <- mapM (CairoTxt.textVisualBoundedIO txtCairoStyle+ . DiaTxt.Text mempty dtxAlign )+ $ lines str+ let lineWidths = map ((/6 {- Magic number ??? -}) .+ Dia.width) rnTextLines+ nLines = length lineWidths+ lineHeight = 1 + extraTopPad + 2*padding+ ζx = ζy * xAspect+ ζy = txtSize -- / lineHeight+ width = (maximum $ 0 : lineWidths) + 2*padding+ height = fromIntegral nLines * lineHeight+ y₀ = case vAlign of+ AlignBottom -> padding+ AlignMid -> 0+ AlignTop -> - padding+ fullText = mconcat $ zipWith3 ( \n w -> + let y = n' * lineHeight+ n' = n - case vAlign of+ AlignTop -> 0+ AlignMid -> fromIntegral nLines / 2+ AlignBottom -> fromIntegral nLines+ in (Dia.translate $ Dia.r2 (case hAlign of + AlignBottom -> ( padding, y₀-y )+ AlignMid -> ( 0 , y₀-y )+ AlignTop -> (-padding, y₀-y )+ ) ) ) [0..] lineWidths rnTextLines+ p = px ^& py+ where px = max l' . min r' $ p₀^._x+ py = max b' . min t' $ p₀^._y+ (l', r') = case hAlign of+ AlignBottom -> (lBound , rBound - w )+ 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+ bBound' = bBound + lineHeight*ζy+ return . Dia.translate p . Dia.scaleX ζx . Dia.scaleY ζy + $ Dia.lc Dia.grey fullText+ +++++lg :: Floating a => a -> a+lg = logBase 10
dynamic-plot.cabal view
@@ -1,5 +1,5 @@ Name: dynamic-plot-Version: 0.1.0.1+Version: 0.1.1.0 Category: graphics Synopsis: Interactive diagram windows Description: Haskell excels at handling data like continuous functions@@ -42,6 +42,7 @@ , vector-space>=0.8 , MemoTrie , vector+ , tagged , containers , semigroups , random@@ -51,15 +52,15 @@ , deepseq , process , constrained-categories >= 0.2- , diagrams-core == 1.2.0.2- , diagrams-lib >= 1 && < 1.4- , diagrams-cairo == 1.2.0.2+ , diagrams-core+ , diagrams-lib >= 1.3 && < 1.4+ , diagrams-cairo > 1.3.0.5 && < 1.4 , diagrams-gtk , gtk > 0.10 && < 0.15 , glib , colour >= 2 && < 3- , manifolds >= 0.1.0.1 && < 0.2- , lens+ , manifolds >= 0.1.5 && < 0.1.6+ , lens < 4.12.3 Other-Extensions: FlexibleInstances , TypeFamilies , FlexibleContexts@@ -74,3 +75,5 @@ default-language: Haskell2010 Exposed-modules: Graphics.Dynamic.Plot.R2 Other-modules: Graphics.Dynamic.Plot.Colour+ , Graphics.Dynamic.Plot.Internal.Types+ , Graphics.Text.Annotation