{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A Space containing numerical elements
module NumHask.Space.Range
  ( Range (..),
    gridSensible,
  )
where

import Data.Distributive as D
import Data.Functor.Apply (Apply (..))
import Data.Functor.Classes
import Data.Functor.Rep
import GHC.Show (show)
import NumHask.Prelude hiding (show)
import NumHask.Space.Types as S

-- $setup
--
-- >>> :set -XFlexibleContexts
-- >>> :set -XGADTs
-- >>> import NumHask.Prelude
-- >>> import NumHask.Space

-- | A continuous range over type a
--
-- >>> let a = Range (-1) 1
-- >>> a
-- Range -1 1
--
-- >>> a + a
-- Range -2 2
--
-- >>> a * a
-- Range -2.0 2.0
--
-- >>> (+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.0 10.0) 5
-- [0.0,2.0,4.0,6.0,8.0,10.0]
--
-- divide up a Range into equal-sized sections
--
-- >>> gridSpace (Range 0.0 1.0) 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 (Range a -> Range a -> Bool
forall a. Eq a => Range a -> Range a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range a -> Range a -> Bool
$c/= :: forall a. Eq a => Range a -> Range a -> Bool
== :: Range a -> Range a -> Bool
$c== :: forall a. Eq a => Range a -> Range a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Range a) x -> Range a
forall a x. Range a -> Rep (Range a) x
$cto :: forall a x. Rep (Range a) x -> Range a
$cfrom :: forall a x. Range a -> Rep (Range a) x
Generic)

instance (Show a) => Show (Range a) where
  show :: Range a -> String
show (Range a
a a
b) = String
"Range " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
a forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
b

instance Eq1 Range where
  liftEq :: forall a b. (a -> b -> Bool) -> Range a -> Range b -> Bool
liftEq a -> b -> Bool
f (Range a
a a
b) (Range b
c b
d) = a -> b -> Bool
f a
a b
c Bool -> Bool -> Bool
&& a -> b -> Bool
f a
b b
d

instance Show1 Range where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Range a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
_ Int
d (Range a
a a
b) = forall a b.
(Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
showsBinaryWith Int -> a -> ShowS
sp Int -> a -> ShowS
sp String
"Range" Int
d a
a a
b

instance Functor Range where
  fmap :: forall a b. (a -> b) -> Range a -> Range b
fmap a -> b
f (Range a
a a
b) = forall a. a -> a -> Range a
Range (a -> b
f a
a) (a -> b
f a
b)

instance Apply Range where
  Range a -> b
fa a -> b
fb <.> :: forall a b. Range (a -> b) -> Range a -> Range b
<.> Range a
a a
b = forall a. a -> a -> Range a
Range (a -> b
fa a
a) (a -> b
fb a
b)

instance Applicative Range where
  pure :: forall a. a -> Range a
pure a
a = forall a. a -> a -> Range a
Range a
a a
a

  (Range a -> b
fa a -> b
fb) <*> :: forall a b. Range (a -> b) -> Range a -> Range b
<*> Range a
a a
b = forall a. a -> a -> Range a
Range (a -> b
fa a
a) (a -> b
fb a
b)

instance Foldable Range where
  foldMap :: forall m a. Monoid m => (a -> m) -> Range a -> m
foldMap a -> m
f (Range a
a a
b) = a -> m
f a
a forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
b

instance Traversable Range where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Range a -> f (Range b)
traverse a -> f b
f (Range a
a a
b) = forall a. a -> a -> Range a
Range forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
b

instance D.Distributive Range where
  collect :: forall (f :: * -> *) a b.
Functor f =>
(a -> Range b) -> f a -> Range (f b)
collect a -> Range b
f f a
x = forall a. a -> a -> Range a
Range (forall {a}. Range a -> a
getL forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Range b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x) (forall {a}. Range a -> a
getR forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Range b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x)
    where
      getL :: Range a -> a
getL (Range a
l a
_) = a
l
      getR :: Range a -> a
getR (Range a
_ a
r) = a
r

instance Representable Range where
  type Rep Range = Bool

  tabulate :: forall a. (Rep Range -> a) -> Range a
tabulate Rep Range -> a
f = forall a. a -> a -> Range a
Range (Rep Range -> a
f Bool
False) (Rep Range -> a
f Bool
True)

  index :: forall a. Range a -> Rep Range -> a
index (Range a
l a
_) Bool
Rep Range
False = a
l
  index (Range a
_ a
r) Bool
Rep Range
True = a
r

instance (Ord a) => JoinSemiLattice (Range a) where
  \/ :: Range a -> Range a -> Range a
(\/) = forall (f :: * -> *) a b c.
Representable f =>
(a -> b -> c) -> f a -> f b -> f c
liftR2 forall a. Ord a => a -> a -> a
min

instance (Ord a) => MeetSemiLattice (Range a) where
  /\ :: Range a -> Range a -> Range a
(/\) = forall (f :: * -> *) a b c.
Representable f =>
(a -> b -> c) -> f a -> f b -> f c
liftR2 forall a. Ord a => a -> a -> a
max

instance (Ord a) => Space (Range a) where
  type Element (Range a) = a

  lower :: Range a -> Element (Range a)
lower (Range a
l a
_) = a
l

  upper :: Range a -> Element (Range a)
upper (Range a
_ a
u) = a
u

  >.< :: Element (Range a) -> Element (Range a) -> Range a
(>.<) = forall a. a -> a -> Range a
Range

instance (Field a, Ord a, FromIntegral a Int) => FieldSpace (Range a) where
  type Grid (Range a) = Int

  grid :: Pos -> Range a -> Grid (Range a) -> [Element (Range a)]
grid Pos
o Range a
s Grid (Range a)
n = (forall a. Additive a => a -> a -> a
+ forall a. a -> a -> Bool -> a
bool forall a. Additive a => a
zero (a
step forall a. Divisive a => a -> a -> a
/ forall a. (Multiplicative a, Additive a) => a
two) (Pos
o forall a. Eq a => a -> a -> Bool
== Pos
MidPos)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
posns
    where
      posns :: [a]
posns = (forall s. Space s => s -> Element s
lower Range a
s +) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (a
step *) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. FromIntegral a b => b -> a
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
i0 .. Int
i1]
      step :: a
step = forall a. Divisive a => a -> a -> a
(/) (forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
s) (forall a b. FromIntegral a b => b -> a
fromIntegral Grid (Range a)
n)
      (Int
i0, Int
i1) = case Pos
o of
        Pos
OuterPos -> (Int
0, Grid (Range a)
n)
        Pos
InnerPos -> (Int
1, Grid (Range a)
n forall a. Subtractive a => a -> a -> a
- Int
1)
        Pos
LowerPos -> (Int
0, Grid (Range a)
n forall a. Subtractive a => a -> a -> a
- Int
1)
        Pos
UpperPos -> (Int
1, Grid (Range a)
n)
        Pos
MidPos -> (Int
0, Grid (Range a)
n forall a. Subtractive a => a -> a -> a
- Int
1)

  gridSpace :: Range a -> Grid (Range a) -> [Range a]
gridSpace Range a
r Grid (Range a)
n = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. a -> a -> Range a
Range [Element (Range a)]
ps (forall a. Int -> [a] -> [a]
drop Int
1 [Element (Range a)]
ps)
    where
      ps :: [Element (Range a)]
ps = forall s. FieldSpace s => Pos -> s -> Grid s -> [Element s]
grid Pos
OuterPos Range a
r Grid (Range a)
n

-- | Monoid based on convex hull union
instance (Ord a) => Semigroup (Range a) where
  <> :: Range a -> Range a -> Range a
(<>) Range a
a Range a
b = forall a. Union a -> a
getUnion (forall a. a -> Union a
Union Range a
a forall a. Semigroup a => a -> a -> a
<> forall a. a -> Union a
Union Range a
b)

instance (Additive a, Ord a) => Additive (Range a) where
  (Range a
l a
u) + :: Range a -> Range a -> Range a
+ (Range a
l' a
u') = forall s (f :: * -> *).
(Space s, Traversable f) =>
f (Element s) -> s
unsafeSpace1 [a
l forall a. Additive a => a -> a -> a
+ a
l', a
u forall a. Additive a => a -> a -> a
+ a
u']
  zero :: Range a
zero = forall a. a -> a -> Range a
Range forall a. Additive a => a
zero forall a. Additive a => a
zero

instance (Subtractive a, Ord a) => Subtractive (Range a) where
  negate :: Range a -> Range a
negate (Range a
l a
u) = forall a. Subtractive a => a -> a
negate a
u forall s. Space s => Element s -> Element s -> s
... forall a. Subtractive a => a -> a
negate a
l

instance (Field a, Ord a) => Multiplicative (Range a) where
  Range a
a * :: Range a -> Range a -> Range a
* Range a
b = forall a. a -> a -> Bool -> a
bool (forall a. a -> a -> Range a
Range (a
m forall a. Subtractive a => a -> a -> a
- a
r forall a. Divisive a => a -> a -> a
/ (forall a. Multiplicative a => a
one forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one)) (a
m forall a. Additive a => a -> a -> a
+ a
r forall a. Divisive a => a -> a -> a
/ (forall a. Multiplicative a => a
one forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one))) forall a. Additive a => a
zero (Range a
a forall a. Eq a => a -> a -> Bool
== forall a. Additive a => a
zero Bool -> Bool -> Bool
|| Range a
b forall a. Eq a => a -> a -> Bool
== forall a. Additive a => a
zero)
    where
      m :: a
m = forall s. (Space s, Field (Element s)) => s -> Element s
mid Range a
a forall a. Additive a => a -> a -> a
+ forall s. (Space s, Field (Element s)) => s -> Element s
mid Range a
b
      r :: a
r = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
a forall a. Multiplicative a => a -> a -> a
* forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
b

  one :: Range a
one = forall a. a -> a -> Range a
Range (forall a. Subtractive a => a -> a
negate forall a. Multiplicative a => a
one forall a. Divisive a => a -> a -> a
/ (forall a. Multiplicative a => a
one forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one)) (forall a. Multiplicative a => a
one forall a. Divisive a => a -> a -> a
/ (forall a. Multiplicative a => a
one forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one))

instance (Ord a, Field a) => Divisive (Range a) where
  recip :: Range a -> Range a
recip Range a
a = forall a. a -> a -> Bool -> a
bool (forall a. a -> a -> Range a
Range (-Element (Range a)
m forall a. Subtractive a => a -> a -> a
- forall a. Multiplicative a => a
one forall a. Divisive a => a -> a -> a
/ (forall a. (Multiplicative a, Additive a) => a
two forall a. Multiplicative a => a -> a -> a
* Element (Range a)
r)) (-Element (Range a)
m forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one forall a. Divisive a => a -> a -> a
/ (forall a. (Multiplicative a, Additive a) => a
two forall a. Multiplicative a => a -> a -> a
* Element (Range a)
r))) forall a. Additive a => a
zero (Element (Range a)
r forall a. Eq a => a -> a -> Bool
== forall a. Additive a => a
zero)
    where
      m :: Element (Range a)
m = forall s. (Space s, Field (Element s)) => s -> Element s
mid Range a
a
      r :: Element (Range a)
r = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
a

instance (Field a, Ord a) => Basis (Range a) where
  type Mag (Range a) = Range a
  type Base (Range a) = a
  basis :: Range a -> Base (Range a)
basis (Range a
l a
u) = forall a. a -> a -> Bool -> a
bool (forall a. Subtractive a => a -> a
negate forall a. Multiplicative a => a
one) forall a. Multiplicative a => a
one (a
u forall a. Ord a => a -> a -> Bool
>= a
l)
  magnitude :: Range a -> Mag (Range a)
magnitude (Range a
l a
u) = forall a. a -> a -> Bool -> a
bool (a
u forall s. Space s => Element s -> Element s -> s
... a
l) (a
l forall s. Space s => Element s -> Element s -> s
... a
u) (a
u forall a. Ord a => a -> a -> Bool
>= a
l)

stepSensible :: Pos -> Double -> Int -> Double
stepSensible :: Pos -> Double -> Int -> Double
stepSensible Pos
tp Double
span' Int
n =
  Double
step forall a. Additive a => a -> a -> a
+ forall a. a -> a -> Bool -> a
bool Double
0 (Double
step forall a. Divisive a => a -> a -> a
/ Double
2) (Pos
tp forall a. Eq a => a -> a -> Bool
== Pos
MidPos)
  where
    step' :: Double
step' = Double
10.0 forall b a.
(Ord b, Divisive a, Subtractive b, Integral b) =>
a -> b -> a
^^ forall a. (QuotientField a, Ring (Whole a)) => a -> Whole a
floor (forall a. ExpField a => a -> a -> a
logBase Double
10 (Double
span' forall a. Divisive a => a -> a -> a
/ forall a b. FromIntegral a b => b -> a
fromIntegral Int
n))
    err :: Double
err = forall a b. FromIntegral a b => b -> a
fromIntegral Int
n forall a. Divisive a => a -> a -> a
/ Double
span' forall a. Multiplicative a => a -> a -> a
* Double
step'
    step :: Double
step
      | Double
err forall a. Ord a => a -> a -> Bool
<= Double
0.15 = Double
10.0 forall a. Multiplicative a => a -> a -> a
* Double
step'
      | Double
err forall a. Ord a => a -> a -> Bool
<= Double
0.35 = Double
5.0 forall a. Multiplicative a => a -> a -> a
* Double
step'
      | Double
err forall a. Ord a => a -> a -> Bool
<= Double
0.75 = Double
2.0 forall a. Multiplicative a => a -> a -> a
* Double
step'
      | Bool
otherwise = Double
step'

-- | a grid for five-digits per limb species
--
-- >>> 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 ::
  Pos ->
  Bool ->
  Range Double ->
  Int ->
  [Double]
gridSensible :: Pos -> Bool -> Range Double -> Int -> [Double]
gridSensible Pos
tp Bool
inside r :: Range Double
r@(Range Double
l Double
u) Int
n =
  forall a. a -> a -> Bool -> a
bool forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (forall a. (a -> Bool) -> [a] -> [a]
filter (forall s. Space s => Element s -> s -> Bool
`memberOf` Range Double
r)) Bool
inside forall a b. (a -> b) -> a -> b
$
    (forall a. Additive a => a -> a -> a
+ forall a. a -> a -> Bool -> a
bool Double
0 (Double
step forall a. Divisive a => a -> a -> a
/ Double
2) (Pos
tp forall a. Eq a => a -> a -> Bool
== Pos
MidPos)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Double]
posns
  where
    posns :: [Double]
posns = (Double
first' +) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Double
step *) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. FromIntegral a b => b -> a
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
i0 .. Int
i1]
    span' :: Double
span' = Double
u forall a. Subtractive a => a -> a -> a
- Double
l
    step :: Double
step = Pos -> Double -> Int -> Double
stepSensible Pos
tp Double
span' Int
n
    first' :: Double
first' = Double
step forall a. Multiplicative a => a -> a -> a
* forall a b. FromIntegral a b => b -> a
fromIntegral (forall a. (QuotientField a, Ring (Whole a)) => a -> Whole a
floor (Double
l forall a. Divisive a => a -> a -> a
/ Double
step forall a. Additive a => a -> a -> a
+ Double
1e-6))
    last' :: Double
last' = Double
step forall a. Multiplicative a => a -> a -> a
* forall a b. FromIntegral a b => b -> a
fromIntegral (forall a. (QuotientField a, Distributive (Whole a)) => a -> Whole a
ceiling (Double
u forall a. Divisive a => a -> a -> a
/ Double
step forall a. Subtractive a => a -> a -> a
- Double
1e-6))
    n' :: Whole Double
n' = forall a.
(QuotientField a, Eq (Whole a), Ring (Whole a)) =>
a -> Whole a
round ((Double
last' forall a. Subtractive a => a -> a -> a
- Double
first') forall a. Divisive a => a -> a -> a
/ Double
step)
    (Int
i0, Int
i1) =
      case Pos
tp of
        Pos
OuterPos -> (Int
0, Whole Double
n')
        Pos
InnerPos -> (Int
1, Whole Double
n' forall a. Subtractive a => a -> a -> a
- Int
1)
        Pos
LowerPos -> (Int
0, Whole Double
n' forall a. Subtractive a => a -> a -> a
- Int
1)
        Pos
UpperPos -> (Int
1, Whole Double
n')
        Pos
MidPos -> (Int
0, Whole Double
n' forall a. Subtractive a => a -> a -> a
- Int
1)