{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
module NumHask.Range
( Range(..)
, pattern Range
, gridSensible
) where
import Prelude
import Data.Functor.Rep
import Data.Distributive as D
import Data.Bool (bool)
import Data.Functor.Apply (Apply(..))
import Data.Functor.Classes
import Data.Semigroup.Foldable (Foldable1(..))
import Data.Semigroup.Traversable (Traversable1(..))
import GHC.Exts
import GHC.Generics (Generic)
import NumHask.Space.Types as S
import Algebra.Lattice
newtype Range a = Range' (a,a)
deriving (Eq, Generic)
type role Range representational
pattern Range :: a -> a -> Range a
pattern Range a b = Range' (a,b)
{-# COMPLETE Range#-}
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 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 D.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 (Ord a) => Lattice (Range a) where
(\/) = liftR2 min
(/\) = liftR2 max
instance (Eq a, Ord a) => Space (Range a) where
type Element (Range a) = a
lower (Range l _) = l
upper (Range _ u) = u
(>.<) = Range
instance (Ord a, Fractional a) => FieldSpace (Range a) where
type Grid (Range a) = Int
grid o s n = (+ bool 0 (step/2) (o==MidPos)) <$> posns
where
posns = (lower s +) . (step *) . fromIntegral <$> [i0..i1]
step = (/) (width s) (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)
gridSpace r n = zipWith Range ps (drop 1 ps)
where
ps = grid OuterPos r n
instance (Eq a, Ord a) => Semigroup (Range a) where
(<>) a b = getUnion (Union a <> Union b)
instance (Num a, Eq a, Ord a) => Num (Range a) where
(Range l u) + (Range l' u') = space1 [l+l',u+u']
negate (Range l u) = negate u ... negate l
(Range l u) * (Range l' u') =
space1 [l * l', l * u', u * l', u * u']
signum (Range l u) = bool (negate 1) 1 (u >= l)
abs (Range l u) = bool (u ... l) (l ... u) (u >= l)
fromInteger x = fromInteger x ... fromInteger x
stepSensible :: (Fractional a, RealFrac a, Floating a, Integral b) => Pos -> a -> b -> a
stepSensible tp span' n =
step + bool 0 (step/2) (tp==MidPos)
where
step' = 10.0 ^^ (floor (logBase 10 (span'/fromIntegral n)) :: Integer)
err = fromIntegral n / span' * step'
step
| err <= 0.15 = 10.0 * step'
| err <= 0.35 = 5.0 * step'
| err <= 0.75 = 2.0 * step'
| otherwise = step'
gridSensible :: (Ord a, RealFrac a, Floating a, Integral b) =>
Pos -> Bool -> Range a -> b -> [a]
gridSensible tp inside r@(Range l u) n =
bool id (filter (`memberOf` r)) inside $
(+ bool 0 (step/2) (tp==MidPos)) <$> posns
where
posns = (first' +) . (step *) . fromIntegral <$> [i0..i1]
span' = u - l
step = stepSensible tp span' n
first' = step * fromIntegral (floor (l/step + 1e-6) :: Integer)
last' = step * fromIntegral (ceiling (u/step - 1e-6) :: Integer)
n' = round ((last' - first')/step)
(i0,i1) =
case tp of
OuterPos -> (0::Integer,n')
InnerPos -> (1,n' - 1)
LowerPos -> (0,n' - 1)
UpperPos -> (1,n')
MidPos -> (0,n' - 1)