Range.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
#if ( __GLASGOW_HASKELL__ < 820 )
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
#endif

{- |

'Range -0.5 0.5 :: Range Double' is a 1-dimensional instance of a 'Space Double' from -0.5 to 0.5 on the Double number line.

The instances chosen for 'NumHask.Range' are conducive to Charting.  Specifically:

- a Range is polymorphic, with the main constraint being 'Ord a'
- 'NumHask.Additive.Additive' and 'NumHask.Multiplicative.Multiplicative' instances define numeric manipulation rather than relying on the 'Num' class in base.
- '(+)' and '(<>)' are defined as the convex hull of two ranges (compare the interval package approach for + of `fmap (+)`). 'zero' and 'mempty' are defined as `Range infinity neginfinity`.  This arrangement targets a neat definition for conversion of a foldable into a range via a very neat `foldMap singleton`.  An additional benefit is that Ranges are additively idempotent (a + a = a).

- The starting point for understanding Range multiplication is the diagrams <https://hackage.haskell.org/package/diagrams-lib-1.4.1.2/docs/Diagrams-TwoD-Shapes.html#v:unitSquare unitSquare>.  Restricting consideration to one-dimension, a natural 'one' Range is `Range -0.5 0.5`, which uniquely satisfies the equations:

  `mid one == zero`
  `width one == one`

  where the right zero and one refer to the underlying type.

-}

module NumHask.Range
  ( Range(..)
  , pattern Range
  , gridSensible
 ) where

import NumHask.Prelude
import NumHask.Space

import Data.Functor.Apply (Apply(..))
import Data.Semigroup.Foldable (Foldable1(..))
import Data.Semigroup.Traversable (Traversable1(..))
import Data.Functor.Rep
import Data.Functor.Classes
import Data.Distributive
import Test.QuickCheck.Arbitrary (Arbitrary(..))
import qualified Text.Show as Show

-- $setup
-- >>> :set -XNoImplicitPrelude
-- >>> :set -XExtendedDefaultRules
--

-- | Range is a newtype wrapped (a,a) tuple
newtype Range a = Range' (a,a)
  deriving (Eq, Generic)

-- | 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.
-- >>> Range 0 1
-- Range 0 1
pattern Range :: a -> a -> Range a
pattern Range a b = Range' (a, b)
{-# COMPLETE Range#-}

-- | recovering the synonym name
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

-- | and here we recover the desired property of fmap'ing over both elements in contrast to the (a,) functor.
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

-- | times may well be some sort of affine projection lurking under the hood
instance (Ord a, BoundedField a, FromInteger 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

-- | The unital object derives from:
--
-- width one = one
--
-- mid zero = zero
--
-- ie (-0.5,0.5)
instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeUnital (Range a) where
    one = Range (negate half) half

instance (Ord a, FromInteger a, BoundedField a) => MultiplicativeAssociative (Range a)

instance (Ord a, FromInteger 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 (Ord a, BoundedField a, FromInteger a) => MultiplicativeCommutative (Range a)
instance (Ord a, BoundedField a, FromInteger a) => Multiplicative (Range a)
instance (Ord a, BoundedField a, FromInteger a) => MultiplicativeGroup (Range a)

instance (AdditiveInvertible a, BoundedField a, Ord a, FromInteger 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) = 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

instance (Ord a, BoundedField a, FromInteger 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

-- | 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
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)