diff --git a/Graphics/Dynamic/Plot/Colour.hs b/Graphics/Dynamic/Plot/Colour.hs --- a/Graphics/Dynamic/Plot/Colour.hs +++ b/Graphics/Dynamic/Plot/Colour.hs @@ -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 diff --git a/Graphics/Dynamic/Plot/Internal/Types.hs b/Graphics/Dynamic/Plot/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/Dynamic/Plot/Internal/Types.hs @@ -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=< 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=< 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 + + + + 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 @@ -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=< 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=< 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 diff --git a/Graphics/Text/Annotation.hs b/Graphics/Text/Annotation.hs new file mode 100644 --- /dev/null +++ b/Graphics/Text/Annotation.hs @@ -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 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.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