{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK hide #-}
module NumHask.Space.Types
( Space (..),
Union (..),
Intersection (..),
FieldSpace (..),
mid,
project,
Pos (..),
space1,
memberOf,
contains,
disjoint,
width,
(+/-),
monotone,
eps,
widen,
widenEps,
scale,
move,
)
where
import NumHask.Prelude
import qualified Prelude as P
class Space s where
type Element s :: Type
lower :: s -> Element s
upper :: s -> Element s
singleton :: Element s -> s
singleton s = s >.< s
intersection :: s -> s -> s
default intersection :: (Ord (Element s)) => s -> s -> s
intersection a b = l >.< u
where
l = lower a `max` lower b
u = upper a `min` upper b
union :: s -> s -> s
default union :: (Ord (Element s)) => s -> s -> s
union a b = l >.< u
where
l = lower a `min` lower b
u = upper a `max` upper b
norm :: s -> s
norm s = lower s ... upper s
infix 3 ...
(...) :: Element s -> Element s -> s
default (...) :: (Ord (Element s)) => Element s -> Element s -> s
(...) a b = (a `min` b) >.< (a `max` b)
infix 3 >.<
(>.<) :: Element s -> Element s -> s
infixl 7 |.|
(|.|) :: Element s -> s -> Bool
default (|.|) :: (Ord (Element s)) => Element s -> s -> Bool
(|.|) a s = (a >= lower s) && (upper s >= a)
infixl 7 |>|
(|>|) :: s -> s -> Bool
default (|>|) :: (Ord (Element s)) => s -> s -> Bool
(|>|) s0 s1 =
lower s0 >= upper s1
infixl 7 |<|
(|<|) :: s -> s -> Bool
default (|<|) :: (Ord (Element s)) => s -> s -> Bool
(|<|) s0 s1 =
lower s1 <= upper s0
contains :: (Space s) => s -> s -> Bool
contains s0 s1 =
lower s1 |.| s0
&& upper s1 |.| s0
disjoint :: (Space s) => s -> s -> Bool
disjoint s0 s1 = s0 |>| s1 || s0 |<| s1
memberOf :: (Space s) => Element s -> s -> Bool
memberOf = (|.|)
width :: (Space s, Subtractive (Element s)) => s -> Element s
width s = upper s - lower s
infixl 6 +/-
(+/-) :: (Space s, Subtractive (Element s)) => Element s -> Element s -> s
a +/- b = a - b ... a + b
newtype Union a = Union {getUnion :: a}
instance (Space a) => Semigroup (Union a) where
(<>) (Union a) (Union b) = Union (a `union` b)
newtype Intersection a = Intersection {getIntersection :: a}
instance (Space a) => Semigroup (Intersection a) where
(<>) (Intersection a) (Intersection b) = Intersection (a `union` b)
class (Space s, Field (Element s)) => FieldSpace s where
type Grid s :: Type
grid :: Pos -> s -> Grid s -> [Element s]
gridSpace :: s -> Grid s -> [s]
data Pos
=
OuterPos
|
InnerPos
|
LowerPos
|
UpperPos
|
MidPos
deriving (Show, Eq)
mid :: (Space s, Field (Element s)) => s -> Element s
mid s = (lower s + upper s) / (one + one)
project :: (Space s, Field (Element s)) => s -> s -> Element s -> Element s
project s0 s1 p =
((p - lower s0) / (upper s0 - lower s0)) * (upper s1 - lower s1) + lower s1
space1 :: (Space s, Traversable f) => f (Element s) -> s
space1 = P.foldr1 union . fmap singleton
monotone :: (Space a, Space b) => (Element a -> Element b) -> a -> b
monotone f s = space1 [f (lower s), f (upper s)]
eps ::
( Space s,
FromRational (Element s),
Field (Element s)
) =>
Element s ->
Element s ->
s
eps accuracy a = a +/- (accuracy * a * 1e-6)
widen ::
( Space s,
Ring (Element s)
) =>
Element s ->
s ->
s
widen a s = (lower s - a) >.< (upper s + a)
widenEps ::
( Space s,
FromRational (Element s),
Field (Element s)
) =>
Element s ->
s ->
s
widenEps accuracy = widen (accuracy * 1e-6)
scale :: (Multiplicative (Element s), Space s) => Element s -> s -> s
scale e s = (e * lower s) ... (e * upper s)
move :: (Additive (Element s), Space s) => Element s -> s -> s
move e s = (e + lower s) ... (e + upper s)