FruitFRP.hs

{-# LANGUAGE NoImplicitPrelude #-}
module FruitFRP where

import Prelude hiding ((.), id)
import Control.Arrow
import Control.Applicative
import Control.Category
import Control.Concurrent (threadDelay)
import Control.Monad
import Data.Bifunctor hiding (first)
import Data.Function hiding ((.), id)
import Data.Maybe
import Data.List.NonEmpty
import Data.Profunctor
import Data.Profunctor.Sieve
import Data.VectorSpace

{-
Denotations

Signal α = Time → α

ST α β = Signal α → Signal β

[[arr f]] = λs : Signal α . λt : Time . [[f]](s(t))

[[fa >>> ga]] = ([[ga]] ◦ [[fa]])

first :: ST b c -> ST (b, d) (c, d)
-- [[first fa]] = λs : Signal(β × γ) . pairZ ([[fa]] (fstZ s)) (sndZ s)

second :: ST b c -> ST (d, b) (d, c)


(***) :: ST b c -> ST b' c' -> ST (b, b') (c, c')

(&&&) :: ST b c -> ST b c' -> ST b (c, c')

-- [[loop fa]] = λs : Signal β. fstZ(Y(λr.[[fa]](pairZ s (sndZ r))))

[[integral]] = λs.λt. ∫_{0}^{t} s(t)dt

[[time]] = λs.λt.t

[[iPre x]] = λs.λt. if t <= e then [[x]] else s (t - e)


fstZ : ST (a, b) a
sndZ : ST (a, b) b

pairZ : Signal a -> Signal b -> ST (a, b) (a, b)

-}

type Time = Double
type DTime = Double

-- | Signal
-- A signal is a function from some Time to a value `a`
type Signal a = Time -> a


-- | Signal Transformer
-- Transforms a signal carrying values of type `a` into a signal
-- carrying values of type `b`. Denotationally you can think of SF as:
--
-- type Time = Double
-- type ST a b = Signal a -> Signal b
--
-- From an implementation perspective, given a Time and an initial `a`
-- value returns a pair of the next state in the form of future ST and
-- the output `b` at the current time step.
newtype ST a b = ST { _runST :: DTime -> a -> (ST a b, b) }

instance Semigroup b => Semigroup (ST a b) where
  ST f <> ST g = ST $ \dt s -> f dt s <> g dt s

instance Monoid b => Monoid (ST a b) where
  mappend = (<>)
  mempty = ST mempty

instance Functor (ST a) where
  fmap :: (b -> c) -> ST a b -> ST a c
  fmap f st = arr f . st

instance Applicative (ST a) where
  pure :: b -> ST a b
  pure a = arr $ const a

  (<*>) :: ST a (b -> c) -> ST a b -> ST a c
  (<*>) (ST sf) (ST sa) = ST $ \t a ->
    let (ab, b) = (sa t) a
        g = snd $ (sf t) a
    in (fmap g ab, g b)

  liftA2 :: (b -> c -> d) -> ST a b -> ST a c -> ST a d
  liftA2 f (ST g) (ST h) = ST $ \t a ->
    let  (ac, c) = (h t) a
         (ab, b) = (g t) a
    in (liftA2 f ab ac, f b c)

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

  (.) :: ST b c -> ST a b -> ST a c
  ST f . ST g = ST $ \t a ->
    let (ab, b) = (g t) a
        (bc, c) = (f t) b
    in (bc . ab, c)

instance Profunctor ST where
  dimap :: (a -> b) -> (c -> d) -> ST b c -> ST a d
  dimap f g h = arr f >>> h >>> arr g

instance Strong ST where
  first' :: ST b c -> ST (b, d) (c, d)
  first' (ST f) = ST $ \t (b, d) ->
    let (bc, c) = f t b
    in (first bc, (c, d))

  second' :: ST a b -> ST (c, a) (c, b)
  second' (ST f) = ST $ \t (c, a) ->
    let (g, b) = f t a
    in (second' g, (c, b))

instance Costrong ST where
  unfirst :: ST (a, d) (b, d) -> ST a b
  unfirst (ST f) = ST $ \dt a ->
    let (h, (b, d)) = fix (\r -> let (g, (b, d)) = _runST sndZ dt r in f dt (a, d))
    in (unfirst h, b)

instance Choice ST where
  left' :: ST a b -> ST (Either a c) (Either b c)
  left' (ST f) = ST $ \dt -> \case
    Left a -> let (g, b) = f dt a in (left' g, Left b)
    Right c -> (left' (ST f), Right c)

--instance Cosieve ST NonEmpty where
--  cosieve :: ST a b -> NonEmpty (DTime, a) -> b
--  cosieve f xs = observe' f xs

--instance Closed ST where
--  closed :: ST a b -> ST (x -> a) (x -> b)
--  closed (ST f) = ST $ \dt s ->
--    let f' = f dt . s
--    in _

instance Arrow ST where
  arr :: (b -> c) -> ST b c
  arr f = ST $ \t b -> (arr f, f b)

  first :: ST b c -> ST (b, d) (c, d)
  first = first'

instance ArrowLoop ST where
  loop :: ST (b, d) (c, d) -> ST b c
  loop = unfirst

fstZ :: ST (a, b) a
fstZ = arr fst

sndZ :: ST (a, b) b
sndZ = arr snd

pairZ :: Signal a -> Signal b -> Signal (a, b)
pairZ f g = liftA2 (,) f g

constant :: b -> ST a b
constant = arr . const

integral :: VectorSpace a s => ST a a
integral = ST (integralF zeroVector)
  where
    integralF :: VectorSpace a s => a -> DTime -> a -> (ST a a, a)
    integralF acc dt x =
      let res = acc ^+^ (undefined $ realToFrac dt) *^ x
      in (ST (integralF res), acc)

integral' :: Fractional a => ST a a
integral' = ST (aux 0)
  where
    aux :: Fractional a => a -> DTime -> a -> (ST a a, a)
    aux acc dt a =
      let tf = aux (acc + a * realToFrac dt)
      in (ST tf, acc)

switch :: ST a (b, Maybe c) -> (c -> ST a b) -> ST a b
switch (ST f) cb = ST switchF
  where
    switchF dt s =
      let (g, (b, event)) = f dt s
      in case event of
        Nothing -> (switch g cb, b)
        Just c -> (_runST (cb c)) dt s

reactimate :: Monad m
           => m a                           -- ^ Initialization action
           -> (Bool -> m (Time, Maybe a))    -- ^ Input sensing action
           -> (Bool -> b -> m Bool)           -- ^ Actuation (output processing) action
           -> ST a b                        -- ^ Signal function
           -> m ()
reactimate init sense actuate (ST f) = do
  a <- init
  let (st, b) = f 0 a
  loop st a b
  where
    loop st a b = do
      done <- actuate True b
      unless (a `seq` b `seq` done) $ do
        (dt, ma') <- sense False
        let a' = fromMaybe a ma'
            (st', b') = (_runST st) dt a'
        loop st' a' b'

embed :: ST a b -> (a, [(Time, Maybe a)]) -> [b]
embed (ST f) (a, xs) = b0 : loop a g xs
  where
    (g, b0) = f 0 a
    loop :: a -> ST a b -> [(Time, Maybe a)] -> [b]
    loop _ _ [] = []
    loop a (ST g) ((t, ma) : ts) =
      let a' = fromMaybe a ma
          (h, b) = g t a'
      in b : (a `seq` b `seq` loop a' h ts)

main = reactimate (pure 0) senseInput actuate signal
  where
    senseInput :: Bool -> IO (Time, Maybe Int)
    senseInput _ = do
      threadDelay 30000
      pure (0.1, Nothing)

    actuate :: Bool -> Int -> IO Bool
    actuate _ i = print i >> pure False

    signal :: ST Int Int
    signal = arr (+1)

pump' :: ST a b -> NonEmpty (DTime, a) -> NonEmpty b
pump' (ST f) (x :| xs) =
  let (g, b) = uncurry f x
  in b :| pump g xs

pump :: ST a b -> [(DTime, a)] -> [b]
pump (ST f) [] = []
pump (ST f) (x:xs) =
  let (g, b) = uncurry f x
  in b : pump g xs

observe :: ST a b -> [(Time, a)] -> b
observe f = Prelude.last . pump f

observe' :: ST a b -> NonEmpty (Time, a) -> b
observe' f = Data.List.NonEmpty.last . pump' f