numhask-space 0.2.0 → 0.3.0
raw patch · 12 files changed
+1021/−791 lines, 12 filesdep +containersdep +doctestdep +tdigest
Dependencies added: containers, doctest, tdigest
Files
- numhask-space.cabal +20/−9
- src/NumHask/Point.hs +0/−147
- src/NumHask/Range.hs +0/−214
- src/NumHask/Rect.hs +0/−262
- src/NumHask/Space.hs +29/−14
- src/NumHask/Space/Histogram.hs +127/−0
- src/NumHask/Space/Point.hs +146/−0
- src/NumHask/Space/Range.hs +200/−0
- src/NumHask/Space/Rect.hs +303/−0
- src/NumHask/Space/Time.hs +82/−87
- src/NumHask/Space/Types.hs +98/−58
- test/test.hs +16/−0
numhask-space.cabal view
@@ -1,9 +1,9 @@ name: numhask-space-version: 0.2.0+version: 0.3.0 synopsis: numerical spaces description:- Spaces as higher-kinded numbers.+ Spaces and the numerical elements that inhabit them. category: mathematics homepage:@@ -32,10 +32,6 @@ library hs-source-dirs: src- default-extensions:- NegativeLiterals- OverloadedStrings- UnicodeSyntax ghc-options: -Wall -Wcompat@@ -51,12 +47,27 @@ , time >= 1.8.0.2 && <2 , text >= 1.2.3.1 && <2 , foldl >= 1.4.5 && <2+ , containers >= 0.6 && < 0.7+ , tdigest >= 0.2.1 && < 0.3 exposed-modules: NumHask.Space NumHask.Space.Types- NumHask.Range- NumHask.Rect- NumHask.Point+ NumHask.Space.Range+ NumHask.Space.Rect+ NumHask.Space.Point NumHask.Space.Time+ NumHask.Space.Histogram other-modules: default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , doctest+ default-language: Haskell2010+
− src/NumHask/Point.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}---- | A 2-dimensional point.-module NumHask.Point- ( Point(..)- , pattern Point- , rotate- , gridP- ) where--import Prelude-import GHC.Generics (Generic)-import Data.Functor.Classes-import Text.Show-import Algebra.Lattice-import Data.Functor.Rep-import Data.Distributive as D-import NumHask.Range-import NumHask.Space.Types---- $setup--- >>> :set -XNoImplicitPrelude--- >>> :set -XFlexibleContexts------- | A 2-dim point of a's, implemented as a tuple, but api represented as Point a a.------ >>> fmap (+1) (Point 1 2)--- Point 2 3--- >>> pure one :: Point Int--- Point 1 1--- >>> (*) <$> Point 1 2 <*> pure 2--- Point 2 4--- >>> foldr (++) [] (Point [1,2] [3])--- [1,2,3]--- >>> Point "a" "pair" `mappend` pure " " `mappend` Point "string" "mappended"--- Point "a string" "pair mappended"------ As a Ring and Field class------ >>> Point 0 1 + zero--- Point 0 1--- >>> Point 0 1 + Point 2 3--- Point 2 4--- >>> Point 1 1 - one--- Point 0 0--- >>> Point 0 1 * one--- Point 0 1--- >>> Point 0.0 1.0 / one--- Point 0.0 1.0--- >>> Point 11 12 `mod` (pure 6)--- Point 5 0-newtype Point a =- Point' (a, a)- deriving (Eq, Generic)---- | the preferred pattern-pattern Point :: a -> a -> Point a-pattern Point a b = Point' (a,b)-{-# COMPLETE Point#-}--instance (Show a) => Show (Point a) where- show (Point a b) = "Point " <> Text.Show.show a <> " " <> Text.Show.show b--instance Functor Point where- fmap f (Point a b) = Point (f a) (f b)--instance Eq1 Point where- liftEq f (Point a b) (Point c d) = f a c && f b d--instance Show1 Point where- liftShowsPrec sp _ d (Point' (a, b)) = showsBinaryWith sp sp "Point" d a b--instance Applicative Point where- pure a = Point a a- (Point fa fb) <*> Point a b = Point (fa a) (fb b)--instance Monad Point where- Point a b >>= f = Point a' b'- where- Point a' _ = f a- Point _ b' = f b--instance Foldable Point where- foldMap f (Point a b) = f a `mappend` f b--instance Traversable Point where- traverse f (Point a b) = Point <$> f a <*> f b--instance (Semigroup a) => Semigroup (Point a) where- (Point a0 b0) <> (Point a1 b1) = Point (a0 <> a1) (b0 <> b1)--instance (Semigroup a, Monoid a) => Monoid (Point a) where- mempty = Point mempty mempty- mappend = (<>)--instance (Bounded a) => Bounded (Point a) where- minBound = Point minBound minBound- maxBound = Point maxBound maxBound--unaryOp :: (a -> a) -> (Point a -> Point a)-unaryOp f (Point a b) = Point (f a) (f b)--instance (Num a) => Num (Point a) where- (Point a0 b0) + (Point a1 b1) = Point (a0 + a1) (b0 + b1)- negate = unaryOp negate- (Point a0 b0) * (Point a1 b1) = Point (a0 * a1) (b0 * b1)- signum = unaryOp signum- abs = unaryOp abs- fromInteger x = Point (fromInteger x) (fromInteger x)--instance (Fractional a) => Fractional (Point a) where- fromRational x = Point (fromRational x) 0- recip = unaryOp recip--instance Distributive Point where- collect f x = Point (getL . f <$> x) (getR . f <$> x)- where getL (Point l _) = l- getR (Point _ r) = r--instance Representable Point where- type Rep Point = Bool- tabulate f = Point (f False) (f True)- index (Point l _) False = l- index (Point _ r) True = r--instance (Ord a) => Lattice (Point a) where- (\/) (Point x y) (Point x' y') = Point (max x x') (max y y')- (/\) (Point x y) (Point x' y') = Point (min x x') (min y y')---- | rotate a point by x degrees relative to the origin-rotate :: (Floating a) => a -> Point a -> Point a-rotate d (Point x y) = Point (x * cos d' + y*sin d') (y* cos d'-x*sin d')- where- d' = d*pi/180---- | Create Points for a formulae y = f(x) across an x range-gridP :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Point a]-gridP f r g = (\x -> Point x (f x)) <$> grid OuterPos r g
− src/NumHask/Range.hs
@@ -1,214 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wall #-}---- | An Space with no empty, a semigroup based on a convex hull union, and a monoid on a negative space.-module NumHask.Range- ( Range(..)- , pattern Range- , gridSensible- ) where--import Prelude-import Data.Functor.Rep-import Data.Distributive as D-import Data.Bool (bool)-import Data.Functor.Apply (Apply(..))-import Data.Functor.Classes-import Data.Semigroup.Foldable (Foldable1(..))-import Data.Semigroup.Traversable (Traversable1(..))-import GHC.Exts-import GHC.Generics (Generic)-import NumHask.Space.Types as S-import Algebra.Lattice---- $setup--- >>> :set -XNoImplicitPrelude--- >>> :set -XFlexibleContexts---- | A continuous range over type a------ >>> let a = Range (-1) 1--- >>> a--- Range -1 1--- >>> fmap (+1) (Range 1 2)--- Range 2 3--- >>> one :: Range Double--- Range -0.5 0.5--- >>> zero :: Range Double--- Range Infinity -Infinity---- | as a Field instance------ >>> Range 0 1 + zero--- Range 0.0 1.0--- >>> Range 0 1 + Range 2 3--- Range 0.0 3.0--- >>> Range 1 1 - one--- Range 0.5 1.0--- >>> Range 0 1 * one--- Range 0.0 1.0--- >>> Range 0 1 / one--- Range 0.0 1.0--- >>> abs (Range 1 0)--- Range 0.0 1.0--- >>> sign (Range 1 0) == negate one--- True------ Idempotent------ >>> Range 0 2 + Range 0 2--- Range 0.0 2.0------ as a space instance------ >>> NumHask.Space.project (Range 0 1) (Range 1 4) 0.5--- 2.5--- >>> NumHask.Space.grid NumHask.Space.OuterPos (Range 0 10) 5--- [0.0,2.0,4.0,6.0,8.0,10.0]--- >>> NumHask.Space.gridSpace (Range 0 1) 4--- [Range 0.0 0.25,Range 0.25 0.5,Range 0.5 0.75,Range 0.75 1.0]--- >>> gridSensible NumHask.Space.OuterPos (Range (-12.0) 23.0) 6--- [-10.0,-5.0,0.0,5.0,10.0,15.0,20.0]--newtype Range a = Range' (a,a)- deriving (Eq, Generic)---- not sure if this is correct or needed-type role Range representational---- | A tuple is the preferred concrete implementation of a Range, due to many libraries having substantial optimizations for tuples already (eg 'Vector'). 'Pattern Synonyms' allow us to recover a constructor without the need for tuple syntax.-pattern Range :: a -> a -> Range a-pattern Range a b = Range' (a,b)-{-# COMPLETE Range#-}--instance (Show a) => Show (Range a) where- show (Range a b) = "Range " <> show a <> " " <> show b--instance Eq1 Range where- liftEq f (Range a b) (Range c d) = f a c && f b d--instance Show1 Range where- liftShowsPrec sp _ d (Range' (a,b)) = showsBinaryWith sp sp "Range" d a b--instance Functor Range where- fmap f (Range a b) = Range (f a) (f b)--instance Apply Range where- Range fa fb <.> Range a b = Range (fa a) (fb b)--instance Applicative Range where- pure a = Range a a- (Range fa fb) <*> Range a b = Range (fa a) (fb b)--instance Foldable Range where- foldMap f (Range a b) = f a `mappend` f b--instance Foldable1 Range--instance Traversable Range where- traverse f (Range a b) = Range <$> f a <*> f b--instance Traversable1 Range where- traverse1 f (Range a b) = Range <$> f a Data.Functor.Apply.<.> f b--instance D.Distributive Range where- collect f x = Range (getL . f <$> x) (getR . f <$> x)- where getL (Range l _) = l- getR (Range _ r) = r--instance Representable Range where- type Rep Range = Bool- tabulate f = Range (f False) (f True)- index (Range l _) False = l- index (Range _ r) True = r--instance (Ord a) => Lattice (Range a) where- (\/) = liftR2 min- (/\) = liftR2 max--instance (Eq a, Ord a) => Space (Range a) where- type Element (Range a) = a-- lower (Range l _) = l- upper (Range _ u) = u-- (>.<) = Range--instance (Ord a, Fractional a) => FieldSpace (Range a) where- type Grid (Range a) = Int-- grid o s n = (+ bool 0 (step/2) (o==MidPos)) <$> posns- where- posns = (lower s +) . (step *) . fromIntegral <$> [i0..i1]- step = (/) (width s) (fromIntegral n)- (i0,i1) = case o of- OuterPos -> (0,n)- InnerPos -> (1,n - 1)- LowerPos -> (0,n - 1)- UpperPos -> (1,n)- MidPos -> (0,n - 1)- gridSpace r n = zipWith Range ps (drop 1 ps)- where- ps = grid OuterPos r n---- | Monoid based on convex hull union-instance (Eq a, Ord a) => Semigroup (Range a) where- (<>) a b = getUnion (Union a <> Union b)---- | Numeric algebra based on Interval arithmetic--- https://en.wikipedia.org/wiki/Interval_arithmetic-----instance (Num a, Eq a, Ord a) => Num (Range a) where- (Range l u) + (Range l' u') = space1 [l+l',u+u']- negate (Range l u) = negate u ... negate l- (Range l u) * (Range l' u') =- space1 [l * l', l * u', u * l', u * u']- signum (Range l u) = bool (negate 1) 1 (u >= l)- abs (Range l u) = bool (u ... l) (l ... u) (u >= l)- fromInteger x = fromInteger x ... fromInteger x--stepSensible :: (Fractional a, RealFrac a, Floating a, Integral b) => Pos -> a -> b -> a-stepSensible tp span' n =- step + bool 0 (step/2) (tp==MidPos)- where- step' = 10.0 ^^ (floor (logBase 10 (span'/fromIntegral n)) :: Integer)- err = fromIntegral n / span' * step'- step- | err <= 0.15 = 10.0 * step'- | err <= 0.35 = 5.0 * step'- | err <= 0.75 = 2.0 * step'- | otherwise = step'--gridSensible :: (Ord a, RealFrac a, Floating a, Integral b) =>- Pos -> Bool -> Range a -> b -> [a]-gridSensible tp inside r@(Range l u) n =- bool id (filter (`memberOf` r)) inside $- (+ bool 0 (step/2) (tp==MidPos)) <$> posns- where- posns = (first' +) . (step *) . fromIntegral <$> [i0..i1]- span' = u - l- step = stepSensible tp span' n- first' = step * fromIntegral (floor (l/step + 1e-6) :: Integer)- last' = step * fromIntegral (ceiling (u/step - 1e-6) :: Integer)- n' = round ((last' - first')/step)- (i0,i1) =- case tp of- OuterPos -> (0::Integer,n')- InnerPos -> (1,n' - 1)- LowerPos -> (0,n' - 1)- UpperPos -> (1,n')- MidPos -> (0,n' - 1)
− src/NumHask/Rect.hs
@@ -1,262 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wall #-}---- | a two-dimensional plane, implemented as a composite of a 'Point' of 'Range's.-module NumHask.Rect- ( Rect(..)- , pattern Rect- , pattern Ranges- , corners- , corners4- , projectRect- , addRect- , multRect- , unitRect- , foldRect- , addPoint- , rotateRect- , gridR- , gridF- , aspect- , ratio- ) where--import Data.Bool (bool)-import GHC.Exts-import GHC.Generics (Generic)-import Data.Distributive as D-import Data.Functor.Compose-import Data.Functor.Rep-import Prelude-import NumHask.Range-import NumHask.Space.Types-import NumHask.Point-import Algebra.Lattice-import Data.List.NonEmpty-import Data.Semigroup---- $setup--- >>> :set -XNoImplicitPrelude---- | a 'Point' of 'Ranges' that form a rectangle in what is often thought of as the XY plane.------ >>> let a = Rect (-1) 1 (-2) 4--- >>> a--- Rect -1 1 -2 4--- >>> let (Ranges x y) = a--- >>> x--- Range -1 1--- >>> y--- Range -2 4--- >>> fmap (+1) (Rect 1 2 3 4)--- Rect 2 3 4 5--- >>> one :: Rect Double--- Rect -0.5 0.5 -0.5 0.5--- >>> zero :: Rect Double--- Rect Infinity -Infinity Infinity -Infinity------ as a Field instance------ >>> Rect 0 1 2 3 + zero--- Rect 0.0 1.0 2.0 3.0--- >>> Rect 0 1 (-2) (-1) + Rect 2 3 (-5) 3--- Rect 0.0 3.0 -5.0 3.0--- >>> Rect 1 1 1 1 - one--- Rect 0.5 1.0 0.5 1.0--- >>> Rect 0 1 0 1 * one--- Rect 0.0 1.0 0.0 1.0--- >>> Rect 0 1 0 1 / one--- Rect 0.0 1.0 0.0 1.0--- >>> singleton (Point 1.0 2.0) :: Rect Double--- Rect 1.0 1.0 2.0 2.0--- >>> abs (Rect 1 0 1 0)--- Rect 0.0 1.0 0.0 1.0--- >>> sign (Rect 1 0 1 0) == negate one--- True------ as a Space instance------ >>> project (Rect 0 1 (-1) 0) (Rect 1 4 10 0) (Point 0.5 1)--- Point 2.5 -10.0--- >>> gridSpace (Rect 0 10 0 1) (Point 2 2)--- [Rect 0.0 5.0 0.0 0.5,Rect 0.0 5.0 0.5 1.0,Rect 5.0 10.0 0.0 0.5,Rect 5.0 10.0 0.5 1.0]--- >>> grid MidPos (Rect 0 10 0 1) (Point 2 2)--- [Point 2.5 0.25,Point 2.5 0.75,Point 7.5 0.25,Point 7.5 0.75]-newtype Rect a =- Rect' (Compose Point Range a)- deriving (Eq, Functor, Applicative, Foldable, Traversable,- Generic)---- | pattern of Rect lowerx upperx lowery uppery-pattern Rect :: a -> a -> a -> a -> Rect a-pattern Rect a b c d = Rect' (Compose (Point (Range a b) (Range c d)))-{-# COMPLETE Rect#-}---- | pattern of Ranges xrange yrange-pattern Ranges :: Range a -> Range a -> Rect a-pattern Ranges a b = Rect' (Compose (Point a b))-{-# COMPLETE Ranges#-}--instance (Show a) => Show (Rect a) where- show (Rect a b c d) =- "Rect " <> show a <> " " <> show b <> " " <> show c <> " " <> show d--instance Distributive Rect where- collect f x =- Rect (getA . f <$> x) (getB . f <$> x) (getC . f <$> x) (getD . f <$> x)- where- getA (Rect a _ _ _) = a- getB (Rect _ b _ _) = b- getC (Rect _ _ c _) = c- getD (Rect _ _ _ d) = d- -instance Representable Rect where- type Rep Rect = (Bool, Bool)- tabulate f =- Rect (f (False, False)) (f (False, True)) (f (True, False)) (f (True, True))- index (Rect a _ _ _) (False, False) = a- index (Rect _ b _ _) (False, True) = b- index (Rect _ _ c _) (True, False) = c- index (Rect _ _ _ d) (True, True) = d--instance (Ord a) => Semigroup (Rect a) where- (<>) = union--instance (Ord a) => Space (Rect a) where- type Element (Rect a) = Point a-- union (Ranges a b) (Ranges c d) = Ranges (a `union` c) (b `union` d)-- intersection (Ranges a b) (Ranges c d) = Ranges (a `intersection` c)- (b `intersection` d)-- (>.<) (Point l0 l1) (Point u0 u1) = Rect l0 u0 l1 u1-- lower (Rect l0 _ l1 _) = Point l0 l1- upper (Rect _ u0 _ u1) = Point u0 u1-- singleton (Point x y) = Rect x x y y-- (...) p p' = (p /\ p') >.< (p \/ p')-- (|.|) a s = (a `meetLeq` lower s) && (upper s `meetLeq` a)-- (|>|) s0 s1 = lower s0 `meetLeq` upper s1-- (|<|) s0 s1 = lower s1 `joinLeq` upper s0--instance (Ord a, Fractional a, Num a) => FieldSpace (Rect a) where- type Grid (Rect a) = Point Int-- grid o s n = (+ bool 0 (step/2) (o==MidPos)) <$> posns- where- posns =- (lower s +) . (step *) . fmap fromIntegral <$>- [Point x y | x <- [x0 .. x1], y <- [y0 .. y1]]- step = (/) (width s) (fromIntegral <$> n)- (Point x0 y0, Point x1 y1) =- case o of- OuterPos -> (0, n)- InnerPos -> (1, n - 1)- LowerPos -> (0, n - 1)- UpperPos -> (1, n)- MidPos -> (0, n - 1)-- gridSpace (Ranges rX rY) (Point stepX stepY) =- [ Rect x (x + sx) y (y + sy)- | x <- grid LowerPos rX stepX- , y <- grid LowerPos rY stepY- ]- where- sx = width rX / fromIntegral stepX- sy = width rY / fromIntegral stepY---- | create a list of points representing the lower left and upper right corners of a rectangle.-corners :: (Ord a) => Rect a -> [Point a]-corners r = [lower r, upper r]---- | the 4 corners-corners4 :: Rect a -> NonEmpty (Point a)-corners4 (Rect x z y w) =- Point x y :|- [ Point x w- , Point z y- , Point z w- ]----- | project a Rect from an old range to a new 1-projectRect ::- (Ord a, Fractional 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)- (Point b' d') = project r0 r1 (Point b d)----- | Rect projection maths: some sort of affine projection lurking under the hood?--- > width one = one--- > mid zero = zero--addRect :: (Num a) => Rect a -> Rect a -> Rect a-addRect (Rect a b c d) (Rect a' b' c' d') =- Rect (a + a') (b + b') (c + c') (d + d')--multRect :: (Ord a, Fractional a) => Rect a -> Rect a -> Rect a-multRect (Ranges x0 y0) (Ranges x1 y1) =- Ranges (x0 `rtimes` x1) (y0 `rtimes` y1)- where- rtimes a b = bool (Range (m - r/2) (m + r/2)) 0 (a == 0 || b == 0)- where- m = mid a + mid b- r = width a * width b--unitRect :: (Fractional a) => Rect a-unitRect = Ranges rone rone where- rone = Range (-0.5) 0.5--foldRect :: (Ord a) => [Rect a] -> Maybe (Rect a)-foldRect [] = Nothing-foldRect (x:xs) = Just $ sconcat (x :| xs)--addPoint :: (Num a) => Point a -> Rect a -> Rect a-addPoint (Point x' y') (Rect x z y w) = Rect (x+x') (z+x') (y+y') (w+y')---- | rotate the corners of a Rect by x degrees relative to the origin, and fold to a new Rcet-rotateRect :: (Floating a, Ord a) => a -> Rect a -> Rect a-rotateRect d r =- space1 $ rotate d <$> corners r---- | Create Rects for a formulae y = f(x) across an x range-gridR :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Rect a]-gridR f r g = (\x -> Rect (x-tick/2) (x+tick/2) 0 (f x)) <$> grid MidPos r g- where- tick = width r / fromIntegral g---- | Create values c for Rects data for a formulae c = f(x,y)-gridF :: (Ord a, Fractional a) => (Point a -> b) -> Rect a -> Grid (Rect a) -> [(Rect a, b)]-gridF f r g = (\x -> (x, f (mid x))) <$> gridSpace r g---- | convert a ratio of x-plane : y-plane to a ViewBox with a height of one.-aspect :: (Fractional a) => a -> Rect a-aspect a = Rect (a * (-0.5)) (a * 0.5) (-0.5) 0.5---- | convert a Rect to a ratio-ratio :: (Fractional a) => Rect a -> a-ratio (Rect x z y w) = (z-x)/(w-y)
src/NumHask/Space.hs view
@@ -1,28 +1,43 @@ {-# OPTIONS_GHC -Wall #-} --- | a continuous set of numbers--- mathematics does not define a space, so library devs are free to experiment.--- https://en.wikipedia.org/wiki/Interval_(mathematics)+-- | A continuous set of numbers. --+-- Mathematics does not define a space, leaving library devs to experiment.+--+-- https://en.wikipedia.org/wiki/Space_(mathematics)+-- module NumHask.Space ( -- * Space -- $space- module NumHask.Space.Types+ module NumHask.Space.Types,+ -- * Instances- , module NumHask.Point- , module NumHask.Range- , module NumHask.Rect- ) where+ -- $instances+ module NumHask.Space.Point,+ module NumHask.Space.Range,+ module NumHask.Space.Rect,+ module NumHask.Space.Time,+ module NumHask.Space.Histogram,+ )+where -import NumHask.Space.Types-import NumHask.Point-import NumHask.Range-import NumHask.Rect+import NumHask.Space.Point hiding ()+import NumHask.Space.Range hiding ()+import NumHask.Space.Rect hiding ()+import NumHask.Space.Time hiding ()+import NumHask.Space.Histogram hiding ()+import NumHask.Space.Types hiding () -- $space -- The final frontier. -- $instances--- Some concrete data types that are usseful in charting.+-- 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.+--+-- - A histogram is a divided Range with a count of elements within each division.
+ src/NumHask/Space/Histogram.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++-- | A histogram, if you squint, is a series of contiguous ranges, annotated with values.+module NumHask.Space.Histogram+ ( Histogram (..),+ DealOvers (..),+ fill,+ regular,+ makeRects,+ regularQuantiles,+ quantileFold,+ fromQuantiles,+ freq,+ )+where++import qualified Control.Foldl as L+import qualified Data.List+import qualified Data.Map as Map+import Data.Maybe+import Data.TDigest+import NumHask.Space.Range+import NumHask.Space.Rect+import NumHask.Space.Types+import 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+ }+ 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.+data DealOvers = IgnoreOvers | IncludeOvers Double++-- | Fill a Histogram using pre-specified cuts+--+-- >>> fill [0,50,100] [1..100]+-- Histogram {cuts = [0.0,50.0,100.0], values = fromList [(1,50.0),(2,50.0)]}+fill :: (Functor f, Foldable f) => [Double] -> f Double -> Histogram+fill cs xs = Histogram cs (histMap cs xs)+ where+ histMap cs' xs' =+ L.fold count $+ (\x -> L.fold countBool (fmap (x >) cs')) <$> xs'+ count = L.premap (,1.0) countW+ countBool = L.Fold (\x a -> x + if a then 1 else 0) 0 id+ countW = L.Fold (\x (a, w) -> Map.insertWith (+) a w x) Map.empty id++-- | Make a histogram using n equally spaced cuts over the entire range of the data+--+-- >>> regular 4 [0..100]+-- Histogram {cuts = [0.0,25.0,50.0,75.0,100.0], values = fromList [(0,1.0),(1,25.0),(2,25.0),(3,25.0),(4,25.0)]}+regular :: Int -> [Double] -> Histogram+regular n xs = fill cs xs+ where+ cs = grid OuterPos (space1 xs :: Range Double) n++-- | Transform a Histogram to Rects+--+-- >>> makeRects IgnoreOvers (regular 4 [0..100])+-- [Rect 0.0 25.0 0.0 0.25,Rect 25.0 50.0 0.0 0.25,Rect 50.0 75.0 0.0 0.25,Rect 75.0 100.0 0.0 0.25]+makeRects :: DealOvers -> Histogram -> [Rect Double]+makeRects o (Histogram cs counts) = Data.List.zipWith4 Rect x z y w'+ where+ y = repeat 0+ w =+ zipWith+ (/)+ ((\x' -> Map.findWithDefault 0 x' counts) <$> [f .. l])+ (zipWith (-) z x)+ f = case o of+ IgnoreOvers -> 1+ IncludeOvers _ -> 0+ l = case o of+ IgnoreOvers -> length cs - 1+ IncludeOvers _ -> length cs+ w' = (/ sum w) <$> w+ x = case o of+ IgnoreOvers -> cs+ IncludeOvers outw ->+ [Data.List.head cs - outw]+ <> cs+ <> [Data.List.last cs + outw]+ z = drop 1 x++-- | approx regular n-quantiles+--+-- >>> regularQuantiles 4 [0..100]+-- [0.0,24.75,50.0,75.25,100.0]+regularQuantiles :: Double -> [Double] -> [Double]+regularQuantiles n = L.fold (quantileFold qs)+ where+ qs = ((1 / n) *) <$> [0 .. n]++-- | one-pass approximate quantiles fold+quantileFold :: [Double] -> L.Fold Double [Double]+quantileFold qs = L.Fold step begin done+ where+ step x a = Data.TDigest.insert a x+ begin = tdigest ([] :: [Double]) :: TDigest 25+ done x = fromMaybe (0 / 0) . (`quantile` compress x) <$> qs++-- | take a specification of quantiles and make a Histogram+--+-- >>> fromQuantiles [0,0.25,0.5,0.75,1] (regularQuantiles 4 [0..100])+-- Histogram {cuts = [0.0,24.75,50.0,75.25,100.0], values = fromList [(1,0.25),(2,0.25),(3,0.25),(4,0.25)]}+fromQuantiles :: [Double] -> [Double] -> Histogram+fromQuantiles qs xs = Histogram xs (Map.fromList $ zip [1 ..] (diffq qs))+ where+ diffq [] = []+ diffq [_] = []+ diffq (x : xs') = L.fold (L.Fold step (x, []) (reverse . snd)) xs'+ step (a0, xs') a = (a, (a - a0) : xs')++-- | normalize a histogram so that sum values = 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
+ src/NumHask/Space/Point.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}++-- | A 2-dimensional point.+module NumHask.Space.Point+ ( Point (..),+ rotate,+ gridP,+ )+where++import Algebra.Lattice+import Data.Distributive as D+import Data.Functor.Classes+import Data.Functor.Rep+import GHC.Generics (Generic)+import NumHask.Space.Range+import NumHask.Space.Types+import Text.Show+import Prelude++-- $setup+-- ++-- | A 2-dim point of a's+--+-- A Point is functorial over both arguments, and is a Num instance.+--+-- >>> let p = Point 1 1+-- >>> p + p+-- Point 2 2+-- >>> (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.+--+-- >>> Point 0 1 /\ Point 1 0+-- Point 0 0+-- >>> Point 0 1 \/ Point 1 0+-- Point 1 1+data Point a+ = Point a a+ deriving (Eq, Generic)++instance (Show a) => Show (Point a) where+ show (Point a b) = "Point " <> Text.Show.show a <> " " <> Text.Show.show b++instance Functor Point where+ fmap f (Point a b) = Point (f a) (f b)++instance Eq1 Point where+ liftEq f (Point a b) (Point c d) = f a c && f b d++instance Show1 Point where+ liftShowsPrec sp _ d (Point a b) = showsBinaryWith sp sp "Point" d a b++instance Applicative Point where++ pure a = Point a a++ (Point fa fb) <*> Point a b = Point (fa a) (fb b)++instance Monad Point where+ Point a b >>= f = Point a' b'+ where+ Point a' _ = f a+ Point _ b' = f b++instance Foldable Point where+ foldMap f (Point a b) = f a `mappend` f b++instance Traversable Point where+ traverse f (Point a b) = Point <$> f a <*> f b++instance (Semigroup a) => Semigroup (Point a) where+ (Point a0 b0) <> (Point a1 b1) = Point (a0 <> a1) (b0 <> b1)++instance (Semigroup a, Monoid a) => Monoid (Point a) where++ mempty = Point mempty mempty++ mappend = (<>)++instance (Bounded a) => Bounded (Point a) where++ minBound = Point minBound minBound++ maxBound = Point maxBound maxBound++instance (Num a) => Num (Point a) where++ (Point a0 b0) + (Point a1 b1) = Point (a0 + a1) (b0 + b1)++ negate = fmap negate++ (Point a0 b0) * (Point a1 b1) = Point (a0 * a1) (b0 * b1)++ signum = fmap signum++ abs = fmap abs++ fromInteger x = Point (fromInteger x) (fromInteger x)++instance (Fractional a) => Fractional (Point a) where++ fromRational x = Point (fromRational x) (fromRational x) ++ recip = fmap recip++instance Distributive Point where+ collect f x = Point (getL . f <$> x) (getR . f <$> x)+ where+ getL (Point l _) = l+ getR (Point _ r) = r++instance Representable Point where++ type Rep Point = Bool++ tabulate f = Point (f False) (f True)++ index (Point l _) False = l+ index (Point _ r) True = r++instance (Ord a) => Lattice (Point a) where++ (\/) (Point x y) (Point x' y') = Point (max x x') (max y y')++ (/\) (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 :: (Floating a) => a -> Point a -> Point a+rotate d (Point x y) = Point (x * cos d' + y * sin d') (y * cos d' - x * sin d')+ where+ d' = d * pi / 180++-- | Create Points for a formulae y = f(x) across an x range+--+-- >>> 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 :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Point a]+gridP f r g = (\x -> Point x (f x)) <$> grid OuterPos r g
+ src/NumHask/Space/Range.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}++-- | A Space containing numerical elements+module NumHask.Space.Range+ ( Range (..),+ gridSensible,+ )+where++import Algebra.Lattice+import Data.Bool (bool)+import Data.Distributive as D+import Data.Functor.Apply (Apply (..))+import Data.Functor.Classes+import Data.Functor.Rep+import Data.Semigroup.Foldable (Foldable1 (..))+import Data.Semigroup.Traversable (Traversable1 (..))+import GHC.Generics (Generic)+import NumHask.Space.Types as S+import Prelude++-- $setup++-- | A continuous range over type a+--+-- >>> let a = Range (-1) 1+-- >>> 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 1+-- >>> (+1) <$> (Range 1 2)+-- Range 2 3+--+-- Ranges are very useful in shifting a bunch of numbers from one Range to another.+-- eg project 0.5 from the range 0 to 1 to the range 1 to 4+--+-- >>> project (Range 0 1) (Range 1 4) 0.5+-- 2.5+--+-- Create an equally spaced grid including outer bounds over a Range+--+-- >>> grid OuterPos (Range 0 10) 5+-- [0.0,2.0,4.0,6.0,8.0,10.0]+--+-- divide up a Range into equal-sized sections+--+-- >>> gridSpace (Range 0 1) 4+-- [Range 0.0 0.25,Range 0.25 0.5,Range 0.5 0.75,Range 0.75 1.0]+data Range a = Range a a+ deriving (Eq, Generic)++instance (Show a) => Show (Range a) where+ show (Range a b) = "Range " <> show a <> " " <> show b++instance Eq1 Range where+ liftEq f (Range a b) (Range c d) = f a c && f b d++instance Show1 Range where+ liftShowsPrec sp _ d (Range a b) = showsBinaryWith sp sp "Range" d a b++instance Functor Range where+ fmap f (Range a b) = Range (f a) (f b)++instance Apply Range where+ Range fa fb <.> Range a b = Range (fa a) (fb b)++instance Applicative Range where++ pure a = Range a a++ (Range fa fb) <*> Range a b = Range (fa a) (fb b)++instance Foldable Range where+ foldMap f (Range a b) = f a `mappend` f b++instance Foldable1 Range++instance Traversable Range where+ traverse f (Range a b) = Range <$> f a <*> f b++instance Traversable1 Range where+ traverse1 f (Range a b) = Range <$> f a Data.Functor.Apply.<.> f b++instance D.Distributive Range where+ collect f x = Range (getL . f <$> x) (getR . f <$> x)+ where+ getL (Range l _) = l+ getR (Range _ r) = r++instance Representable Range where++ type Rep Range = Bool++ tabulate f = Range (f False) (f True)++ index (Range l _) False = l+ index (Range _ r) True = r++instance (Ord a) => Lattice (Range a) where++ (\/) = liftR2 min++ (/\) = liftR2 max++instance (Eq a, Ord a) => Space (Range a) where++ type Element (Range a) = a++ lower (Range l _) = l++ upper (Range _ u) = u++ (>.<) = Range++instance (Ord a, Fractional a) => FieldSpace (Range a) where++ type Grid (Range a) = Int++ grid o s n = (+ bool 0 (step / 2) (o == MidPos)) <$> posns+ where+ posns = (lower s +) . (step *) . fromIntegral <$> [i0 .. i1]+ step = (/) (width s) (fromIntegral n)+ (i0, i1) = case o of+ OuterPos -> (0, n)+ InnerPos -> (1, n - 1)+ LowerPos -> (0, n - 1)+ UpperPos -> (1, n)+ MidPos -> (0, n - 1)++ gridSpace r n = zipWith Range ps (drop 1 ps)+ where+ ps = grid OuterPos r n++-- | Monoid based on convex hull union+instance (Eq a, Ord a) => Semigroup (Range a) where+ (<>) a b = getUnion (Union a <> Union b)++-- | Numeric algebra based on Interval arithmetic+instance (Num a, Eq a, Ord a) => Num (Range a) where++ (Range l u) + (Range l' u') = space1 [l + l', u + u']++ negate (Range l u) = negate u ... negate l++ (Range l u) * (Range l' u') =+ space1 [l * l', l * u', u * l', u * u']++ signum (Range l u) = bool (negate 1) 1 (u >= l)++ abs (Range l u) = bool (u ... l) (l ... u) (u >= l)++ fromInteger x = fromInteger x ... fromInteger x++stepSensible :: (Fractional a, RealFrac a, Floating a, Integral b) => Pos -> a -> b -> a+stepSensible tp span' n =+ step + bool 0 (step / 2) (tp == MidPos)+ where+ step' = 10.0 ^^ (floor (logBase 10 (span' / fromIntegral n)) :: Integer)+ err = fromIntegral n / span' * step'+ step+ | err <= 0.15 = 10.0 * step'+ | err <= 0.35 = 5.0 * step'+ | err <= 0.75 = 2.0 * step'+ | otherwise = step'++-- | a grid with human sensible (rounded) values+--+-- >>> gridSensible OuterPos False (Range (-12.0) 23.0) 6+-- [-15.0,-10.0,-5.0,0.0,5.0,10.0,15.0,20.0,25.0]+gridSensible ::+ (Ord a, RealFrac a, Floating a, Integral b) =>+ Pos ->+ Bool ->+ Range a ->+ b ->+ [a]+gridSensible tp inside r@(Range l u) n =+ bool id (filter (`memberOf` r)) inside $+ (+ bool 0 (step / 2) (tp == MidPos)) <$> posns+ where+ posns = (first' +) . (step *) . fromIntegral <$> [i0 .. i1]+ span' = u - l+ step = stepSensible tp span' n+ first' = step * fromIntegral (floor (l / step + 1e-6) :: Integer)+ last' = step * fromIntegral (ceiling (u / step - 1e-6) :: Integer)+ n' = round ((last' - first') / step)+ (i0, i1) =+ case tp of+ OuterPos -> (0 :: Integer, n')+ InnerPos -> (1, n' - 1)+ LowerPos -> (0, n' - 1)+ UpperPos -> (1, n')+ MidPos -> (0, n' - 1)
+ src/NumHask/Space/Rect.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wincomplete-patterns #-}++-- | a two-dimensional plane, implemented as a composite of a 'Point' of 'Range's.+module NumHask.Space.Rect+ ( Rect (..),+ pattern Rect,+ pattern Ranges,+ corners,+ corners4,+ projectRect,+ addRect,+ multRect,+ unitRect,+ foldRect,+ addPoint,+ rotateRect,+ gridR,+ gridF,+ aspect,+ ratio,+ )+where++import Algebra.Lattice+import Data.Bool (bool)+import Data.Distributive as D+import Data.Functor.Compose+import Data.Functor.Rep+import Data.List.NonEmpty+import Data.Semigroup+import GHC.Exts+import GHC.Generics (Generic)+import NumHask.Space.Point+import NumHask.Space.Range+import NumHask.Space.Types+import Prelude++-- $setup++-- | a rectangular space often representing a 2-dimensional or XY plane.+--+-- >>> let a = Rect (-1) 1 (-2) 4+-- >>> a+-- Rect -1 1 -2 4+-- >>> let (Ranges x y) = a+-- >>> x+-- Range -1 1+-- >>> y+-- Range -2 4+-- >>> fmap (+1) (Rect 1 2 3 4)+-- Rect 2 3 4 5+--+-- as a Space instance with Points as Elements+--+-- >>> project (Rect 0 1 (-1) 0) (Rect 1 4 10 0) (Point 0.5 1)+-- Point 2.5 -10.0+-- >>> gridSpace (Rect 0 10 0 1) (Point 2 2)+-- [Rect 0.0 5.0 0.0 0.5,Rect 0.0 5.0 0.5 1.0,Rect 5.0 10.0 0.0 0.5,Rect 5.0 10.0 0.5 1.0]+-- >>> grid MidPos (Rect 0 10 0 1) (Point 2 2)+-- [Point 2.5 0.25,Point 2.5 0.75,Point 7.5 0.25,Point 7.5 0.75]+newtype Rect a+ = Rect' (Compose Point Range a)+ deriving+ ( Eq,+ Functor,+ Applicative,+ Foldable,+ Traversable,+ Generic+ )++-- | pattern of Rect lowerx upperx lowery uppery+pattern Rect :: a -> a -> a -> a -> Rect a+pattern Rect a b c d = Rect' (Compose (Point (Range a b) (Range c d)))+{-# COMPLETE Rect #-}++-- | pattern of Ranges xrange yrange+pattern Ranges :: Range a -> Range a -> Rect a+pattern Ranges a b = Rect' (Compose (Point a b))+{-# COMPLETE Ranges #-}++instance (Show a) => Show (Rect a) where+ show (Rect a b c d) =+ "Rect " <> show a <> " " <> show b <> " " <> show c <> " " <> show d++instance Distributive Rect where+ collect f x =+ Rect (getA . f <$> x) (getB . f <$> x) (getC . f <$> x) (getD . f <$> x)+ where+ getA (Rect a _ _ _) = a+ getB (Rect _ b _ _) = b+ getC (Rect _ _ c _) = c+ getD (Rect _ _ _ d) = d++instance Representable Rect where++ type Rep Rect = (Bool, Bool)++ tabulate f =+ Rect (f (False, False)) (f (False, True)) (f (True, False)) (f (True, True))++ index (Rect a _ _ _) (False, False) = a+ index (Rect _ b _ _) (False, True) = b+ index (Rect _ _ c _) (True, False) = c+ index (Rect _ _ _ d) (True, True) = d++instance (Ord a) => Semigroup (Rect a) where+ (<>) = union++instance (Ord a) => Space (Rect a) where++ type Element (Rect a) = Point a++ union (Ranges a b) (Ranges c d) = Ranges (a `union` c) (b `union` d)++ intersection (Ranges a b) (Ranges c d) =+ Ranges+ (a `intersection` c)+ (b `intersection` d)++ (>.<) (Point l0 l1) (Point u0 u1) = Rect l0 u0 l1 u1++ lower (Rect l0 _ l1 _) = Point l0 l1++ upper (Rect _ u0 _ u1) = Point u0 u1++ singleton (Point x y) = Rect x x y y++ (...) p p' = (p /\ p') >.< (p \/ p')++ (|.|) a s = (a `meetLeq` lower s) && (upper s `meetLeq` a)++ (|>|) s0 s1 = lower s0 `meetLeq` upper s1++ (|<|) s0 s1 = lower s1 `joinLeq` upper s0++instance (Ord a, Fractional a, Num a) => FieldSpace (Rect a) where++ type Grid (Rect a) = Point Int++ grid o s n = (+ bool 0 (step / 2) (o == MidPos)) <$> posns+ where+ posns =+ (lower s +) . (step *) . fmap fromIntegral+ <$> [Point x y | x <- [x0 .. x1], y <- [y0 .. y1]]+ step = (/) (width s) (fromIntegral <$> n)+ (Point x0 y0, Point x1 y1) =+ case o of+ OuterPos -> (0, n)+ InnerPos -> (1, n - 1)+ LowerPos -> (0, n - 1)+ UpperPos -> (1, n)+ MidPos -> (0, n - 1)++ gridSpace (Ranges rX rY) (Point stepX stepY) =+ [ Rect x (x + sx) y (y + sy)+ | x <- grid LowerPos rX stepX,+ y <- grid LowerPos rY stepY+ ]+ where+ sx = width rX / fromIntegral stepX+ sy = width rY / fromIntegral stepY++-- | create a list of points representing the lower left and upper right corners of a rectangle.+--+-- >>> corners unitRect+-- [Point -0.5 -0.5,Point 0.5 0.5]+corners :: (Ord a) => Rect a -> [Point a]+corners r = [lower r, upper r]++-- | the 4 corners+--+-- >>> corners4 unitRect+-- [Point -0.5 -0.5,Point -0.5 0.5,Point 0.5 -0.5,Point 0.5 0.5]+corners4 :: Rect a -> [Point a]+corners4 (Rect x z y w) =+ [ Point x y,+ Point x w,+ Point z y,+ Point z w+ ]++-- | project a Rect from an old Space (Rect) to a new one.+--+-- The Space instance of Rect uses Points as Elements, but a Rect can also be a Space over Rects.+--+-- >>> 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 ::+ (Ord a, Fractional 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)+ (Point b' d') = project r0 r1 (Point b d)++-- | Numeric algebra based on interval arithmetioc for addition and unitRect and projection for multiplication+instance (Fractional a, Num a, Eq a, Ord a) => Num (Rect a) where++ (+) = addRect++ negate = fmap negate++ (*) = multRect++ signum (Rect x z y w) = bool (negate 1) 1 (z >= x && (w >= y))++ abs (Ranges x y) = Ranges (norm x) (norm y)++ fromInteger x = fromInteger x ... fromInteger x++-- | Rect addition+--+-- >>> unitRect `addRect` unitRect+-- Rect -1.0 1.0 -1.0 1.0+addRect :: (Num a) => Rect a -> Rect a -> Rect a+addRect (Rect a b c d) (Rect a' b' c' d') =+ Rect (a + a') (b + b') (c + c') (d + d')++-- | Rect multiplication+--+-- >>> unitRect `multRect` Rect 0 2 0 4+-- Rect 0.0 2.0 0.0 4.0+multRect :: (Ord a, Fractional a) => Rect a -> Rect a -> Rect a+multRect (Ranges x0 y0) (Ranges x1 y1) =+ Ranges (x0 `rtimes` x1) (y0 `rtimes` y1)+ where+ rtimes a b = bool (Range (m - r / 2) (m + r / 2)) 0 (a == 0 || b == 0)+ where+ m = mid a + mid b+ r = width a * width b++-- | a unit Rectangle, with values chosen so that width and height are one and mid is zero+--+-- >>> unitRect :: Rect Double+-- Rect -0.5 0.5 -0.5 0.5+unitRect :: (Fractional a) => Rect a+unitRect = Ranges rone rone+ where+ rone = Range (-0.5) 0.5++-- | convex hull union of Rect's+--+-- >>> foldRect [Rect 0 1 0 1, unitRect]+-- Just Rect -0.5 1.0 -0.5 1.0+foldRect :: (Ord a) => [Rect a] -> Maybe (Rect a)+foldRect [] = Nothing+foldRect (x : xs) = Just $ sconcat (x :| xs)++-- | add a Point to a Rect+--+-- >>> addPoint (Point 0 1) unitRect+-- Rect -0.5 0.5 0.5 1.5+addPoint :: (Num a) => Point a -> Rect a -> Rect a+addPoint (Point x' y') (Rect x z y w) = Rect (x + x') (z + x') (y + y') (w + y')++-- | rotate the corners of a Rect by x degrees relative to the origin, and fold to a new Rect+--+-- >>> rotateRect 45 unitRect+-- Rect -0.7071067811865475 0.7071067811865475 -5.551115123125783e-17 5.551115123125783e-17+rotateRect :: (Floating a, Ord a) => a -> Rect a -> Rect a+rotateRect d r =+ space1 $ rotate d <$> corners r++-- | 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+-- [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 :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Rect a]+gridR f r g = (\x -> Rect (x - tick / 2) (x + tick / 2) 0 (f x)) <$> grid MidPos r g+ where+ tick = width r / fromIntegral g++-- | Create values c for Rects data for a formulae c = f(x,y)+--+-- >>> gridF (\(Point x y) -> x * y) (Rect 0 4 0 4) (Point 2 2)+-- [(Rect 0.0 2.0 0.0 2.0,1.0),(Rect 0.0 2.0 2.0 4.0,3.0),(Rect 2.0 4.0 0.0 2.0,3.0),(Rect 2.0 4.0 2.0 4.0,9.0)]+gridF :: (Ord a, Fractional a) => (Point a -> b) -> Rect a -> Grid (Rect a) -> [(Rect a, b)]+gridF f r g = (\x -> (x, f (mid x))) <$> gridSpace r g++-- | convert a ratio (eg x:1) to a Rect with a height of one.+--+-- >>> aspect 2+-- Rect -1.0 1.0 -0.5 0.5+aspect :: (Fractional a) => a -> Rect a+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)+-- 2.0+ratio :: (Fractional a) => Rect a -> a+ratio (Rect x z y w) = (z - x) / (w - y)
src/NumHask/Space/Time.hs view
@@ -1,31 +1,27 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- | data algorithms related to time (as a Space) module NumHask.Space.Time- ( parseUTCTime- , TimeGrain(..)- , floorGrain- , ceilingGrain- , sensibleTimeGrid- , PosDiscontinuous(..)- , placedTimeLabelDiscontinuous- ) where+ ( parseUTCTime,+ TimeGrain (..),+ floorGrain,+ ceilingGrain,+ sensibleTimeGrid,+ PosDiscontinuous (..),+ placedTimeLabelDiscontinuous,+ )+where +import qualified Control.Foldl as L+import qualified Data.Text as Text+import Data.Text (Text) import Data.Time import GHC.Base (String) import GHC.Generics+import NumHask.Space.Types import Prelude-import qualified Control.Foldl as L-import qualified Data.Text as Text-import Data.Text (Text)-import NumHask.Space -- | parse text as per iso8601 --@@ -33,7 +29,6 @@ -- >>> let t0 = parseUTCTime ("2017-12-05" :: Text) -- >>> t0 -- Just 2017-12-05 00:00:00 UTC--- parseUTCTime :: Text -> Maybe UTCTime parseUTCTime = parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing) . Text.unpack@@ -58,7 +53,7 @@ toDouble :: NominalDiffTime -> Double toDouble t =- (/1000000000000.0) $+ (/ 1000000000000.0) $ fromIntegral (floor $ t * 1000000000000 :: Integer) toDouble' :: DiffTime -> Double@@ -68,14 +63,14 @@ fromDouble :: Double -> NominalDiffTime fromDouble x = let d0 = ModifiedJulianDay 0- days = floor (x/toDouble nominalDay)+ days = floor (x / toDouble nominalDay) secs = x - fromIntegral days * toDouble nominalDay t0 = UTCTime d0 (picosecondsToDiffTime 0) t1 = UTCTime (addDays days d0) (picosecondsToDiffTime $ floor (secs / 1.0e-12))- in diffUTCTime t1 t0+ in diffUTCTime t1 t0 fromDouble' :: Double -> DiffTime-fromDouble' d = toEnum $ fromEnum $ d * ((10 :: Double) ^ (12 :: Integer))+fromDouble' d = toEnum . fromEnum $ d * ((10 :: Double) ^ (12 :: Integer)) -- | add a TimeGrain to a UTCTime --@@ -84,41 +79,45 @@ -- -- >>> addGrain (Months 1) 1 (UTCTime (fromGregorian 2015 2 28) 0) -- 2015-03-31 00:00:00 UTC--- +-- -- >>> addGrain (Hours 6) 5 (UTCTime (fromGregorian 2015 2 28) 0) -- 2015-03-01 06:00:00 UTC--- +-- -- >>> addGrain (Seconds 0.001) (60*1000+1) (UTCTime (fromGregorian 2015 2 28) 0) -- 2015-02-28 00:01:00.001 UTC--- addGrain :: TimeGrain -> Int -> UTCTime -> UTCTime addGrain (Years n) x (UTCTime d t) =- UTCTime (addDays (-1) $ addGregorianYearsClip (n*fromIntegral x) (addDays 1 d)) t+ UTCTime (addDays (-1) $ addGregorianYearsClip (n * fromIntegral x) (addDays 1 d)) t addGrain (Months n) x (UTCTime d t) =- UTCTime (addDays (-1) $ addGregorianMonthsClip (fromIntegral (n*x)) (addDays 1 d)) t+ UTCTime (addDays (-1) $ addGregorianMonthsClip (fromIntegral (n * x)) (addDays 1 d)) t addGrain (Days n) x (UTCTime d t) = UTCTime (addDays (fromIntegral x * fromIntegral n) d) t addGrain g@(Hours _) x d = addUTCTime (fromDouble (fromIntegral x * grainSecs g)) d addGrain g@(Minutes _) x d = addUTCTime (fromDouble (fromIntegral x * grainSecs g)) d addGrain g@(Seconds _) x d = addUTCTime (fromDouble (fromIntegral x * grainSecs g)) d - addHalfGrain :: TimeGrain -> UTCTime -> UTCTime addHalfGrain (Years n) (UTCTime d t) =- UTCTime (addDays (-1) $ (if m'==1 then addGregorianMonthsClip 6 else id) $- addGregorianYearsClip d' (addDays 1 d)) t+ UTCTime+ ( addDays (-1) . (if m' == 1 then addGregorianMonthsClip 6 else id) $+ addGregorianYearsClip d' (addDays 1 d)+ )+ t where- (d',m') = divMod 2 n+ (d', m') = divMod 2 n addHalfGrain (Months n) (UTCTime d t) =- UTCTime (addDays (if m'==1 then 15 else 0) {- sue me -} $- addDays (-1) $- addGregorianMonthsClip (fromIntegral d') (addDays 1 d)) t+ UTCTime+ ( addDays (if m' == 1 then 15 else 0 {- sue me -})+ . addDays (-1)+ $ addGregorianMonthsClip (fromIntegral d') (addDays 1 d)+ )+ t where- (d',m') = divMod 2 n+ (d', m') = divMod 2 n addHalfGrain (Days n) (UTCTime d t) =- (if m'== 1 then addUTCTime (fromDouble (0.5 * grainSecs (Days 1))) else id) $+ (if m' == 1 then addUTCTime (fromDouble (0.5 * grainSecs (Days 1))) else id) $ UTCTime (addDays (fromIntegral d') d) t where- (d',m') = divMod 2 n+ (d', m') = divMod 2 n addHalfGrain g@(Hours _) d = addUTCTime (fromDouble (0.5 * grainSecs g)) d addHalfGrain g@(Minutes _) d = addUTCTime (fromDouble (0.5 * grainSecs g)) d addHalfGrain g@(Seconds _) d = addUTCTime (fromDouble (0.5 * grainSecs g)) d@@ -139,25 +138,24 @@ -- -- >>> floorGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) 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) 0 where- (y,_,_) = toGregorian (addDays 1 d)+ (y, _, _) = toGregorian (addDays 1 d) y' = fromIntegral $ 1 + n * floor (fromIntegral (y - 1) / fromIntegral n :: Double) floorGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y m' 1) 0 where- (y,m,_) = toGregorian (addDays 1 d)+ (y, m, _) = toGregorian (addDays 1 d) m' = fromIntegral (1 + fromIntegral n * floor (fromIntegral (m - 1) / fromIntegral n :: Double) :: Integer) floorGrain (Days _) (UTCTime d _) = UTCTime d 0 floorGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t- x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (floor (s / (fromIntegral h*3600)) :: Integer)) - s+ x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (floor (s / (fromIntegral h * 3600)) :: Integer)) - s floorGrain (Minutes m) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t- x = fromDouble $ fromIntegral (m * 60 * fromIntegral (floor (s / (fromIntegral m*60)) :: Integer)) - s+ x = fromDouble $ fromIntegral (m * 60 * fromIntegral (floor (s / (fromIntegral m * 60)) :: Integer)) - s floorGrain (Seconds secs) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t@@ -179,26 +177,25 @@ -- -- >>> ceilingGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) 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) 0 where- (y,_,_) = toGregorian (addDays 1 d)+ (y, _, _) = toGregorian (addDays 1 d) y' = fromIntegral $ 1 + n * ceiling (fromIntegral (y - 1) / fromIntegral n :: Double) ceilingGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' m'' 1) 0 where- (y,m,_) = toGregorian (addDays 1 d)+ (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==0 then UTCTime d 0 else UTCTime (addDays 1 d) 0+ (y', m'') = fromIntegral <$> if m' == 12 then (y + 1, 1) else (y, m' + 1)+ceilingGrain (Days _) (UTCTime d t) = if t == 0 then UTCTime d 0 else UTCTime (addDays 1 d) 0 ceilingGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t- x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (ceiling (s / (fromIntegral h*3600)) :: Integer)) - s+ x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (ceiling (s / (fromIntegral h * 3600)) :: Integer)) - s ceilingGrain (Minutes m) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t- x = fromDouble $ fromIntegral (m * 60 * fromIntegral (ceiling (s / (fromIntegral m*60)) :: Integer)) - s+ x = fromDouble $ fromIntegral (m * 60 * fromIntegral (ceiling (s / (fromIntegral m * 60)) :: Integer)) - s ceilingGrain (Seconds secs) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t@@ -212,7 +209,6 @@ -- -- >>> 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] -- ([(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') where@@ -231,32 +227,32 @@ autoFormat :: TimeGrain -> String autoFormat (Years x)- | x == 1 = "%b %Y"- | otherwise = "%Y"+ | x == 1 = "%b %Y"+ | otherwise = "%Y" autoFormat (Months _) = "%d %b %Y" autoFormat (Days _) = "%d %b %y" autoFormat (Hours x)- | x > 3 = "%d/%m/%y %R"- | otherwise = "%R"+ | x > 3 = "%d/%m/%y %R"+ | otherwise = "%R" autoFormat (Minutes _) = "%R" autoFormat (Seconds _) = "%R%Q" matchTimes :: [UTCTime] -> L.Fold UTCTime ([UTCTime], [(Int, UTCTime)])-matchTimes ticks = L.Fold step begin (\(p,x,_) -> (p,reverse x))+matchTimes ticks = L.Fold step begin (\(p, x, _) -> (p, reverse x)) where- begin = (ticks,[],0)+ begin = (ticks, [], 0) step ([], xs, n) _ = ([], xs, n)- step (p:ps, xs, n) a- | p == a = step (ps, (n,p):xs, n) a- | p > a = (p:ps, xs, n + 1)- | otherwise = step (ps, (n - 1,p):xs, n) a+ step (p : ps, xs, n) a+ | p == a = step (ps, (n, p) : xs, n) a+ | p > a = (p : ps, xs, n + 1)+ | otherwise = step (ps, (n - 1, p) : xs, n) a -laterTimes :: [(Int, a)] -> [(Int,a)]+laterTimes :: [(Int, a)] -> [(Int, a)] laterTimes [] = [] laterTimes [x] = [x]-laterTimes (x:xs) = L.fold (L.Fold step (x,[]) (\(x0,x1) -> reverse $ x0:x1)) xs+laterTimes (x : xs) = L.fold (L.Fold step (x, []) (\(x0, x1) -> reverse $ x0 : x1)) xs where- step ((n,a), rs) (na, aa) = if na == n then ((na,aa),rs) else ((na,aa),(n,a):rs)+ step ((n, a), rs) (na, aa) = if na == n then ((na, aa), rs) else ((na, aa), (n, a) : rs) -- | compute a sensible TimeGrain and list of UTCTimes --@@ -268,10 +264,9 @@ -- -- >>> sensibleTimeGrid UpperPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 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) -- (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) where@@ -281,27 +276,27 @@ last' = ceilingGrain grain u n' = round $ toDouble (diffUTCTime last' first') / grainSecs grain :: Integer posns = case p of- OuterPos -> take (fromIntegral $ n'+1)- InnerPos -> drop (if first'==l then 0 else 1) . take (fromIntegral $ n' + if last'==u then 1 else 0)+ OuterPos -> take (fromIntegral $ n' + 1)+ InnerPos -> drop (if first' == l then 0 else 1) . take (fromIntegral $ n' + if last' == u then 1 else 0) UpperPos -> drop 1 . take (fromIntegral $ n' + 1) LowerPos -> take (fromIntegral n') MidPos -> take (fromIntegral n') ts = case p of- MidPos -> take (fromIntegral n') $ addHalfGrain grain . (\x -> addGrain grain x first') <$> [0..]- _ -> posns $ (\x -> addGrain grain x first') <$> [0..]+ MidPos -> take (fromIntegral n') $ addHalfGrain grain . (\x -> addGrain grain x first') <$> [0 ..]+ _ -> posns $ (\x -> addGrain grain x first') <$> [0 ..] -- come up with a sensible step for a grid over a Field stepSensible ::- (Fractional a, RealFrac a, Floating a)- => Pos- -> a- -> Int- -> a+ (Fractional a, RealFrac a, Floating a) =>+ Pos ->+ a ->+ Int ->+ a stepSensible tp span' n =- step +- if tp == MidPos- then step / 2- else 0+ step+ + if tp == MidPos+ then step / 2+ else 0 where step' = 10 ^^ (floor (logBase 10 (span' / fromIntegral n)) :: Integer) err = fromIntegral n / span' * step'@@ -314,16 +309,16 @@ -- come up with a sensible step for a grid over a Field, where sensible means the 18th century -- practice of using multiples of 3 to round stepSensible3 ::- (Fractional a, Floating a, RealFrac a)- => Pos- -> a- -> Int- -> a+ (Fractional a, Floating a, RealFrac a) =>+ Pos ->+ a ->+ Int ->+ a stepSensible3 tp span' n =- step +- if tp == MidPos- then step / 2- else 0+ step+ + if tp == MidPos+ then step / 2+ else 0 where step' = 10 ^^ (floor (logBase 10 (span' / fromIntegral n)) :: Integer) err = fromIntegral n / span' * step'
src/NumHask/Space/Types.hs view
@@ -1,35 +1,44 @@-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK hide #-} +-- | Space types module NumHask.Space.Types- ( Space(..)- , Union(..)- , Intersection(..)- , FieldSpace(..)- , mid- , project- , Pos(..)- , space1- , memberOf- , contains- , disjoint- , width- , (+/-)- , monotone- , eps- , widen- , widenEps- , scale- , move+ ( Space (..),+ Union (..),+ Intersection (..),+ FieldSpace (..),+ mid,+ project,+ Pos (..),+ space1,+ memberOf,+ contains,+ disjoint,+ width,+ (+/-),+ monotone,+ eps,+ widen,+ widenEps,+ scale,+ move, )- where +import Prelude++-- | Space is a continuous range of numbers that contains elements and has an upper and lower value.+--+-- > a `union` b == b `union` a+-- > a `intersection` b == b `intersection` a+-- > (a `union` b) `intersection` c == (a `intersection` b) `union` (a `intersection` c)+-- > (a `intersection` b) `union` c == (a `union` b) `intersection` (a `union` c)+-- > norm (norm a) = norm a+-- > a |>| b == b |<| a+-- > a |.| singleton a+ class Space s where -- | the underlying element in the space@@ -49,16 +58,19 @@ intersection :: s -> s -> s default intersection :: (Ord (Element s)) => s -> s -> s- intersection a b = l >.< u where+ intersection a b = l >.< u+ where l = lower a `max` lower b u = upper a `min` upper b -- | the union of two spaces union :: s -> s -> s+ default union :: (Ord (Element s)) => s -> s -> s- union a b = l >.< u where- l = lower a `min` lower b- u = upper a `max` upper b+ union a b = l >.< u+ where+ l = lower a `min` lower b+ u = upper a `max` upper b -- | Normalise a space so that -- > lower a \/ upper a == lower a@@ -68,45 +80,57 @@ -- | create a normalised space from two elements infix 3 ...+ (...) :: Element s -> Element s -> s+ default (...) :: (Ord (Element s)) => Element s -> Element s -> s (...) a b = (a `min` b) >.< (a `max` b) -- | create a space from two elements without normalising infix 3 >.<+ (>.<) :: Element s -> Element s -> s -- | is an element in the space infixl 7 |.|+ (|.|) :: Element s -> s -> Bool+ default (|.|) :: (Ord (Element s)) => Element s -> s -> Bool (|.|) a s = (a >= lower s) && (upper s >= a) -- | is one space completely above the other infixl 7 |>|+ (|>|) :: s -> s -> Bool+ default (|>|) :: (Ord (Element s)) => s -> s -> Bool (|>|) s0 s1 = lower s0 >= upper s1 -- | is one space completely below the other infixl 7 |<|+ (|<|) :: s -> s -> Bool+ default (|<|) :: (Ord (Element s)) => s -> s -> Bool (|<|) s0 s1 = lower s1 <= upper s0 -- | is a space contained within another?+--+-- > (a `union` b) `contains` a+-- > (a `union` b) `contains` b contains :: (Space s) => s -> s -> Bool contains s0 s1 =- lower s1 |.| s0 &&- upper s1 |.| s0+ lower s1 |.| s0+ && upper s1 |.| s0 -- | are two spaces disjoint? disjoint :: (Space s) => s -> s -> Bool disjoint s0 s1 = s0 |>| s1 || s0 |<| s1 --- (|.|) a s = (a `joinLeq` lower s) && (upper s `meetLeq` a)+-- | is an element contained within a space memberOf :: (Space s) => Element s -> s -> Bool memberOf = (|.|) @@ -116,22 +140,28 @@ -- | create a space centered on a plus or minus b infixl 6 +/-+ (+/-) :: (Space s, Num (Element s)) => Element s -> Element s -> s a +/- b = a - b ... a + b -newtype Union a = Union { getUnion :: a }+-- | a convex hull+newtype Union a = Union {getUnion :: a} instance (Space a) => Semigroup (Union a) where (<>) (Union a) (Union b) = Union (a `union` b) -newtype Intersection a = Intersection { getIntersection :: a }+-- | https://en.wikipedia.org/wiki/Intersection_(set_theory)+newtype Intersection a = Intersection {getIntersection :: a} instance (Space a) => Semigroup (Intersection a) where (<>) (Intersection a) (Intersection b) = Intersection (a `union` b) -- | a space that can be divided neatly --+-- > space1 (grid OuterPos s g) == s+-- > getUnion (sconcat (Union <$> (gridSpace s g))) == s class (Space s, Num (Element s)) => FieldSpace s where+ type Grid s :: * -- | create equally-spaced elements across a space@@ -141,26 +171,33 @@ gridSpace :: s -> Grid s -> [s] -- | Pos suggests where points should be placed in forming a grid across a field space.-data Pos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Show, Eq)+data Pos =+ -- | include boundaries+ OuterPos |+ -- | don't include boundaries+ InnerPos |+ -- | include the lower boundary+ LowerPos |+ -- | include the upper boundary+ UpperPos |+ -- | use the mid-point of the space+ MidPos deriving (Show, Eq) --- | mid-point of the space+-- | middle element of the space mid :: (Space s, Fractional (Element s)) => s -> Element s-mid s = (lower s + upper s)/2.0+mid s = (lower s + upper s) / 2.0 -- | project a data point from one space to another, preserving relative position -- -- > project o n (lower o) = lower n -- > project o n (upper o) = upper n -- > project a a x = x--- > project mempty one zero = NaN--- > project one mempty zero = Infinity--- > project one mempty one = NaN--- project :: (Space s, Fractional (Element s)) => s -> s -> Element s -> Element s project s0 s1 p =- ((p-lower s0)/(upper s0-lower s0)) * (upper s1-lower s1) + lower s1+ ((p - lower s0) / (upper s0 - lower s0)) * (upper s1 - lower s1) + lower s1 -- | the containing space of a non-empty Traversable+-- > all $ space1 a `contains` <$> a space1 :: (Space s, Traversable f) => f (Element s) -> s space1 = foldr1 union . fmap singleton @@ -170,35 +207,38 @@ -- | a small space eps ::- ( Space s- , Fractional (Element s)- )- => Element s -> Element s -> s+ ( Space s,+ Fractional (Element s)+ ) =>+ Element s ->+ Element s ->+ s eps accuracy a = a +/- (accuracy * a * 1e-6) -- | widen a space widen ::- ( Space s- , Num (Element s))- => Element s -> s -> s+ ( Space s,+ Num (Element s)+ ) =>+ Element s ->+ s ->+ s widen a s = (lower s - a) >.< (upper s + a) -- | widen by a small amount widenEps ::- ( Space s- , Fractional (Element s)- )- => Element s -> s -> s+ ( Space s,+ Fractional (Element s)+ ) =>+ Element s ->+ s ->+ s widenEps accuracy = widen (accuracy * 1e-6) --- | scale a Space+-- | Scale a Space. (scalar multiplication) scale :: (Num (Element s), Space s) => Element s -> s -> s scale e s = (e * lower s) ... (e * upper s) --- | move a Space+-- | Move a Space. (scalar addition) move :: (Num (Element s), Space s) => Element s -> s -> s move e s = (e + lower s) ... (e + upper s)----
+ test/test.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall #-}++module Main where++import Test.DocTest+import Prelude++main :: IO ()+main =+ doctest+ [ "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"+ ]