FRP.hs

import Prelude hiding ((.), id)
import Control.Category
import Control.Arrow

data Stream a = Stream
  { headS :: a
  , tailS :: Stream a
  }
  deriving Show

streamToList :: Stream a -> [a]
streamToList (Stream a as) = a : streamToList as

printStream :: Show a => Stream a -> IO ()
printStream (Stream a stream) = do
  print a
  printStream stream

instance Functor Stream where
  fmap f (Stream a as) = Stream (f a) $ fmap f as

addStreams :: Num a => Stream a -> Stream a -> Stream a
addStreams (Stream a as) (Stream b bs) = Stream ((a +) b) $ addStreams as bs

instance Applicative Stream where
  pure a = Stream a $ pure a
  Stream f fs <*> Stream a as = Stream (f a) $ fs <*> as

zipS :: Stream a -> Stream b -> Stream (a, b)
zipS as bs = ( , ) <$> as <*> bs
{-
class Functor stream => Applicative stream where
  pure :: a -> stream a
  (<*>) :: stream (a -> b) -> stream a -> stream b
-}

nats :: Stream Integer
nats = Stream 0 $ incStream nats

incStream :: Stream Integer -> Stream Integer
incStream = fmap (1 +)

prepend :: [a] -> Stream a -> Stream a
prepend [] stream = stream
prepend (a : as) stream = Stream a $ prepend as stream

nats' :: Stream Integer
nats' = dfix incStream [0]

unfold :: (s -> (s, a)) -> s -> Stream a
unfold f s = let (s', a) = f s in Stream a $ unfold f s'

-- Stream a $ Stream (f a) $ Stream (f $ f a) ...
iterateS :: (a -> a) -> a -> Stream a
iterateS f a = unfold g a
  where
    g a = (f a, a)

dfix :: (Stream a -> Stream a) -> [a] -> Stream a
dfix f prefix = stream
  where
    stream = prepend prefix $ f stream

-- a0, a1, a2,... -> 0, a0, a0 + a1, a0 + a1 + a2
sumS :: Num a => Stream a -> Stream a
sumS as = unfold f (as, 0)
  where
    f (as_, accum) = ((tailS as_, accum + headS as_), accum)

sumS' stream = dfix (((+) <$> stream) <*>) [0]

downsample :: Fractional a => Stream a -> Stream a
downsample (Stream a0 (Stream a1 as)) = Stream ((a0 + a1) / 2) $ downsample as

-- 1,2,3,4,5,6, (1+2)/2, (3+4)/2, (5+6)2, x, y, ?=(y + ?)/2
hang :: Stream Float
hang = dfix downsample [1,2,3,4,5,6]

-- FRAn Functional Reactive Animations

type Time = Float

type Signal a = Time -> a
type Event a = Stream (Time, a)
values :: Event a -> Stream a
values = fmap snd
current :: Event a -> a
current = snd . headS

type Clock = Stream Time

sample :: Signal a -> Clock -> Event a
sample signal clock = zipS clock $ fmap signal clock

ms :: Clock
ms = fmap ((/ 1000) . fromInteger) nats

second :: Clock
second = fromInteger <$> nats

interpolate :: Event a -> Signal a
interpolate as = \time -> current $ dropUntil (\(ts, a) -> ts >= time) as

dropUntil :: (a -> Bool) -> Stream a -> Stream a
dropUntil f (Stream a as) = if f a then Stream a as else dropUntil f as

integral :: Fractional a => Signal a -> Signal a
integral signal = interpolate $ zipS ms $ (/1000) <$> (sumS $ values $ sample signal ms)

data StreamF a b = StreamF { unstreamF :: a -> (b, StreamF a b) }

apply :: StreamF a b -> Stream a -> Stream b
apply (StreamF f) (Stream a as) = let (b, streamF') = f a in Stream b $ apply streamF' as

-- (() -> a) == a
iso :: StreamF () a -> Stream a
iso = undefined

sumSF :: Num a => StreamF a a
sumSF = sumSFFrom 0
  where
    sumSFFrom a0 = StreamF $ \a -> (a0, sumSFFrom $ a0 + a)

feedback :: c -> StreamF (a, c) (b, c) -> StreamF a b
feedback c streamF = StreamF $ \a ->
  let ((b, c'), streamF') = unstreamF streamF (a, c)
  in (b, feedback c' streamF')

sumSF' = feedback 0 $ arr $ \(a, accum) -> (accum, accum + a)

instance Category StreamF where
  -- id :: StreamF a a
  id = StreamF $ \a -> (a, id)

  -- (.) :: StreamF b c -> StreamF a b -> StreamF a c
  f . g = StreamF $ \a ->
    let (b, g') = unstreamF g a
        (c, f') = unstreamF f b
    in (c, f' . g')

instance Arrow StreamF where
  -- arr :: (a -> b) -> StreamF a b
  arr f = StreamF $ \a -> (f a, arr f)

  -- (***) :: StreamF a b -> StreamF c d -> StreamF (a, c) (b, d)
  f *** g = StreamF $ \(a, c) ->
    let (b, f') = unstreamF f a
        (d, g') = unstreamF g c
    in ((b, d), f' *** g')

{-
bigSF = proc (a, b, c) -> do
  d <- sumSF' -< a
  e <- sumSF' . sumSF' -< b + c
  returnA -< d + e
-}


main :: IO ()
main = printStream $ apply (id *** sumSF') $ pure (1,1)