{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
#if ( __GLASGOW_HASKELL__ < 820 )
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
#endif

-- | a two-dimensional plane, implemented as a composite of a 'Pair' of 'Range's.
module NumHask.Rect
  ( Rect(..)
  , pattern Rect
  , pattern Ranges
  , corners
  , projectRect
  ) where

import Data.Distributive
import Data.Functor.Apply (Apply(..))
import Data.Functor.Compose
import Data.Functor.Rep
import Data.Semigroup.Foldable (Foldable1(..))
import Data.Semigroup.Traversable (Traversable1(..))
import NumHask.Pair
import NumHask.Prelude hiding ((<.>))
import NumHask.Range
import NumHask.Space
import qualified Text.Show as Show
import Test.QuickCheck.Arbitrary (Arbitrary(..))

-- $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, Apply, Applicative, Foldable, Foldable1, 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

-- rect'' :: Dhall.Type (Rect a)
-- rect'' = pair (pair double double) (pair double double)

-- instance (Interpret a) => Interpret (Rect a)
-- input auto "{ _1 = {_1 = 1.1, _2 = 1.1 }}" :: IO (Range Double)


instance Traversable1 Rect where
  traverse1 f (Rect a b c d) = Rect <$> f a <.> f b <.> f c <.> f d

instance (Ord a) =>
         AdditiveMagma (Rect a) where
  plus (Ranges x0 y0) (Ranges x1 y1) = Ranges (x0 `plus` x1) (y0 `plus` y1)

instance (Ord a, BoundedField a) =>
         AdditiveUnital (Rect a) where
  zero = Ranges zero zero

instance (Ord a) =>
         AdditiveAssociative (Rect a)

instance (Ord a) =>
         AdditiveCommutative (Rect a)

instance (Ord a) =>
         AdditiveIdempotent (Rect a)

instance (Ord a, BoundedField a) => Additive (Rect a)

instance (Ord a) =>
         AdditiveInvertible (Rect a) where
  negate (Ranges x y) = Ranges (negate x) (negate y)

instance (Ord a, BoundedField a) =>
         AdditiveGroup (Rect a)

instance (FromInteger a, Ord a, BoundedField a) =>
         MultiplicativeMagma (Rect a) where
  times (Ranges x0 y0) (Ranges x1 y1) = Ranges (x0 `times` x1) (y0 `times` y1)

instance (FromInteger a, Ord a, BoundedField a) =>
         MultiplicativeUnital (Rect a) where
  one = Ranges one one

instance (FromInteger a, Ord a, BoundedField a) =>
         MultiplicativeAssociative (Rect a)

instance (FromInteger a, Ord a, BoundedField a) =>
         MultiplicativeCommutative (Rect a)

instance (FromInteger a, Ord a, BoundedField a) => Multiplicative (Rect a)

instance (FromInteger a, Ord a, BoundedField a) =>
         MultiplicativeInvertible (Rect a) where
  recip (Ranges x y) = Ranges (recip x) (recip y)

instance (FromInteger a, Ord a, BoundedField a) =>
         MultiplicativeGroup (Rect a)

instance (FromInteger a, AdditiveInvertible a, BoundedField a, Ord a) =>
         Signed (Rect a) where
  sign (Ranges l u) = Ranges (sign l) (sign u)
  abs (Ranges l u) = Ranges (sign l * l) (sign u * u)

instance (AdditiveGroup a) => Normed (Rect a) (Pair a) where
  normL1 (Ranges l u) = Pair (normL1 l) (normL1 u)
  normL2 (Ranges l u) = Pair (normL2 l) (normL2 u)
  normLp (Pair pl pu) (Ranges l u) = Pair (normLp pl l) (normLp pu u)

instance (BoundedField a, Ord a, Epsilon a) => Epsilon (Rect a) where
    nearZero (Ranges a b) = nearZero a && nearZero b
    aboutEqual (Ranges a b) (Ranges a' b')= aboutEqual a a' && aboutEqual b b'

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 (FromInteger a, Signed a, Ord a, BoundedField a) => Space (Rect a) where
  type Element (Rect a) = Pair a
  nul = Ranges nul nul
  union (Ranges a b) (Ranges c d) = Ranges (a `union` c) (b `union` d)
  lower (Rect l0 _ l1 _) = Pair l0 l1
  upper (Rect _ u0 _ u1) = Pair u0 u1
  singleton (Pair x y) = Rect x x y y
  type Grid (Rect a) = Pair Int
  grid :: Pos -> Rect a -> Pair Int -> [Pair a]
  grid o s n =
    (+ if o == MidPos
         then step / (one + one)
         else zero) <$>
    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

instance (FromInteger a, Signed a, Ord a, BoundedField a) => Semigroup (Rect a) where
  (<>) = union

instance (FromInteger a, Signed a, Ord a, BoundedField a) => Monoid (Rect a) where
  mempty = nul
  mappend = (<>)

instance (Arbitrary a) => Arbitrary (Rect a) where
    arbitrary = do
        a <- arbitrary
        b <- arbitrary
        pure (Ranges a b)

instance NFData a => NFData (Rect a) where
  rnf (Ranges a b) = rnf a `seq` rnf b

-- | create a list of pairs representing the lower left and upper right cormners of a rectangle.
corners :: (FromInteger a, Signed a, BoundedField a, Ord a) => Rect a -> [Pair a]
corners r = [lower r, upper r]

-- | project a Rect from an old range to a new one
projectRect ::
     (FromInteger a, Signed a, Ord a, BoundedField 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)

instance (Additive a) => AdditiveBasis Rect a where
    (.+.) = liftR2 (+)
instance (AdditiveGroup a) => AdditiveGroupBasis Rect a where
    (.-.) = liftR2 (-)
instance (Multiplicative a) => MultiplicativeBasis Rect a where
    (.*.) = liftR2 (*)
instance (MultiplicativeGroup a) => MultiplicativeGroupBasis Rect a where
    (./.) = liftR2 (/)

instance (Additive a) => AdditiveModule Rect a where
    (.+) r s = fmap (s+) r
    (+.) s r = fmap (s+) r
instance (AdditiveGroup a) => AdditiveGroupModule Rect a where
    (.-) r s = fmap (\x -> x - s) r
    (-.) s r = fmap (\x -> x - s) r
instance (Multiplicative a) => MultiplicativeModule Rect a where
    (.*) r s = fmap (s*) r
    (*.) s r = fmap (s*) r
instance (MultiplicativeGroup a) => MultiplicativeGroupModule Rect a where
    (./) r s = fmap (/ s) r
    (/.) s r = fmap (/ s) r

-- | fixme: this is a deeply flawed hack
instance Singleton Rect where
    singleton a = Rect a a a a