ArrowShowcase.hs

{-# LANGUAGE Arrows, TypeOperators #-}

import Prelude hiding (id, (.))
import SF

-- this is the timer - returns length of the tick
ticks :: () :-> Double
ticks = constant 1

-- Modelling the physics. 
-- The inner block receives current force.
physics :: Double -> Double -> Double :-> Double
physics mass startPos = proc force -> do

    -- receiving the time diff signal
    dt <- ticks -< ()

    -- this block has recursive dependencies
    rec
        -- detect collision

        -- it is delayed by emitting False before all output
        -- this is done to preserve the rules of casuality
        -- because bounce is circular dependent on x
        -- so, it makes bounce depend on _previous_ x
        bounce <- delayBy False <<< front collision -< x
                
        let a = force / mass

        -- invert speed on collision
        let reflect :: Double -> Double
            reflect = if bounce then negate else id

        -- black magic:
        --  both ways carried kinetic energy away, so I decided to experiment
        let refine :: Double -> Double
            refine v = avg [reflect (a * dt + v), a * dt + reflect v]

        -- integrating dv into speed & speed into position
        -- integrate' receives function to perform on value
        v <- integrate' 0        -< refine
        x <- integrate' startPos -< (+ v)

    returnA -< x

avg list = sum list / fromIntegral (length list)

-- detects if the probe got inside the floor
collision :: Double :-> Bool
collision = 
    arr (\x -> x <= 0) 

-- collision = arr . (<= 0)

draw :: Double -> IO ()
draw = id
    >>> truncate           -- Double -> Int
    >>> (`replicate` '*')  -- n : Int -> line of n '*'
    >>> putStrLn           -- print it

main = mapM_ draw $ take 150
    
    -- simulation: mass = 1, startPos = 10, gravity is a constant -1
    (physics 1 10 `listen` repeat (-1))

ArrowShowcaseUncommented.hs

{-# LANGUAGE Arrows, TypeOperators #-}

import Prelude hiding (id, (.))
import SF

ticks :: () :-> Double
ticks = constant 1

physics :: Double -> Double -> Double :-> Double
physics mass startPos = proc force -> do

    dt <- ticks -< ()

    rec
        bounce <- delayBy False <<< front collision -< x
                
        let a = force / mass

        let reflect :: Double -> Double
            reflect = if bounce then negate else id

        let refine :: Double -> Double
            refine v = avg [reflect (a * dt + v), a * dt + reflect v]

        v <- integrate' 0        -< refine
        x <- integrate' startPos -< (+ v)

    returnA -< x

avg list = sum list / fromIntegral (length list)

collision :: Double :-> Bool
collision = 
    arr (\x -> x <= 0) 

draw :: Double -> IO ()
draw = id
    >>> truncate           -- Double -> Int
    >>> (`replicate` '*')  -- n : Int -> line of n '*'
    >>> putStrLn           -- print it

main = mapM_ draw $ take 150
    
    (physics 1 10 `listen` repeat (-1))

Output part

*********
*******
****

****
*******
*********
**********
**********
*********
*******
****

****
*******
*********
**********
**********
*********
*******
****

****
*******
*********
**********
**********
*********
*******
****

****
*******
...

SF.hs

{-# LANGUAGE TypeOperators #-}

module SF 
    ( module Control.Arrow
    , module Control.Category
    , module Control.Applicative
    , SF
    , (:->)
    , (==>)
    , andB
    , listen
    , conditions
    , conditions_test
    , constant
    , delayBy
    , diff
    , fallback
    , fib
    , fromAngle
    , hold
    , integrate'
    , integrate
    , liftB2
    , loop'
    , nat
    , onNothing
    , orB
    , peak
    , tick
    , whenB
    , cycleB
    , front
    , switchByFront
    , b2i
    )
    where

import Prelude hiding (id, (.))

import Control.Applicative
import Control.Arrow
import Control.Category

newtype SF a b =
    SF { runSF :: a -> (SF a b, b) } 

type (:->) = SF

instance Category SF where
    id = arr id

    f . g = SF $ \a ->

        let 
            (g', b) = g `runSF` a
            (f', c) = f `runSF` b

        in (f' . g', c)

instance Arrow SF where
    arr pure = SF $ const (arr pure) &&& pure

    first arrow = 
        SF $ \(a, b) ->
            let
                (arrow', c) = arrow `runSF` a

            in (first arrow', (c, b))

instance ArrowLoop SF where
    loop arrow = 
        SF $ \a ->
            let 
                (arrow', (b, s)) = arrow `runSF` (a, s)

            in (loop arrow', b)

instance ArrowChoice SF where
    left arrow = 
        SF $ \a -> case a of
            Left a ->
                let (arrow', b) = arrow `runSF` a
                in  (left arrow', Left b)

            Right a ->
                (left arrow, Right a)

instance Num b => Num (SF a b) where
    fromInteger = constant . fromInteger

    (+) = liftB2 (+)
    (*) = liftB2 (*)

    abs    = arr abs
    negate = arr negate
    signum = arr signum

instance Functor (SF a) where
    fmap f = (>>> arr f)

instance Applicative (SF a) where
    pure = constant

    f <*> x = SF $ \a ->
        let
            (f', pf) = f `runSF` a
            (x', px) = x `runSF` a

        in (f' <*> x', pf px)

-- Seems to be no way to implement ArrowApply and Monad right.

-- The monad instance requires us in `ma >>= amb` transform the 
-- result of `amb a` and send it as state to the future. But, the result
-- depends on arbitrary `a`, which makes it inaccessible.

-- `ArrowApply` due to semantics `being a monad` shows the same problem.

instance ArrowApply SF where
    app = 
        SF $ \(bf, a) ->
            let
                (_, c) = bf `runSF` a

            in (app, c)

liftB2 (?) left right = (?) <$> left <*> right

delayBy :: a -> SF a a
delayBy x =
    SF $ \a -> 
        (delayBy a, x)

onNothing :: a -> SF (Maybe a) a
onNothing filler =
    SF $ \a ->
        case a of
            Just value -> (onNothing filler, value)
            Nothing    -> (onNothing filler, filler)

hold :: a -> SF (Maybe a) a
hold seed =
    SF $ \a ->
        case a of
            Just value -> (hold value, value)
            Nothing    -> (hold seed,  seed)

peak :: Eq a => a -> SF a (Maybe a)
peak prev =
    SF $ \a ->
        ( peak a
        , if a == prev
          then Nothing
          else Just a
        )

conditions :: [(SF a Bool, SF a b)] -> SF a b
conditions [] = error "No condition matched, use fallback (constant True) as the last one!"

conditions list = 
    conditions' [] list

  where
    conditions' failed ((predicate, action) : rest) =
        SF $ \a ->
            let
                (predicate', flag) = predicate `runSF` a

            in  if  flag
                then let
                        (action', b) = action `runSF` a
                    
                     in (conditions $ reverse failed ++ (predicate', action') : rest, b)

                else
                    let 
                        next = conditions' ((predicate', action) : failed) rest

                    in  next `runSF` a

andB, orB :: SF a Bool -> SF a Bool -> SF a Bool
andB = liftB2 (&&)
orB  = liftB2 (||)

conditions_test = conditions
    [                   arr (>  5) ==> constant "over five"

    , arr (<= 5) `andB` arr (>  2) ==> arr show >>> arr ("is " ++)

    ,                   arr (== 1) ==> integrate 0 (+) 
                                   >>> arr show
                                   >>> arr (++ " time we found 1")

    , fallback                     ==> constant "very bad"
    ]

infix 0 ==>
(==>) = (,)

fallback = constant True

whenB :: SF a b -> SF a Bool -> SF a (Maybe b)
action `whenB` predicate =
    SF $ \a ->
        let
            (predicate', flag) = predicate `runSF` a

        in  if   flag
            then let
                    (action', b) = action `runSF` a

                 in (action' `whenB` predicate', Just b)

            else (action `whenB` predicate', Nothing)

loop' seed arrow = 
    loop $ second (delayBy seed) >>> arrow

fib = integrate (0, 1) (\(a, b) _ -> (a + b, a)) >>> arr snd

nat = 1 >>> integrate 0 (+)

tick = nat

infix 0 `listen`

listen :: SF a b -> [a] -> [b]
listen _ []       = []
listen b (a : as) =
    let
        (b', c) = b `runSF` a

    in c : listen b' as

constant :: b -> SF a b
constant x = SF $ const $ (constant x, x)

diff init (?) = delayBy init &&& id >>> arr (uncurry (?))

fromAngle = arr sin &&& arr cos :: SF Float (Float, Float)

integrate' :: c -> SF (c -> c) c
integrate' seed =
    SF $ \f -> (integrate' $ f seed, f seed)

integrate :: c -> (c -> b -> c) -> SF b c
integrate seed (?) =
    SF $ \a ->
        let
            newseed = seed ? a

        in (integrate newseed (?), newseed)

cycleB :: [b] -> SF a b
cycleB list =
    integrate (undefined : cycle list) (flip $ const tail) >>> arr head

front :: SF a Bool -> SF a Bool
front arrow =
    liftA2 (\now before -> now && not before) 
        arrow
        (arrow >>> delayBy False)

switchByFront :: SF a Bool -> SF a Bool
switchByFront arrow =
    front arrow >>> integrate False (/=)

b2i :: Bool -> Int
b2i True  = 1
b2i False = 0