MiniYampa.hs

{-# LANGUAGE Arrows #-}

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

-- Only for testing
import Text.Printf

newtype SF a b = SF (Float -> a -> (SF a b, b))

-- Given a list of inputs with delta times produce a list of outputs.
runSF (SF sf) [] = []
runSF (SF sf) ((dt, x) : dtxs) = y : runSF sf' dtxs
  where
    (sf', y) = sf dt x

-- This is required by Arrow nowadays.
instance Category SF where
    id = idSF
      where
        idSF = SF (\dt x -> (idSF, x))
    SF sf2 . SF sf1 = SF sf12
      where
        sf12 dt x1 = (sf2' . sf1', x3)
          where
            (sf1', x2) = sf1 dt x1
            (sf2', x3) = sf2 dt x2

-- Note that in the old times (>>>) was part of Arrow, but now
-- it's just a plain function defined in terms of (.) from Category.
instance Arrow SF where
    arr f = arrSF
      where
        arrSF = SF (\dt x -> (arrSF, f x))
    first (SF sf) = SF firstF
      where
        firstF dt (x, y) = (first sf', (x', y))
          where
            (sf', x') = sf dt x

-- Value recursion only!
instance ArrowLoop SF where
    loop (SF sf) = SF loopF
      where
        loopF dt x = (loop sf', x')
          where
            (sf', (x', y)) = sf dt (x, y)

-- Safe to use in loops.
integral acc0 = SF (integralF acc0)
  where
    integralF acc dt x = (SF (integralF res), acc)
      where
        res = acc + dt * x

-- Not safe in loops but doesn't impose a delay.
integralImmediate acc0 = SF (integralF acc0)
  where
    integralF acc dt x = (SF (integralF res), res)
      where
        res = acc + dt * x

-- Immediate switch: we see the output of the new behaviour when the event fires.
switch (SF sf) k = SF switchF
  where
    switchF dt x = case evt of
        Nothing -> (switch sf' k, y)
        Just e -> sfNew dt x
          where
            SF sfNew = k e
      where
        (sf', (y, evt)) = sf dt x

testSF sf prtFun n dt = mapM_ prtFun (take n (runSF sf (repeat (dt, ()))))

trigSF = proc _ -> do
    rec sin <- integral 0 -< cos
        cos <- integral 1 -< -sin
    returnA -< (sin, cos)

-- Just to demonstrate how inaccurate Euler integration is...
testTrig = testSF trigSF printTrig 200 0.01
  where
    printTrig :: (Float, Float) -> IO ()
    printTrig (sint, cost) = printf "(%1.4f,%1.4f)\n" sint cost

risingSawtooth init threshold = switch risingSegment react
  where
    react level = risingSawtooth (level - threshold) (threshold + 1)
    risingSegment = proc _ -> do
        level <- integral init -< 1
        returnA -< (level, if level > threshold then Just level else Nothing)

testTeeth = testSF (risingSawtooth 0 2) printLevel 100 0.15
  where
    printLevel :: Float -> IO ()
    printLevel level = printf "%1.2f\n" level