{-# LANGUAGE Arrows #-}

module FRP.Moe.Combinators where

import Prelude hiding (cycle)
import FRP.Moe.Core
import Control.Arrow
import System.Random

sfConst :: a -> SF b a
-- ^ Input:  <i1, i2, ...> (ignored)

-- ^ Output: <x,  x,  ...>
sfConst x = arr (const x)

time :: SF () Double
-- ^ Input:  <(), (), ...>

-- ^ Outputs the sequence of the current time at each sample point
time = sfConst 1 >>> integral

noise :: (Random a, RandomGen b) => b -> SF () a
-- ^ Input:  <i1, i2, ...> (ignored)

-- ^ Outputs a sequence of random generated numbers using g0
noise g0 = proc () -> do rec let (x, g') = random g
                             g <- delay g0 -< g'
                         returnA -< x

noiseR :: (Random a, RandomGen b) => (a, a) -> b -> SF () a
-- ^ Input:  <i1, i2, ...> (ignored)

-- ^ Outputs a sequence of random generated numbers using g0, with lh

-- ^ indicating the minimum and maximum numbers that are allowed.
noiseR lh g0 = proc () -> do rec let (x, g') = randomR lh g
                                 g <- delay g0 -< g'
                             returnA -< x

rep :: Int -> SF a a -> SF a a
-- ^ rep n sf = sf >>> sf >>> ... >>> sf (n times)
rep 0 sf = arr (\x -> x)
rep n sf = sf >>> rep (n - 1) sf

cycle :: [a] -> SF () a
-- ^ xs:     [x1, x2, x3]

-- ^ Input:  <(), (), (), (), (), ...>

-- ^ Output: <x1, x2, x3, x1, x2, ...>
cycle [] = error "Cycle: list is empty."
cycle xs = proc () -> do rec let (y : ys) = zs
                             zs <- delay xs -< case ys of
                                                 [] -> xs
                                                 _ -> ys
                         returnA -< y

timedCycle :: [(DTime, a)] -> SF () a
timedCycle [] = error "TimedCycle: list is empty."
timedCycle txs = auxCycle txs where
           auxCycle ((timeOut, x) : txs') = dswitch aux (\_ -> if null txs' 
                                                               then auxCycle txs
                                                               else auxCycle txs') where
                                              aux = proc () -> do t <- time -< ()
                                                                  returnA -< (x, if t > timeOut
                                                                                 then Event ()
                                                                                 else NoEvent)

data MemOp a = Read | Write a

memory :: a -> SF (MemOp a) a
-- ^ Input:  <Read, Write x1, Read, ...>

-- ^ Output: <x0,   x1,       x1,   ...>
memory x0 = proc op -> do rec let y = case op of
                                        Read -> z
                                        Write y' -> y'
                              z <- delay x0 -< y
                          returnA -< y

stateful :: (a -> a) -> a -> SF () a
-- ^ Input:  <(), (), (), ...>

-- ^ Output: <x0, f x0, f (f x0), ...>
stateful f x0 = proc () -> do rec let z = f y
                                  y <- delay x0 -< z
                              returnA -< y

stateful2 :: (a -> b -> a) -> a -> SF b a
-- ^ Input:  <i1, i2, i3, ...>

-- ^ Output: <x0, f x0 i1, f (f x0 i1) i2, ...>
stateful2 f x0 = proc i -> do rec let z = f y i
                                  y <- delay x0 -< z
                              returnA -< y
                      
integral :: SF Double Double
-- ^ Simple integration
integral = proc x -> do dt <- dTime -< ()
                        rec let y = i + x * dt
                            i <- delay 0 -< y
                        returnA -< i

broadcast :: Functor col => col sf -> a -> col (a, sf)
broadcast sfs x = fmap ((,) x) sfs