{-|
Module      : TCategories
Description : Categorical instances of functions over tiles
Copyright   : (c) David Janin, 2016
License     : see the LICENSE file in the distribution
Maintainer  : janin@labri.fr
Stability   : experimental

Haskell instances of the categorical properties of duration or delay preserving function over tiles, using 
the various packages Control.Category.* by Edward Kmett.
-}

{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
{-# LANGUAGE TypeFamilies,
             MultiParamTypeClasses #-}

module Tile.TCategories where

import Prelude hiding ((.), id, fst, snd, curry, uncurry)
        
import Control.Category.Cartesian.Closed
import Control.Category
import Control.Category.Cartesian
import Control.Category.Associative
import Control.Categorical.Bifunctor
import Control.Category.Braided
import Control.Category.Monoidal

                             
import Tile.Tile
import Tile.Functile
import Duration.Lattice

-- * Category instances

-- | The category of functions over tiles
newtype FuncT d iv v1 v2 = FuncT (Tile d iv v1 -> Tile d iv v2)

instance Category (FuncT d iv) where
    id = FuncT id
    (.) (FuncT f) (FuncT g) = FuncT (f . g)
    
-- | The category of duration preserving functions over tiles.
-- A tile function is a /duration preserving/ tile function when
--
-- prop> durationT t == durationT (f t)

newtype FuncDurP d iv v1 v2 = FuncDurP (Tile d iv v1 -> Tile d iv v2)

-- Num instance
instance (Eq d, Num d, Lattice d) => Num (FuncDurP d iv v1 v2) where
    (+) (FuncDurP f1) (FuncDurP f2) = FuncDurP $ \t -> (f1 t) + (f2 t)
    (*) (FuncDurP f1) (FuncDurP f2) = FuncDurP $ \t -> (f1 t) * (f2 t)
    negate (FuncDurP f) = FuncDurP $ \t -> negate (f t) 
    fromInteger n = FuncDurP $ const $ (fromInteger n)
    abs = const $ FuncDurP $ const (fromInteger 1) 
    signum = id

-- Fractional instance
instance (Eq d, Fractional d, Lattice d) => Fractional (FuncDurP d iv v1 v2) where
    fromRational n = FuncDurP $ const $ (fromRational n)
    recip (FuncDurP f) = FuncDurP $ \t -> recip (f t)


-- | Lifts any function over tiles to a duration preserving function over tiles.

toFuncDurP :: (Eq d, Num d, Lattice d, POrd v1) =>
                      Functile d iv v1 v2 -> FuncDurP d iv v1 v2
toFuncDurP f = FuncDurP (forceDurP f)

instance Category (FuncDurP d iv) where
    id = FuncDurP id
    (.) (FuncDurP f) (FuncDurP g) = FuncDurP (f . g)

                                    
instance (Eq d, Num d, Lattice d) => Cartesian (FuncDurP d iv) where
    type Product (FuncDurP d iv) = Either
    fst = FuncDurP fromLeftT
    snd = FuncDurP fromRightT
    (&&&) (FuncDurP f1) (FuncDurP f2) = FuncDurP (factorProductT f1 f2)

    
instance (Eq d, Num d, Lattice d) => CCC (FuncDurP d iv) where
    type Exp (FuncDurP d iv) =  FuncDurP d iv
    apply = let g t = applyT (fmap (\(FuncDurP f) -> f) $ fromLeftT t) (fromRightT t)
          in FuncDurP g
    curry (FuncDurP f) = FuncDurP  $ \t -> fmap (\f1 -> FuncDurP f1) (curryT f t)
    uncurry (FuncDurP g)
        = FuncDurP $ \t1 -> uncurryT (\t -> fmap (\(FuncDurP f1) -> f1) (g t)) t1

instance (Eq d, Num d, Lattice d) => PFunctor Either (FuncDurP d iv) (FuncDurP d iv) where first f = bimap f id
instance (Eq d, Num d, Lattice d) => QFunctor Either (FuncDurP d iv) (FuncDurP d iv) where second = bimap id
instance (Eq d, Num d, Lattice d) => Bifunctor Either (FuncDurP d iv) (FuncDurP d iv) (FuncDurP d iv) where
    bimap = bimapProduct

instance (Eq d, Num d, Lattice d) =>  Associative (FuncDurP d iv) Either where
    associate = associateProduct
    disassociate = disassociateProduct

instance (Eq d, Num d, Lattice d) =>  Braided (FuncDurP d iv) Either where
    braid  = FuncDurP swapT  -- braidProduct

instance (Eq d, Num d, Lattice d) => Symmetric (FuncDurP d iv) Either
    
instance (Eq d, Num d, Lattice d) => Monoidal (FuncDurP d iv) Either where
    type Id (FuncDurP d iv) Either = Void
    idl = snd
    idr = fst
    coidl = FuncDurP toRightT 
    coidr = FuncDurP toLeftT


-- | The category of delay preserving functions over tiles.
-- A tile function is a /delay preserving/ tile function when
--
-- prop> f (delayT t) == delayT (f t)

newtype FuncDelayP d iv v1 v2 = FuncDelayP (Tile d iv v1 -> Tile d iv v2)

-- Num instance
instance (Eq d, Num d, Lattice d) => Num (FuncDelayP d iv v1 v2) where
    (+) (FuncDelayP f1) (FuncDelayP f2) = FuncDelayP $ \t -> (f1 t) + (f2 t)
    (*) (FuncDelayP f1) (FuncDelayP f2) = FuncDelayP $ \t -> (f1 t) * (f2 t)
    negate (FuncDelayP f) = FuncDelayP $ \t -> negate (f t) 
    fromInteger n = FuncDelayP $ const $ (fromInteger n)
    abs = const $ FuncDelayP $ const (fromInteger 1) 
    signum = id

-- Fractional instance
instance (Eq d, Fractional d, Lattice d) => Fractional (FuncDelayP d iv v1 v2) where
    fromRational n = FuncDelayP $ const $ (fromRational n)
    recip (FuncDelayP f) = FuncDelayP $ \t -> recip (f t)


-- | Lifts any function over tiles to a delay preserving function over tiles.
toFuncDelayP :: (Eq d, Num d, Lattice d, POrd v1) =>
                      Functile d iv v1 v2 -> FuncDelayP d iv v1 v2
toFuncDelayP f = FuncDelayP (forceDelayP f)


instance Category (FuncDelayP d iv) where
    id = FuncDelayP id
    (.) (FuncDelayP f) (FuncDelayP g) = FuncDelayP (f . g)

                                    
instance (Eq d, Num d, Lattice d) => Cartesian (FuncDelayP d iv) where
    type Product (FuncDelayP d iv) = Either
    fst = FuncDelayP fromLeftT
    snd = FuncDelayP fromRightT
    (&&&) (FuncDelayP f1) (FuncDelayP f2) = FuncDelayP (factorProductT f1 f2)



instance (Eq d, Num d, Lattice d) => PFunctor Either (FuncDelayP d iv) (FuncDelayP d iv) where first f = bimap f id
instance (Eq d, Num d, Lattice d) => QFunctor Either (FuncDelayP d iv) (FuncDelayP d iv) where second = bimap id
instance (Eq d, Num d, Lattice d) => Bifunctor Either (FuncDelayP d iv) (FuncDelayP d iv) (FuncDelayP d iv) where
    bimap = bimapProduct

instance (Eq d, Num d, Lattice d) =>  Associative (FuncDelayP d iv) Either where
    associate = associateProduct
    disassociate = disassociateProduct

instance (Eq d, Num d, Lattice d) =>  Braided (FuncDelayP d iv) Either where
    braid = braidProduct

instance (Eq d, Num d, Lattice d) => Symmetric (FuncDelayP d iv) Either
    
instance (Eq d, Num d, Lattice d) => Monoidal (FuncDelayP d iv) Either where
    type Id (FuncDelayP d iv) Either = Void
    idl = snd
    idr = fst
    coidl = FuncDelayP toRightT 
    coidr = FuncDelayP toLeftT


instance (Eq d, Num d, Lattice d) => CoCartesian (FuncDelayP d iv) where
    type Sum (FuncDelayP d iv) = Either
    inl = FuncDelayP toLeftT
    inr = FuncDelayP toRightT
    (|||) (FuncDelayP f1) (FuncDelayP f2) = FuncDelayP (factorSumT f1 f2)