Skip to content

Instantly share code, notes, and snippets.

@cobbpg
Last active August 29, 2015 14:20
Show Gist options
  • Save cobbpg/34b16cf9c1f076be7d3f to your computer and use it in GitHub Desktop.
Save cobbpg/34b16cf9c1f076be7d3f to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment