{-|
Module      : Tile
Description : The basic tile data type 
Copyright   : (c) David Janin, Simon Archipoff, 2016
License     : see the LICENSE file in the distribution
Maintainer  : janin@labri.fr
Stability   : experimental

A handy data structure that generalizes Hudak's notion of 
Polymorphic Temporal Media (<https://hal.archives-ouvertes.fr/hal-00955113 Tiled PTM>). 
See "Docs" for a step by step introduction to tiles, with examples and pictures of tiles 
(recommanded). 


Otherwise, denoting by (d) a delay of duration d and by (d,v) 
a value v of duration d, a tile can always be depicted as follows:

<<ex12.svg>>

that is, a qlist (in black) extended with two synchronization marks (in blue), the input and output root of the tile, positioned over the underlying qlist by delays (in red). 



-}


{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}

{-# LANGUAGE MultiParamTypeClasses,
             GADTs,
             FlexibleInstances,
             FlexibleContexts #-}

module Tile.Tile where
    
import Reactive.Updatable

import Tile.Tilable

import Control.Comonad
        
-- import Tile.Atom

import Tile.QList

--------------------------------------------------------------------
-- * Tile definition
--------------------------------------------------------------------

-- | A tile is build over duration type d, input value type iv and output value type v.
data Tile d iv v = Tile d d  !(QList d iv v)
     deriving (Show)

-- | For on-the fly updates
instance Updatable (Tile d iv v) d iv where
  update (f,nq) (Tile d1 d2 q) = Tile (f d1) (f d2) (update (f,nq) q) 

-- | Tile are tilable...
instance  (Tilable d v, d1~d) => Tilable d (Tile d1 iv v) where
    duration = durationT
    stretch d t = fromDurationT d * t
                  
-- | Derived 'natural' partial order, unfolds recursive definitions.
instance (Num d, Eq d, POrd d, POrd v) => POrd (Tile d iv v) where
    pLeq (Tile d1 ad1 q1) (Tile d2 ad2 q2)
        = case (d1 == d2) of
            True -> case partialCompare ad1 ad2 of
                      Just EQ -> pLeq q1 q2
                      Just LT -> pLeq (DQ 0 q1) (DQ (ad2-ad1) q2)
                      Just GT -> pLeq (DQ (ad1 - ad2) q1) (DQ 0 q2)
                      Nothing -> error "Tile Partial Order : incomparable durations"
            False -> False

-- | Semantical equality, unfolds recursive definitions.
instance (Num d, Eq d, POrd d, POrd v) => Eq (Tile d iv v) where
    (==) = pOrdEq

--------------------------------------------------------------------
-- * Setters
--------------------------------------------------------------------

-- ** Primitive setters

-- | The zero tile
zeroT :: (Num d) => Tile d iv v
zeroT = fromIntegerT 0

-- | Creates a tile from a tilable value.
--
-- Warning: tile made out of functions have default infinite duration (see "Tile.Tilable" for more details), that is, they'll be applicable
-- at nauseam when applyed with 'evalT' or 'evalOnV'. For finite explicit applicability, use 'fromDurationAndValueT' or 'setDurationT'.
fromValueT :: (Tilable d v) =>  v -> Tile d iv v
fromValueT v = Tile (duration v) 0 (fromValueQ v)

-- | Sets the duration of a tile (unchanging its contents)
setDurationT :: d -> Tile d iv v -> Tile d iv v
setDurationT nd (Tile _ ad q) = Tile nd ad q
               

-- | Creates a tile from a duration
fromDurationT :: Num d => d -> Tile d iv v
fromDurationT d = Tile d 0 QEnd

-- | Creates a tile from a duration and a value
fromDurationAndValueT :: Num d => d -> v -> Tile d iv v
fromDurationAndValueT d v = Tile d 0 $ fromDurationAndValueQ d v


-- ** Conversion functions (qlist <-> tiles)

-- | Turns a tile into a qlist
toQList :: (Num d, Lattice d) => Tile d iv v -> QList d iv v
toQList (Tile _ ad q)
    = case (partialCompare 0 ad ) of
        Just LT -> addDelayQ ad q -- QList [] (DQ ad q)
        Just GT -> dropQ (-ad) q
        Just EQ -> q
        Nothing -> error "toQList : No droppable tile"

-- | Turns a qlist into a tile. The following properties are satisfied:
--
-- prop> toQList . fromQList q == q
--
-- prop> not (hasAnticipationT t) => fromQList . toQList t == re[t]

fromQList :: (Num d) => QList d iv v -> Tile d iv v
fromQList q = Tile 0 0 q

--------------------------------------------------------------------
-- ** Explicit recursion
--------------------------------------------------------------------

recT :: (Eq d, Num d, Lattice d, Updatable p d iv) =>
             (p -> Tile d iv v1 -> Tile d iv v2) -> p -> Tile d iv v1 -> Tile d iv v2

-- | Recursive call for the tile (f p t) with parameter p and tile t. The computation is frozen
-- until the last moment, the parameter p being 'Updatable' for on-the-fly updates till that moment.
--
-- Concerning anticipation, the following property is required:
--
-- prop> delayToTailT (recT f p t) == 0
--
-- that is, any negative anticipation resulting from the recursion is discarded.
--
-- Concerning duration, the following property is always satisfied:
--
-- prop> durationT (recT f p t) == durationT t
recT f p t@(Tile d _ _)
    = let qrec (p,t)
              =  let (Tile _ ad q) = f p t
                       -- reduceT $ f p t
                 in case partialCompare 0 ad of
                      Just GT -> QEnd -- _ -> error "Negative anticipation in recursion schema"
                      Just EQ -> q
                      Just LT -> addDelayQ ad q -- (QList [] (DQ ad q))
                      Nothing -> error "Unknown anticipation in recursion schema"
      in Tile d 0 (QRec 1 qrec (p,t))

-- | Reduces successive delays without atoms in a tile (may unfold immediate recursive definition)
reduceT :: (Num d, Eq d, POrd d) => Tile d iv v -> Tile d iv v
reduceT (Tile d ad q)
    = let q1 = reduceQ q
      in case q1 of
        QEnd -> Tile d 0 QEnd
        QList [] (DQ d1 q2) -> Tile d (ad+d1) q2
        QList _ _ -> Tile d ad q1
        _ -> error "This should never happend"

--------------------------------------------------------------------
-- ** Num and Fractional instance functions
--------------------------------------------------------------------

-- | Sums two tiles, that is, synchronizes the output root of the first with the input root of the second and merges
-- the underlying timed lists of temporal values.
--
-- prop> t == t + 0, t == 0 + t and t1 + (t2 + t3) == (t1 + t2)+t3
--
-- Warning: the sum is /not/ commutative as it places its arguments in time and time is not commutative.
--
-- Remark : tiles equiped with tile sum form an inverse with negation as semigroup inverse.
plusT :: (Eq d, Lattice d, Num d) => (Tile d iv v) -> (Tile d iv v) -> (Tile d iv v)
plusT (Tile d1 _ QEnd) (Tile d2 _ QEnd) = Tile (d1+d2) 0 QEnd
plusT (Tile d1 _ QEnd) (Tile d2 da2 q2) = Tile (d1+d2) (d1+da2) q2
plusT (Tile d1 da1 q1) (Tile d2 _ QEnd) = Tile (d1+d2) da1 q1
plusT (Tile d1 da1 q1) (Tile d2 da2 q2)
  = let dd = d1 + d2
        da2p = d1 + da2
    in case partialCompare da1 da2p of
       Just EQ -> Tile dd da1  $ mergeQ (q1,q2)
       Just LT -> Tile dd da1 $ insertQ q1 (DQ (da2p-da1) q2)
       Just GT -> Tile dd da2p $ insertQ q2 (DQ (da1-da2p) q1)
       Nothing -> let d = meet [da1,da2p]
                      contQ (DQ d1 q1,DQ d2 q2)
                            = case partialCompare d1 d2 of
                                Just EQ -> mergeQ (q1,q2)
                                Just LT -> insertQ q1 (DQ (d2 - d1) q2)
                                Just GT -> insertQ q2 (DQ (d1 - d2) q1)
                                Nothing ->  error "PlusT : meet not solved by time"
                  in Tile dd d (QRec 1 contQ (DQ da1 q1,DQ da2p q2))

                     
-- | Negates a tile, that is, permute its input and output root. It satisfies:
--
-- prop> t == - (- t) and - (t1 + t2) == -t2 -t1
--
-- Warning: as sum is /not/ commutative, the order of t1 and t2 above /does/ matter. 
--
-- Also, following inverse semigroup theory, -t is the unique tile such that
--
-- prop>  t == t - t + t and -t == -t + t -t
--
-- In particular, we have
--
-- prop> re [t] == t - t, co [t] = - t + t

negateT :: Num d => Tile d iv v -> Tile d iv v
negateT (Tile d ad q) = Tile (-d) (ad - d ) q

-- | converts integers into delays
--
-- prop> fromIntegerT (n1 + n2) == fromIntegerT n1 + fromIntegerT n2

fromIntegerT :: Num d => Integer -> Tile d iv v
fromIntegerT n = Tile (fromInteger n) 0 QEnd

-- | converts rationals into delays
--
-- prop> fromRationalT (r1 + r2) == fromRationalT r1 + fromRationalT r2
fromRationalT :: Fractional d => Rational -> Tile d iv v
fromRationalT n = Tile (fromRational n) 0 QEnd

-- | stretch the duration and content of a tile by the specified factor, taking first the negation when negative.
--
-- prop> stretchT 1 t == t, stretchT (-1) t = -t
--
-- prop> (0 <= d) => stretchT d (t1 + t2)  == stretchT d t1 + stretchT d t2
-- 
-- prop> (d <= 0) => stretchT d (t1 + t2)  == stretchT d t2 + stretchT d t1

stretchT :: (Num d, Lattice d) =>
                  d -> Tile d iv v -> Tile d iv v
stretchT dd t@(Tile d ad q)
  = case (partialCompare 0 dd) of
      Just EQ -> Tile (dd*d) (dd*ad) (stretchQ dd q) -- An alternative could be fromIntegerT 0, but this piles up all atoms into zero duration atoms
      Just LT -> Tile (dd*d) (dd*ad) (stretchQ dd q)
      Just GT -> negateT $ stretchT (-dd) t
      Nothing -> error "stretchT : Illegal stretch factor"

-- | essentially defined by
--
-- @
-- multT t1 t2 = plusT (stretchT (durationT t2) t1) (stretchT (durationT t1) t2)
-- @
-- Warning: product may /not/ distribute over sum while /positive/ delays do.
--
-- prop> if (durationT t >= 0 ) then delayT t * (t1 + t2) == delayT t * t1 + delayT t * t2
-- prop> if (durationT t >= 0 ) then (t1 + t2) * delayT t == t1 * delayT t + t2 * delayT t
--
-- With negative duration, sums are switched.
--
-- prop> if (durationT t <= 0 ) then delayT t * (t1 + t2) == delayT t * t2 + delayT t * t1
-- prop> if (durationT t <= 0 ) then (t1 + t2) * delayT t == t2 * delayT t + t1 * delayT t
multT :: (Eq d, Num d, Lattice d) =>
               Tile d iv v -> Tile d iv v -> Tile d iv v
multT t1 t2 = plusT (re[stretchT (durationT t2) t1]) (stretchT (durationT t1) t2)

-- | Essentially defined by
--
-- @
-- recipT t = stretchT (1 // (durationT t) // (durationT t)) t
-- @
-- Fails when duration is not constant.
--
-- Warning : t/t may not be equal to 1. However, we have
--
-- prop> (durationT t /= 0) => durationT (t/t) == 1 and t = t*t/t
--
-- Remark : tiles of non zero duration equipped with tile product form an inverse monoid with 'recipT'
-- as inverse. Then, the induced natural order coincide with the natural order induced by the additive
-- inverse monoid.
recipT :: (Fractional d, Lattice d) =>
                Tile d iv v -> Tile d iv v
recipT t = stretchT (1/(durationT t)/(durationT t)) t

-- | For syntactic comfort (with partially defined product)
instance (Num d, Eq d, Lattice d) => Num (Tile d iv v) where
  (+) = plusT
  (*) = multT
  negate = negateT
  fromInteger = fromIntegerT
  abs = const (fromInteger 1)
  signum = id

-- | For syntactic comfort (with partially defined inverse)
instance (Fractional d, Eq d, Lattice d) => Fractional (Tile d iv v) where
   recip = recipT
   fromRational = fromRationalT
  


--------------------------------------------------------------------
-- * Getters
--------------------------------------------------------------------

--------------------------------------------------------------------
-- ** Basic getters
--------------------------------------------------------------------

-- | True when is a delay
isDelayT :: (Num d, Eq d) => Tile d iv v -> Bool
isDelayT (Tile _ _ q) = isEmptyQ q

-- | True when there is a negative anticipation
hasAnticipationT :: (Num d, Eq d, POrd d, Lattice d) => Tile d iv v -> Bool
hasAnticipationT t
    = let (Tile _ ad _) = reduceT t
      in case (partialCompare 0 ad) of
           Just GT -> True
           Nothing -> True
           _ -> False
            
--------------------------------------------------------------------
-- ** Delays and durations
--------------------------------------------------------------------

-- | Gets the (tile) delay defined from the input root to the ouput root of a tile
--
-- prop> delayT (- t) == - delayT t
--
-- prop> delayT (t1 + t2) == delayT t1 + delayT t2
--
-- prop> delayT (t1 * t2) == delayT t1 * delayT t2
--

delayT :: (Eq d, Num d) =>
                Tile d iv1 v1 -> Tile d iv2 v2
delayT (Tile d1 _ _) = Tile d1 0 QEnd

-- | Gets the duration of a tile, that is the (relative) distance from its input root to its output root.
--
-- prop> delayT t == fromDurationT (durationT t)
--
durationT :: Tile d iv v -> d
durationT (Tile d _ _) = d

--------------------------------------------------------------------
-- ** Normalization operators
--------------------------------------------------------------------

-- | Gets the head of a tile, that is, the bundle (possibly empty)
-- of atoms at the input root and the duration to the next earliest one, or,
-- in the absence of any atoms in the tile, the duration of the tile.

headT :: (Eq d, Num d, POrd d) => Tile d iv v -> Tile d iv v
headT (Tile d 0 QEnd) = Tile d 0 QEnd
headT (Tile d 0 q) -- = Tile (delayToTailQ q) 0 (atomsQ q)
    = case (delayToTailQ q) of
        0 -> Tile d 0 (atomsQ q)
             -- the remainder of the tile is empty
        _ -> Tile (delayToTailQ q) 0 (atomsQ q)
             
headT (Tile _ ad _) = Tile ad 0 QEnd

-- | Gets the tail of a tile, that is, the remainder of the tile after the heads, or, in the absence of atoms,
-- the zero tile.
--
-- Invariant property :
--
-- prop> t == headT t + tailT t

tailT :: (Eq d, Num d, POrd d) => Tile d iv v -> Tile d iv v
tailT (Tile _ 0 QEnd) = Tile 0 0 QEnd
tailT (Tile d 0 q)    -- = Tile (d-delayToTailQ q) 0 (tailQ q)
    = case (delayToTailQ q) of
        0 -> Tile 0 0 QEnd
             -- the remainder of the tile is empty
        _ -> Tile (d-delayToTailQ q) 0 (tailQ q)
                     
tailT (Tile d ad q) = Tile (d-ad) 0 q
                      
-- | Gets the bundle of temporal values at the input root
atomsT :: (Eq d, Num d) => Tile d iv v -> [Tile d iv v]
atomsT (Tile _ 0 q) = fmap (\(d,v) -> fromDurationAndValueT d v) (getAllFromAtomsQ q)
atomsT _ = []
    
-- | Gets the non zero delay from the input root to the earliest bundle of temporal values,
-- or to the ouput root if none.
--
-- Invariant properties
--
-- prop> delayToTailT t == delayT (headT t)
--
-- prop> headT t == re (atomsT t) + delayToTailT t
--
-- prop> headT t == re (atomsT (headT t)) + delayT (headT t)
delayToTailT :: (Eq d, Num d, POrd d) =>
                Tile d iv v1 -> Tile d iv v2
delayToTailT t = delayT (headT t)

-- | Gets the duration and values of atomsT (usefull ?)
getAllFromAtomsT :: (Eq d, Num d) => Tile d iv v -> [(d,v)]
getAllFromAtomsT (Tile _ d2 q)
  = case (d2==0) of
    False -> []
    True -> getAllFromAtomsQ q

------------------------------------------
-- ** Inverse semigroup derived operators
------------------------------------------

-- | Resets a list of tiles, that is, moves their output roots to their input roots and sum them up.
-- Properties derived from inverse semigroup theory.
--
-- prop> re []  == 0
--
-- prop> re (t:ts)  == t - t + re ts
--
-- prop> t is idempotent if and only if t == re [t]
--
-- prop> re l == co (map negateT l)
--
-- prop> Idempotents commute

re :: (Num d, Eq d, Lattice d) => [Tile d iv v] -> Tile d iv v
re [] = zeroT
re (Tile _ ad q:l) =  (Tile 0 ad q) + re l

-- | Coresets a list of tiles, that is, moves their input roots to their output roots and sum them up.
-- Properties derived from inverse semigroup theory.
--
-- prop> co []  == 0
--
-- prop> co (t:ts)  == - t + t + co ts
--
-- prop> t is idempotent if and only if t == co [t]
--
-- prop> co l == re (map negateT l)
co :: (Num d, Eq d, Lattice d) => [Tile d iv v] -> Tile d iv v
co = re . (map negateT)

------------------------------------------
-- ** Derived parallel operators
------------------------------------------

-- | Starts two tiles in parallel
--
-- prop> durationT (parForkT t1 t2) == durationT t2
parForkT :: (Eq d, Num d, Lattice d) =>
               Tile d iv v -> Tile d iv v -> Tile d iv v
parForkT t1 t2 = re[t1] + t2

-- | Ends two tiles in parallel
--
-- prop> durationT (parJoinT t1 t2) == durationT t1
--
parJoinT :: (Eq d, Num d, Lattice d) =>
               Tile d iv v -> Tile d iv v -> Tile d iv v
parJoinT t1 t2 = t1 + co[t2]



------------------------------------------
-- * Taking, dropping and selecting
------------------------------------------

-- | Takes all bundles of notes that starts strictly before duration d from the input root
--
-- prop> durationT (takeD d t) == d
--
-- prop> takeD (durationT (headT t)) t == headT t
--
takeD :: (Eq d, Num d, Lattice d) =>
               d -> Tile d iv v -> Tile d iv v
takeD d (Tile _ ad1 q1)
  = case (partialCompare ad1 d) of
    Just LT -> Tile d ad1 (QRec 1 (\(DQ d q) -> takeQ d q) (DQ (d-ad1) q1))
    _ -> fromDurationT d
    
-- | Drops all bundles of temporal values that starts strictly before some duration d from the input root
--
-- prop> durationT (dropT d t) == durationT t - d
--
-- prop> dropD (durationT (headT t)) t == tailT t
--
-- Invariant property:
--
-- prop> t == takeT d t + dropT d t 
dropD :: (Eq d, Num d, Lattice d) =>
               d -> Tile d iv v -> Tile d iv v
dropD d (Tile d1 ad1 q1)
  = case (partialCompare ad1 d) of
    Just LT -> Tile (d1-d) 0 (QRec 1 (\(DQ d q) -> dropQ d q) (DQ (d-ad1) q1))
    _ -> Tile (d1 -d) (ad1 -d) q1
--    Just GT -> Tile (d1-d) (ad1 - d) q1
--    Just EQ -> Tile (d1-d) 0 q1
--    Nothing -> error "dropD : Unknown duration"
               -- Tile (d1-d) 0 (QRec 1 (\(DQ d q) -> dropQ d q) (DQ (d-ad1) q1))
    
-- | Splits a tile with a boolean function
splitT :: Num d =>
                (b -> Bool) -> Tile d iv b -> Tile d iv (Either b b)
splitT f (Tile d ad q) = Tile d ad (split f q)
                        
--------------------------------------------------------------------
-- * Playing with delays
--------------------------------------------------------------------

-- | Take the minimum delay of two tiles. Implemented by:
--
-- @
-- minDelayT t1 t2 = fromDurationT $ meet [durationT t1, durationT t2]
-- @ 
minDelayT :: (Num d, Lattice d) =>
               Tile d iv1 v1 -> Tile d iv2 v2 -> Tile d iv v
minDelayT t1 t2 = fromDurationT $ meet [durationT t1, durationT t2]

-- | Take the maximum delay of two tiles. Implemented by:
--
-- @
-- maxDelayT t1 t2 = fromDurationT $ join [durationT t1, durationT t2]
-- @
maxDelayT :: (Num d, Lattice d) =>
               Tile d iv1 v1 -> Tile d iv2 v2 -> Tile d iv v
maxDelayT t1 t2 = fromDurationT $ join [durationT t1, durationT t2]

--------------------------------------------------------------------
-- * Various control like class instances
--------------------------------------------------------------------

-- ** Functor

-- | Maps a value function over all temporal values in a tile with associated
-- "Control.Functor" instance:
--
-- @
-- instance Num d => Functor (Tile d iv) where
--    fmap = fmapT
-- @

fmapT :: Num d => (v1 -> v2) -> Tile d iv v1 -> Tile d iv v2
fmapT f (Tile d1 d2 q) = Tile d1 d2 (fmapQ f q)

                         
instance Num d => Functor (Tile d iv) where
    fmap = fmapT

-- ** Applicative like
           
-- | Applies a tile of functions over values to a tile of values. This function
-- is delay preserving in its second argument:
--
-- prop> delayT (applyOnV tf t) == delayT t
--
-- The following property also holds:
--
-- prop> fmap f t == applyOnV  (fromValueT f) t
-- 
-- however, values that lasts for an infinite time are not much exiting for application.
--
-- Remark: this does not lead to an  Applicative instance because tile duration gets a bit lost
-- failing to satisfies applicative axioms.
applyOnV :: (Eq d, Num d, Lattice d) => Tile d iv (v1 -> v2) -> Tile d iv v1 -> Tile d iv v2
applyOnV (Tile _ _ QEnd) t = delayT t
applyOnV _ (Tile d _ QEnd) = Tile d 0 QEnd
applyOnV f t = evalOnV (re[fmap Left f] + fmap Right  t)

-- | Reduces a tile of functions and arguements into a tile of results. The duration of a function gives the
-- duration of the apply
evalOnV :: (Eq d, Num d, Lattice d) => Tile d iv (Either (v1 -> v2) v1) -> Tile d iv v2
evalOnV t
    = let fl = [(d,f) | (d,Left f) <- getAllFromAtomsT t]
      in re (map (\(d,f) -> fmap f (takeD d (fromRightT t))) fl) + delayToTailT t
         + recT (\_ t -> evalOnV t) () (tailT t)
           where -- copied from Functile.hs
             fromRightT (Tile d _ QEnd) = Tile d 0 QEnd
             fromRightT (Tile d ad q) = Tile d ad (fromRightQ q)

-- | Yet not clear under what conditions 'Applicative' axioms are satisfied... 
instance (Num d, Eq d, Lattice d) => Applicative (Tile d iv) where
    pure = fromDurationAndValueT 1
    (<*>) = applyOnV


-- ** Monad and comonad like
            
-- | Reduces a tile of tiles into a tile through fmaps. This function is delay
-- preserving.
--
-- prop> delayT (joinT t) == joinT (delayT t)
--
-- Remark: despite the type of this reduction, this does not lead yet to a Monad instance.
-- This could be solved turning every types into tilable types.
joinT :: (Eq d, Num d, Lattice d) => Tile d iv (Tile d iv v) -> Tile d iv v
joinT (Tile d _ QEnd) = Tile d 0 QEnd
joinT t
    = let atomTilesList = fmap (\(d,ta) -> stretchT d ta) $ getAllFromAtomsT t
          df = delayToTailT t
      in re atomTilesList + df + recT (\_ t -> joinT t) () (tailT t)

-- | Turn a value into a tile
returnT :: Tilable d v => v -> Tile d iv v
returnT = fromValueT

-- | Yet not clear under what conditions 'Monad' axioms are satisfied...
instance (Num d, Eq d, Lattice d) => Monad (Tile d iv) where
    return = pure
    (>>=) ta f = joinT  (fmap f ta)

-- | Turns every atom in a tile into a tile. This function is delay
-- preserving.
--
-- prop> delayT (coJoinT t) == coJoinT (delayT t)
-- 
-- The following property is satisfied:
--
-- prop> joinT . coJoinT = id
coJoinT :: (Num d, Eq d, Lattice d) => Tile d iv v -> Tile d iv (Tile d iv v)
coJoinT t = let newAtoms = fmap (\(d,v) -> fromDurationAndValueT 1 $ fromDurationAndValueT d v) $ getAllFromAtomsT t
            in re newAtoms + delayToTailT t + recT (\_ t -> coJoinT t) () (tailT t)
               
-- | Extracts the first value of the first atoms of a tile (fairly useless ?).
-- The following property is satisfied:
--
-- prop> coReturnT . returnT = id
coReturnT :: (Eq d, Num d) => Tile d iv v -> v
coReturnT t = let al = getAllFromAtomsT t
             in case al of
                  [] -> error "extractT : no atoms located on input root"
                  ((_,x):_) -> x
-- | Yet not clear under what conditions 'Comonad' axioms are satisfied...
instance (Num d, Eq d, Lattice d) => Comonad (Tile d iv) where
    extract = coReturnT
    duplicate = coJoinT
             
                               
-- ** Weak functors over duration

-- | Maps a duration function on a tile, though, in this case, the input and ouput duration type must be the same
fmapDT :: Num d => (d -> d) -> Tile d iv v -> Tile d iv v
fmapDT f (Tile d1 d2 q) = Tile (f d1) (f d2) (fmapDQ f q)

-- | Maps a duration function on the time signature of a tile, not altering its contents
fmapSigDT :: Num d => (d -> d) -> Tile d iv v -> Tile d iv v
fmapSigDT f (Tile d1 d2 q) = Tile (f d1)  d2 q

-- | Maps a duration function on the  sigcontent of a tile, not altering its signature.
--
-- /Remark/: In these three functions, the duration type is preserved.
-- This is due to our aim at providing a realtime/reactive implementation of tiles.
-- Changing duration types would mean changing time scale... This makes no difficulties in
-- an out-of-time context (as for 'reverseT' below) but, in realtime/reactive context,
-- there is yet a lot more to be understood...
fmapContDT :: Num d => (d -> d) -> Tile d iv v -> Tile d iv v
fmapContDT f (Tile d1 d2 q) = Tile d1  (f d2) (fmapDQ f q)


    
--------------------------------------------------------------------
-- * Reversing time
--------------------------------------------------------------------

-- | Reverses the flow of time, with time origin (center of symmetry) taken midway from input root to output root.
--
-- prop> reverseT (fromValueT v) == fromValueT
-- prop> reverseT (fromDurationT d) == (fromDurationT d)
-- prop> reverseT (-t) == - reverseT t
-- prop> reverseT (t1 + t2) == reverseT t2 + reverseT t1
-- prop> reverseT (stretchT d t) == stretchT d $ reverseT t
--
-- Warning: in reactive usage, such a function hides plenty of non causal aspects... far beyond the obvious ones 
reverseT :: (Fractional d,Lattice d) => Tile d iv v -> Tile d iv v
reverseT (Tile d ad q)
    = let (dr,qr) = reverseQ (ad - d/2) q
      in Tile d (d/2 + dr) qr

--------------------------------------------------------------------
-- * Other functions (internal use / debug)
--------------------------------------------------------------------

-- | Unfold immediately recursive definition in a tile
unfoldNowT :: (Num d,Eq d, POrd d) => Tile d iv v -> Tile d iv v
unfoldNowT t
    = case reduceT t of 
        (Tile d 0 QEnd) -> Tile d 0 QEnd
        (Tile d 0 (QRec dd f p)) -> unfoldNowT (Tile d 0 (stretchQ dd (f p)))
        (Tile d 0 (QList [] (DQ dd q))) -> unfoldNowT (Tile d dd q)
        (Tile _ ad _) -> case partialCompare 0 ad of
                           Just LT -> t
                           Just EQ -> t
                           _ -> error "unfoldNowT : bad tile to be unfolded"
               
-- | Unfold all recursive definitions in a tile (for debug purpose)
unfoldT :: Num d => Tile d iv v -> Tile d iv v
unfoldT (Tile d ad q)
    = Tile d ad (unfoldQ q)

-- | Normalizes a tile
normalizeT :: (Eq d, Num d, Lattice d, POrd v) => Tile d iv v -> Tile d iv v
normalizeT (Tile d _ QEnd) = Tile d 0 QEnd 
normalizeT t
    = let ht = headT t
      in ht + normalizeT (tailT t)