Behaviour.hs

module Behaviour where

import Event

type Behaviour ref a = ref a

stepper :: EventContext clip m ref => a -> Event clip m ref a -> m (Behaviour ref a)
stepper initial event = do
    behaviour <- new initial

    event `attach` write behaviour

    return behaviour

snapshot :: EventContext clip m ref => Event clip m ref b -> Behaviour ref a -> m (Event clip m ref a)
event `snapshot` behaviour = do
    [event] `register` \fire _ -> do
        state <- retrieve behaviour

        fire state

constant :: Ref m ref => a -> m (Behaviour ref a)
constant = new

applyTo 
    :: EventContext clip m ref 
    => Behaviour ref (a -> b) 
    -> Event clip m ref a -> m (Event clip m ref b)

behaviour `applyTo` event = do
    [event] `register` \fire a -> do
        function <- retrieve behaviour

        fire (function a)

Event.hs

{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances      #-}

module Event where

import Control.Monad     (forM_, forM, zipWithM, when)
import Control.Monad.Fix

import Data.IORef
import Data.List ((\\))

data Event clip m ref a = Event
    { subscribers :: ref (clip (a -> m ()))
    , destroy     :: m ()
    }
    
class (Ref m ref, Store clip) => EventContext clip m ref where

class Store s where
    put    :: s a -> a -> (Int, s a)
    remove :: s a -> Int -> s a
    empty  :: s a
    each   :: Monad m => s a -> (a -> m ()) -> m ()
    isNull :: s a -> Bool

class Monad m => Ref m r | m -> r where
    new      ::   a -> m (r a)
    retrieve :: r a -> m a
    modify   :: r a -> (a -> (b, a)) -> m b
      --
      -- second arg must take current state of var and produce some result, 
      --  along with new state
    
ref `write` value = ref `modify` \_ -> ((), value)

-- input produces void event (no subs) with a feeder function
--
input :: EventContext clip m ref => m (Event clip m ref a, a -> m ())
input = do
    subs <- new empty
    
    let 
        fire a = do
            list <- retrieve subs
            
            list `each` \worker -> 
                worker a
        
        event = Event 
            { subscribers = subs
            , destroy     = skip
            }
        
    return (event, fire)
    
-- "register" takes a handler (which will take some "fire" function 
--  and some value) and attaches it to all dependencies
--
-- the handler in the "injected commutation" between output of current event
--  and the input of produced one
--
register 
    :: EventContext clip m ref 
    => [Event clip m ref a] 
    -> ((b -> m ()) -> a -> m ()) 
    -> m (Event clip m ref b)
    
deps `register` perform = do
    (event, fire) <- input
    
    indices <- forM deps (`attach` perform fire)
            
    return event 
        { destroy = do
            subscribers event `modify` \_ -> ((), empty)

            zipWithM removeSubscriber deps indices
            mapM_    tryDestroy       deps
        }
        
attach :: EventContext clip m ref => Event clip m ref a -> (a -> m ()) -> m Int  
attach event sink =
    subscribers event `modify` (`put` sink)

-- "mapE" prepends a transformation "f" to "event"'s values stream, 
--  producing a new, transformed event. Source event remains "untouched".
--
mapE :: EventContext clip m ref => (a -> b) -> Event clip m ref a -> m (Event clip m ref b)
mapE f event = [event] `register` (. f)

transform = flip mapE

fold :: EventContext clip m ref => Event clip m ref a -> (a -> b -> b) -> b -> m (Event clip m ref b)
fold event (+) initial = do
    accum <- new initial

    [event] `register` \fire a -> do
        result <- accum `modify` (andThenReturn . (a + ))
            
        fire result
        
  where
    andThenReturn x = (x, x)
        
select :: EventContext clip m ref => Event clip m ref a -> (a -> Bool) -> m (Event clip m ref a)
select event predicate = 
    [event] `register` \fire a ->
        when (predicate a) $ 
            fire a

once :: (MonadFix m, EventContext clip m ref) => Event clip m ref a -> m (Event clip m ref a)
once event = do
    mfix $ \it -> do
        [event] `register` \fire a -> do
            fire a
            destroy it

switch 
    :: EventContext clip m ref 
    => Event clip m ref a                     -- initial event
    -> Event clip m ref (Event clip m ref a)  -- event on events
    -> m (Event clip m ref a)

switch initial events = do
    (result, feed) <- input

    index  <- initial `attach` feed

    source <- new (initial, index)

    events `attach` \event -> do
        (previous, index) <- retrieve source

        previous `removeSubscriber` index

        index <- event `attach` feed

        source `write` (event, index)

    return result

merge :: EventContext clip m ref => Event clip m ref a -> Event clip m ref a -> m (Event clip m ref a)
merge left right =
    [left, right] `register` ($)

removeSubscriber 
    :: EventContext clip m ref 
    => Event clip m ref a 
    -> Int 
    -> m ()

event `removeSubscriber` index =
    subscribers event `modify` \list -> ((), list `remove` index)
    
tryDestroy :: EventContext clip m ref => Event clip m ref a -> m ()
tryDestroy event = do
    list <- retrieve (subscribers event)
    
    when (isNull list) $
        destroy event
    
skip :: Monad m => m ()
skip = return ()

-------------------------------------------------------------------------------

simpleInput :: IO (Event ListStorage IO IORef a, a -> IO ())
simpleInput = input
    
data ListStorage a = LS [(Int, a)]

instance Store ListStorage where
    LS list `put` item = 
        case list of
            []         -> (0,     LS [(0,     item)])
            (n, _) : _ -> (n + 1, LS ((n + 1, item) : list))

    LS list `remove` index =
        LS $ filter ((index /=) . fst) list

    empty            = LS []
    each   (LS list) = forM_ (map snd list)
    isNull (LS list) = null list

instance Ref IO IORef where
    new      = newIORef
    retrieve = readIORef

    modify r f = do
        x <- readIORef r
        
        let (b, x') = f x
        
        r `writeIORef` x'
        
        return b

instance (Ref m ref, Store clip) => EventContext clip m ref where

-------------------------------------------------------------------------------

addMovement (dx, dy)  (x, y) = (x + dx, y + dy)
outOfSquareWithEdge n (x, y) = abs x > n || abs y > n

charToShift char =
    case char of
        'w' -> ( 0, -1)
        's' -> ( 0,  1)
        'a' -> (-1,  0)
        'd' -> ( 1,  0)
        _   -> ( 0,  0)

main = do
    (chars, feed) <- simpleInput
    
    dirs    <- chars `transform` charToShift 
    pos     <- dirs  `fold`      addMovement $ (0, 0)
    outOf   <- pos   `select`    outOfSquareWithEdge 2
    warning <- once outOf
    
    pos     `attach`        print
    warning `attach` \_ ->
        print "Its dangerous to go alone. Take this o=|===>"
            
    ----
    
    putStrLn "Enter some WASD chars in any order:"
    
    line <- getLine
    
    forM_ line feed
    
    destroy dirs  

testSwitch = do
    (t0, f0) <- simpleInput
    (t1, f1) <- simpleInput
    (t2, f2) <- simpleInput
    (t3, f3) <- simpleInput

    (inputs, fi) <- simpleInput

    switched <- switch t0 inputs

    switched `attach` print

    f0 "a - 0"
    f1 "b - 0"
    f2 "c - 0"
    f3 "d - 0"

    fi t1

    f0 "a - 1"
    f1 "b - 1"
    f2 "c - 1"
    f3 "d - 1"

    fi t2

    f0 "a - 2"
    f1 "b - 2"
    f2 "c - 2"
    f3 "d - 2"

    fi t3

    f0 "a - 3"
    f1 "b - 3"
    f2 "c - 3"
    f3 "d - 3"