packages feed

numhask-space 0.5.0 → 0.6.0

raw patch · 10 files changed

+338/−221 lines, 10 filesdep +numhaskdep −foldldep −latticesdep −protoludedep ~time

Dependencies added: numhask

Dependencies removed: foldl, lattices, protolude

Dependency ranges changed: time

Files

numhask-space.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: numhask-space-version: 0.5.0+version: 0.6.0 synopsis:   numerical spaces description:@@ -48,13 +48,11 @@     base >=4.7 && <5,     containers >= 0.6 && < 0.7,     distributive >=0.2.2 && <1,-    foldl >= 1.4.5 && <2,-    lattices >= 2.0.1 && <2.1,-    protolude >= 0.3.0 && < 0.4.0,+    numhask >= 0.6 && < 0.7,     semigroupoids >=5 && <6,     tdigest >= 0.2.1 && < 0.3,     text >= 1.2.3.1 && <2,-    time >= 1.8.0.2 && <2+    time >= 1.8.0.2 && <2,   exposed-modules:     NumHask.Space     NumHask.Space.Types@@ -63,6 +61,7 @@     NumHask.Space.Point     NumHask.Space.Time     NumHask.Space.Histogram+    NumHask.Space.XY   other-modules:   default-language: Haskell2010 @@ -74,7 +73,7 @@   build-depends:     base >=4.7 && <5,     doctest >= 0.16 && < 0.18,-    protolude >= 0.3+    numhask >= 0.6 && < 0.7,   default-language: Haskell2010   ghc-options:     -Wall
src/NumHask/Space.hs view
@@ -17,6 +17,7 @@     module NumHask.Space.Rect,     module NumHask.Space.Time,     module NumHask.Space.Histogram,+    module NumHask.Space.XY,   ) where @@ -26,17 +27,21 @@ import NumHask.Space.Rect hiding () import NumHask.Space.Time hiding () import NumHask.Space.Types hiding ()+import NumHask.Space.XY hiding ()  -- $space -- The final frontier. --- $instances--- Space is an interesting cross-section of many programming domains.------ - A Range is a Space of numbers.------ - A Rect is a Space of Points.------ - A time span is a space containing moments of time.------ - A histogram is a divided Range with a count of elements within each division.+{- $instances++ Space is an interesting cross-section of many programming domains.++ - A Range is a Space of numbers.++ - A Rect is a Space of Points.++ - A time span is a space containing moments of time.++ - A histogram is a divided Range with a count of elements within each division.++-}
src/NumHask/Space/Histogram.hs view
@@ -17,14 +17,13 @@   ) where -import qualified Control.Foldl as L import qualified Data.List as List import qualified Data.Map as Map import Data.TDigest import NumHask.Space.Range import NumHask.Space.Rect import NumHask.Space.Types-import Protolude+import NumHask.Prelude  -- | This Histogram is a list of contiguous boundaries (a boundary being the lower edge of one bucket and the upper edge of another), and a value (usually a count) for each bucket, represented here as a map --@@ -95,13 +94,13 @@ -- >>> regularQuantiles 4 [0..100] -- [0.0,24.75,50.0,75.25,100.0] regularQuantiles :: Double -> [Double] -> [Double]-regularQuantiles n = L.fold (quantileFold qs)+regularQuantiles n xs = quantileFold qs xs   where     qs = ((1 / n) *) <$> [0 .. n]  -- | one-pass approximate quantiles fold-quantileFold :: [Double] -> L.Fold Double [Double]-quantileFold qs = L.Fold step begin done+quantileFold :: [Double] -> [Double] -> [Double]+quantileFold qs xs = done $ foldl' step begin xs   where     step x a = Data.TDigest.insert a x     begin = tdigest ([] :: [Double]) :: TDigest 25@@ -116,7 +115,7 @@   where     diffq [] = []     diffq [_] = []-    diffq (x : xs') = L.fold (L.Fold step (x, []) (reverse . snd)) xs'+    diffq (x : xs') = (reverse . snd) $ foldl' step (x, []) xs'     step (a0, xs') a = (a, (a - a0) : xs')  -- | normalize a histogram so that sum values = one
src/NumHask/Space/Point.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} @@ -11,14 +13,14 @@   ) where -import Algebra.Lattice-import Data.Distributive as D+import Data.Distributive import Data.Functor.Classes import Data.Functor.Rep import GHC.Show (show) import NumHask.Space.Range import NumHask.Space.Types-import Protolude as P hiding (rotate)+import NumHask.Prelude hiding (show, Distributive, rotate)+import qualified NumHask.Prelude as P  -- $setup -- >>> :set -XNoImplicitPrelude@@ -44,7 +46,7 @@   deriving (Eq, Generic)  instance (Show a) => Show (Point a) where-  show (Point a b) = "Point " <> P.show a <> " " <> P.show b+  show (Point a b) = "Point " <> show a <> " " <> show b  instance Functor Point where   fmap f (Point a b) = Point (f a) (f b)@@ -85,22 +87,26 @@    maxBound = Point maxBound maxBound -instance (Num a) => Num (Point a) where+instance (Additive a) => Additive (Point a) where   (Point a0 b0) + (Point a1 b1) = Point (a0 + a1) (b0 + b1)+  zero = Point zero zero +instance (Subtractive a) => Subtractive (Point a) where   negate = fmap negate +instance (Multiplicative a) => Multiplicative (Point a) where   (Point a0 b0) * (Point a1 b1) = Point (a0 * a1) (b0 * b1)--  signum = fmap signum+  one = Point one one -  abs = fmap abs+instance (P.Distributive a) => P.Distributive (Point a) -  fromInteger x = Point (fromInteger x) (fromInteger x)+instance (Field a) => Field (Point a) -instance (Fractional a) => Fractional (Point a) where-  fromRational x = Point (fromRational x) (fromRational x)+instance (Signed a) => Signed (Point a) where+  sign = fmap sign+  abs = fmap abs +instance (Divisive a) => Divisive (Point a) where   recip = fmap recip  instance Distributive Point where@@ -117,16 +123,17 @@   index (Point l _) False = l   index (Point _ r) True = r -instance (Ord a) => Lattice (Point a) where+instance (Ord a) => JoinSemiLattice (Point a) where   (\/) (Point x y) (Point x' y') = Point (max x x') (max y y') +instance (Ord a) => MeetSemiLattice (Point a) where   (/\) (Point x y) (Point x' y') = Point (min x x') (min y y')  -- | rotate a point by x degrees relative to the origin -- -- >>> rotate 90 (Point 0 1) -- Point 1.0 6.123233995736766e-17-rotate :: (Floating a) => a -> Point a -> Point a+rotate :: (FromInteger a, TrigField 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@@ -135,5 +142,5 @@ -- -- >>> gridP (**2) (Range 0 4) 4 -- [Point 0.0 0.0,Point 1.0 1.0,Point 2.0 4.0,Point 3.0 9.0,Point 4.0 16.0]-gridP :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Point a]+gridP :: (FieldSpace (Range a)) => (a -> a) -> Range a -> Grid (Range a) -> [Point a] gridP f r g = (\x -> Point x (f x)) <$> grid OuterPos r g
src/NumHask/Space/Range.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-}@@ -10,8 +11,6 @@   ) where -import Algebra.Lattice-import Control.Category (id) import Data.Distributive as D import Data.Functor.Apply (Apply (..)) import Data.Functor.Classes@@ -20,9 +19,13 @@ import Data.Semigroup.Traversable (Traversable1 (..)) import GHC.Show (show) import NumHask.Space.Types as S-import Protolude as P+import NumHask.Prelude hiding (show)  -- $setup+--+-- >>> :set -XFlexibleContexts+-- >>> :set -XGADTs+--  -- | A continuous range over type a --@@ -35,7 +38,7 @@ -- >>> a + a -- Range -2 2 -- >>> a * a--- Range -1 1+-- Range -1.0 1.0 -- >>> (+1) <$> (Range 1 2) -- Range 2 3 --@@ -47,18 +50,18 @@ -- -- Create an equally spaced grid including outer bounds over a Range ----- >>> grid OuterPos (Range 0 10) 5+-- >>> grid OuterPos (Range 0.0 10.0) 5 -- [0.0,2.0,4.0,6.0,8.0,10.0] -- -- divide up a Range into equal-sized sections ----- >>> gridSpace (Range 0 1) 4+-- >>> gridSpace (Range 0.0 1.0) 4 -- [Range 0.0 0.25,Range 0.25 0.5,Range 0.5 0.75,Range 0.75 1.0] data Range a = Range a a   deriving (Eq, Generic)  instance (Show a) => Show (Range a) where-  show (Range a b) = "Range " <> P.show a <> " " <> P.show b+  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@@ -102,9 +105,10 @@   index (Range l _) False = l   index (Range _ r) True = r -instance (Ord a) => Lattice (Range a) where+instance (Ord a) => JoinSemiLattice (Range a) where   (\/) = liftR2 min +instance (Ord a) => MeetSemiLattice (Range a) where   (/\) = liftR2 max  instance (Eq a, Ord a) => Space (Range a) where@@ -116,8 +120,8 @@    (>.<) = Range -instance (Ord a, Fractional a) => FieldSpace (Range a) where-  type Grid (Range a) = Int+instance FieldSpace (Range Double) where+  type Grid (Range Double) = Int    grid o s n = (+ bool 0 (step / 2) (o == MidPos)) <$> posns     where@@ -138,26 +142,27 @@ instance (Eq a, Ord a) => Semigroup (Range a) where   (<>) a b = getUnion (Union a <> Union b) --- | Numeric algebra based on Interval arithmetic-instance (Num a, Eq a, Ord a) => Num (Range a) where+instance (Additive a, Eq a, Ord a) => Additive (Range a) where   (Range l u) + (Range l' u') = space1 [l + l', u + u']+  zero = Range zero zero +instance (Subtractive a, Eq a, Ord a) => Subtractive (Range a) where   negate (Range l u) = negate u ... negate l +instance (Field a, Eq a, Ord a) => Multiplicative (Range a) where   (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)+  one = Range (negate one/(one + one)) (one/(one+one)) +instance (Field a, Subtractive a, Eq a, Ord a) => Signed (Range a) where+  sign (Range l u) = bool (negate one) one (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 :: Pos -> Double -> Integer -> Double stepSensible tp span' n =   step + bool 0 (step / 2) (tp == MidPos)   where-    step' = 10.0 ^^ (floor (logBase 10 (span' / fromIntegral n)) :: Integer)+    step' = 10.0 ^^ (floor (logBase 10 (span' / fromInteger n)) :: Integer)     err = fromIntegral n / span' * step'     step       | err <= 0.15 = 10.0 * step'@@ -170,12 +175,11 @@ -- >>> gridSensible OuterPos False (Range (-12.0) 23.0) 6 -- [-15.0,-10.0,-5.0,0.0,5.0,10.0,15.0,20.0,25.0] gridSensible ::-  (Ord a, RealFrac a, Floating a, Integral b) =>   Pos ->   Bool ->-  Range a ->-  b ->-  [a]+  Range Double ->+  Integer ->+  [Double] gridSensible tp inside r@(Range l u) n =   bool id (filter (`memberOf` r)) inside $     (+ bool 0 (step / 2) (tp == MidPos)) <$> posns
src/NumHask/Space/Rect.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wincomplete-patterns #-}@@ -16,9 +18,6 @@     corners,     corners4,     projectRect,-    addRect,-    multRect,-    unitRect,     foldRect,     addPoint,     rotateRect,@@ -29,7 +28,6 @@   ) where -import Algebra.Lattice import Data.Distributive as D import Data.Functor.Compose import Data.Functor.Rep@@ -39,30 +37,34 @@ import NumHask.Space.Point import NumHask.Space.Range import NumHask.Space.Types-import Protolude as P hiding (rotate)+import NumHask.Prelude hiding (rotate, Distributive, show)  -- $setup+--+-- >>> :set -XFlexibleContexts+-- >>> :set -XGADTs+--  -- | a rectangular space often representing a 2-dimensional or XY plane. ----- >>> let a = Rect (-1) 1 (-2) 4+-- >>> let a = Rect (-1.0) 1.0 (-2.0) 4.0 -- >>> a--- Rect -1 1 -2 4+-- Rect -1.0 1.0 -2.0 4.0 -- >>> let (Ranges x y) = a -- >>> x--- Range -1 1+-- Range -1.0 1.0 -- >>> y--- Range -2 4+-- Range -2.0 4.0 -- >>> fmap (+1) (Rect 1 2 3 4) -- Rect 2 3 4 5 -- -- as a Space instance with Points as Elements ----- >>> project (Rect 0 1 (-1) 0) (Rect 1 4 10 0) (Point 0.5 1)+-- >>> project (Rect 0.0 1.0 (-1.0) 0.0) (Rect 1.0 4.0 10.0 0.0) (Point 0.5 1.0) -- Point 2.5 -10.0--- >>> gridSpace (Rect 0 10 0 1) (Point 2 2)+-- >>> gridSpace (Rect 0.0 10.0 0.0 1.0) (Point (2::Int) (2::Int)) -- [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)+-- >>> grid MidPos (Rect 0.0 10.0 0.0 1.0) (Point (2::Int) (2::Int)) -- [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)@@ -89,7 +91,7 @@  instance (Show a) => Show (Rect a) where   show (Rect a b c d) =-    "Rect " <> P.show a <> " " <> P.show b <> " " <> P.show c <> " " <> P.show d+    "Rect " <> show a <> " " <> show b <> " " <> show c <> " " <> show d  instance Distributive Rect where   collect f x =@@ -140,10 +142,10 @@    (|<|) s0 s1 = lower s1 `joinLeq` upper s0 -instance (Ord a, Fractional a, Num a) => FieldSpace (Rect a) where-  type Grid (Rect a) = Point Int+instance FieldSpace (Rect Double) where+  type Grid (Rect Double) = Point Int -  grid o s n = (+ bool 0 (step / 2) (o == MidPos)) <$> posns+  grid o s n = (+ bool zero (step / (one+one)) (o == MidPos)) <$> posns     where       posns =         (lower s +) . (step *) . fmap fromIntegral@@ -151,11 +153,11 @@       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)+          OuterPos -> (zero, n)+          InnerPos -> (one, n - one)+          LowerPos -> (zero, n - one)+          UpperPos -> (one, n)+          MidPos -> (zero, n - one)    gridSpace (Ranges rX rY) (Point stepX stepY) =     [ Rect x (x + sx) y (y + sy)@@ -168,14 +170,14 @@  -- | create a list of points representing the lower left and upper right corners of a rectangle. ----- >>> corners unitRect+-- >>> corners one -- [Point -0.5 -0.5,Point 0.5 0.5] corners :: (Ord a) => Rect a -> [Point a] corners r = [lower r, upper r]  -- | the 4 corners ----- >>> corners4 unitRect+-- >>> corners4 one -- [Point -0.5 -0.5,Point -0.5 0.5,Point 0.5 -0.5,Point 0.5 0.5] corners4 :: Rect a -> [Point a] corners4 (Rect x z y w) =@@ -192,63 +194,47 @@ -- >>> projectRect (Rect 0 1 (-1) 0) (Rect 0 4 0 8) (Rect 0.25 0.75 (-0.75) (-0.25)) -- Rect 1.0 3.0 2.0 6.0 projectRect ::-  (Ord a, Fractional a) =>-  Rect a ->-  Rect a ->-  Rect a ->-  Rect a+  Rect Double ->+  Rect Double ->+  Rect Double ->+  Rect Double 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)  -- | Numeric algebra based on interval arithmetioc for addition and unitRect and projection for multiplication-instance (Fractional a, Num a, Eq a, Ord a) => Num (Rect a) where-  (+) = addRect+-- >>> one + one :: Rect Double+-- Rect -1.0 1.0 -1.0 1.0+--+instance (Additive a) => Additive (Rect a) where+  (+)+    (Rect a b c d) (Rect a' b' c' d') =+    Rect (a + a') (b + b') (c + c') (d + d')+  zero = Rect zero zero zero zero +instance (Subtractive a) => Subtractive (Rect a) where   negate = fmap negate -  (*) = multRect--  signum (Rect x z y w) = bool (negate 1) 1 (z >= x && (w >= y))--  abs (Ranges x y) = Ranges (norm x) (norm y)--  fromInteger x = fromInteger x ... fromInteger x---- | Rect addition------ >>> unitRect `addRect` unitRect--- Rect -1.0 1.0 -1.0 1.0-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')+instance (Ord a, Field a) => Multiplicative (Rect a) where+  (*)+    (Ranges x0 y0) (Ranges x1 y1) =+    Ranges (x0 `rtimes` x1) (y0 `rtimes` y1)+    where+      rtimes a b = bool (Range (m - r / (one+one)) (m + r / (one+one))) zero (a == zero || b == zero)+        where+          m = mid a + mid b+          r = width a * width b --- | Rect multiplication------ >>> unitRect `multRect` Rect 0 2 0 4--- Rect 0.0 2.0 0.0 4.0-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+  one = Ranges one one --- | a unit Rectangle, with values chosen so that width and height are one and mid is zero------ >>> unitRect :: Rect Double--- Rect -0.5 0.5 -0.5 0.5-unitRect :: (Fractional a) => Rect a-unitRect = Ranges rone rone-  where-    rone = Range (-0.5) 0.5+instance (Ord a, Field a) => Signed (Rect a) where+  sign (Rect x z y w) = bool (negate one) one (z >= x && (w >= y))+  abs (Ranges x y) = Ranges (abs x) (abs y)  -- | convex hull union of Rect's ----- >>> foldRect [Rect 0 1 0 1, unitRect]+-- >>> foldRect [Rect 0 1 0 1, one] -- Just Rect -0.5 1.0 -0.5 1.0 foldRect :: (Ord a) => [Rect a] -> Maybe (Rect a) foldRect [] = Nothing@@ -256,16 +242,16 @@  -- | add a Point to a Rect ----- >>> addPoint (Point 0 1) unitRect+-- >>> addPoint (Point 0 1) one -- Rect -0.5 0.5 0.5 1.5-addPoint :: (Num a) => Point a -> Rect a -> Rect a+addPoint :: (Additive 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 Rect ----- >>> rotateRect 45 unitRect+-- >>> rotateRect 45 one -- Rect -0.7071067811865475 0.7071067811865475 -5.551115123125783e-17 5.551115123125783e-17-rotateRect :: (Floating a, Ord a) => a -> Rect a -> Rect a+rotateRect :: Double -> Rect Double -> Rect Double rotateRect d r =   space1 $ rotate d <$> corners r @@ -273,7 +259,7 @@ -- -- >>> gridR (**2) (Range 0 4) 4 -- [Rect 0.0 1.0 0.0 0.25,Rect 1.0 2.0 0.0 2.25,Rect 2.0 3.0 0.0 6.25,Rect 3.0 4.0 0.0 12.25]-gridR :: (Ord a, Fractional a) => (a -> a) -> Range a -> Int -> [Rect a]+gridR :: (Double -> Double) -> Range Double -> Int -> [Rect Double] 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@@ -282,19 +268,19 @@ -- -- >>> gridF (\(Point x y) -> x * y) (Rect 0 4 0 4) (Point 2 2) -- [(Rect 0.0 2.0 0.0 2.0,1.0),(Rect 0.0 2.0 2.0 4.0,3.0),(Rect 2.0 4.0 0.0 2.0,3.0),(Rect 2.0 4.0 2.0 4.0,9.0)]-gridF :: (Ord a, Fractional a) => (Point a -> b) -> Rect a -> Grid (Rect a) -> [(Rect a, b)]+gridF :: (Point Double -> b) -> Rect Double -> Grid (Rect Double) -> [(Rect Double, b)] gridF f r g = (\x -> (x, f (mid x))) <$> gridSpace r g  -- | convert a ratio (eg x:1) to a Rect with a height of one. -- -- >>> aspect 2 -- Rect -1.0 1.0 -0.5 0.5-aspect :: (Fractional a) => a -> Rect a+aspect :: Double -> Rect Double aspect a = Rect (a * (-0.5)) (a * 0.5) (-0.5) 0.5  -- | convert a Rect to a ratio -- -- >>> ratio (Rect (-1) 1 (-0.5) 0.5) -- 2.0-ratio :: (Fractional a) => Rect a -> a+ratio :: (Field a) => Rect a -> a ratio (Rect x z y w) = (z - x) / (w - y)
src/NumHask/Space/Time.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}  -- | data algorithms related to time (as a Space) module NumHask.Space.Time@@ -13,17 +16,19 @@     PosDiscontinuous (..),     placedTimeLabelDiscontinuous,     placedTimeLabelContinuous,+    fromNominalDiffTime,+    toNominalDiffTime,+    fromDiffTime,+    toDiffTime,   ) where -import Control.Category (id)-import qualified Control.Foldl as L import Data.List (nub) import Data.String (String)-import Data.Text (pack, unpack) import Data.Time import NumHask.Space.Types-import Protolude+import NumHask.Prelude+import Data.Fixed (Fixed(MkFixed))  -- | parse text as per iso8601 --@@ -46,34 +51,32 @@   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 (Years n) = fromIntegral n * 365.0 * fromNominalDiffTime nominalDay+grainSecs (Months n) = fromIntegral n * 365.0 / 12 * fromNominalDiffTime nominalDay+grainSecs (Days n) = fromIntegral n * fromNominalDiffTime 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+fromNominalDiffTime :: NominalDiffTime -> Double+fromNominalDiffTime t = let (MkFixed i) = (nominalDiffTimeToSeconds t) in (fromInteger i) * 1e-12 -fromDouble :: Double -> NominalDiffTime-fromDouble x =+toNominalDiffTime :: Double -> NominalDiffTime+toNominalDiffTime x =   let d0 = ModifiedJulianDay 0-      days = floor (x / toDouble nominalDay)-      secs = x - fromIntegral days * toDouble nominalDay+      days = floor (x / fromNominalDiffTime nominalDay)+      secs = x - fromIntegral days * fromNominalDiffTime 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))+fromDiffTime :: DiffTime -> Double+fromDiffTime =+  (\x -> x / ((10 :: Double) ^ (12 :: Integer))) . fromIntegral . fromEnum +toDiffTime :: Double -> DiffTime+toDiffTime d = toEnum . fromEnum $ d * ((10 :: Double) ^ (12 :: Integer))+ -- | add a TimeGrain to a UTCTime -- -- >>> addGrain (Years 1) 5 (UTCTime (fromGregorian 2015 2 28) 0)@@ -93,9 +96,9 @@ 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+addGrain g@(Hours _) x d = addUTCTime (toNominalDiffTime (fromIntegral x * grainSecs g)) d+addGrain g@(Minutes _) x d = addUTCTime (toNominalDiffTime (fromIntegral x * grainSecs g)) d+addGrain g@(Seconds _) x d = addUTCTime (toNominalDiffTime (fromIntegral x * grainSecs g)) d  addHalfGrain :: TimeGrain -> UTCTime -> UTCTime addHalfGrain (Years n) (UTCTime d t) =@@ -116,13 +119,13 @@   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) $+  (if m' == 1 then addUTCTime (toNominalDiffTime (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+addHalfGrain g@(Hours _) d = addUTCTime (toNominalDiffTime (0.5 * grainSecs g)) d+addHalfGrain g@(Minutes _) d = addUTCTime (toNominalDiffTime (0.5 * grainSecs g)) d+addHalfGrain g@(Seconds _) d = addUTCTime (toNominalDiffTime (0.5 * grainSecs g)) d  -- | compute the floor UTCTime based on the timegrain --@@ -135,33 +138,33 @@ -- >>> 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))+-- >>> floorGrain (Minutes 15) (UTCTime (fromGregorian 2016 12 30) (toDiffTime $ 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+floorGrain (Years n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' 1 1) (secondsToDiffTime 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+floorGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y m' 1) (secondsToDiffTime 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 (Days _) (UTCTime d _) = UTCTime d (secondsToDiffTime 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+    s = fromDiffTime t+    x = toNominalDiffTime $ 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+    s = fromDiffTime t+    x = toNominalDiffTime $ 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+    s = fromDiffTime t+    x = toNominalDiffTime $ (secs * fromIntegral (floor (s / secs) :: Integer)) - s  -- | compute the ceiling UTCTime based on the timegrain --@@ -174,34 +177,34 @@ -- >>> 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))+-- >>> ceilingGrain (Minutes 15) (UTCTime (fromGregorian 2016 12 30) (toDiffTime $ 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+ceilingGrain (Years n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' 1 1) (secondsToDiffTime 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+ceilingGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' m'' 1) (secondsToDiffTime 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 (Days _) (UTCTime d t) = if t == (secondsToDiffTime 0) then UTCTime d (secondsToDiffTime 0) else UTCTime (addDays 1 d) (secondsToDiffTime 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+    s = fromDiffTime t+    x = toNominalDiffTime $ 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+    s = fromDiffTime t+    x = toNominalDiffTime $ 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+    s = fromDiffTime t+    x = toNominalDiffTime $ (secs * fromIntegral (ceiling (s / secs) :: Integer)) - s  -- | whether to include lower and upper times data PosDiscontinuous = PosInnerOnly | PosIncludeBoundaries@@ -221,7 +224,15 @@     tps' = case posd of       PosInnerOnly -> tps       PosIncludeBoundaries -> [l] <> tps <> [u]-    (rem', inds) = L.fold (matchTimes tps') ts+    begin = (tps', [], 0)+    done (p, x, _) = (p, reverse x)+    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+    (rem', inds) = done $ foldl' step begin ts+     inds' = laterTimes inds     fmt = case format of       Just f -> unpack f@@ -240,27 +251,17 @@ 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+laterTimes (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x,[]) xs   where     step ((n, a), rs) (na, aa) = if na == n then ((na, aa), rs) else ((na, aa), (n, a) : rs)  -- | A sensible time grid between two dates, projected onto (0,1) with no attempt to get finnicky. -- -- >>> placedTimeLabelContinuous PosIncludeBoundaries (Just "%d %b") 2 (UTCTime (fromGregorian 2017 12 6) 0, UTCTime (fromGregorian 2017 12 29) 0)--- [(0.0,"06 Dec"),(0.43478260869565216,"16 Dec"),(0.8695652173913043,"26 Dec"),(1.0,"29 Dec")]+-- [(0.0,"06 Dec"),(0.4347826086956521,"16 Dec"),(0.8695652173913042,"26 Dec"),(0.9999999999999999,"29 Dec")] placedTimeLabelContinuous :: PosDiscontinuous -> Maybe Text -> Int -> (UTCTime, UTCTime) -> [(Double, Text)] placedTimeLabelContinuous posd format n (l, u) = zip tpsd labels   where@@ -274,8 +275,8 @@     labels = pack . formatTime defaultTimeLocale fmt <$> tps'     l' = minimum tps'     u' = maximum tps'-    r' = toDouble $ diffUTCTime u' l'-    tpsd = (/ r') . toDouble . flip diffUTCTime l <$> tps'+    r' = fromNominalDiffTime $ diffUTCTime u' l'+    tpsd = (/ r') . fromNominalDiffTime . flip diffUTCTime l <$> tps'  -- | compute a sensible TimeGrain and list of UTCTimes --@@ -297,7 +298,7 @@     grain = stepSensibleTime p span' n     first' = floorGrain grain l     last' = ceilingGrain grain u-    n' = round $ toDouble (diffUTCTime last' first') / grainSecs grain :: Integer+    n' = round $ fromNominalDiffTime (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)@@ -310,11 +311,10 @@  -- come up with a sensible step for a grid over a Field stepSensible ::-  (Fractional a, RealFrac a, Floating a) =>   Pos ->-  a ->+  Double ->   Int ->-  a+  Double stepSensible tp span' n =   step     + if tp == MidPos@@ -332,11 +332,10 @@ -- 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 ->+  Double ->   Int ->-  a+  Double stepSensible3 tp span' n =   step     + if tp == MidPos@@ -362,11 +361,11 @@   | secondsstep >= 1 = Seconds secondsstep3   | otherwise = Seconds secondsstep   where-    sp = toDouble span'+    sp = fromNominalDiffTime span'     minutes = sp / 60     hours = sp / (60 * 60)-    days = sp / toDouble nominalDay-    years = sp / 365 / toDouble nominalDay+    days = sp / fromNominalDiffTime nominalDay+    years = sp / 365 / fromNominalDiffTime nominalDay     months' = years * 12     yearsstep = stepSensible tp years n     monthsstep = stepSensible3 tp months' n
src/NumHask/Space/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}@@ -27,8 +28,8 @@   ) where -import Protolude-import Protolude.Partial (foldr1)+import NumHask.Prelude+import qualified Prelude as P  -- | Space is a continuous range of numbers that contains elements and has an upper and lower value. --@@ -129,13 +130,13 @@ memberOf = (|.|)  -- | distance between boundaries-width :: (Space s, Num (Element s)) => s -> Element s+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, Num (Element s)) => Element s -> Element s -> s+(+/-) :: (Space s, Subtractive (Element s)) => Element s -> Element s -> s a +/- b = a - b ... a + b  -- | a convex hull@@ -154,7 +155,7 @@ -- -- > space1 (grid OuterPos s g) == s -- > getUnion (sconcat (Union <$> (gridSpace s g))) == s-class (Space s, Num (Element s)) => FieldSpace s where+class (Space s, Field (Element s)) => FieldSpace s where   type Grid s :: Type    -- | create equally-spaced elements across a space@@ -178,8 +179,8 @@   deriving (Show, Eq)  -- | middle element of the space-mid :: (Space s, Fractional (Element s)) => s -> Element s-mid s = (lower s + upper s) / 2.0+mid :: (Space s, Field (Element s)) => s -> Element s+mid s = (lower s + upper s) / (one + one)  -- | project a data point from one space to another, preserving relative position --@@ -187,7 +188,7 @@ -- > project o n (upper o) = upper n -- > project o n (mid o) = mid n -- > project a a x = x-project :: (Space s, Fractional (Element s)) => s -> s -> Element s -> Element s+project :: (Space s, Field (Element s)) => s -> s -> Element s -> Element s project s0 s1 p =   ((p - lower s0) / (upper s0 - lower s0)) * (upper s1 - lower s1) + lower s1 @@ -195,7 +196,7 @@ -- -- > all $ space1 a `contains` <$> a space1 :: (Space s, Traversable f) => f (Element s) -> s-space1 = foldr1 union . fmap singleton+space1 = P.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@@ -204,7 +205,8 @@ -- | a small space eps ::   ( Space s,-    Fractional (Element s)+    FromRational (Element s),+    Field (Element s)   ) =>   Element s ->   Element s ->@@ -214,7 +216,7 @@ -- | widen a space widen ::   ( Space s,-    Num (Element s)+    Ring (Element s)   ) =>   Element s ->   s ->@@ -224,7 +226,8 @@ -- | widen by a small amount widenEps ::   ( Space s,-    Fractional (Element s)+    FromRational (Element s),+    Field (Element s)   ) =>   Element s ->   s ->@@ -232,9 +235,9 @@ widenEps accuracy = widen (accuracy * 1e-6)  -- | Scale a Space. (scalar multiplication)-scale :: (Num (Element s), Space s) => Element s -> s -> s+scale :: (Multiplicative (Element s), Space s) => Element s -> s -> s scale e s = (e * lower s) ... (e * upper s)  -- | Move a Space. (scalar addition)-move :: (Num (Element s), Space s) => Element s -> s -> s+move :: (Additive (Element s), Space s) => Element s -> s -> s move e s = (e + lower s) ... (e + upper s)
+ src/NumHask/Space/XY.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}++{- | Unification of a point on the XY-plane and a rectangle on the XY-plane.+++-}++module NumHask.Space.XY+  ( XY(..),+    pattern P,+    pattern R,+    toRect,+    toPoint,+    projectOn,+    projectTo,+    fixRect,+  ) where++import NumHask.Prelude+import NumHask.Space.Point+import NumHask.Space.Rect+import NumHask.Space.Types++-- | unification of a point and rect on the plane+data XY a+  = PointXY (Point a)+  | RectXY (Rect a)+  deriving (Eq, Show, Functor)++-- | make an XY from a point+pattern P :: a -> a -> XY a+pattern P x y = PointXY (Point x y)++{-# COMPLETE P #-}++-- | make an XY from a rectangle+pattern R :: a -> a -> a -> a -> XY a+pattern R x z y w = RectXY (Rect x z y w)++{-# COMPLETE R #-}++instance (Additive a) => Additive (XY a) where+  PointXY (Point x y) + PointXY (Point x' y') = PointXY (Point (x + x') (y + y'))+  PointXY (Point x' y') + RectXY (Rect x z y w) = RectXY $ Rect (x + x') (z + x') (y + y') (w + y')+  RectXY (Rect x z y w) + PointXY (Point x' y') = RectXY $ Rect (x + x') (z + x') (y + y') (w + y')+  RectXY (Rect x z y w) + RectXY (Rect x' z' y' w') =+    RectXY $ Rect (x + x') (z + z') (y + y') (w + w')+  zero = PointXY (Point zero zero)++instance (Ord a, Field a) => Multiplicative (XY a) where+  x * y = RectXY $ toRect x * toRect y+  one = RectXY one++instance (Ord a, Subtractive a) => Subtractive (XY a) where+  negate (PointXY (Point x y)) = PointXY (Point (negate x) (negate y))+  negate (RectXY (Rect x z y w)) = RectXY (Rect (negate x) (negate z) (negate y) (negate w))++instance (Ord a, Field a, Signed a) => Signed (XY a) where+  abs x = PointXY $ abs <$> toPoint x+  sign x = PointXY $ sign <$> toPoint x++-- * Natural transformations++-- | Convert a spot to a Rect+toRect :: XY a -> Rect a+toRect (PointXY (Point x y)) = Rect x x y y+toRect (RectXY a) = a++-- | Convert a spot to a Point+toPoint :: (Ord a, Field a) => XY a -> Point a+toPoint (PointXY (Point x y)) = Point x y+toPoint (RectXY (Ranges x y)) = Point (mid x) (mid y)++instance (Ord a) => Semigroup (XY a) where+  (<>) a b = RectXY (toRect a `union` toRect b)++-- | project an XY from one Rect to another, preserving relative position.+--+-- >>> projectOn one (Rect 0 1 0 1) zero+-- PointXY Point -0.5 -0.5+projectOn :: Rect Double -> Rect Double -> XY Double -> XY Double+projectOn new old@(Rect x z y w) po@(PointXY (Point px py))+  | x == z && y == w = po+  | x == z = (P px py')+  | y == w = (P px' py)+  | otherwise = (P px' py')+  where+    (Point px' py') = project old new (toPoint po)+projectOn new old@(Rect x z y w) ao@(RectXY (Rect ox oz oy ow))+  | x == z && y == w = ao+  | x == z = (R ox oz ny nw)+  | y == w = (R nx nz oy ow)+  | otherwise = RectXY a+  where+    a@(Rect nx nz ny nw) = projectRect old new (toRect ao)++-- | project a [Spot a] from it's folded space to the given area+--+-- >>> projectTo one (SpotPoint <$> zipWith Point [0..2] [0..2])+-- [SpotPoint Point -0.5 -0.5,SpotPoint Point 0.0 0.0,SpotPoint Point 0.5 0.5]+projectTo :: Rect Double -> [XY Double] -> [XY Double]+projectTo _ [] = []+projectTo vb (x : xs) = projectOn vb (toRect $ sconcat (x :| xs)) <$> (x : xs)++-- | guard substituting singleton dimensions+fixRect :: Maybe (Rect Double) -> Rect Double+fixRect r = maybe one singletonUnit r+  where+    singletonUnit (Rect x z y w)+      | x == z && y == w = Rect (x - 0.5) (x + 0.5) (y - 0.5) (y + 0.5)+      | x == z = Rect (x - 0.5) (x + 0.5) y w+      | y == w = Rect x z (y - 0.5) (y + 0.5)+      | otherwise = Rect x z y w
test/test.hs view
@@ -2,7 +2,7 @@  module Main where -import Protolude+import NumHask.Prelude import Test.DocTest  main :: IO ()