{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
module NumHask.Data.Rect
( Rect(..)
, pattern Rect
, pattern Ranges
, corners
, projectRect
) where
import Data.Bool (bool)
import GHC.Exts
import GHC.Generics (Generic)
import Data.Distributive
import Data.Functor.Compose
import Data.Functor.Rep
import NumHask.Data.Pair
import Prelude (Eq(..), Show(..), Bool(..), Foldable(..), Functor, Traversable(..), Applicative, (.), fmap, (<$>), Semigroup(..), Monoid(..))
import NumHask.Data.Range
import NumHask.Data.Integral
import NumHask.Analysis.Space
import NumHask.Algebra.Abstract
newtype Rect a =
Rect' (Compose Pair Range a)
deriving (Eq, Functor, Applicative, Foldable, Traversable,
Generic)
pattern Rect :: a -> a -> a -> a -> Rect a
pattern Rect a b c d = Rect' (Compose (Pair (Range a b) (Range c d)))
{-# COMPLETE Rect#-}
pattern Ranges :: Range a -> Range a -> Rect a
pattern Ranges a b = Rect' (Compose (Pair a b))
{-# COMPLETE Ranges#-}
instance (Show a) => Show (Rect a) where
show (Rect a b c d) =
"Rect " <> show a <> " " <> show b <> " " <> show c <> " " <> show d
instance Data.Distributive.Distributive Rect where
collect f x =
Rect (getA . f <$> x) (getB . f <$> x) (getC . f <$> x) (getD . f <$> x)
where
getA (Rect a _ _ _) = a
getB (Rect _ b _ _) = b
getC (Rect _ _ c _) = c
getD (Rect _ _ _ d) = d
instance Representable Rect where
type Rep Rect = (Bool, Bool)
tabulate f =
Rect (f (False, False)) (f (False, True)) (f (True, False)) (f (True, True))
index (Rect a _ _ _) (False, False) = a
index (Rect _ b _ _) (False, True) = b
index (Rect _ _ c _) (True, False) = c
index (Rect _ _ _ d) (True, True) = d
instance (BoundedLattice a) => Semigroup (Rect a) where
(<>) (Ranges x y) (Ranges x' y') = Ranges (x `union` x') (y `union` y')
instance (BoundedLattice a) => Monoid (Rect a) where
mempty = Ranges mempty mempty
instance (Lattice a) => Space (Rect a) where
type Element (Rect a) = Pair a
union (Ranges a b) (Ranges c d) = Ranges (a `union` c) (b `union` d)
intersection (Ranges a b) (Ranges c d) = Ranges (a `intersection` c) (b `intersection` d)
(>.<) (Pair l0 l1) (Pair u0 u1) = Rect l0 u0 l1 u1
lower (Rect l0 _ l1 _) = Pair l0 l1
upper (Rect _ u0 _ u1) = Pair u0 u1
singleton (Pair x y) = Rect x x y y
instance (Lattice a, Field a, Subtractive a, FromInteger a) => FieldSpace (Rect a) where
type Grid (Rect a) = Pair Int
grid o s n = (+ bool zero (step/(one+one)) (o==MidPos)) <$> posns
where
posns =
(lower s +) . (step *) . fmap fromIntegral <$>
[Pair x y | x <- [x0 .. x1], y <- [y0 .. y1]]
step = (/) (width s) (fromIntegral <$> n)
(Pair x0 y0, Pair x1 y1) =
case o of
OuterPos -> (zero, n)
InnerPos -> (one, n - one)
LowerPos -> (zero, n - one)
UpperPos -> (one, n)
MidPos -> (zero, n - one)
gridSpace (Ranges rX rY) (Pair stepX stepY) =
[ Rect x (x + sx) y (y + sy)
| x <- grid LowerPos rX stepX
, y <- grid LowerPos rY stepY
]
where
sx = width rX / fromIntegral stepX
sy = width rY / fromIntegral stepY
corners :: (Lattice a) => Rect a -> [Pair a]
corners r = [lower r, upper r]
projectRect ::
(Lattice a, Subtractive a, Field a)
=> Rect a
-> Rect a
-> Rect a
-> Rect a
projectRect r0 r1 (Rect a b c d) = Rect a' b' c' d'
where
(Pair a' c') = project r0 r1 (Pair a c)
(Pair b' d') = project r0 r1 (Pair b d)
type instance Actor (Rect a) = a
instance (Additive a) => AdditiveAction (Rect a) where
(.+) r s = fmap (s+) r
(+.) s = fmap (s+)
instance (Subtractive a) => SubtractiveAction (Rect a) where
(.-) r s = fmap (\x -> x - s) r
(-.) s = fmap (\x -> x - s)
instance (Multiplicative a) => MultiplicativeAction (Rect a) where
(.*) r s = fmap (s*) r
(*.) s = fmap (s*)
instance (Divisive a) => DivisiveAction (Rect a) where
(./) r s = fmap (/ s) r
(/.) s = fmap (/ s)