module NumHask.Range
( Range(..)
, (...)
, low
, high
, mid
, width
, element
, singleton
, singular
, intersection
, contains
, range
, project
, LinearPos(..)
, linearSpace
, linearSpaceSensible
, fromLinearSpace
) where
import NumHask.Prelude
import Control.Category (id)
import Control.Lens hiding (Magma, singular, element, contains, (...))
import qualified Control.Foldl as L
import Test.QuickCheck
newtype Range a = Range { range_ :: (a, a) }
deriving (Eq, Ord, Show, Functor)
(...) :: Ord a => a -> a -> Range a
a ... b
| a <= b = Range (a, b)
| otherwise = Range (b, a)
low :: Lens' (Range a) a
low = lens (\(Range (l,_)) -> l) (\(Range (_,u)) l -> Range (l,u))
high :: Lens' (Range a) a
high = lens (\(Range (_,u)) -> u) (\(Range (l,_)) u -> Range (l,u))
mid ::
(BoundedField a) =>
Lens' (Range a) a
mid =
lens
plushom
(\r m -> Range (m plushom r, m + plushom r))
width ::
(BoundedField a) =>
Lens' (Range a) a
width =
lens
(\(Range (l,u)) -> (ul))
(\r w -> Range (plushom r w/two, plushom r + w/two))
instance (Arbitrary a) => Arbitrary (Range a) where
arbitrary = do
a <- arbitrary
b <- arbitrary
pure (Range (a,b))
instance (Ord a) => AdditiveMagma (Range a) where
plus (Range (l0,u0)) (Range (l1,u1)) = Range (min l0 l1, max u0 u1)
instance (Ord a, BoundedField a) => AdditiveUnital (Range a) where
zero = Range (infinity,neginfinity)
instance (Ord a) => AdditiveAssociative (Range a)
instance (Ord a) => AdditiveCommutative (Range a)
instance (Ord a, BoundedField a) => Additive (Range a)
instance (Ord a) => Semigroup (Range a) where
(<>) = plus
instance (AdditiveUnital (Range a), Semigroup (Range a)) => Monoid (Range a) where
mempty = zero
mappend = (<>)
instance (Ord a) => AdditiveInvertible (Range a)
where
negate (Range (l,u)) = Range (u,l)
instance (BoundedField a, Ord a) => AdditiveGroup (Range a)
instance (BoundedField a) =>
AdditiveHomomorphic (Range a) a where
plushom (Range (l,u)) = (l+u)/two
instance (Ord a) =>
AdditiveHomomorphic a (Range a) where
plushom a = singleton a
instance (BoundedField a) => MultiplicativeMagma (Range a) where
times a b = Range (m r/two, m + r/two)
where
m = view mid b + (view mid a * view width b)
r = view width a * view width b
instance (BoundedField a) => MultiplicativeUnital (Range a) where
one = Range (negate half, half)
instance (BoundedField a) => MultiplicativeAssociative (Range a)
instance (Ord a, BoundedField a) => MultiplicativeInvertible (Range a) where
recip a = case view width a == zero of
True -> theta
False -> Range (m r/two, m + r/two)
where
m = negate (view mid a) * recip (view width a)
r = recip (view width a)
instance (Ord a, BoundedField a) => MultiplicativeRightCancellative (Range a)
instance (Ord a, BoundedField a) => MultiplicativeLeftCancellative (Range a)
instance (BoundedField a, Ord a) => Signed (Range a) where
sign (Range (l,u)) = if u >= l then one else negate one
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
theta :: (AdditiveUnital a) => Range a
theta = Range (zero, zero)
two :: (MultiplicativeUnital a, Additive a) => a
two = one + one
half :: (BoundedField a) => a
half = one / (one + one)
singleton :: a -> Range a
singleton a = Range (a,a)
element :: (Ord a) => a -> Range a -> Bool
element a (Range (l,u)) = a >= l && a <= u
singular :: (Eq a) => Range a -> Bool
singular (Range (l,u)) = l==u
intersection :: (Ord a) => Range a -> Range a -> Range a
intersection a b =
Range (max (view low a) (view low b), min (view high a) (view high b))
contains :: (Ord a) => Range a -> Range a -> Bool
contains (Range (l,u)) (Range (l',u')) = l <= l' && u >= u'
range :: (Foldable f, Ord a, BoundedField a) => f a -> Range a
range = L.fold (L.Fold (\x a -> x + singleton a) zero id)
project :: (Field b) => Range b -> Range b -> b -> b
project (Range (l0,u0)) (Range (l1,u1)) p =
((pl0)/(u0l0)) * (u1l1) + l1
data LinearPos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq)
linearSpace :: (Field a, FromInteger a) => LinearPos -> Range a -> Int -> [a]
linearSpace o (Range (l, u)) n = (+ if o==MidPos then step/two else zero) <$> posns
where
posns = (l +) . (step *) . fromIntegral <$> [i0..i1]
step = (u l)/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)
linearSpaceSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) =>
LinearPos -> Range a -> Int -> [a]
linearSpaceSensible 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)
fromLinearSpace :: [a] -> [Range a]
fromLinearSpace as = zipWith (curry Range) as (drop 1 as)