-----------------------------------------------------------------------------
-- |
-- Module  :  ForSyDe.Shallow.Signal
-- Copyright   :  (c) SAM Group, KTH/ICT/ECS 2007-2008
-- License     :  BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  forsyde-dev@ict.kth.se
-- Stability   :  experimental
-- Portability :  portable
--
-- This module defines the shallow-embedded 'Signal' datatype and
-- functions operating on it.
-----------------------------------------------------------------------------
module ForSyDe.Shallow.Signal( Signal (NullS, (:-)), (-:), (+-+), (!-), 
       signal, fromSignal,
       unitS, nullS, headS, tailS, atS, takeS, dropS,
       lengthS, infiniteS, copyS, selectS, writeS, readS, fanS
     ) where

infixr 5    :-
infixr 5    -:
infixr 5    +-+
infixr 5    !-


-- | A signal is defined as a list of events. An event has a tag and a value. The tag of an event is defined by the position in the list. A signal is defined as an instance of the classes 'Read' and 'Show'. The signal 1 :- 2 :- NullS is represented as \{1,2\}.
data Signal a = NullS
      | a :- Signal a deriving (Eq)

-- | The function 'signal' converts a list into a signal.
signal     :: [a] -> Signal a 

-- | The function 'fromSignal' converts a signal into a list.
fromSignal     :: Signal a -> [a]

-- | The function 'unitS' creates a signal with one value.
unitS      :: a -> Signal a

-- | The function 'nullS' checks if a signal is empty.
nullS      :: Signal a -> Bool

-- | The function 'headS' gives the first value - the head -  of a signal.
headS      :: Signal a -> a

-- | The function 'tailS' gives the rest of the signal - the tail.
tailS      :: Signal a -> Signal a

-- | The function 'atS'  returns the n-th event in a signal. The numbering of events in a signal starts with 0. There is also an operator version of this function, '(!-)'.
atS        :: Int -> Signal a -> a

-- | The function 'takeS' returns the first n values of a signal.
takeS      :: Int -> Signal a -> Signal a

-- | The function 'dropS' drops the first $n$ values from a signal.
dropS      :: Int -> Signal a -> Signal a

-- | The function 'selectS' takes three parameters, an offset, a stepsize and a signal and returns some elements of the signal such as in the following example:
--
-- @
-- Signal> selectS 2 3 (signal[1,2,3,4,5,6,7,8,9,10])
-- {3,6,9} :: Signal Integer
-- @
selectS        :: Int -> Int -> Signal a -> Signal a

-- | The function 'lengthS' returns the length of a 'finite' signal.
lengthS        :: Signal b -> Int

-- | The function 'infiniteS' creates an infinite signal. The first argument 'f' is a function that is applied on the current value. The second argument 'x' gives the first value of the signal.
--
-- > Signal> takeS 5 (infiniteS (*3) 1)
-- > {1,3,9,27,81} :: Signal Integer
--
infiniteS      :: (a -> a) -> a -> Signal a

-- | The function 'writeS' transforms a signal into a string of the following format:
--
-- @ 
-- Signal> writeS (signal[1,2,3,4,5])
-- "1\n2\n3\n4\n5\n" :: [Char]
-- @
writeS     :: Show a => Signal a -> [Char]

-- | The function 'readS' transforms a formatted string into a signal.
--
-- @
-- Signal> readS "1\n2\n3\n4\n5\n" :: Signal Int
-- {1,2,3,4,5} :: Signal Int
-- @
readS      :: Read a => [Char] -> Signal a

-- | The operator '-:' adds at an element to a signal at the tail.
(-:)       :: Signal a -> a -> Signal a

-- | The operator '+-+' concatinates two signals into one signal.  
(+-+)      :: Signal a -> Signal a -> Signal a 


-- | The function 'copyS' creates a signal with n values 'x'.
copyS :: (Num a, Eq a) => a -> b -> Signal b


-- | The combinator 'fanS' takes two processes 'p1' and 'p2' and and generates a process network, where a signal is split and processed by the processes 'p1' and 'p2'.
fanS :: (Signal a -> Signal b) -> (Signal a -> Signal c) 
      -> Signal a -> (Signal b, Signal c)

-- Implementation

instance (Show a) => Show (Signal a) where
     showsPrec p NullS = showParen (p > 9) (
           showString "{}")
     showsPrec p xs    = showParen (p > 9) (
           showChar '{' . showSignal1 xs)
             where
            showSignal1 NullS
               = showChar '}'
            showSignal1 (y:-NullS) 
               = shows y . showChar '}'
            showSignal1 (y:-ys)    
               = shows y . showChar ',' 
             . showSignal1 ys

instance Read a => Read (Signal a) where
     readsPrec _ s = readsSignal s

readsSignal    :: (Read a) => ReadS (Signal a)
readsSignal s      =  [((x:-NullS), rest) 
            | ("{", r2)   <- lex s,
          (x, r3)     <- reads r2,
          ("}", rest) <- lex r3]
          ++ [(NullS, r4)       
            | ("{", r5) <- lex s,
          ("}", r4) <- lex r5]
          ++ [((x:-xs), r6)     
            | ("{", r7) <- lex s,
          (x, r8)   <- reads r7,
          (",", r9) <- lex r8,
          (xs, r6)  <- readsValues r9]

readsValues    :: (Read a) => ReadS (Signal a)
readsValues s      =  [((x:-NullS), r1) 
            | (x, r2)   <- reads s,
          ("}", r1) <- lex r2]
          ++ [((x:-xs), r3)    
            | (x, r4)   <- reads s,
          (",", r5) <- lex r4,
          (xs, r3)  <- readsValues r5]

signal []           =  NullS
signal (x:xs)       =  x :- signal xs 

fromSignal NullS        =  []
fromSignal (x:-xs)      =  x : fromSignal xs

unitS x             =  x :- NullS

nullS NullS         =  True
nullS _             =  False

headS NullS         =  error "headS : Signal is empty"
headS (x:-_)        =  x

tailS NullS         =  error "tailS : Signal is empty"
tailS (_:-xs)       =  xs

atS _ NullS         
  =  error "atS: Signal has not enough elements"
atS 0 (x:-_)        =  x
atS n (_:-xs)       =  atS (n-1) xs

(!-) :: Signal a -> Int -> a
(!-) xs n           = atS n xs

takeS 0 _           = NullS
takeS _ NullS       = NullS
takeS n (x:-xs) | n <= 0    = NullS
        | otherwise     = x :- takeS (n-1) xs

dropS 0 NullS       = NullS
dropS _ NullS       = NullS 
dropS n (x:-xs) | n <= 0    = x:-xs
      | otherwise       = dropS (n-1) xs


selectS offset step xs = select1S step (dropS offset xs) 
  where
   select1S _  NullS   = NullS
   select1S st (y:-ys) = y :- select1S st (dropS (st-1) ys) 

(-:) xs x           = xs +-+ (x :- NullS)

(+-+) NullS   ys        = ys
(+-+) (x:-xs) ys        = x :- (xs +-+ ys)

lengthS NullS       = 0
lengthS (_:-xs)         = 1 + lengthS xs

infiniteS f x       = x :- infiniteS f (f x)

copyS 0 _           = NullS
copyS n x           = x :- copyS (n-1) x

fanS p1 p2 xs       = (p1 xs, p2 xs)

writeS NullS   = []
writeS (x:-xs) = show x ++ "\n" ++ writeS xs

readS xs   = readS' (words xs)
  where
    readS' []    = NullS
    readS' ("\n":ys) = readS' ys
    readS' (y:ys)    = read y :- readS' ys