packages feed

numhask-space 0.1.1 → 0.2.0

raw patch · 11 files changed

+1228/−745 lines, 11 filesdep +foldldep +latticesdep +textdep −numhask

Dependencies added: foldl, lattices, text, time

Dependencies removed: numhask

Files

numhask-space.cabal view
@@ -1,5 +1,5 @@ name: numhask-space-version: 0.1.1+version: 0.2.0 synopsis:   numerical spaces description:@@ -7,9 +7,9 @@ category:   mathematics homepage:-  https://github.com/tonyday567/numhask#readme+  https://github.com/tonyday567/numhask-space#readme bug-reports:-  https://github.com/tonyday567/numhask/issues+  https://github.com/tonyday567/numhask-space/issues author:   Tony Day maintainer:@@ -28,9 +28,7 @@   type:     git   location:-    https://github.com/tonyday567/numhask-  subdir:-    numhask-space+    https://github.com/tonyday567/numhask-space library   hs-source-dirs:     src@@ -46,14 +44,19 @@     -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+    , lattices >= 2.0.1 && <2.1+    , time >= 1.8.0.2 && <2+    , text >= 1.2.3.1 && <2+    , foldl >= 1.4.5 && <2   exposed-modules:-    NumHask.Analysis.Space-    NumHask.Data.Range-    NumHask.Data.RangeD-    NumHask.Data.Rect+    NumHask.Space+    NumHask.Space.Types+    NumHask.Range+    NumHask.Rect+    NumHask.Point+    NumHask.Space.Time   other-modules:   default-language: Haskell2010
− src/NumHask/Analysis/Space.hs 
@@ -1,222 +0,0 @@-{-# 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 
@@ -1,259 +0,0 @@-{-# 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 
@@ -1,59 +0,0 @@-{-# 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 
@@ -1,194 +0,0 @@-{-# 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)
+ src/NumHask/Point.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++-- | A 2-dimensional point.+module NumHask.Point+  ( Point(..)+  , pattern Point+  , rotate+  , gridP+  ) where++import Prelude+import GHC.Generics (Generic)+import Data.Functor.Classes+import Text.Show+import Algebra.Lattice+import Data.Functor.Rep+import Data.Distributive as D+import NumHask.Range+import NumHask.Space.Types++-- $setup+-- >>> :set -XNoImplicitPrelude+-- >>> :set -XFlexibleContexts+--++-- | A 2-dim point of a's, implemented as a tuple, but api represented as Point a a.+--+-- >>> fmap (+1) (Point 1 2)+-- Point 2 3+-- >>> pure one :: Point Int+-- Point 1 1+-- >>> (*) <$> Point 1 2 <*> pure 2+-- Point 2 4+-- >>> foldr (++) [] (Point [1,2] [3])+-- [1,2,3]+-- >>> Point "a" "pair" `mappend` pure " " `mappend` Point "string" "mappended"+-- Point "a string" "pair mappended"+--+-- As a Ring and Field class+--+-- >>> Point 0 1 + zero+-- Point 0 1+-- >>> Point 0 1 + Point 2 3+-- Point 2 4+-- >>> Point 1 1 - one+-- Point 0 0+-- >>> Point 0 1 * one+-- Point 0 1+-- >>> Point 0.0 1.0 / one+-- Point 0.0 1.0+-- >>> Point 11 12 `mod` (pure 6)+-- Point 5 0+newtype Point a =+  Point' (a, a)+  deriving (Eq, Generic)++-- | the preferred pattern+pattern Point :: a -> a -> Point a+pattern Point a b = Point' (a,b)+{-# COMPLETE Point#-}++instance (Show a) => Show (Point a) where+  show (Point a b) = "Point " <> Text.Show.show a <> " " <> Text.Show.show b++instance Functor Point where+  fmap f (Point a b) = Point (f a) (f b)++instance Eq1 Point where+  liftEq f (Point a b) (Point c d) = f a c && f b d++instance Show1 Point where+  liftShowsPrec sp _ d (Point' (a, b)) = showsBinaryWith sp sp "Point" d a b++instance Applicative Point where+  pure a = Point a a+  (Point fa fb) <*> Point a b = Point (fa a) (fb b)++instance Monad Point where+  Point a b >>= f = Point a' b'+    where+      Point a' _ = f a+      Point _ b' = f b++instance Foldable Point where+  foldMap f (Point a b) = f a `mappend` f b++instance Traversable Point where+  traverse f (Point a b) = Point <$> f a <*> f b++instance (Semigroup a) => Semigroup (Point a) where+  (Point a0 b0) <> (Point a1 b1) = Point (a0 <> a1) (b0 <> b1)++instance (Semigroup a, Monoid a) => Monoid (Point a) where+  mempty = Point mempty mempty+  mappend = (<>)++instance (Bounded a) => Bounded (Point a) where+  minBound = Point minBound minBound+  maxBound = Point maxBound maxBound++unaryOp :: (a -> a) -> (Point a -> Point a)+unaryOp f (Point a b) = Point (f a) (f b)++instance (Num a) => Num (Point a) where+  (Point a0 b0) + (Point a1 b1) = Point (a0 + a1) (b0 + b1)+  negate = unaryOp negate+  (Point a0 b0) * (Point a1 b1) = Point (a0 * a1) (b0 * b1)+  signum = unaryOp signum+  abs = unaryOp abs+  fromInteger x = Point (fromInteger x) (fromInteger x)++instance (Fractional a) => Fractional (Point a) where+  fromRational x = Point (fromRational x) 0+  recip = unaryOp recip++instance Distributive Point where+  collect f x = Point (getL . f <$> x) (getR . f <$> x)+    where getL (Point l _) = l+          getR (Point _ r) = r++instance Representable Point where+  type Rep Point = Bool+  tabulate f = Point (f False) (f True)+  index (Point l _) False = l+  index (Point _ r) True = r++instance (Ord a) => Lattice (Point a) where+  (\/) (Point x y) (Point x' y') = Point (max x x') (max y y')+  (/\) (Point x y) (Point x' y') = Point (min x x') (min y y')++-- | rotate a point by x degrees relative to the origin+rotate :: (Floating a) => a -> Point a -> Point a+rotate d (Point x y) = Point (x * cos d' + y*sin d') (y* cos d'-x*sin d')+  where+    d' = d*pi/180++-- | Create Points for a formulae y = f(x) across an x range+gridP :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Point a]+gridP f r g = (\x -> Point x (f x)) <$> grid OuterPos r g
+ src/NumHask/Range.hs view
@@ -0,0 +1,214 @@+{-# 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 #-}++-- | An Space with no empty, a semigroup based on a convex hull union, and a monoid on a negative space.+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++-- $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 (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++-- | Monoid based on convex hull union+instance (Eq a, Ord a) => Semigroup (Range a) where+  (<>) a b = getUnion (Union a <> Union b)++-- | Numeric algebra based on Interval arithmetic+-- https://en.wikipedia.org/wiki/Interval_arithmetic+--++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)
+ src/NumHask/Rect.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++-- | a two-dimensional plane, implemented as a composite of a 'Point' of 'Range's.+module NumHask.Rect+  ( Rect(..)+  , pattern Rect+  , pattern Ranges+  , corners+  , corners4+  , projectRect+  , addRect+  , multRect+  , unitRect+  , foldRect+  , addPoint+  , rotateRect+  , gridR+  , gridF+  , aspect+  , ratio+  ) where++import Data.Bool (bool)+import GHC.Exts+import GHC.Generics (Generic)+import Data.Distributive as D+import Data.Functor.Compose+import Data.Functor.Rep+import Prelude+import NumHask.Range+import NumHask.Space.Types+import NumHask.Point+import Algebra.Lattice+import Data.List.NonEmpty+import Data.Semigroup++-- $setup+-- >>> :set -XNoImplicitPrelude++-- | a 'Point' 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 (Point 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) (Point 0.5 1)+-- Point 2.5 -10.0+-- >>> gridSpace (Rect 0 10 0 1) (Point 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) (Point 2 2)+-- [Point 2.5 0.25,Point 2.5 0.75,Point 7.5 0.25,Point 7.5 0.75]+newtype Rect a =+  Rect' (Compose Point 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 (Point (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 (Point 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 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 (Ord a) => Semigroup (Rect a) where+  (<>) = union++instance (Ord a) => Space (Rect a) where+  type Element (Rect a) = Point 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)++  (>.<) (Point l0 l1) (Point u0 u1) = Rect l0 u0 l1 u1++  lower (Rect l0 _ l1 _) = Point l0 l1+  upper (Rect _ u0 _ u1) = Point u0 u1++  singleton (Point x y) = Rect x x y y++  (...) p p' = (p /\ p') >.< (p \/ p')++  (|.|) a s = (a `meetLeq` lower s) && (upper s `meetLeq` a)++  (|>|) s0 s1 = lower s0 `meetLeq` upper s1++  (|<|) s0 s1 = lower s1 `joinLeq` upper s0++instance (Ord a, Fractional a, Num a) => FieldSpace (Rect a) where+    type Grid (Rect a) = Point Int++    grid o s n = (+ bool 0 (step/2) (o==MidPos)) <$> posns+      where+      posns =+        (lower s +) . (step *) . fmap fromIntegral <$>+        [Point x y | x <- [x0 .. x1], y <- [y0 .. y1]]+      step = (/) (width s) (fromIntegral <$> n)+      (Point x0 y0, Point x1 y1) =+        case o of+          OuterPos -> (0, n)+          InnerPos -> (1, n - 1)+          LowerPos -> (0, n - 1)+          UpperPos -> (1, n)+          MidPos -> (0, n - 1)++    gridSpace (Ranges rX rY) (Point 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 points representing the lower left and upper right corners of a rectangle.+corners :: (Ord a) => Rect a -> [Point a]+corners r = [lower r, upper r]++-- | the 4 corners+corners4 :: Rect a -> NonEmpty (Point a)+corners4 (Rect x z y w) =+  Point x y :|+  [ Point x w+  , Point z y+  , Point z w+  ]+++-- | project a Rect from an old range to a new 1+projectRect ::+     (Ord a, Fractional a)+  => Rect a+  -> Rect a+  -> Rect a+  -> Rect a+projectRect r0 r1 (Rect a b c d) = Rect a' b' c' d'+  where+    (Point a' c') = project r0 r1 (Point a c)+    (Point b' d') = project r0 r1 (Point b d)+++-- | Rect projection maths: some sort of affine projection lurking under the hood?+-- > width one = one+-- > mid zero = zero++addRect :: (Num a) => Rect a -> Rect a -> Rect a+addRect (Rect a b c d) (Rect a' b' c' d') =+  Rect (a + a') (b + b') (c + c') (d + d')++multRect :: (Ord a, Fractional a) => Rect a -> Rect a -> Rect a+multRect (Ranges x0 y0) (Ranges x1 y1) =+  Ranges (x0 `rtimes` x1) (y0 `rtimes` y1)+  where+    rtimes a b = bool (Range (m - r/2) (m + r/2)) 0 (a == 0 || b == 0)+      where+        m = mid a + mid b+        r = width a * width b++unitRect :: (Fractional a) => Rect a+unitRect = Ranges rone rone where+    rone = Range (-0.5) 0.5++foldRect :: (Ord a) => [Rect a] -> Maybe (Rect a)+foldRect [] = Nothing+foldRect (x:xs) = Just $ sconcat (x :| xs)++addPoint :: (Num a) => Point a -> Rect a -> Rect a+addPoint (Point x' y') (Rect x z y w) = Rect (x+x') (z+x') (y+y') (w+y')++-- | rotate the corners of a Rect by x degrees relative to the origin, and fold to a new Rcet+rotateRect :: (Floating a, Ord a) => a -> Rect a -> Rect a+rotateRect d r =+  space1 $ rotate d <$> corners r++-- | Create Rects for a formulae y = f(x) across an x range+gridR :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Rect a]+gridR f r g = (\x -> Rect (x-tick/2) (x+tick/2) 0 (f x)) <$> grid MidPos r g+  where+    tick = width r / fromIntegral g++-- | Create values c for Rects data for a formulae c = f(x,y)+gridF :: (Ord a, Fractional a) => (Point a -> b) -> Rect a -> Grid (Rect a) -> [(Rect a, b)]+gridF f r g = (\x -> (x, f (mid x))) <$> gridSpace r g++-- | convert a ratio of x-plane : y-plane to a ViewBox with a height of one.+aspect :: (Fractional a) => a -> Rect a+aspect a = Rect (a * (-0.5)) (a * 0.5) (-0.5) 0.5++-- | convert a Rect to a ratio+ratio :: (Fractional a) => Rect a -> a+ratio (Rect x z y w) = (z-x)/(w-y)
+ src/NumHask/Space.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wall #-}++-- | a continuous set of numbers+-- mathematics does not define a space, so library devs are free to experiment.+-- https://en.wikipedia.org/wiki/Interval_(mathematics)+--+module NumHask.Space+  ( -- * Space+    -- $space+    module NumHask.Space.Types+    -- * Instances+  , module NumHask.Point+  , module NumHask.Range+  , module NumHask.Rect+  ) where++import NumHask.Space.Types+import NumHask.Point+import NumHask.Range+import NumHask.Rect++-- $space+-- The final frontier.++-- $instances+-- Some concrete data types that are usseful in charting.+--+
+ src/NumHask/Space/Time.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++-- | data algorithms related to time (as a Space)+module NumHask.Space.Time+  ( parseUTCTime+  , TimeGrain(..)+  , floorGrain+  , ceilingGrain+  , sensibleTimeGrid+  , PosDiscontinuous(..)+  , placedTimeLabelDiscontinuous+  ) where++import Data.Time+import GHC.Base (String)+import GHC.Generics+import Prelude+import qualified Control.Foldl as L+import qualified Data.Text as Text+import Data.Text (Text)+import NumHask.Space++-- | parse text as per iso8601+--+-- >>> :set -XOverloadedStrings+-- >>> let t0 = parseUTCTime ("2017-12-05" :: Text)+-- >>> t0+-- Just 2017-12-05 00:00:00 UTC+--+parseUTCTime :: Text -> Maybe UTCTime+parseUTCTime =+  parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing) . Text.unpack++-- | a step in time+data TimeGrain+  = Years Integer+  | Months Int+  | Days Int+  | Hours Int+  | Minutes Int+  | Seconds Double+  deriving (Show, Eq, Generic)++grainSecs :: TimeGrain -> Double+grainSecs (Years n) = fromIntegral n * 365.0 * toDouble nominalDay+grainSecs (Months n) = fromIntegral n * 365.0 / 12 * toDouble nominalDay+grainSecs (Days n) = fromIntegral n * toDouble nominalDay+grainSecs (Hours n) = fromIntegral n * 60 * 60+grainSecs (Minutes n) = fromIntegral n * 60+grainSecs (Seconds n) = n++toDouble :: NominalDiffTime -> Double+toDouble t =+    (/1000000000000.0) $+    fromIntegral (floor $ t * 1000000000000 :: Integer)++toDouble' :: DiffTime -> Double+toDouble' =+  (\x -> x / ((10 :: Double) ^ (12 :: Integer))) . fromIntegral . fromEnum++fromDouble :: Double -> NominalDiffTime+fromDouble x =+  let d0 = ModifiedJulianDay 0+      days = floor (x/toDouble nominalDay)+      secs = x - fromIntegral days * toDouble nominalDay+      t0 = UTCTime d0 (picosecondsToDiffTime 0)+      t1 = UTCTime (addDays days d0) (picosecondsToDiffTime $ floor (secs / 1.0e-12))+  in diffUTCTime t1 t0++fromDouble' :: Double -> DiffTime+fromDouble' d = toEnum $ fromEnum $ d * ((10 :: Double) ^ (12 :: Integer))++-- | add a TimeGrain to a UTCTime+--+-- >>> addGrain (Years 1) 5 (UTCTime (fromGregorian 2015 2 28) 0)+-- 2020-02-29 00:00:00 UTC+--+-- >>> addGrain (Months 1) 1 (UTCTime (fromGregorian 2015 2 28) 0)+-- 2015-03-31 00:00:00 UTC+-- +-- >>> addGrain (Hours 6) 5 (UTCTime (fromGregorian 2015 2 28) 0)+-- 2015-03-01 06:00:00 UTC+-- +-- >>> addGrain (Seconds 0.001) (60*1000+1) (UTCTime (fromGregorian 2015 2 28) 0)+-- 2015-02-28 00:01:00.001 UTC+-- +addGrain :: TimeGrain -> Int -> UTCTime -> UTCTime+addGrain (Years n) x (UTCTime d t) =+    UTCTime (addDays (-1) $ addGregorianYearsClip (n*fromIntegral x) (addDays 1 d)) t+addGrain (Months n) x (UTCTime d t) =+    UTCTime (addDays (-1) $ addGregorianMonthsClip (fromIntegral (n*x)) (addDays 1 d)) t+addGrain (Days n) x (UTCTime d t) = UTCTime (addDays (fromIntegral x * fromIntegral n) d) t+addGrain g@(Hours _) x d = addUTCTime (fromDouble (fromIntegral x * grainSecs g)) d+addGrain g@(Minutes _) x d = addUTCTime (fromDouble (fromIntegral x * grainSecs g)) d+addGrain g@(Seconds _) x d = addUTCTime (fromDouble (fromIntegral x * grainSecs g)) d+++addHalfGrain :: TimeGrain -> UTCTime -> UTCTime+addHalfGrain (Years n) (UTCTime d t) =+    UTCTime (addDays (-1) $ (if m'==1 then addGregorianMonthsClip 6 else id) $+             addGregorianYearsClip d' (addDays 1 d)) t+  where+    (d',m') = divMod 2 n+addHalfGrain (Months n) (UTCTime d t) =+    UTCTime (addDays (if m'==1 then 15 else 0) {- sue me -} $+             addDays (-1) $+             addGregorianMonthsClip (fromIntegral d') (addDays 1 d)) t+  where+    (d',m') = divMod 2 n+addHalfGrain (Days n) (UTCTime d t) =+    (if m'== 1 then addUTCTime (fromDouble (0.5 * grainSecs (Days 1))) else id) $+    UTCTime (addDays (fromIntegral d') d) t+  where+    (d',m') = divMod 2 n+addHalfGrain g@(Hours _) d = addUTCTime (fromDouble (0.5 * grainSecs g)) d+addHalfGrain g@(Minutes _) d = addUTCTime (fromDouble (0.5 * grainSecs g)) d+addHalfGrain g@(Seconds _) d = addUTCTime (fromDouble (0.5 * grainSecs g)) d++-- | compute the floor UTCTime based on the timegrain+--+-- >>> floorGrain (Years 5) (UTCTime (fromGregorian 1999 1 1) 0)+-- 1995-12-31 00:00:00 UTC+--+-- >>> floorGrain (Months 3) (UTCTime (fromGregorian 2016 12 30) 0)+-- 2016-09-30 00:00:00 UTC+--+-- >>> floorGrain (Days 5) (UTCTime (fromGregorian 2016 12 30) 1)+-- 2016-12-30 00:00:00 UTC+--+-- >>> floorGrain (Minutes 15) (UTCTime (fromGregorian 2016 12 30) (fromDouble' $ 15*60+1))+-- 2016-12-30 00:15:00 UTC+--+-- >>> floorGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) 0.12)+-- 2016-12-30 00:00:00.1 UTC+--+floorGrain :: TimeGrain -> UTCTime -> UTCTime+floorGrain (Years n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' 1 1) 0+  where+    (y,_,_) = toGregorian (addDays 1 d)+    y' = fromIntegral $ 1 + n * floor (fromIntegral (y - 1) / fromIntegral n :: Double)+floorGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y m' 1) 0+  where+    (y,m,_) = toGregorian (addDays 1 d)+    m' = fromIntegral (1 + fromIntegral n * floor (fromIntegral (m - 1) / fromIntegral n :: Double) :: Integer)+floorGrain (Days _) (UTCTime d _) = UTCTime d 0+floorGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u+  where+    s = toDouble' t+    x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (floor (s / (fromIntegral h*3600)) :: Integer)) - s+floorGrain (Minutes m) u@(UTCTime _ t) = addUTCTime x u+  where+    s = toDouble' t+    x = fromDouble $ fromIntegral (m * 60 * fromIntegral (floor (s / (fromIntegral m*60)) :: Integer)) - s+floorGrain (Seconds secs) u@(UTCTime _ t) = addUTCTime x u+  where+    s = toDouble' t+    x = fromDouble $ (secs * fromIntegral (floor (s / secs) :: Integer)) - s++-- | compute the ceiling UTCTime based on the timegrain+--+-- >>> ceilingGrain (Years 5) (UTCTime (fromGregorian 1999 1 1) 0)+-- 2000-12-31 00:00:00 UTC+--+-- >>> ceilingGrain (Months 3) (UTCTime (fromGregorian 2016 12 30) 0)+-- 2016-12-31 00:00:00 UTC+--+-- >>> ceilingGrain (Days 5) (UTCTime (fromGregorian 2016 12 30) 1)+-- 2016-12-31 00:00:00 UTC+--+-- >>> ceilingGrain (Minutes 15) (UTCTime (fromGregorian 2016 12 30) (fromDouble' $ 15*60+1))+-- 2016-12-30 00:30:00 UTC+--+-- >>> ceilingGrain (Seconds 0.1) (UTCTime (fromGregorian 2016 12 30) 0.12)+-- 2016-12-30 00:00:00.2 UTC+--+ceilingGrain :: TimeGrain -> UTCTime -> UTCTime+ceilingGrain (Years n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' 1 1) 0+  where+    (y,_,_) = toGregorian (addDays 1 d)+    y' = fromIntegral $ 1 + n * ceiling (fromIntegral (y - 1) / fromIntegral n :: Double)+ceilingGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' m'' 1) 0+  where+    (y,m,_) = toGregorian (addDays 1 d)+    m' = (m + n - 1) `div` n * n+    (y',m'') = fromIntegral <$> if m' == 12 then (y+1,1) else (y,m'+1)+ceilingGrain (Days _) (UTCTime d t) = if t==0 then UTCTime d 0 else UTCTime (addDays 1 d) 0+ceilingGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u+  where+    s = toDouble' t+    x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (ceiling (s / (fromIntegral h*3600)) :: Integer)) - s+ceilingGrain (Minutes m) u@(UTCTime _ t) = addUTCTime x u+  where+    s = toDouble' t+    x = fromDouble $ fromIntegral (m * 60 * fromIntegral (ceiling (s / (fromIntegral m*60)) :: Integer)) - s+ceilingGrain (Seconds secs) u@(UTCTime _ t) = addUTCTime x u+  where+    s = toDouble' t+    x = fromDouble $ (secs * fromIntegral (ceiling (s / secs) :: Integer)) - s++-- | whether to include lower and upper times+data PosDiscontinuous = PosInnerOnly | PosIncludeBoundaries++-- | dates attached to charts are often discontinuous, but we want to smooth that reality over and show a continuous range on the axis+-- The assumption with getSensibleTimeGrid is that there is a list of discountinuous UTCTimes rather than a continuous range.  Output is a list of index points for the original [UTCTime] and label tuples, and a list of unused list elements.+--+-- >>> placedTimeLabelDiscontinuous PosIncludeBoundaries (Just "%d %b") 2 [UTCTime (fromGregorian 2017 12 6) 0, UTCTime (fromGregorian 2017 12 29) 0, UTCTime (fromGregorian 2018 1 31) 0, UTCTime (fromGregorian 2018 3 3) 0]+-- ([(0,"06 Dec"),(1,"31 Dec"),(2,"28 Feb"),(3,"03 Mar")],[])+--+placedTimeLabelDiscontinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> ([(Int, Text)], [UTCTime])+placedTimeLabelDiscontinuous posd format n ts = (zip (fst <$> inds') labels, rem')+  where+    l = minimum ts+    u = maximum ts+    (grain, tps) = sensibleTimeGrid InnerPos n (l, u)+    tps' = case posd of+      PosInnerOnly -> tps+      PosIncludeBoundaries -> [l] <> tps <> [u]+    (rem', inds) = L.fold (matchTimes tps') ts+    inds' = laterTimes inds+    fmt = case format of+      Just f -> Text.unpack f+      Nothing -> autoFormat grain+    labels = Text.pack . formatTime defaultTimeLocale fmt . snd <$> inds'++autoFormat :: TimeGrain -> String+autoFormat (Years x)+    | x == 1 = "%b %Y"+    | otherwise = "%Y"+autoFormat (Months _) = "%d %b %Y"+autoFormat (Days _) = "%d %b %y"+autoFormat (Hours x)+    | x > 3 = "%d/%m/%y %R"+    | otherwise = "%R"+autoFormat (Minutes _) = "%R"+autoFormat (Seconds _) = "%R%Q"++matchTimes :: [UTCTime] -> L.Fold UTCTime ([UTCTime], [(Int, UTCTime)])+matchTimes ticks = L.Fold step begin (\(p,x,_) -> (p,reverse x))+  where+    begin = (ticks,[],0)+    step ([], xs, n) _ = ([], xs, n)+    step (p:ps, xs, n) a+        | p == a = step (ps, (n,p):xs, n) a+        | p > a = (p:ps, xs, n + 1)+        | otherwise = step (ps, (n - 1,p):xs, n) a++laterTimes :: [(Int, a)] -> [(Int,a)]+laterTimes [] = []+laterTimes [x] = [x]+laterTimes (x:xs) = L.fold (L.Fold step (x,[]) (\(x0,x1) -> reverse $ x0:x1)) xs+  where+    step ((n,a), rs) (na, aa) = if na == n then ((na,aa),rs) else ((na,aa),(n,a):rs)++-- | compute a sensible TimeGrain and list of UTCTimes+--+-- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2016 12 31) 0, UTCTime (fromGregorian 2017 12 31) 0)+-- (Months 6,[2016-12-31 00:00:00 UTC,2017-06-30 00:00:00 UTC,2017-12-31 00:00:00 UTC])+--+-- >>> sensibleTimeGrid InnerPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 0)+-- (Months 6,[2017-06-30 00:00:00 UTC])+--+-- >>>  sensibleTimeGrid UpperPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 0)+-- (Months 6,[2017-06-30 00:00:00 UTC,2017-12-31 00:00:00 UTC])+-- +-- >>>sensibleTimeGrid LowerPos 2 (UTCTime (fromGregorian 2017 1 1) 0, UTCTime (fromGregorian 2017 12 30) 0)+-- (Months 6,[2016-12-31 00:00:00 UTC,2017-06-30 00:00:00 UTC])+--+sensibleTimeGrid :: Pos -> Int -> (UTCTime, UTCTime) -> (TimeGrain, [UTCTime])+sensibleTimeGrid p n (l, u) = (grain, ts)+  where+    span' = u `diffUTCTime` l+    grain = stepSensibleTime p span' n+    first' = floorGrain grain l+    last' = ceilingGrain grain u+    n' = round $ toDouble (diffUTCTime last' first') / grainSecs grain :: Integer+    posns = case p of+      OuterPos -> take (fromIntegral $ n'+1)+      InnerPos -> drop (if first'==l then 0 else 1) . take (fromIntegral $ n' + if last'==u then 1 else 0)+      UpperPos -> drop 1 . take (fromIntegral $ n' + 1)+      LowerPos -> take (fromIntegral n')+      MidPos -> take (fromIntegral n')+    ts = case p of+      MidPos -> take (fromIntegral n') $ addHalfGrain grain . (\x -> addGrain grain x first') <$> [0..]+      _ -> posns $ (\x -> addGrain grain x first') <$> [0..]++-- come up with a sensible step for a grid over a Field+stepSensible ::+     (Fractional a, RealFrac a, Floating a)+  => Pos+  -> a+  -> Int+  -> a+stepSensible tp span' n =+  step ++  if tp == MidPos+    then step / 2+    else 0+  where+    step' = 10 ^^ (floor (logBase 10 (span' / fromIntegral n)) :: Integer)+    err = fromIntegral n / span' * step'+    step+      | err <= 0.15 = 10 * step'+      | err <= 0.35 = 5 * step'+      | err <= 0.75 = 2 * step'+      | otherwise = step'++-- come up with a sensible step for a grid over a Field, where sensible means the 18th century+-- practice of using multiples of 3 to round+stepSensible3 ::+     (Fractional a, Floating a, RealFrac a)+  => Pos+  -> a+  -> Int+  -> a+stepSensible3 tp span' n =+  step ++  if tp == MidPos+    then step / 2+    else 0+  where+    step' = 10 ^^ (floor (logBase 10 (span' / fromIntegral n)) :: Integer)+    err = fromIntegral n / span' * step'+    step+      | err <= 0.05 = 12 * step'+      | err <= 0.3 = 6 * step'+      | err <= 0.5 = 3 * step'+      | otherwise = step'++-- | come up with a sensible TimeGrain over a NominalDiffTime+stepSensibleTime :: Pos -> NominalDiffTime -> Int -> TimeGrain+stepSensibleTime tp span' n+  | yearsstep >= 1 = Years (floor yearsstep)+  | monthsstep >= 1 = Months (fromIntegral (floor monthsstep :: Integer))+  | daysstep >= 1 = Days (fromIntegral (floor daysstep :: Integer))+  | hoursstep >= 1 = Hours (fromIntegral (floor hoursstep :: Integer))+  | minutesstep >= 1 = Minutes (fromIntegral (floor minutesstep :: Integer))+  | secondsstep >= 1 = Seconds secondsstep3+  | otherwise = Seconds secondsstep+  where+    sp = toDouble span'+    minutes = sp / 60+    hours = sp / (60 * 60)+    days = sp / toDouble nominalDay+    years = sp / 365 / toDouble nominalDay+    months' = years * 12+    yearsstep = stepSensible tp years n+    monthsstep = stepSensible3 tp months' n+    daysstep = stepSensible tp days n+    hoursstep = stepSensible3 tp hours n+    minutesstep = stepSensible3 tp minutes n+    secondsstep3 = stepSensible3 tp sp n+    secondsstep = stepSensible tp sp n
+ src/NumHask/Space/Types.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module NumHask.Space.Types+  ( Space(..)+  , Union(..)+  , Intersection(..)+  , FieldSpace(..)+  , mid+  , project+  , Pos(..)+  , space1+  , memberOf+  , contains+  , disjoint+  , width+  , (+/-)+  , monotone+  , eps+  , widen+  , widenEps+  , scale+  , move+  )++where++class 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++  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++  -- | the union of two spaces+  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++  -- | 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+  default (...) :: (Ord (Element s)) => Element s -> Element s -> s+  (...) a b = (a `min` b) >.< (a `max` b)++  -- | create a space from two elements without normalising+  infix 3 >.<+  (>.<) :: Element s -> Element s -> s++  -- | is an element in the space+  infixl 7 |.|+  (|.|) :: Element s -> s -> Bool+  default (|.|) :: (Ord (Element s)) => Element s -> s -> Bool+  (|.|) a s = (a >= lower s) && (upper s >= a)++  -- | is one space completely above the other+  infixl 7 |>|+  (|>|) :: s -> s -> Bool+  default (|>|) :: (Ord (Element s)) => s -> s -> Bool+  (|>|) s0 s1 =+    lower s0 >= upper s1++  -- | is one space completely below the other+  infixl 7 |<|+  (|<|) :: s -> s -> Bool+  default (|<|) :: (Ord (Element s)) => s -> s -> Bool+  (|<|) s0 s1 =+    lower s1 <= upper s0++-- | 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++-- (|.|) a s = (a `joinLeq` lower s) && (upper s `meetLeq` a)+memberOf :: (Space s) => Element s -> s -> Bool+memberOf = (|.|)++-- | distance between boundaries+width :: (Space s, Num (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, Num (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)++-- | a space that can be divided neatly+--+class (Space s, Num (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, Fractional (Element s)) => s -> Element s+mid s = (lower s + upper s)/2.0++-- | 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 mempty one zero = NaN+-- > project one mempty zero = Infinity+-- > project one mempty one = NaN+--+project :: (Space s, Fractional (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 Traversable+space1 :: (Space s, Traversable f) => f (Element s) -> s+space1 = foldr1 union . fmap singleton++-- | 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 small space+eps ::+    ( Space s+    , Fractional (Element s)+    )+    => Element s -> Element s -> s+eps accuracy a = a +/- (accuracy * a * 1e-6)++-- | widen a space+widen ::+    ( Space s+    , Num (Element s))+    => Element s -> s -> s+widen a s = (lower s - a) >.< (upper s + a)++-- | widen by a small amount+widenEps ::+    ( Space s+    , Fractional (Element s)+    )+    => Element s -> s -> s+widenEps accuracy = widen (accuracy * 1e-6)++-- | scale a Space+scale :: (Num (Element s), Space s) => Element s -> s -> s+scale e s = (e * lower s) ... (e * upper s)++-- | move a Space+move :: (Num (Element s), Space s) => Element s -> s -> s+move e s = (e + lower s) ... (e + upper s)++++