{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module NumHask.Analysis.Space
( Space(..)
, Spaceable
, Union(..)
, Intersection(..)
, FieldSpace(..)
, mid
, project
, Pos(..)
, space1
, (|.|)
, memberOf
, contains
, disjoint
, (|>|)
, (|<|)
, width
, (+/-)
, monotone
, whole
, negWhole
, eps
, widen
, widenEps
)
where
import Data.Bool
import NumHask.Algebra.Abstract
import NumHask.Analysis.Metric
import Prelude (Functor(..), Eq(..), Bool(..), Show, foldr1, Traversable(..), (.), Semigroup(..), Monoid(..))
type Spaceable a = (Eq a, JoinSemiLattice a, MeetSemiLattice a)
class (Spaceable (Element s)) => Space s where
type Element s :: *
lower :: s -> Element s
upper :: s -> Element s
singleton :: Element s -> s
singleton s = s >.< s
intersection :: s -> s -> s
intersection a b = l >.< u where
l = lower a /\ lower b
u = upper a \/ upper b
union :: s -> s -> s
union a b = l >.< u where
l = lower a \/ lower b
u = upper a /\ upper b
norm :: s -> s
norm s = lower s ... upper s
infix 3 ...
(...) :: Element s -> Element s -> s
(...) a b = (a\/b) >.< (a/\b)
infix 3 >.<
(>.<) :: Element s -> Element s -> s
newtype Union a = Union { getUnion :: a }
instance (Space a) => Semigroup (Union a) where
(<>) (Union a) (Union b) = Union (a `union` b)
instance (BoundedJoinSemiLattice a, Space a) => Monoid (Union a) where
mempty = Union bottom
newtype Intersection a = Intersection { getIntersection :: a }
instance (Space a) => Semigroup (Intersection a) where
(<>) (Intersection a) (Intersection b) = Intersection (a `union` b)
instance (BoundedMeetSemiLattice a, Space a) => Monoid (Intersection a) where
mempty = Intersection top
class (Space s, Subtractive (Element s), Field (Element s)) => FieldSpace s where
type Grid s :: *
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)/two
project :: (Space s, Field (Element s), Subtractive (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 = foldr1 union . fmap singleton
infixl 7 |.|
(|.|) :: (Space s) => Element s -> s -> Bool
(|.|) a s = (a `joinLeq` lower s) && (upper s `meetLeq` a)
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
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
infixl 7 |>|
(|>|) :: (Space s) => s -> s -> Bool
(|>|) s0 s1 =
lower s0 `joinLeq` upper s1
infixl 7 |<|
(|<|) :: (Space s) => s -> s -> Bool
(|<|) s0 s1 =
lower s1 `meetLeq` upper s0
monotone :: (Space a, Space b) => (Element a -> Element b) -> a -> b
monotone f s = space1 [f (lower s), f (upper s)]
whole ::
( Space s
, BoundedJoinSemiLattice (Element s)
, BoundedMeetSemiLattice (Element s)
) => s
whole = bottom ... top
negWhole ::
( Space s
, BoundedJoinSemiLattice (Element s)
, BoundedMeetSemiLattice (Element s)
) => s
negWhole = top >.< bottom
eps ::
( Space s
, Epsilon (Element s)
, Multiplicative (Element s)
)
=> Element s -> Element s -> s
eps accuracy a = a +/- (accuracy * a * epsilon)
widen ::
( Space s
, Subtractive (Element s))
=> Element s -> s -> s
widen a s = (lower s - a) >.< (upper s + a)
widenEps ::
( Space s
, Epsilon (Element s)
, Multiplicative (Element s))
=> Element s -> s -> s
widenEps accuracy = widen (accuracy * epsilon)