{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

module NumHask.Range
  ( Range(..)
  , (...)
  , posit
  , low
  , high
  , mid
  , width
  , element
  , singleton
  , singular
  , mirrored
  , intersection
  , contains
  , range
  , rescaleP
  , TickPos(..)
  , ticks
  , ticksSensible
  , fromTicks
 ) 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

-- | a range represented by a (minimum, maximum) tuple
-- very similar to https://hackage.haskell.org/package/intervals-0.7.2 but the
-- metaphor and purpose there is closer to a fuzzy value around a central point.
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)) -> (u-l))
    (\r w -> Range (plushom r - w/two, plushom r + w/two))

instance (Ord a, Arbitrary a) => Arbitrary (Range a) where
    arbitrary = do
        a <- arbitrary
        b <- arbitrary
        pure (posit (Range (a,b)))

posit :: (Ord a) => Range a -> Range a
posit r@(Range (l,u))  = if l<=u then r else Range (u,l)

-- | the convex hull as plus seems like a natural choice, given the cute zero definition.
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 = (<>)

-- | natural interpretation of a `Range a` as an `a` is the mid-point
instance (BoundedField a) =>
    AdditiveHomomorphic (Range a) a where
    plushom (Range (l,u)) = (l+u)/two

-- | natural interpretation of an `a` as a `Range a` is a singular Range
instance (Ord a) =>
    AdditiveHomomorphic a (Range a) where
    plushom a = singleton a

-- | times may well be some sort of affine transformation lurking under the hood
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

-- | The unital object derives from:
--
-- view range one = one
-- view mid zero = zero
-- ie (-0.5,0.5)
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 (AdditiveGroup a) => Normed (Range a) a where
    size (Range (l, u)) = u-l

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 is a bit like 1/infinity
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)

-- | determine whether a point is within the range
element :: (Ord a) => a -> Range a -> Bool
element a (Range (l,u)) = a >= l && a <= u

-- | is the range a singleton point
singular :: (Eq a) => Range a -> Bool
singular (Range (l,u)) = l==u

-- | is the range low higher than the high
-- there well may be an interesting complex-like set of operations on mirrored ranges
mirrored :: (Ord a) => Range a -> Bool
mirrored (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 of a foldable
range :: (Foldable f, Ord a, BoundedField a) => f a -> Range a
range = L.fold (L.Fold (\x a -> x + singleton a) zero id)

-- | `rescaleP rold rnew p` rescales a data point from an old range to a new range
-- rescaleP o n (view low o) == view low n
-- rescaleP o n (view high o) == view high n
-- rescaleP a a == id
rescaleP :: (Field b) => Range b -> Range b -> b -> b
rescaleP (Range (l0,u0)) (Range (l1,u1)) p =
    ((p-l0)/(u0-l0)) * (u1-l1) + l1

-- * ticks are a series of `a`s constructued from a `Range a`
-- | where on the `Range` should the ticks be placed
data TickPos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Eq)

-- | turn a range into a ist of n `a`s, that are (view width x/n) apart
ticks :: (Field a, FromInteger a) => TickPos -> Range a -> Int -> [a]
ticks 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)

-- | turn a range into n `a`s pleasing to human sense and sensibility
-- the `a`s may well lie outside the original range as a result
ticksSensible :: (Fractional a, Ord a, FromInteger a, QuotientField a, ExpRing a, MultiplicativeGroup a) => TickPos -> Range a -> Int -> [a]
ticksSensible 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)

-- | take a list of (ascending) `a`s and make some (ascending) ranges
-- based on OuterPos
-- fromTicks . ticks OuterPos == id
-- ticks OuterPos . fromTicks == id
fromTicks :: [a] -> [Range a]
fromTicks as = zipWith (curry Range) as (drop 1 as)