Mutant.hs

{-# OPTIONS -Wall -fno-warn-orphans #-}
{-# LANGUAGE TypeOperators, TypeSynonymInstances, GeneralizedNewtypeDeriving
  #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.Bot.Mutant
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- An experiment in arrow-based FRP.  See
-- <http://conal.net/blog/tag/bot/> for explanation and
-- @Data.Bot.ChatterBot@ for a more flexible alternative.
----------------------------------------------------------------------

module Data.Bot.Mutant
  (
    MutantBot, steps, concatMB, scanlM, accumM
  ) where

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

import Control.Arrow.Transformer.Automaton


-- | Mutant-bot (Mealy machine).  Instance of 'Arrow', 'Functor', and
-- 'Applicative' (partially applied for the latter two).
-- 
-- Isomorphic to @a -> (b, a -> (b, a -> (b, ...)))@
type MutantBot = Automaton (->)

instance Monoid o => Monoid (MutantBot i o) where
  mempty  = pure   mempty
  mappend = liftA2 mappend

-- | Perform multiple steps, yielding the collected outputs and residual bot.
steps :: ([i], MutantBot i o) -> ([o], MutantBot i o)
steps (is,bot) =
  first reverse $ foldl step ([], bot) is
 where
   step (os, Automaton f) i = first (:os) (f i)

-- | Perform multiple steps, concatenating the results from from each.
concatMB :: MutantBot b [c] -> MutantBot [b] [c]
concatMB bot = Automaton $ \ bs ->
  (concat *** concatMB) (steps (bs,bot))

-- scanl :: (b -> a -> b) -> b -> [a] -> [b]

-- scanl' :: (b -> a -> b) -> b -> [a] -> [b]
-- scanl' _ _ []     = []
-- scanl' f b (a:as) = 
--   let b' = f b a in b' : scanl' f b' as

-- | Mutant-bot analog to list 'scanl', but without initial @b@
scanlM :: (b -> a -> b) -> b -> MutantBot a b
scanlM f b = Automaton $ \ a ->
  let b' = f b a in
    (b', scanlM f b')

-- Or simply
-- scanlM f b = Automaton $ (id &&& scanlM f) . f b

-- | Cumulative function applications.  @accumM == scanlM (flip ($))@
accumM :: a -> MutantBot (a->a) a
accumM = scanlM (flip ($))

-- accum :: a -> [a->a] -> [a]
-- accum _ [] = []
-- accum a (f:fs) = a' : accum a' fs where a' = f a

-- or
-- accum a = tail . scanl (flip ($)) a


---- Move elsewhere

instance Arrow (~>) => Functor (Automaton (~>) i) where fmap = (^<<)

instance Arrow (~>) => Applicative (Automaton (~>) i) where
  pure x        = arr (const x)
  fbot <*> xbot = fbot &&& xbot >>> arr (uncurry ($))