numhask-space 0.6.1 → 0.7.0.0
raw patch · 12 files changed
+587/−194 lines, 12 filesdep ~numhask
Dependency ranges changed: numhask
Files
- ChangeLog.md +16/−0
- numhask-space.cabal +18/−13
- readme.md +23/−0
- src/NumHask/Space.hs +44/−21
- src/NumHask/Space/Histogram.hs +45/−13
- src/NumHask/Space/Point.hs +161/−18
- src/NumHask/Space/Range.hs +22/−12
- src/NumHask/Space/Rect.hs +81/−39
- src/NumHask/Space/Time.hs +46/−28
- src/NumHask/Space/Types.hs +104/−7
- src/NumHask/Space/XY.hs +20/−41
- test/test.hs +7/−2
+ ChangeLog.md view
@@ -0,0 +1,16 @@+0.7.0+=====++* GHC 8.10.2 support+* Added `Transform` and `Affinity` capabilities+* Added `Line` and associated functions.+* Support for random-1.2; `uniformS` and `uniformSs`+* Shifted to zero-centered, width scaling `Range` multiplication.+* Added `average` & `quantile` to NumHask.Space.Histogram+* Improved haddocks+* Extended doctests++0.6.1+=====++* GHC 8.10.1 support
numhask-space.cabal view
@@ -1,10 +1,19 @@ cabal-version: 2.4 name: numhask-space-version: 0.6.1+version: 0.7.0.0 synopsis:- numerical spaces+ Numerical spaces. description:- Spaces and the numerical elements that inhabit them.+ @numhask-space@ provides support for spaces where [space](https://en.wikipedia.org/wiki/Space_(mathematics\)) is defined as a set of numbers with a lower and upper bound.+ .+ == Usage+ .+ >>> {-# LANGUAGE NegativeLiterals #-}+ >>> {-# LANGUAGE RebindableSyntax #-}+ >>> import NumHask.Prelude+ >>> import NumHask.Space+ .+ category: mathematics homepage:@@ -23,6 +32,10 @@ LICENSE build-type: Simple+tested-with: GHC ==8.8.4 || ==8.10.2+extra-source-files:+ readme.md+ ChangeLog.md source-repository head type: git@@ -39,16 +52,12 @@ -Wincomplete-uni-patterns -Wredundant-constraints default-extensions:- NegativeLiterals- NoImplicitPrelude- OverloadedStrings- UnicodeSyntax build-depends: adjunctions >=4.0 && <5, base >=4.7 && <5, containers >= 0.6 && < 0.7, distributive >=0.2.2 && <1,- numhask >= 0.6 && < 0.7,+ numhask >= 0.7 && < 0.8, semigroupoids >=5 && <6, tdigest >= 0.2.1 && < 0.3, text >= 1.2.3.1 && <2,@@ -73,7 +82,7 @@ build-depends: base >=4.7 && <5, doctest >= 0.16 && < 0.18,- numhask >= 0.6 && < 0.7,+ numhask >= 0.7 && < 0.8, default-language: Haskell2010 ghc-options: -Wall@@ -82,7 +91,3 @@ -Wincomplete-uni-patterns -Wredundant-constraints default-extensions:- NegativeLiterals- NoImplicitPrelude- OverloadedStrings- UnicodeSyntax
+ readme.md view
@@ -0,0 +1,23 @@+numhask-space+===++[](https://travis-ci.org/tonyday567/numhask-space) [](https://hackage.haskell.org/package/numhask-space)++`numhask-space` provides support for spaces where [space](https://en.wikipedia.org/wiki/Space_(mathematics)) is defined as a set of numbers with a `lower `and `upper` bound.++Usage+===++``` haskell+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE RebindableSyntax #-}+import NumHask.Prelude+import NumHask.Space+```++Develop+===++```+stack build --test --haddock --file-watch+```
src/NumHask/Space.hs view
@@ -1,17 +1,19 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-} --- | A continuous set of numbers.------ Mathematics does not define a space, leaving library devs to experiment.------ https://en.wikipedia.org/wiki/Space_(mathematics)+-- | Mathematics does not rigorously define a [space](https://en.wikipedia.org/wiki/Space_(mathematics\)), leaving library devs free to push boundaries on what a space is.+-- module NumHask.Space- ( -- * Space+ ( -- * Usage+ -- $setup++ -- * Space -- $space module NumHask.Space.Types, -- * Instances- -- $instances module NumHask.Space.Point, module NumHask.Space.Range, module NumHask.Space.Rect,@@ -29,19 +31,40 @@ import NumHask.Space.Types hiding () import NumHask.Space.XY hiding () --- $space--- The final frontier.--{- $instances-- Space is an interesting cross-section of many programming domains.-- - A Range is a Space of numbers.-- - A Rect is a Space of Points.-- - A time span is a space containing moments of time.+-- $setup+--+-- >>> :set -XRebindableSyntax+-- >>> :set -XNegativeLiterals+-- >>> import NumHask.Prelude+-- >>> import NumHask.Space+-- >>> Point 1 1+-- Point 1 1+--+-- >>> one :: Range Double+-- Range -0.5 0.5+--+-- >>> grid OuterPos (Range 0 50 :: Range Double) 5+-- [0.0,10.0,20.0,30.0,40.0,50.0] - - A histogram is a divided Range with a count of elements within each division.+-- $space+--+-- Space is an interesting cross-section of many programming domains.+--+-- - A 'Range' is a 'Space' of numbers.+--+-- - A 'Rect' is a 'Space' of 'Point's. It can also be a 'Space' of 'Rect's (but this is not yet coded up here).+--+-- - A time span is a 'Space' containing moments of time.+--+-- - A 'Histogram' is a divided 'Range' with a count of elements within each division. --}+-- $extensions+-- > :t Point 1.0 -1.0+-- Point 1.0 -1.0+-- :: (Subtractive a, FromRatio a Integer,+-- FromRatio (a -> Point a) Integer) =>+-- a -> Point a+--+-- > :set -XNegativeLiterals+-- > :t Point 1.0 -1.0+-- Point 1.0 -1.0 :: FromRatio a Integer => Point a
src/NumHask/Space/Histogram.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-} --- | A histogram, if you squint, is a series of contiguous ranges, annotated with values.+-- | A histogram, if you squint, is a series of contiguous 'Range's, annotated with values. module NumHask.Space.Histogram ( Histogram (..), DealOvers (..),@@ -14,25 +14,27 @@ quantileFold, fromQuantiles, freq,+ average,+ quantiles,+ quantile, ) where import qualified Data.List as List import qualified Data.Map as Map-import Data.TDigest+import qualified Data.TDigest as TD+import NumHask.Prelude import NumHask.Space.Range import NumHask.Space.Rect import NumHask.Space.Types-import NumHask.Prelude -- | This Histogram is a list of contiguous boundaries (a boundary being the lower edge of one bucket and the upper edge of another), and a value (usually a count) for each bucket, represented here as a map -- -- Overs and Unders are contained in key = 0 and key = length cuts-data Histogram- = Histogram- { cuts :: [Double], -- bucket boundaries- values :: Map.Map Int Double -- bucket counts- }+data Histogram = Histogram+ { cuts :: [Double], -- bucket boundaries+ values :: Map.Map Int Double -- bucket counts+ } deriving (Show, Eq) -- | Whether or not to ignore unders and overs. If overs and unders are dealt with, IncludeOvers supplies an assumed width for the outer buckets.@@ -102,9 +104,9 @@ quantileFold :: [Double] -> [Double] -> [Double] quantileFold qs xs = done $ foldl' step begin xs where- step x a = Data.TDigest.insert a x- begin = tdigest ([] :: [Double]) :: TDigest 25- done x = fromMaybe (0 / 0) . (`quantile` compress x) <$> qs+ step x a = TD.insert a x+ begin = TD.tdigest ([] :: [Double]) :: TD.TDigest 25+ done x = fromMaybe (0 / 0) . (`TD.quantile` TD.compress x) <$> qs -- | take a specification of quantiles and make a Histogram --@@ -118,9 +120,39 @@ diffq (x : xs') = (reverse . snd) $ foldl' step (x, []) xs' step (a0, xs') a = (a, (a - a0) : xs') --- | normalize a histogram so that sum values = one+-- | normalize a histogram --+-- > \h -> sum (values $ freq h) == one+-- -- >>> freq $ fill [0,50,100] [1..100] -- Histogram {cuts = [0.0,50.0,100.0], values = fromList [(1,0.5),(2,0.5)]} freq :: Histogram -> Histogram freq (Histogram cs vs) = Histogram cs $ Map.map (* recip (sum vs)) vs++-- | average+--+-- >>> average [0..1000]+-- 500.0+average :: (Foldable f) => f Double -> Double+average xs = sum xs / fromIntegral (length xs)++-- | Regularly spaced (approx) quantiles+--+-- >>> quantiles 5 [1..1000]+-- [1.0,200.5,400.5,600.5000000000001,800.5,1000.0]+--+quantiles :: (Foldable f) => Int -> f Double -> [Double]+quantiles n xs =+ ( \x ->+ fromMaybe 0 $+ TD.quantile x (TD.tdigest xs :: TD.TDigest 25)+ )+ <$> ((/ fromIntegral n) . fromIntegral <$> [0 .. n])++-- | single (approx) quantile+--+-- >>> quantile 0.1 [1..1000]+-- 100.5+--+quantile :: (Foldable f) => Double -> f Double -> Double+quantile p xs = fromMaybe 0 $ TD.quantile p (TD.tdigest xs :: TD.TDigest 25)
src/NumHask/Space/Point.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-}@@ -8,8 +10,20 @@ -- | A 2-dimensional point. module NumHask.Space.Point ( Point (..),- rotate,+ rotateP, gridP,+ dotP,+ (<.>),+ crossP,+ flipY,+ Line (..),+ lineSolve,+ lineDistance,+ closestPoint,+ lineIntersect,+ translate,+ scaleT,+ skew, ) where @@ -17,17 +31,17 @@ import Data.Functor.Classes import Data.Functor.Rep import GHC.Show (show)+import NumHask.Prelude hiding (Distributive, rotate, show)+import qualified NumHask.Prelude as P import NumHask.Space.Range import NumHask.Space.Types-import NumHask.Prelude hiding (show, Distributive, rotate)-import qualified NumHask.Prelude as P -- $setup -- >>> :set -XNoImplicitPrelude --- | A 2-dim point of a's+-- | A 2-dimensional Point of a's ----- A Point is functorial over both arguments, and is a Num instance.+-- In contrast with a tuple, a Point is functorial over both arguments. -- -- >>> let p = Point 1 1 -- >>> p + p@@ -35,14 +49,21 @@ -- >>> (2*) <$> p -- Point 2 2 ----- A major reason for this bespoke treatment of a point is that Points do not have maximums and minimums but they form a lattice, and this is useful for folding points to find out the (rectangular) Space they occupy.+-- A major reason for this bespoke treatment (compared to just using linear, say) is that Points do not have maximums and minimums but they do form a lattice, and this is useful for folding sets of points to find out the (rectangular) Space they occupy. -- -- >>> Point 0 1 /\ Point 1 0 -- Point 0 0 -- >>> Point 0 1 \/ Point 1 0 -- Point 1 1-data Point a- = Point a a+--+-- This is used extensively in [chart-svg](https://hackage.haskell.org/package/chart-svg) to ergonomically obtain chart areas.+--+-- > space1 [Point 1 0, Point 0 1] :: Rect Double+-- Rect 0.0 1.0 0.0 1.0+data Point a = Point+ { _x :: a,+ _y :: a+ } deriving (Eq, Generic) instance (Show a) => Show (Point a) where@@ -115,6 +136,22 @@ getL (Point l _) = l getR (Point _ r) = r +instance (Additive a) => AdditiveAction (Point a) a where+ (.+) a (Point x y) = Point (a + x) (a + y)+ (+.) (Point x y) a = Point (a + x) (a + y)++instance (Subtractive a) => SubtractiveAction (Point a) a where+ (.-) a (Point x y) = Point (a - x) (a - y)+ (-.) (Point x y) a = Point (x - a) (y - a)++instance (Multiplicative a) => MultiplicativeAction (Point a) a where+ (.*) a (Point x y) = Point (a * x) (a * y)+ (*.) (Point x y) a = Point (a * x) (a * y)++instance (Divisive a) => DivisiveAction (Point a) a where+ (./) a (Point x y) = Point (a / x) (a / y)+ (/.) (Point x y) a = Point (x / a) (y / a)+ instance Representable Point where type Rep Point = Bool @@ -129,18 +166,124 @@ instance (Ord a) => MeetSemiLattice (Point a) where (/\) (Point x y) (Point x' y') = Point (min x x') (min y y') --- | rotate a point by x degrees relative to the origin------ >>> rotate 90 (Point 0 1)--- Point 1.0 6.123233995736766e-17-rotate :: (FromInteger a, TrigField a) => a -> Point a -> Point a-rotate d (Point x y) = Point (x * cos d' + y * sin d') (y * cos d' - x * sin d')+instance+ (ExpField a) =>+ Norm (Point a) a where- d' = d * pi / 180+ norm (Point x y) = sqrt (x * x + y * y)+ basis p = p /. norm p +-- | angle formed by a vector from trhe origin to a Point and the x-axis (Point 1 0). Note that an angle between two points p1 & p2 is thus angle p2 - angle p1+--+-- > \u@(Point ux uy) v@(Point vx vy) -> angle v - angle u == sign (ux*vy-uy*vx) * acos (dotP u v / (norm u * norm v))+instance (TrigField a) => Direction (Point a) a where+ angle (Point x y) = atan2 y x+ ray x = Point (cos x) (sin x)++instance (UniformRange a) => UniformRange (Point a) where+ uniformRM (Point x y, Point x' y') g =+ Point <$> uniformRM (x, x') g <*> uniformRM (y, y') g++instance (Multiplicative a, Additive a) => Affinity (Point a) a where+ transform (Transform a b c d e f) (Point x y) =+ Point (a * x + b * y + c) (d * x + e * y + f)++-- | move an 'Affinity' by a 'Point'+translate :: (TrigField a) => Point a -> Transform a+translate (Point x y) = Transform one zero x zero one y++-- | scale an 'Affinity' by a 'Point'+scaleT :: (TrigField a) => Point a -> Transform a+scaleT (Point x y) = Transform x zero zero y zero zero++-- | Skew transform+--+-- x-axis skew+--+-- > skew (Point x 0)+skew :: (TrigField a) => Point a -> Transform a+skew (Point x y) = Transform one (tan x) zero (tan y) one zero++-- | rotate a point by x relative to the origin+--+-- >>> rotateP (pi/2) (Point 1 0)+-- Point 6.123233995736766e-17 1.0+rotateP :: (TrigField a) => a -> Point a -> Point a+rotateP d p = rotate d |. p+ -- | Create Points for a formulae y = f(x) across an x range ----- >>> gridP (**2) (Range 0 4) 4+-- >>> gridP (^2) (Range 0 4) 4 -- [Point 0.0 0.0,Point 1.0 1.0,Point 2.0 4.0,Point 3.0 9.0,Point 4.0 16.0] gridP :: (FieldSpace (Range a)) => (a -> a) -> Range a -> Grid (Range a) -> [Point a] gridP f r g = (\x -> Point x (f x)) <$> grid OuterPos r g++-- | dot product+dotP :: (Multiplicative a, Additive a) => Point a -> Point a -> a+dotP (Point x y) (Point x' y') = x * x' + y * y'++infix 4 <.>++-- | dot product operator+(<.>) :: (Multiplicative a, Additive a) => Point a -> Point a -> a+(<.>) = dotP++-- | cross product+crossP :: (Multiplicative a, Subtractive a) => Point a -> Point a -> a+crossP (Point x y) (Point x' y') = x * y' - y * x'++-- | reflect on x-axis+flipY :: (Subtractive a) => Point a -> Point a+flipY (Point x y) = Point x (- y)++-- | A line is a composed of 2 'Point's+data Line a = Line+ { lineStart :: Point a,+ lineEnd :: Point a+ }+ deriving (Show, Eq, Functor, Foldable, Traversable)++instance (Multiplicative a, Additive a) => Affinity (Line a) a where+ transform t (Line s e) = Line (transform t s) (transform t e)++-- | Return the parameters (a, b, c) for the line equation @a*x + b*y + c = 0@.+lineSolve :: ExpField a => Line a -> (a, a, a)+lineSolve (Line p1 p2) = (- my, mx, c)+ where+ m@(Point mx my) = basis (p2 - p1)+ c = crossP p1 m++-- | Return the signed distance from a point to the line. If the+-- distance is negative, the point lies to the right of the line+lineDistance :: (ExpField a) => Line a -> Point a -> a+lineDistance (Line (Point x1 y1) (Point x2 y2)) =+ let dy = y1 - y2+ dx = x2 - x1+ d = sqrt (dx * dx + dy * dy)+ in dy `seq` dx `seq` d+ `seq` \(Point x y) -> (x - x1) * dy / d + (y - y1) * dx / d++-- | Return the point on the line closest to the given point.+closestPoint :: (Field a) => Line a -> Point a -> Point a+closestPoint (Line p1 p2) p3 = Point px py+ where+ d@(Point dx dy) = p2 - p1+ u = dy * _y p3 + dx * _x p3+ v = _x p1 * _y p2 - _x p2 * _y p1+ m = d <.> d+ px = (dx * u + dy * v) / m+ py = (dy * u - dx * v) / m++-- | Calculate the intersection of two lines. If the determinant is+-- less than tolerance (parallel or coincident lines), return Nothing.+lineIntersect :: (Ord a, Epsilon a, Signed a, Field a) => Line a -> Line a -> Maybe (Point a)+lineIntersect (Line p1 p2) (Line p3 p4)+ | abs det <= epsilon = Nothing+ | otherwise = Just $ (a .* d2 - b .* d1) /. det+ where+ d1 = p1 - p2+ d2 = p3 - p4+ det = crossP d1 d2+ a = crossP p1 p2+ b = crossP p3 p4+
src/NumHask/Space/Range.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} -- | A Space containing numerical elements@@ -18,14 +20,13 @@ import Data.Semigroup.Foldable (Foldable1 (..)) import Data.Semigroup.Traversable (Traversable1 (..)) import GHC.Show (show)-import NumHask.Space.Types as S import NumHask.Prelude hiding (show)+import NumHask.Space.Types as S -- $setup -- -- >>> :set -XFlexibleContexts -- >>> :set -XGADTs--- -- | A continuous range over type a --@@ -33,12 +34,12 @@ -- >>> a -- Range -1 1 ----- Num instance based on interval arithmetic (with Ranges normalising to lower ... upper)--- -- >>> a + a -- Range -2 2+-- -- >>> a * a--- Range -1.0 1.0+-- Range -2.0 2.0+-- -- >>> (+1) <$> (Range 1 2) -- Range 2 3 --@@ -120,10 +121,10 @@ (>.<) = Range -instance FieldSpace (Range Double) where- type Grid (Range Double) = Int+instance (Field a, Ord a, FromIntegral a Int) => FieldSpace (Range a) where+ type Grid (Range a) = Int - grid o s n = (+ bool 0 (step / 2) (o == MidPos)) <$> posns+ grid o s n = (+ bool zero (step / two) (o == MidPos)) <$> posns where posns = (lower s +) . (step *) . fromIntegral <$> [i0 .. i1] step = (/) (width s) (fromIntegral n)@@ -150,9 +151,18 @@ negate (Range l u) = negate u ... negate l instance (Field a, Eq a, Ord a) => Multiplicative (Range a) where- (Range l u) * (Range l' u') =- space1 [l * l', l * u', u * l', u * u']- one = Range (negate one/(one + one)) (one/(one+one))+ a * b = bool (Range (m - r / (one + one)) (m + r / (one + one))) zero (a == zero || b == zero)+ where+ m = mid a + mid b+ r = width a * width b++ one = Range (negate one / (one + one)) (one / (one + one))++instance (Ord a, Field a) => Divisive (Range a) where+ recip a = bool (Range (- m - one / (two * r)) (- m + one / (two * r))) zero (r == zero)+ where+ m = mid a+ r = width a instance (Field a, Subtractive a, Eq a, Ord a) => Signed (Range a) where sign (Range l u) = bool (negate one) one (u >= l)
src/NumHask/Space/Rect.hs view
@@ -1,16 +1,16 @@-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wincomplete-patterns #-} --- | a two-dimensional plane, implemented as a composite of a 'Point' of 'Range's.+-- | A (finite) two-dimensional plane, implemented as a composite of a 'Point' of 'Range's. module NumHask.Space.Rect ( Rect (..), pattern Rect,@@ -19,37 +19,50 @@ corners4, projectRect, foldRect,+ foldRectUnsafe, addPoint,- rotateRect,+ rotationBound, gridR, gridF, aspect, ratio,+ projectOnR,+ projectOnP, ) where import Data.Distributive as D+import Data.Foldable (Foldable (foldr1)) import Data.Functor.Compose import Data.Functor.Rep-import Data.List.NonEmpty-import GHC.Exts import GHC.Show (show)+import NumHask.Prelude hiding (Distributive, rotate, show) import NumHask.Space.Point import NumHask.Space.Range import NumHask.Space.Types-import NumHask.Prelude hiding (rotate, Distributive, show) -- $setup -- -- >>> :set -XFlexibleContexts--- >>> :set -XGADTs--- --- | a rectangular space often representing a 2-dimensional or XY plane.+-- | a rectangular space often representing a finite 2-dimensional or XY plane. --+-- >>> one :: Rect Double+-- Rect -0.5 0.5 -0.5 0.5+--+-- >>> zero :: Rect Double+-- Rect 0.0 0.0 0.0 0.0+--+-- >>> one + one :: Rect Double+-- Rect -1.0 1.0 -1.0 1.0+-- -- >>> let a = Rect (-1.0) 1.0 (-2.0) 4.0 -- >>> a -- Rect -1.0 1.0 -2.0 4.0+--+-- >>> a * one+-- Rect -1.0 1.0 -2.0 4.0+-- -- >>> let (Ranges x y) = a -- >>> x -- Range -1.0 1.0@@ -142,10 +155,10 @@ (|<|) s0 s1 = lower s1 `joinLeq` upper s0 -instance FieldSpace (Rect Double) where- type Grid (Rect Double) = Point Int+instance (FromIntegral a Int, Field a, Ord a) => FieldSpace (Rect a) where+ type Grid (Rect a) = Point Int - grid o s n = (+ bool zero (step / (one+one)) (o == MidPos)) <$> posns+ grid o s n = (+ bool zero (step / (one + one)) (o == MidPos)) <$> posns where posns = (lower s +) . (step *) . fmap fromIntegral@@ -194,10 +207,11 @@ -- >>> projectRect (Rect 0 1 (-1) 0) (Rect 0 4 0 8) (Rect 0.25 0.75 (-0.75) (-0.25)) -- Rect 1.0 3.0 2.0 6.0 projectRect ::- Rect Double ->- Rect Double ->- Rect Double ->- Rect Double+ (Field a, Ord a) =>+ Rect a ->+ Rect a ->+ Rect a ->+ Rect a projectRect r0 r1 (Rect a b c d) = Rect a' b' c' d' where (Point a' c') = project r0 r1 (Point a c)@@ -206,10 +220,8 @@ -- | Numeric algebra based on interval arithmetioc for addition and unitRect and projection for multiplication -- >>> one + one :: Rect Double -- Rect -1.0 1.0 -1.0 1.0--- instance (Additive a) => Additive (Rect a) where- (+)- (Rect a b c d) (Rect a' b' c' d') =+ (+) (Rect a b c d) (Rect a' b' c' d') = Rect (a + a') (b + b') (c + c') (d + d') zero = Rect zero zero zero zero @@ -217,17 +229,14 @@ negate = fmap negate instance (Ord a, Field a) => Multiplicative (Rect a) where- (*)- (Ranges x0 y0) (Ranges x1 y1) =- Ranges (x0 `rtimes` x1) (y0 `rtimes` y1)- where- rtimes a b = bool (Range (m - r / (one+one)) (m + r / (one+one))) zero (a == zero || b == zero)- where- m = mid a + mid b- r = width a * width b+ (*) (Ranges x0 y0) (Ranges x1 y1) =+ Ranges (x0 * x1) (y0 * y1) one = Ranges one one +instance (Ord a, Field a) => Divisive (Rect a) where+ recip (Ranges x y) = Ranges (recip x) (recip y)+ instance (Ord a, Field a) => Signed (Rect a) where sign (Rect x z y w) = bool (negate one) one (z >= x && (w >= y)) abs (Ranges x y) = Ranges (abs x) (abs y)@@ -240,6 +249,13 @@ foldRect [] = Nothing foldRect (x : xs) = Just $ sconcat (x :| xs) +-- | convex hull union of Rect's applied to a non-empty structure+--+-- >>> foldRectUnsafe [Rect 0 1 0 1, one]+-- Rect -0.5 1.0 -0.5 1.0+foldRectUnsafe :: (Foldable f, Ord a) => f (Rect a) -> Rect a+foldRectUnsafe = foldr1 (<>)+ -- | add a Point to a Rect -- -- >>> addPoint (Point 0 1) one@@ -249,18 +265,17 @@ -- | rotate the corners of a Rect by x degrees relative to the origin, and fold to a new Rect ----- >>> rotateRect 45 one--- Rect -0.7071067811865475 0.7071067811865475 -5.551115123125783e-17 5.551115123125783e-17-rotateRect :: Double -> Rect Double -> Rect Double-rotateRect d r =- space1 $ rotate d <$> corners r+-- >>> rotationBound (pi/4) one+-- Rect -0.7071067811865475 0.7071067811865475 -0.7071067811865475 0.7071067811865475+rotationBound :: (TrigField a, Ord a) => a -> Rect a -> Rect a+rotationBound d = space1 . fmap (rotate d |.) . corners4 -- | Create Rects for a formulae y = f(x) across an x range where the y range is Range 0 y ----- >>> gridR (**2) (Range 0 4) 4+-- >>> gridR (^2) (Range 0 4) 4 -- [Rect 0.0 1.0 0.0 0.25,Rect 1.0 2.0 0.0 2.25,Rect 2.0 3.0 0.0 6.25,Rect 3.0 4.0 0.0 12.25]-gridR :: (Double -> Double) -> Range Double -> Int -> [Rect Double]-gridR f r g = (\x -> Rect (x - tick / 2) (x + tick / 2) 0 (f x)) <$> grid MidPos r g+gridR :: (Field a, FromIntegral a Int, Ord a) => (a -> a) -> Range a -> Int -> [Rect a]+gridR f r g = (\x -> Rect (x - tick / two) (x + tick / two) zero (f x)) <$> grid MidPos r g where tick = width r / fromIntegral g @@ -276,11 +291,38 @@ -- >>> aspect 2 -- Rect -1.0 1.0 -0.5 0.5 aspect :: Double -> Rect Double-aspect a = Rect (a * (-0.5)) (a * 0.5) (-0.5) 0.5+aspect a = Rect (a * -0.5) (a * 0.5) -0.5 0.5 -- | convert a Rect to a ratio ----- >>> ratio (Rect (-1) 1 (-0.5) 0.5)+-- >>> :set -XNegativeLiterals+-- >>> ratio (Rect -1 1 -0.5 0.5) -- 2.0 ratio :: (Field a) => Rect a -> a ratio (Rect x z y w) = (z - x) / (w - y)++-- | project a Rect from one Rect to another, preserving relative position, with guards for singleton Rects.+--+-- >>> projectOnR one (Rect 0 1 0 1) (Rect 0 0.5 0 0.5)+-- Rect -0.5 0.0 -0.5 0.0+projectOnR :: Rect Double -> Rect Double -> Rect Double -> Rect Double+projectOnR new old@(Rect x z y w) ao@(Rect ox oz oy ow)+ | x == z && y == w = ao+ | x == z = Rect ox oz ny nw+ | y == w = Rect nx nz oy ow+ | otherwise = a+ where+ a@(Rect nx nz ny nw) = projectRect old new ao++-- | project a Point from one Rect to another, preserving relative position, with guards for singleton Rects.+--+-- >>> projectOnP one (Rect 0 1 0 1) zero+-- Point -0.5 -0.5+projectOnP :: Rect Double -> Rect Double -> Point Double -> Point Double+projectOnP new old@(Rect x z y w) po@(Point px py)+ | x == z && y == w = po+ | x == z = Point px py'+ | y == w = Point px' py+ | otherwise = Point px' py'+ where+ (Point px' py') = project old new po
src/NumHask/Space/Time.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -23,13 +24,22 @@ ) where +import Data.Fixed (Fixed (MkFixed)) import Data.List (nub) import Data.String (String) import Data.Time-import NumHask.Space.Types import NumHask.Prelude-import Data.Fixed (Fixed(MkFixed))+import NumHask.Space.Types +-- $setup+--+-- >>> :set -XRebindableSyntax+-- >>> :set -XNegativeLiterals+-- >>> import NumHask.Prelude+-- >>> import NumHask.Space+-- >>> Point 1 1+-- Point 1 1+ -- | parse text as per iso8601 -- -- >>> :set -XOverloadedStrings@@ -58,9 +68,11 @@ grainSecs (Minutes n) = fromIntegral n * 60 grainSecs (Seconds n) = n +-- | convenience conversion to Double fromNominalDiffTime :: NominalDiffTime -> Double-fromNominalDiffTime t = let (MkFixed i) = (nominalDiffTimeToSeconds t) in (fromInteger i) * 1e-12+fromNominalDiffTime t = let (MkFixed i) = nominalDiffTimeToSeconds t in fromInteger i * 1e-12 +-- | convenience conversion from Double toNominalDiffTime :: Double -> NominalDiffTime toNominalDiffTime x = let d0 = ModifiedJulianDay 0@@ -70,25 +82,32 @@ t1 = UTCTime (addDays days d0) (picosecondsToDiffTime $ floor (secs / 1.0e-12)) in diffUTCTime t1 t0 +-- | Convert from 'DiffTime' to seconds (as a Double)+--+-- >>> fromDiffTime $ toDiffTime 1+-- 1.0 fromDiffTime :: DiffTime -> Double fromDiffTime =- (\x -> x / ((10 :: Double) ^ (12 :: Integer))) . fromIntegral . fromEnum+ (/ 1e12) . fromIntegral . fromEnum +-- | Convert from seconds (as a Double) to 'DiffTime'+-- >>> toDiffTime 1+-- 1s toDiffTime :: Double -> DiffTime-toDiffTime d = toEnum . fromEnum $ d * ((10 :: Double) ^ (12 :: Integer))+toDiffTime d = toEnum . fromEnum $ d * 1e12 -- | add a TimeGrain to a UTCTime ----- >>> addGrain (Years 1) 5 (UTCTime (fromGregorian 2015 2 28) 0)+-- >>> addGrain (Years 1) 5 (UTCTime (fromGregorian 2015 2 28) (toDiffTime 0)) -- 2020-02-29 00:00:00 UTC ----- >>> addGrain (Months 1) 1 (UTCTime (fromGregorian 2015 2 28) 0)+-- >>> addGrain (Months 1) 1 (UTCTime (fromGregorian 2015 2 28) (toDiffTime 0)) -- 2015-03-31 00:00:00 UTC ----- >>> addGrain (Hours 6) 5 (UTCTime (fromGregorian 2015 2 28) 0)+-- >>> addGrain (Hours 6) 5 (UTCTime (fromGregorian 2015 2 28) (toDiffTime 0)) -- 2015-03-01 06:00:00 UTC ----- >>> addGrain (Seconds 0.001) (60*1000+1) (UTCTime (fromGregorian 2015 2 28) 0)+-- >>> addGrain (Seconds 0.001) (60*1000+1) (UTCTime (fromGregorian 2015 2 28) (toDiffTime 0)) -- 2015-02-28 00:01:00.001 UTC addGrain :: TimeGrain -> Int -> UTCTime -> UTCTime addGrain (Years n) x (UTCTime d t) =@@ -129,19 +148,19 @@ -- | compute the floor UTCTime based on the timegrain ----- >>> floorGrain (Years 5) (UTCTime (fromGregorian 1999 1 1) 0)+-- >>> floorGrain (Years 5) (UTCTime (fromGregorian 1999 1 1) (toDiffTime 0)) -- 1995-12-31 00:00:00 UTC ----- >>> floorGrain (Months 3) (UTCTime (fromGregorian 2016 12 30) 0)+-- >>> floorGrain (Months 3) (UTCTime (fromGregorian 2016 12 30) (toDiffTime 0)) -- 2016-09-30 00:00:00 UTC ----- >>> floorGrain (Days 5) (UTCTime (fromGregorian 2016 12 30) 1)+-- >>> floorGrain (Days 5) (UTCTime (fromGregorian 2016 12 30) (toDiffTime 1)) -- 2016-12-30 00:00:00 UTC -- -- >>> floorGrain (Minutes 15) (UTCTime (fromGregorian 2016 12 30) (toDiffTime $ 15*60+1)) -- 2016-12-30 00:15:00 UTC ----- >>> floorGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) 0.12)+-- >>> floorGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) ((toDiffTime 0.12))) -- 2016-12-30 00:00:00.1 UTC floorGrain :: TimeGrain -> UTCTime -> UTCTime floorGrain (Years n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' 1 1) (secondsToDiffTime 0)@@ -168,19 +187,19 @@ -- | compute the ceiling UTCTime based on the timegrain ----- >>> ceilingGrain (Years 5) (UTCTime (fromGregorian 1999 1 1) 0)+-- >>> ceilingGrain (Years 5) (UTCTime (fromGregorian 1999 1 1) (toDiffTime 0)) -- 2000-12-31 00:00:00 UTC ----- >>> ceilingGrain (Months 3) (UTCTime (fromGregorian 2016 12 30) 0)+-- >>> ceilingGrain (Months 3) (UTCTime (fromGregorian 2016 12 30) (toDiffTime 0)) -- 2016-12-31 00:00:00 UTC ----- >>> ceilingGrain (Days 5) (UTCTime (fromGregorian 2016 12 30) 1)+-- >>> ceilingGrain (Days 5) (UTCTime (fromGregorian 2016 12 30) (toDiffTime 1)) -- 2016-12-31 00:00:00 UTC -- -- >>> ceilingGrain (Minutes 15) (UTCTime (fromGregorian 2016 12 30) (toDiffTime $ 15*60+1)) -- 2016-12-30 00:30:00 UTC ----- >>> ceilingGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) 0.12)+-- >>> ceilingGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) (toDiffTime 0.12)) -- 2016-12-30 00:00:00.2 UTC ceilingGrain :: TimeGrain -> UTCTime -> UTCTime ceilingGrain (Years n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' 1 1) (secondsToDiffTime 0)@@ -192,7 +211,7 @@ (y, m, _) = toGregorian (addDays 1 d) m' = (m + n - 1) `div` n * n (y', m'') = fromIntegral <$> if m' == 12 then (y + 1, 1) else (y, m' + 1)-ceilingGrain (Days _) (UTCTime d t) = if t == (secondsToDiffTime 0) then UTCTime d (secondsToDiffTime 0) else UTCTime (addDays 1 d) (secondsToDiffTime 0)+ceilingGrain (Days _) (UTCTime d t) = if t == secondsToDiffTime 0 then UTCTime d (secondsToDiffTime 0) else UTCTime (addDays 1 d) (secondsToDiffTime 0) ceilingGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u where s = fromDiffTime t@@ -213,7 +232,7 @@ -- -- The assumption with getSensibleTimeGrid is that there is a list of discountinuous UTCTimes rather than a continuous range. Output is a list of index points for the original [UTCTime] and label tuples, and a list of unused list elements. ----- >>> placedTimeLabelDiscontinuous PosIncludeBoundaries (Just "%d %b") 2 [UTCTime (fromGregorian 2017 12 6) 0, UTCTime (fromGregorian 2017 12 29) 0, UTCTime (fromGregorian 2018 1 31) 0, UTCTime (fromGregorian 2018 3 3) 0]+-- >>> placedTimeLabelDiscontinuous PosIncludeBoundaries (Just "%d %b") 2 [UTCTime (fromGregorian 2017 12 6) (toDiffTime 0), UTCTime (fromGregorian 2017 12 29) (toDiffTime 0), UTCTime (fromGregorian 2018 1 31) (toDiffTime 0), UTCTime (fromGregorian 2018 3 3) (toDiffTime 0)] -- ([(0,"06 Dec"),(1,"31 Dec"),(2,"28 Feb"),(3,"03 Mar")],[]) placedTimeLabelDiscontinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> ([(Int, Text)], [UTCTime]) placedTimeLabelDiscontinuous posd format n ts = (zip (fst <$> inds') labels, rem')@@ -232,7 +251,6 @@ | p > a = (p : ps, xs, n + 1) | otherwise = step (ps, (n - 1, p) : xs, n) a (rem', inds) = done $ foldl' step begin ts- inds' = laterTimes inds fmt = case format of Just f -> unpack f@@ -254,13 +272,13 @@ laterTimes :: [(Int, a)] -> [(Int, a)] laterTimes [] = [] laterTimes [x] = [x]-laterTimes (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x,[]) xs+laterTimes (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x, []) xs where step ((n, a), rs) (na, aa) = if na == n then ((na, aa), rs) else ((na, aa), (n, a) : rs) -- | A sensible time grid between two dates, projected onto (0,1) with no attempt to get finnicky. ----- >>> placedTimeLabelContinuous PosIncludeBoundaries (Just "%d %b") 2 (UTCTime (fromGregorian 2017 12 6) 0, UTCTime (fromGregorian 2017 12 29) 0)+-- >>> placedTimeLabelContinuous PosIncludeBoundaries (Just "%d %b") 2 (UTCTime (fromGregorian 2017 12 6) (toDiffTime 0), UTCTime (fromGregorian 2017 12 29) (toDiffTime 0)) -- [(0.0,"06 Dec"),(0.4347826086956521,"16 Dec"),(0.8695652173913042,"26 Dec"),(0.9999999999999999,"29 Dec")] placedTimeLabelContinuous :: PosDiscontinuous -> Maybe Text -> Int -> (UTCTime, UTCTime) -> [(Double, Text)] placedTimeLabelContinuous posd format n (l, u) = zip tpsd labels@@ -280,16 +298,16 @@ -- | compute a sensible TimeGrain and list of UTCTimes ----- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2016 12 31) 0, UTCTime (fromGregorian 2017 12 31) 0)+-- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2016 12 31) (toDiffTime 0), UTCTime (fromGregorian 2017 12 31) (toDiffTime 0)) -- (Months 6,[2016-12-31 00:00:00 UTC,2017-06-30 00:00:00 UTC,2017-12-31 00:00:00 UTC]) ----- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 0)+-- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0), UTCTime (fromGregorian 2017 12 30) (toDiffTime 0)) -- (Months 6,[2017-06-30 00:00:00 UTC]) ----- >>> sensibleTimeGrid UpperPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 0)+-- >>> sensibleTimeGrid UpperPos 2 (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0), UTCTime (fromGregorian 2017 12 30) (toDiffTime 0)) -- (Months 6,[2017-06-30 00:00:00 UTC,2017-12-31 00:00:00 UTC]) ----- >>>sensibleTimeGrid LowerPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 0)+-- >>>sensibleTimeGrid LowerPos 2 (UTCTime (fromGregorian 2017 1 1) (toDiffTime 0), UTCTime (fromGregorian 2017 12 30) (toDiffTime 0)) -- (Months 6,[2016-12-31 00:00:00 UTC,2017-06-30 00:00:00 UTC]) sensibleTimeGrid :: Pos -> Int -> (UTCTime, UTCTime) -> (TimeGrain, [UTCTime]) sensibleTimeGrid p n (l, u) = (grain, ts)
src/NumHask/Space/Types.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK hide #-} @@ -14,6 +17,8 @@ project, Pos (..), space1,+ randomS,+ randomSs, memberOf, contains, disjoint,@@ -25,13 +30,18 @@ widenEps, scale, move,+ Transform (..),+ inverseTransform,+ Affinity (..),+ (|.),+ rotate, ) where -import NumHask.Prelude+import NumHask.Prelude hiding (rotate) import qualified Prelude as P --- | Space is a continuous range of numbers that contains elements and has an upper and lower value.+-- | A 'Space' is a continuous set of numbers. Continuous here means that the set has an upper and lower bound, and an element that is between these two bounds is a member of the 'Space'. -- -- > a `union` b == b `union` a -- > a `intersection` b == b `intersection` a@@ -74,8 +84,8 @@ -- -- > lower a \/ upper a == lower a -- > lower a /\ upper a == upper a- norm :: s -> s- norm s = lower s ... upper s+ normalise :: s -> s+ normalise s = lower s ... upper s -- | create a normalised space from two elements infix 3 ...@@ -151,6 +161,21 @@ instance (Space a) => Semigroup (Intersection a) where (<>) (Intersection a) (Intersection b) = Intersection (a `union` b) +-- | supply a random element within a 'Space'+randomS :: (Space s, RandomGen g, Random (Element s)) => s -> g -> (Element s, g)+randomS s = randomR (lower s, upper s)++-- | supply an (infinite) list of random elements within a 'Space'+--+-- >>> let g = mkStdGen 42+-- >>> take 3 $ randomSs (one :: Range Double) g+-- [0.43085240252163404,-6.472345419562497e-2,0.3854692674681801]+--+-- >>> take 3 $ randomSs (Rect 0 10 0 10 :: Rect Word8) g+-- [Point 8 0,Point 6 4,Point 5 3]+randomSs :: (Space s, RandomGen g, Random (Element s)) => s -> g -> [Element s]+randomSs s = randomRs (lower s, upper s)+ -- | a space that can be divided neatly -- -- > space1 (grid OuterPos s g) == s@@ -182,7 +207,7 @@ mid :: (Space s, Field (Element s)) => s -> Element s mid s = (lower s + upper s) / (one + one) --- | project a data point from one space to another, preserving relative position+-- | project an element from one space to another, preserving relative position. -- -- > project o n (lower o) = lower n -- > project o n (upper o) = upper n@@ -227,7 +252,7 @@ widenEps :: ( Space s, FromRational (Element s),- Field (Element s)+ Ring (Element s) ) => Element s -> s ->@@ -241,3 +266,75 @@ -- | Move a Space. (scalar addition) move :: (Additive (Element s), Space s) => Element s -> s -> s move e s = (e + lower s) ... (e + upper s)++-- | linear transform + translate of a point-like number+--+-- > (x, y) -> (ax + by + c, dx + ey + d)+--+-- or+--+-- \[+-- \begin{pmatrix}+-- a & b & c\\+-- d & e & f\\+-- 0 & 0 & 1+-- \end{pmatrix}+-- \begin{pmatrix}+-- x\\+-- y\\+-- 1+-- \end{pmatrix}+-- \]+data Transform a = Transform+ { ta :: !a,+ tb :: !a,+ tc :: !a,+ td :: !a,+ te :: !a,+ tf :: !a+ }+ deriving (Eq, Show, Functor, Foldable, Traversable)++-- | Calculate the inverse of a transformation.+inverseTransform :: (Eq a, Field a) => Transform a -> Maybe (Transform a)+inverseTransform (Transform a b c d e f) =+ let det = a * e - b * d+ in bool+ ( Just+ ( Transform+ (a / det)+ (d / det)+ (- (a * c + d * f) / det)+ (b / det)+ (e / det)+ (- (b * c + e * f) / det)+ )+ )+ Nothing+ (det == zero)++-- | An 'Affinity' is something that can be subjected to an affine transformation in 2-dimensional space, where affine means a linear matrix operation or a translation (+).+--+-- https://en.wikipedia.org/wiki/Affine_transformation+class Affinity a b | a -> b where+ transform :: Transform b -> a -> a++infix 3 |.++-- | Apply a 'Transform' to an 'Affinity'+(|.) :: (Affinity a b) => Transform b -> a -> a+(|.) = transform++instance (Multiplicative a, Additive a) => Affinity (Transform a) a where+ transform (Transform a' b' c' d' e' f') (Transform a b c d e f) =+ Transform+ (a * a' + b' * d)+ (a' * b + b' * e)+ (a' * c + b' * f + c')+ (d' * a + e' * d)+ (d' * b + e' * e)+ (d' * c + e' * f + f')++-- | Rotate an 'Affinity'+rotate :: (TrigField a) => a -> Transform a+rotate a = Transform (cos a) (- sin a) zero (sin a) (cos a) zero
src/NumHask/Space/XY.hs view
@@ -1,24 +1,21 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE PatternSynonyms #-} -{- | Unification of a point on the XY-plane and a rectangle on the XY-plane.----}-+-- | Unification of 'Point' and 'Rect'. module NumHask.Space.XY- ( XY(..),+ ( XY (..), pattern P, pattern R, toRect, toPoint, projectOn, projectTo,- fixRect,- ) where+ )+where -import NumHask.Prelude+import GHC.Show (show)+import NumHask.Prelude hiding (show) import NumHask.Space.Point import NumHask.Space.Rect import NumHask.Space.Types@@ -27,8 +24,12 @@ data XY a = PointXY (Point a) | RectXY (Rect a)- deriving (Eq, Show, Functor)+ deriving (Eq, Functor) +instance (Show a) => Show (XY a) where+ show (PointXY (Point x y)) = "P " <> show x <> " " <> show y+ show (RectXY (Rect x z y w)) = "R " <> show x <> " " <> show z <> " " <> show y <> " " <> show w+ -- | make an XY from a point pattern P :: a -> a -> XY a pattern P x y = PointXY (Point x y)@@ -63,12 +64,12 @@ -- * Natural transformations --- | Convert a spot to a Rect+-- | Convert an XY to a Rect toRect :: XY a -> Rect a toRect (PointXY (Point x y)) = Rect x x y y toRect (RectXY a) = a --- | Convert a spot to a Point+-- | Convert an XY to a Point toPoint :: (Ord a, Field a) => XY a -> Point a toPoint (PointXY (Point x y)) = Point x y toPoint (RectXY (Ranges x y)) = Point (mid x) (mid y)@@ -79,37 +80,15 @@ -- | project an XY from one Rect to another, preserving relative position. -- -- >>> projectOn one (Rect 0 1 0 1) zero--- PointXY Point -0.5 -0.5+-- P -0.5 -0.5 projectOn :: Rect Double -> Rect Double -> XY Double -> XY Double-projectOn new old@(Rect x z y w) po@(PointXY (Point px py))- | x == z && y == w = po- | x == z = (P px py')- | y == w = (P px' py)- | otherwise = (P px' py')- where- (Point px' py') = project old new (toPoint po)-projectOn new old@(Rect x z y w) ao@(RectXY (Rect ox oz oy ow))- | x == z && y == w = ao- | x == z = (R ox oz ny nw)- | y == w = (R nx nz oy ow)- | otherwise = RectXY a- where- a@(Rect nx nz ny nw) = projectRect old new (toRect ao)+projectOn new old (PointXY p) = PointXY $ projectOnP new old p+projectOn new old (RectXY r) = RectXY $ projectOnR new old r --- | project a [Spot a] from it's folded space to the given area+-- | project an [XY a] from it's enclosing space to the given space ----- >>> projectTo one (SpotPoint <$> zipWith Point [0..2] [0..2])--- [SpotPoint Point -0.5 -0.5,SpotPoint Point 0.0 0.0,SpotPoint Point 0.5 0.5]+-- >>> projectTo one (zipWith P [0..2] [0..2])+-- [P -0.5 -0.5,P 0.0 0.0,P 0.5 0.5] projectTo :: Rect Double -> [XY Double] -> [XY Double] projectTo _ [] = [] projectTo vb (x : xs) = projectOn vb (toRect $ sconcat (x :| xs)) <$> (x : xs)---- | guard substituting singleton dimensions-fixRect :: Maybe (Rect Double) -> Rect Double-fixRect r = maybe one singletonUnit r- where- singletonUnit (Rect x z y w)- | x == z && y == w = Rect (x - 0.5) (x + 0.5) (y - 0.5) (y + 0.5)- | x == z = Rect (x - 0.5) (x + 0.5) y w- | y == w = Rect x z (y - 0.5) (y + 0.5)- | otherwise = Rect x z y w
test/test.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE NegativeLiterals #-} {-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-imports #-} module Main where @@ -8,9 +11,11 @@ main :: IO () main = doctest- [ "src/NumHask/Space/Histogram.hs",+ [ "src/NumHask/Space.hs",+ "src/NumHask/Space/Histogram.hs", "src/NumHask/Space/Point.hs", "src/NumHask/Space/Range.hs", "src/NumHask/Space/Rect.hs",- "src/NumHask/Space/Time.hs"+ "src/NumHask/Space/Time.hs",+ "src/NumHask/Space/XY.hs" ]