#if ( __GLASGOW_HASKELL__ < 820 )
#endif
module NumHask.Range
( Range(..)
, pattern Range
, gridSensible
) where
import NumHask.Prelude hiding (singleton)
import NumHask.Space
import Data.Functor.Apply (Apply(..))
import Data.Semigroup.Foldable (Foldable1(..))
import Data.Semigroup.Traversable (Traversable1(..))
import Data.Functor.Classes
import Data.Distributive
import Test.QuickCheck.Arbitrary (Arbitrary(..))
import qualified Text.Show as Show
newtype Range a = Range' (a,a)
deriving (Eq, Generic)
pattern Range :: a -> a -> Range a
pattern Range a b = Range' (a, b)
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 Monad Range where
Range a b >>= f = Range a' b' where
Range a' _ = f a
Range _ b' = f 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 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 (Arbitrary a) => Arbitrary (Range a) where
arbitrary = do
a <- arbitrary
b <- arbitrary
pure (Range a b)
instance NFData a => NFData (Range a) where
rnf (Range a b) = rnf a `seq` rnf b
two :: (MultiplicativeUnital a, Additive a) => a
two = one + one
half :: (Field a) => a
half = one / two
instance (FromInteger a, Ord a, BoundedField a) => AdditiveMagma (Range a) where
plus (Range l0 u0) (Range l1 u1) = Range (min l0 l1) (max u0 u1)
instance (FromInteger a, Ord a, BoundedField a) => AdditiveUnital (Range a) where
zero = Range infinity neginfinity
instance (FromInteger a, Ord a, BoundedField a) => AdditiveAssociative (Range a)
instance (FromInteger a, Ord a, BoundedField a) => AdditiveInvertible (Range a) where
negate (Range l u) = Range u l
instance (FromInteger a, Ord a, BoundedField a) => AdditiveCommutative (Range a)
instance (FromInteger a, Ord a, BoundedField a) => Additive (Range a)
instance (FromInteger a, Ord a, BoundedField a) => AdditiveGroup (Range a)
instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeMagma (Range a) where
times a b = Range (m r/two) (m + r/two)
where
m = mid a + mid b
r = width a * width b
instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeUnital (Range a) where
one = Range (negate half) half
instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeAssociative (Range a)
instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeInvertible (Range a) where
recip a = case width a == zero of
True -> theta
False -> Range (m r/two) (m + r/two)
where
m = negate (mid a)
r = recip (width a)
instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeCommutative (Range a)
instance (FromInteger a, Ord a, BoundedField a) => Multiplicative (Range a)
instance (FromInteger a, Ord a, BoundedField a) => MultiplicativeGroup (Range a)
instance (FromInteger a, AdditiveInvertible a, BoundedField a, Ord a) => Signed (Range a) where
sign (Range l u) = if u >= l then one else Range half (negate half)
abs (Range l u) = if u >= l then Range l u else Range u l
instance (AdditiveGroup a) => Normed (Range a) a where
size (Range l u) = ul
instance (Ord a, AdditiveGroup a) => Metric (Range a) a where
distance (Range l u) (Range l' u')
| u < l' = l' u
| u' < l = l u'
| otherwise = zero
instance (BoundedField a, Ord a, FromInteger a, Epsilon a) => Epsilon (Range a) where
nearZero (Range l u) = nearZero (l u)
aboutEqual (Range l u) (Range l' u')= aboutEqual l l' && aboutEqual u u'
theta :: (AdditiveUnital a) => Range a
theta = Range zero zero
instance (FromInteger a, Ord a, BoundedField a) => Space (Range a) where
type Element (Range a) = a
union (Range l0 u0) (Range l1 u1) = Range (min l0 l1) (max u0 u1)
nul = Range infinity neginfinity
lower (Range l _) = l
upper (Range _ u) = u
singleton a = Range a a
type Grid (Range a) = Int
grid :: FromInteger a => Pos -> Range a -> Int -> [a]
grid o s n = (+ if o==MidPos then step/(one+one) else zero) <$> posns
where
posns = (lower s +) . (step *) . fromIntegral <$> [i0..i1]
step = (/) (width s) (fromIntegral n)
(i0,i1) = case o of
OuterPos -> (zero,n)
InnerPos -> (one,n one)
LowerPos -> (zero,n one)
UpperPos -> (one,n)
MidPos -> (zero,n one)
gridSpace r n = zipWith Range ps (drop 1 ps)
where
ps = grid OuterPos r n
instance (Ord a, BoundedField a, FromInteger a) => Monoid (Range a) where
mempty = nul
mappend = union
gridSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) =>
Pos -> Range a -> Int -> [a]
gridSensible tp (Range l u) n =
(+ if tp==MidPos then step/two else zero) <$> posns
where
posns = (first' +) . (step *) . fromIntegral <$> [i0..i1]
span = u l
step' = 10 ^^ floor (logBase 10 (span/fromIntegral n))
err = fromIntegral n / span * step'
step
| err <= 0.15 = 10 * step'
| err <= 0.35 = 5 * step'
| err <= 0.75 = 2 * step'
| otherwise = step'
first' = step * fromIntegral (ceiling (l/step))
last' = step * fromIntegral (floor (u/step))
n' = round ((last' first')/step)
(i0,i1) = case tp of
OuterPos -> (0,n')
InnerPos -> (1,n' 1)
LowerPos -> (0,n' 1)
UpperPos -> (1,n')
MidPos -> (0,n' 1)