packages feed

numhask-space (empty) → 0.1.1

raw patch · 7 files changed

+825/−0 lines, 7 filesdep +adjunctionsdep +basedep +distributivesetup-changed

Dependencies added: adjunctions, base, distributive, numhask, semigroupoids

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tony Day nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ numhask-space.cabal view
@@ -0,0 +1,59 @@+name: numhask-space+version: 0.1.1+synopsis:+  numerical spaces+description:+  Spaces as higher-kinded numbers.+category:+  mathematics+homepage:+  https://github.com/tonyday567/numhask#readme+bug-reports:+  https://github.com/tonyday567/numhask/issues+author:+  Tony Day+maintainer:+  tonyday567@gmail.com+copyright:+  Tony Day+license:+  BSD3+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  1.18+source-repository head+  type:+    git+  location:+    https://github.com/tonyday567/numhask+  subdir:+    numhask-space+library+  hs-source-dirs:+    src+  default-extensions:+    NegativeLiterals+    OverloadedStrings+    UnicodeSyntax+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , numhask >=0.3 && < 0.4+    , adjunctions >=4.0 && <5+    , semigroupoids >=5 && <6+    , distributive >=0.2.2 && <1+  exposed-modules:+    NumHask.Analysis.Space+    NumHask.Data.Range+    NumHask.Data.RangeD+    NumHask.Data.Rect+  other-modules:+  default-language: Haskell2010
+ src/NumHask/Analysis/Space.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- https://en.wikipedia.org/wiki/Interval_(mathematics)+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)++-- | a continuous set of numbers+-- mathematics does not define a space, so library devs are free to experiment.+--+-- > a `contains` union a b && b `contains` union a b+-- > lower a \/ upper a == lower a+-- > lower a /\ upper a == upper a+--+class (Spaceable (Element s)) => Space s where++  -- | the underlying element in the space+  type Element s :: *++  -- | lower boundary+  lower :: s -> Element s++  -- | upper boundary+  upper :: s -> Element s++  -- | space containing a single element+  singleton :: Element s -> s+  singleton s = s >.< s++  -- | the intersection of two spaces+  intersection :: s -> s -> s+  intersection a b = l >.< u where+      l = lower a /\ lower b+      u = upper a \/ upper b++  -- | the union of two spaces+  union :: s -> s -> s+  union a b = l >.< u where+    l = lower a \/ lower b+    u = upper a /\ upper b++  -- | Normalise a space so that+  -- > lower a \/ upper a == lower a+  -- > lower a /\ upper a == upper a+  norm :: s -> s+  norm s = lower s ... upper s++  -- | create a normalised space from two elements+  infix 3 ...+  (...) :: Element s -> Element s -> s+  (...) a b = (a\/b) >.< (a/\b)++  -- | create a space from two elements witjout normalising+  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++-- | a space that can be divided neatly+--+class (Space s, Subtractive (Element s), Field (Element s)) => FieldSpace s where+  type Grid s :: *++  -- | create equally-spaced elements across a space+  grid :: Pos -> s -> Grid s -> [Element s]++  -- | create equally-spaced spaces from a space+  gridSpace :: s -> Grid s -> [s]++-- | Pos suggests where points should be placed in forming a grid across a field space.+data Pos = OuterPos | InnerPos | LowerPos | UpperPos | MidPos deriving (Show, Eq)++-- | mid-point of the space+mid :: (Space s, Field (Element s)) => s -> Element s+mid s = (lower s + upper s)/two++-- | project a data point from one space to another, preserving relative position+--+-- > project o n (lower o) = lower n+-- > project o n (upper o) = upper n+-- > project a a x = x+--+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++-- | the containing space of a non-empty Foldable+space1 :: (Space s, Traversable f) => f (Element s) -> s+space1 = foldr1 union . fmap singleton++-- | is an element in the space+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 = (|.|)++-- | distance between boundaries+width :: (Space s, Subtractive (Element s)) => s -> Element s+width s = upper s - lower s++-- | create a space centered on a plus or minus b+infixl 6 +/-+(+/-) :: (Space s, Subtractive (Element s)) => Element s -> Element s -> s+a +/- b = a - b ... a + b++-- | is a space contained within another?+contains :: (Space s) => s -> s -> Bool+contains s0 s1 =+  lower s1 |.| s0 &&+  upper s1 |.| s0++-- | are two spaces disjoint?+disjoint :: (Space s) => s -> s -> Bool+disjoint s0 s1 = s0 |>| s1 || s0 |<| s1++-- | is one space completely above the other+infixl 7 |>|+(|>|) :: (Space s) => s -> s -> Bool+(|>|) s0 s1 =+  lower s0 `joinLeq` upper s1++-- | is one space completely below the other+infixl 7 |<|+(|<|) :: (Space s) => s -> s -> Bool+(|<|) s0 s1 =+  lower s1 `meetLeq` upper s0++-- | lift a monotone function (increasing or decreasing) over a given space+monotone :: (Space a, Space b) => (Element a -> Element b) -> a -> b+monotone f s = space1 [f (lower s), f (upper s)]++-- | a big, big space+whole ::+  ( Space s+  , BoundedJoinSemiLattice (Element s)+  , BoundedMeetSemiLattice (Element s)+  ) => s+whole = bottom ... top++-- | a negative space+negWhole ::+  ( Space s+  , BoundedJoinSemiLattice (Element s)+  , BoundedMeetSemiLattice (Element s)+  ) => s+negWhole = top >.< bottom++-- | a small space+eps ::+    ( Space s+    , Epsilon (Element s)+    , Multiplicative (Element s)+    )+    => Element s -> Element s -> s+eps accuracy a = a +/- (accuracy * a * epsilon)++-- | widen a space+widen ::+    ( Space s+    , Subtractive (Element s))+    => Element s -> s -> s+widen a s = (lower s - a) >.< (upper s + a)++-- | widen by a small amount+widenEps ::+    ( Space s+    , Epsilon (Element s)+    , Multiplicative (Element s))+    => Element s -> s -> s+widenEps accuracy = widen (accuracy * epsilon)
+ src/NumHask/Data/Range.hs view
@@ -0,0 +1,259 @@+{-# 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 #-}+{-# OPTIONS_GHC -Wall #-}++-- | An Space with no empty, a semigroup based on a convex hull union, and a monoid on a negative space.+module NumHask.Data.Range+  ( Range(..)+  , pattern Range+  , gridSensible+ ) where++import Data.Functor.Rep+import Data.Distributive as D+import Data.Bool (bool, not)+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.Algebra.Abstract as A+import NumHask.Analysis.Metric+import NumHask.Analysis.Space as S+import NumHask.Data.Integral+import NumHask.Data.Rational+import Prelude (Eq(..), Ord(..), Show(..), Integer, Bool(..), Foldable(..), Functor, Traversable(..), Applicative, pure, (<*>), (.), otherwise, (&&), fmap, (<$>), Semigroup(..), Monoid(..), zipWith, drop, filter, ($), id)++-- $setup+-- >>> :set -XNoImplicitPrelude+-- >>> :set -XFlexibleContexts++-- | A continuous range over type a+--+-- >>> let a = Range (-1) 1+-- >>> a+-- Range -1 1+-- >>> fmap (+1) (Range 1 2)+-- Range 2 3+-- >>> one :: Range Double+-- Range -0.5 0.5+-- >>> zero :: Range Double+-- Range Infinity -Infinity++-- | as a Field instance+--+-- >>> Range 0 1 + zero+-- Range 0.0 1.0+-- >>> Range 0 1 + Range 2 3+-- Range 0.0 3.0+-- >>> Range 1 1 - one+-- Range 0.5 1.0+-- >>> Range 0 1 * one+-- Range 0.0 1.0+-- >>> Range 0 1 / one+-- Range 0.0 1.0+-- >>> abs (Range 1 0)+-- Range 0.0 1.0+-- >>> sign (Range 1 0) == negate one+-- True+--+-- Idempotent+--+-- >>> Range 0 2 + Range 0 2+-- Range 0.0 2.0+--+-- as a space instance+--+-- >>> NumHask.Space.project (Range 0 1) (Range 1 4) 0.5+-- 2.5+-- >>> NumHask.Space.grid NumHask.Space.OuterPos (Range 0 10) 5+-- [0.0,2.0,4.0,6.0,8.0,10.0]+-- >>> NumHask.Space.gridSpace (Range 0 1) 4+-- [Range 0.0 0.25,Range 0.25 0.5,Range 0.5 0.75,Range 0.75 1.0]+-- >>> gridSensible NumHask.Space.OuterPos (Range (-12.0) 23.0) 6+-- [-10.0,-5.0,0.0,5.0,10.0,15.0,20.0]++newtype Range a = Range' (a,a)+  deriving (Eq, Generic)++-- not sure if this is correct or needed+type role Range representational++-- | 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.+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 (JoinSemiLattice a) => JoinSemiLattice (Range a) where+  (\/) = liftR2 (\/)++instance (MeetSemiLattice a) => MeetSemiLattice (Range a) where+  (/\) = liftR2 (/\)++instance (BoundedLattice a) => BoundedJoinSemiLattice (Range a) where+  bottom = top >.< bottom++instance (BoundedLattice a) => BoundedMeetSemiLattice (Range a) where+  top = bottom >.< top++instance (Lattice a) => Space (Range a) where+  type Element (Range a) = a++  lower (Range l _) = l+  upper (Range _ u) = u++  (>.<) = Range++instance (Lattice a, Field a, Subtractive a, FromInteger a) => FieldSpace (Range a) where+    type Grid (Range a) = Int++    grid o s n = (+ bool zero (step/(one+one)) (o==MidPos)) <$> 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++-- | Monoid based on convex hull union+instance (BoundedLattice a) => Semigroup (Range a) where+  (<>) a b = getUnion (Union a <> Union b)++instance (BoundedLattice a) => Monoid (Range a) where+  mempty = getUnion mempty++-- | Numeric algebra based on Interval arithmetic+-- https://en.wikipedia.org/wiki/Interval_arithmetic+--+instance (Additive a, Lattice a) => Additive (Range a) where+  (Range l u) + (Range l' u') = space1 [l+l',u+u']+  zero = zero ... zero++instance (Subtractive a, Lattice a) => Subtractive (Range a) where+  negate (Range l u) = negate u ... negate l++instance (Multiplicative a, Lattice a) => Multiplicative (Range a) where+  (Range l u) * (Range l' u') =+    space1 [l * l', l * u', u * l', u * u']+  one = one ... one++instance (BoundedLattice a, Epsilon a, Divisive a) =>+  Divisive (Range a)+  where+  recip i@(Range l u)+    | zero |.| i && not (epsilon |.| i) = bottom ... recip l+    | zero |.| i && not (negate epsilon |.| i) = top ... recip l+    | zero |.| i = whole+    | otherwise = recip l ... recip u++instance (Multiplicative a, Subtractive a, Lattice a) => Signed (Range a) where+    sign (Range l u) = bool (negate one) one (u `joinLeq` l)+    abs (Range l u) = bool (u ... l) (l ... u) (u `joinLeq` l)++instance (FromInteger a, Lattice a) => FromInteger (Range a) where+    fromInteger x = fromInteger x ... fromInteger x++type instance Actor (Range a) = a++instance (Additive a) => AdditiveAction (Range a) where+    (.+) r s = fmap (s+) r+    (+.) s = fmap (s+)+instance (Subtractive a) => SubtractiveAction (Range a) where+    (.-) r s = fmap (\x -> x - s) r+    (-.) s = fmap (\x -> x - s)+instance (Multiplicative a) => MultiplicativeAction (Range a) where+    (.*) r s = fmap (s*) r+    (*.) s = fmap (s*)+instance (Divisive a) => DivisiveAction (Range a) where+    (./) r s = fmap (/ s) r+    (/.) s = fmap (/ s)++stepSensible :: (Ord a, FromRatio a, FromInteger a, ExpField a, QuotientField a Integer) => Pos -> a -> Integer -> a+stepSensible tp span n =+    step + bool zero (step/two) (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, JoinSemiLattice a, FromInteger a, FromRatio a, QuotientField a Integer, ExpField a, Epsilon a) =>+    Pos -> Bool -> Range a -> Integer -> [a]+gridSensible tp inside r@(Range l u) n =+    bool id (filter (`memberOf` r)) inside $+    (+ bool zero (step/two) (tp==MidPos)) <$> posns+  where+    posns = (first' +) . (step *) . fromIntegral <$> [i0..i1]+    span = u - l+    step = stepSensible tp span n+    first' = step * fromIntegral (floor (l/step + epsilon) :: Integer)+    last' =  step * fromIntegral (ceiling (u/step - epsilon) :: 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)
+ src/NumHask/Data/RangeD.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++-- | representation of a possibly discontinuous interval+module NumHask.Data.RangeD+  ( RangeD(..)+  , normalise+  ) where++import NumHask.Analysis.Space+import NumHask.Data.Range+import NumHask.Algebra.Abstract+import NumHask.Analysis.Metric+import Data.Bool (bool)+import GHC.Generics (Generic)+import Prelude (Eq(..), Ord(..), Show, Foldable, Functor, Traversable(..), Applicative(..), ($), not, (<$>), Semigroup(..), reverse)+import Data.List (sortBy, foldl')+import Data.Ord (comparing)++newtype RangeD a = RangeD [Range a]+  deriving (Eq, Generic, Show, Functor, Foldable, Traversable)++normalise :: (Ord a, Lattice a, Subtractive a) =>+    RangeD a -> RangeD a+normalise (RangeD rs) = RangeD $ reverse $ foldl' step [] (sortBy (comparing lower) rs)+  where+    step [] a = [a]+    step (x:xs) a = (a `unify` x) <> xs++    unify a b = bool (bool [a,b] [b,a] (lower a `joinLeq` lower b)) [a + b] (not $ a `disjoint` b)++instance (Ord a, Lattice a, Subtractive a) => Additive (RangeD a) where+    (RangeD l0) + (RangeD l1) = normalise $ RangeD $ l0 <> l1+    zero = RangeD []++instance (Divisive a, Ord a, Lattice a, Subtractive a) => Subtractive (RangeD a) where+    negate (RangeD rs) = normalise $ RangeD $ negate <$> rs++instance (Ord a, Lattice a, Subtractive a, Multiplicative a) => Multiplicative (RangeD a) where+    (RangeD a) * (RangeD b) = normalise $ RangeD $ (*) <$> a <*> b+    one = RangeD [one]++instance (Multiplicative a, BoundedLattice a, Epsilon a, Ord a, Subtractive a, Divisive a) => Divisive (RangeD a) where+    recip (RangeD rs) = normalise $ RangeD $ recip <$> rs+
+ src/NumHask/Data/Rect.hs view
@@ -0,0 +1,194 @@+{-# 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 #-}++-- | a two-dimensional plane, implemented as a composite of a 'Pair' of 'Range's.+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++-- $setup+-- >>> :set -XNoImplicitPrelude++-- | a 'Pair' of 'Ranges' that form a rectangle in what is often thought of as the XY plane.+--+-- >>> let a = Rect (-1) 1 (-2) 4+-- >>> a+-- Rect -1 1 -2 4+-- >>> let (Ranges x y) = a+-- >>> x+-- Range -1 1+-- >>> y+-- Range -2 4+-- >>> fmap (+1) (Rect 1 2 3 4)+-- Rect 2 3 4 5+-- >>> one :: Rect Double+-- Rect -0.5 0.5 -0.5 0.5+-- >>> zero :: Rect Double+-- Rect Infinity -Infinity Infinity -Infinity+--+-- as a Field instance+--+-- >>> Rect 0 1 2 3 + zero+-- Rect 0.0 1.0 2.0 3.0+-- >>> Rect 0 1 (-2) (-1) + Rect 2 3 (-5) 3+-- Rect 0.0 3.0 -5.0 3.0+-- >>> Rect 1 1 1 1 - one+-- Rect 0.5 1.0 0.5 1.0+-- >>> Rect 0 1 0 1 * one+-- Rect 0.0 1.0 0.0 1.0+-- >>> Rect 0 1 0 1 / one+-- Rect 0.0 1.0 0.0 1.0+-- >>> singleton (Pair 1.0 2.0) :: Rect Double+-- Rect 1.0 1.0 2.0 2.0+-- >>> abs (Rect 1 0 1 0)+-- Rect 0.0 1.0 0.0 1.0+-- >>> sign (Rect 1 0 1 0) == negate one+-- True+--+-- as a Space instance+--+-- >>> project (Rect 0 1 (-1) 0) (Rect 1 4 10 0) (Pair 0.5 1)+-- Pair 2.5 -10.0+-- >>> gridSpace (Rect 0 10 0 1) (Pair 2 2)+-- [Rect 0.0 5.0 0.0 0.5,Rect 0.0 5.0 0.5 1.0,Rect 5.0 10.0 0.0 0.5,Rect 5.0 10.0 0.5 1.0]+-- >>> grid MidPos (Rect 0 10 0 1) (Pair 2 2)+-- [Pair 2.5 0.25,Pair 2.5 0.75,Pair 7.5 0.25,Pair 7.5 0.75]+newtype Rect a =+  Rect' (Compose Pair Range a)+  deriving (Eq, Functor, Applicative, Foldable, Traversable,+            Generic)++-- | pattern of Rect lowerx upperx lowery uppery+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 of Ranges xrange yrange+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++-- | create a list of pairs representing the lower left and upper right cormners of a rectangle.+corners :: (Lattice a) => Rect a -> [Pair a]+corners r = [lower r, upper r]++-- | project a Rect from an old range to a new one+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)