{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE IncoherentInstances #-}   -- ???

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP

-- | Interval analysis

module ConCat.Interval where

import Prelude hiding (id,(.),curry,uncurry,const)
import GHC.Exts (Coercible,coerce)

import Control.Newtype.Generics
import ConCat.Misc ((:*),(:+),inNew,inNew2)
import qualified ConCat.Category
import ConCat.AltCat

-- For Iv instances:
import GHC.Generics (U1(..),(:*:)(..),Par1(..),(:.:)(..))
import ConCat.Free.VectorSpace (V)
import ConCat.Free.LinearRow (L)

type family Iv a

type instance Iv ()     = ()
type instance Iv Float  = Float  :* Float
type instance Iv Double = Double :* Double
type instance Iv Int    = Int    :* Int

#define NewtypeIv(ty) type instance Iv (ty) = Iv (O (ty))

NewtypeIv(Par1 a)
NewtypeIv(L s a b)
-- TODO: more NewtypeIv

--     • Illegal nested type family application ‘Iv (O (L s a b))’
--       (Use UndecidableInstances to permit this)

data IF a b = IF { unIF :: Iv a -> Iv b }

instance Newtype (IF a b) where
  type O (IF a b) = Iv a -> Iv b
  pack = IF
  unpack = unIF

instance Category IF where
  id = pack id
  -- IF g . IF f = IF (g . f)
  (.) = inNew2 (.)
  {-# INLINE id #-}
  {-# INLINE (.) #-}

{-
    • Overlapping instances for Yes1 (Iv a) arising from a use of ‘id’
      Matching instances:
        instance forall k (a :: k). Yes1 a
          -- Defined at /Users/conal/Haskell/concat/src/ConCat/Misc.hs:98:10
      There exists a (perhaps superclass) match:
        from the context: Ok IF a
          bound by the type signature for:
                     id :: Ok IF a => IF a a
          at /Users/conal/Haskell/concat/src/ConCat/Interval.hs:30:3-4
      (The choice depends on the instantiation of ‘a’
       To pick the first instance above, use IncoherentInstances
       when compiling the other instance declarations)
-}

type instance Iv (a :* b) = Iv a :* Iv b

instance MonoidalPCat IF where
  (***) = inNew2 (***)
  {-# INLINE (***) #-}

instance AssociativePCat IF

instance BraidedPCat IF where
  swapP = pack swapP
  {-# INLINE swapP #-}

instance ProductCat IF where
  exl = pack exl
  exr = pack exr
  dup = pack dup
  {-# INLINE exl #-}
  {-# INLINE exr #-}
  {-# INLINE dup #-}

-- instance UnitCat IF

type instance Iv (a :+ b) = Iv a :+ Iv b

instance MonoidalSCat IF where
  (+++) = inNew2 (+++)
  {-# INLINE (+++) #-}

instance BraidedSCat IF where
  swapS = pack swapS
  {-# INLINE swapS #-}

instance CoproductCat IF where
  inl = pack inl
  inr = pack inr
  jam = pack jam
  {-# INLINE inl #-}
  {-# INLINE inr #-}
  {-# INLINE jam #-}

instance DistribCat IF where
  distl = pack distl
  distr = pack distr
  {-# INLINE distl #-}
  {-# INLINE distr #-}

type instance Iv (a -> b) = Iv a -> Iv b

instance ClosedCat IF where
  apply = pack apply
  -- curry (IF f) = IF (curry f)
  -- uncurry (IF g) = IF (uncurry g)
  curry = inNew curry
  uncurry = inNew uncurry
  {-# INLINE apply #-}
  {-# INLINE curry #-}
  {-# INLINE uncurry #-}

instance Iv b ~ (b :* b) => ConstCat IF b where
  const b = IF (const (b,b))
  unitArrow b = IF (unitArrow (b,b))
  {-# INLINE const #-}
  {-# INLINE unitArrow #-}

-- instance RepCat (->) a r => RepCat IF a r where

instance (Iv a ~ (a :* a), Num a, Ord a) => NumCat IF a where
  negateC = pack (\ (al,ah) -> (-ah, -al))
  addC = pack (\ ((al,ah),(bl,bh)) -> (al+bl,ah+bh))
  subC = addC . second negateC
  mulC = pack (\ ((al,ah),(bl,bh)) ->
               let cs = ((al*bl,al*bh),(ah*bl,ah*bh)) in
                 (min4 cs, max4 cs))

  -- mulC = pack (\ ((al,ah),(bl,bh)) -> minMax4 (al*bl) (al*bh) (ah*bl) (ah*bh))

  powIC = error "powIC: not yet defined on IF"
  {-# INLINE negateC #-}
  {-# INLINE addC #-}
  {-# INLINE subC #-}
  {-# INLINE mulC #-}

min4,max4 :: Ord a => ((a :* a) :* (a :* a)) -> a
min4 ((a,b),(c,d)) = min (min a b) (min c d)
max4 ((a,b),(c,d)) = max (max a b) (max c d)

minMax2 :: Ord a => a -> a -> a
a :* a
-- minMax2 a b = (min a b, max a b)
minMax2 a b | a <= b    = (a,b)
            | otherwise = (b,a)

minMax4 :: Ord a => a -> a -> a -> a -> a :* a
minMax4 a b c d = minMax2 p q
 where
   (p,_) = minMax2 a b
   (_,q) = minMax2 c d

-- class CoerceCat k a b where coerceC :: a `k` b

instance (Coercible (Iv a) (Iv b)) => CoerceCat IF a b where
  coerceC = IF coerceC

{--------------------------------------------------------------------
    ccc driver
--------------------------------------------------------------------}

ivFun :: (a -> b) -> (Iv a -> Iv b)
ivFun _ = error "ivFun called"
{-# NOINLINE ivFun #-}
{-# RULES "ivFun" forall h. ivFun h = unIF (toCcc h) #-}