{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeOperators
           , FunctionalDependencies
  #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  Segment
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Segment class and functions with duration.
-- To avoid name clash, do
-- 
-- @
--    import Prelude hiding (null,length,drop,take,splitAt)
-- @
----------------------------------------------------------------------

module Segment (Segment(..), (:->#)(..)) where

import Prelude hiding (zip,zipWith,null,length,drop,take,splitAt)
import qualified Prelude

import Data.Monoid
import Control.Applicative
import Control.Comonad    -- from category-extras
import Data.Zip           -- from TypeCompose

-- | Segments with length (duration).  Laws:
-- 
-- @
--    drop (length as) (as `mappend` bs) == bs
--    take (length as) (as `mappend` bs) == as
-- 
--    d <= length as ==> length (take d as) == d
--    d <= length as ==> length (drop d as) == length as - d
-- @

class Segment seg dur | seg -> dur where
    null    :: seg -> Bool
    length  :: seg -> dur
    take    :: dur -> seg -> seg
    drop    :: dur -> seg -> seg
    splitAt :: dur -> seg -> (seg,seg)
    -- Defaults:
    splitAt d s = (take d s, drop d s)
    take    d s = fst (splitAt d s)
    drop    d s = snd (splitAt d s)

instance Segment [a] Int where
    null    = Prelude.null
    length  = Prelude.length
    drop    = Prelude.drop
    take    = Prelude.take
    splitAt = Prelude.splitAt

-- | "Function segment", i.e., function with duration
data t :-># a = FS t (t -> a)

instance (Ord t, Num t) => Monoid (t :-># a) where
  mempty = FS 0 (error "sampling empty 't :-># a'")
  FS c f `mappend` FS d g =
    FS (c + d) (\ t -> if t <= c then f t else g (t - c))

instance Num t => Segment (t :-># a) t where
    null   (FS d _) = d == 0  -- d <= 0 ? (would need Ord)
    length (FS d _) = d
    drop t (FS d f) = FS (d - t) (\ t' -> f (t + t'))
    take t (FS _ f) = FS t f


instance Functor ((:->#) t) where
    fmap h (FS d f) = FS d (h . f)

instance Ord t => Zip ((:->#) t) where
    FS xd xf `zip` FS yd yf = FS (xd `min` yd) (xf `zip` yf)

instance (Ord t, Bounded t) => Applicative ((:->#) t) where
    pure a = FS maxBound (const a)
    (<*>)  = zipWith ($)


instance Num t => Copointed ((:->#) t) where
    extract (FS _ f) = f 0

instance Num t => Comonad ((:->#) t) where
    duplicate s = FS (length s) (flip drop s)