Chatter.hs

{-# OPTIONS -Wall #-}
{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}
----------------------------------------------------------------------
-- |
-- Module      :  Examples.Bot
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Examples for "Data.Bot.Bot"
----------------------------------------------------------------------

module Examples.Bot where

import Control.Arrow hiding (pure)
import Control.Arrow.Transformer.Automaton
import Control.Applicative
import Data.Monoid

import Data.Bot.Bot


type a :>- b = (b, a :-> b)

chatter :: (a -> a :>- b) -> a :-> b
chatter f = Chatter (Automaton ((pure *** unChatter) . f))


prod :: Int -> Int -> Either Int Int :>- Int
prod a b = (a*b, chatter next)
 where
   next (Left  a') = prod a' b
   next (Right b') = prod a b'


prod2 :: (Int,Int) -> Either Int Int :>- Int
prod2 (a,b) = (a*b, chatter (prod2 . next))
 where
   next (Left  a') = (a',b)
   next (Right b') = (a,b')

-- I think I could refactor more, abstract out the pattern of a
-- reactive pair of values.  Then @fmap (uncurry (*))@ over the pair
-- bot.

updPair :: Either c d -> (c,d) -> (c,d)
updPair (Left  c') (_,d) = (c',d)
updPair (Right d') (c,_) = (c,d')

pairbot :: (c,d) -> Either c d :>- (c,d)
pairbot cd = (cd, updPair ^>> accumC cd)


foo :: (b -> c) -> (b -> (a :>- b)) -> (b -> (a :>- c))
foo f h b = (f *** fmap f) (h b)

prod3 :: (Int,Int) -> Either Int Int :>- Int
prod3 = uncurry (*) `foo` pairbot

-- Probably a bit neater with Lead/Follow types.


-- Simpler accumulations for blog post

count :: a :-> Int
count = scanlC (\ b _ -> b+1) 0

flipFlop :: a :-> Bool
flipFlop = scanlC (\ b _ -> not b) False

sum :: Num a => a :-> a
sum = scanlC (+) 0

coundOdd :: Integral a => a :-> Int
coundOdd = filterC odd >>> count

upDown :: forall a. (a -> Bool) -> (a -> Bool) -> a :-> Int
upDown isUp isDown = (up `mappend` down) >>> accumC 0
 where
   up, down :: a :-> (Int -> Int)
   up   = filterC isUp   >>> replace (+ 1)
   down = filterC isDown >>> replace (subtract 1)

-- Replace inputs with a fixed value
replace :: Arrow (~>) => b -> a ~> b
replace b = arr (const b)