packages feed

bot (empty) → 0.0

raw patch · 12 files changed

+700/−0 lines, 12 filesdep +Streamdep +arrowsdep +basebuild-type:Customsetup-changed

Dependencies added: Stream, arrows, base

Files

+ Makefile view
@@ -0,0 +1,3 @@+# For special configuration, especially for docs.  Otherwise see README.++include ../my-cabal-make.inc
+ README view
@@ -0,0 +1,13 @@+Bot [1] is an experimental, arrow-friendly foundation for functional+reactive programming.++Please share any comments & suggestions on the discussion (talk) page+there.++You can configure, build, and install all in the usual way with Cabal+commands.+++References:++[1] http://haskell.org/haskellwiki/Bot
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ TODO view
+ bot.cabal view
@@ -0,0 +1,33 @@+Name:                bot+Version:             0.0+Synopsis: 	     bots for functional reactive programming+Category:            reactivity, FRP+Description:+  /Bot/ is an experimental, arrow-friendly foundation for functional+  reactive programming.+  .+  Please see the project wiki page: <http://haskell.org/haskellwiki/Bot>+  .+  The module documentation pages have links to colorized source code and+  to wiki pages where you can read and contribute user comments.  Enjoy!+  .+  &#169; 2008 by Conal Elliott; BSD3 license.+Author:              Conal Elliott +Maintainer:          conal@conal.net+Homepage:            http://haskell.org/haskellwiki/Bot+Package-Url:	     http://darcs.haskell.org/packages/bot+Copyright:           (c) 2007-2008 by Conal Elliott+License:             BSD3+Stability:           experimental+Hs-Source-Dirs:      src+Extensions:          +Build-Depends:       base, arrows, Stream+Exposed-Modules:     +		     Data.Bot.Mutant+		     Data.Bot.Misc+		     Data.Bot.Chatter+		     Data.Bot.LeadFollow+Extra-Source-Files:+		     Examples.Chatter+		     Examples.LeadFollow+ghc-options:         -Wall -O
+ changes.tw view
+ src/Data/Bot/Chatter.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS -Wall -fno-warn-orphans #-}+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving #-}++----------------------------------------------------------------------+-- |+-- Module      :  Data.Bot.Chatter+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Bots who can produce any number of reactions to each input.  See+-- <http://conal.net/blog/tag/bot/> for explanation and @Examples.Chatter@+-- for examples.  Builds on "Data.Bot.Mutant".++----------------------------------------------------------------------++module Data.Bot.Chatter+  ( ChatterBot(..), (:->)+  , justC, filterC, scanlC, accumC+  ) where++import Control.Arrow hiding (pure)+import Control.Applicative+import Data.Monoid+import Data.Maybe++import Data.Bot.Mutant+++-- | Chatter-bots.  Can have any number of outputs per input.  'mappend'+-- appends outputs.+newtype ChatterBot i o =+  Chatter { unChatter :: MutantBot i [o] } deriving Monoid++instance Arrow ChatterBot where+  arr h = Chatter (arr (pure . h))+  Chatter ab >>> Chatter bc = Chatter (ab >>> concatMB bc)+  first (Chatter f) = Chatter $+    first f >>> arr (\ (bs,c) -> [(b,c) | b <- bs])+    -- first f >>> arr (\ (bs,c) -> fmap (flip (,) c) bs)++-- Boilerplate Functor & Applicative for Arrow instance++instance Functor (ChatterBot i) where fmap = (^<<)++instance Applicative (ChatterBot i) where+  pure x        = arr (const x)+  fbot <*> xbot = fbot &&& xbot >>> arr (uncurry ($))++-- TODO: generalize from lists.++-- | Friendly synonym for 'ChatterBot'+type (:->) = ChatterBot+++---- Operations++-- | Each 'Nothing' gets dropped, and the 'Just' constructors are stripped+-- from what's left.+justC :: Maybe a :-> a+justC = Chatter (arr maybeToList)++-- | Pass through whatever satisfies a given predicate +filterC :: (a -> Bool) -> a :-> a+filterC test = f ^>> justC+ where+   f a | test a    = Just a+       | otherwise = Nothing+++-- | Chatter-bot analog to list 'scanl', but without initial @b@+scanlC :: (b -> a -> b) -> b -> (a :-> b)+scanlC = (fmap.fmap) (Chatter . fmap pure) scanlM++-- scanlC f b = Chatter $ pure <$> scanlM f b++-- | Cumulative function applications.  @accumC == scanlC (flip ($))@+accumC :: a -> ((a->a) :-> a)+accumC = scanlC (flip ($))
+ src/Data/Bot/LeadFollow.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Bot.LeadFollow+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Functional reactive programming as an interactive dance of alternating+-- lead and follow.  See <http://conal.net/blog/tag/dance/> for+-- explanation and @Examples.LeadFollow@ for examples.+----------------------------------------------------------------------++module Data.Bot.LeadFollow+  ( -- * Lead and follow -- single-output+    Lead(..), Follow(..), lead, follow+  , scanlF1, scanlL1, accumF1, accumL1+    -- * Lead and follow -- multi-output+  , (:>-)(..), (:->)(..)+  , follow1, lead1, leads, follows+  , splitL, followL, initL+    -- * Filtering+  , justF, filterF+    -- * Accumulation+  , scanlF, scanlL, accumF, accumL+  ) where++import Control.Applicative+import Control.Arrow hiding (pure)+import Data.Maybe (maybeToList)+import Data.Monoid++++{--------------------------------------------------------------------+    Lead and follow -- single-output+--------------------------------------------------------------------}++-- | Respond to inputs, leading to start.+-- +-- Isomorphic to @a -> (b, a -> (b, a -> (b, ...)))@+newtype a  `Lead`  b = Lead   { unLead   :: (b ,  a `Follow` b) }++-- | Respond to inputs, following to start.+-- +-- Isomorphic to @(b, a -> (b, a -> (b, a -> ...)))@+newtype a `Follow` b = Follow { unFollow ::  a -> a  `Lead`  b  }++-- | Start out leading+lead :: b -> a `Follow` b -> a `Lead` b+lead = curry Lead++-- | Start out following+follow :: (a -> a `Lead` b) -> a `Follow` b+follow = Follow++-- instance Functor ((`Follow`) a) where+--   fmap f (Follow h) = Follow (fmap f . h)++-- instance Applicative ((`Follow`) a) where+--   pure b = Follow (const (pure b))+--   Follow h <*> Follow k = Follow $ \ a -> h a <*> k a++-- -- We could also write++instance Functor (Follow a) where+  fmap f (Follow h) = Follow ((fmap.fmap) f h)++instance Applicative (Follow a) where+  pure b = Follow ((pure.pure) b)+  Follow h <*> Follow k = Follow $ liftA2 (<*>) h k++instance Functor (Lead a) where+  fmap f (Lead (b, g)) = Lead (f b, fmap f g)++instance Applicative (Lead a) where+  pure b = Lead (b, pure b)+  Lead (f,pf) <*> Lead (x,px) = Lead (f x, pf <*> px)++-- The four instances above can almost be automatically generated:++-- type Follow a = (->) a :.  Lead a+-- type Lead a =   Id   :*: Follow a++-- Then the Functor and Applicative instances for free.  But we'd still+-- need a loop-breaker.  I don't know how to get GHC to derive instances+-- through newtypes in this case.++-- Adapted from the Automaton Arrow instance+instance Arrow Follow where+  arr f = foll where foll = Follow (\ a -> Lead (f a, foll))+  Follow f >>> Follow g = Follow $+    f >>>+    arr unLead >>>+    first g >>>+    arr (\ (Lead (z, cg), cf) -> Lead (z, cf >>> cg))+  first (Follow f) = Follow $+    first f >>>+    arr (\(Lead (x', c), y) -> Lead ((x', y), first c))++-- Boilerplate Monoid instances for Applicative++instance Monoid b => Monoid (Follow a b) where+  mempty  = pure   mempty+  mappend = liftA2 mappend++instance Monoid b => Monoid (Lead a b) where+  mempty  = pure   mempty+  mappend = liftA2 mappend+++-- | Analog to 'scanl' -- single-output follow (no initial @b@).+scanlF1 :: (b -> a -> b) -> b -> Follow a b+scanlF1 f b = Follow $ \ a -> scanlL1 f (f b a)++-- | Analog to 'scanl' -- single-output lead (with initial @b@).+scanlL1 :: (b -> a -> b) -> b -> Lead a b+scanlL1 f b = Lead (b, scanlF1 f b)++-- | Accumulate function applications -- single-output, no initial @a@.+accumF1 :: a -> Follow (a->a) a+accumF1 = scanlF1 (flip ($))++-- | Accumulate function applications -- single-output, with initial @a@.+accumL1 :: a -> Lead (a->a) a+accumL1 = scanlL1 (flip ($))+++{--------------------------------------------------------------------+    Lead and follow -- mult-output+--------------------------------------------------------------------}++-- Multiple steps+steps :: Monoid os => ([i], i `Follow` os) -> (os, i `Follow` os)+steps (is,bot) =+  first (mconcat.reverse) $ foldl step ([], bot) is+ where+   step :: ([b], a `Follow` b) -> a -> ([b], a `Follow` b)+   step (bs, Follow f) = first (:bs) . unLead . f++concatMB :: Monoid cs => Follow b cs -> Follow [b] cs+concatMB bot = Follow $ \ bs -> Lead $ second concatMB $ steps (bs,bot)+++-- | Start out leading (multi-output)+newtype a :>- b =   Leads { unLeads   ::   Lead a [b] } deriving Monoid++-- | Start out following (multi-output)+newtype a :-> b = Follows { unFollows :: Follow a [b] } deriving Monoid++instance Arrow (:->) where+  arr h = Follows (arr (pure . h))+  Follows ab >>> Follows bc = Follows (ab >>> concatMB bc)+  first (Follows f) = Follows $+    first f >>> arr (\ (bs,c) -> [(b,c) | b <- bs])+    -- first f >>> arr (\ (bs,c) -> fmap (flip (,) c) bs)+++-- The other instances are boilerplate for composition of applicative+-- functors.++instance Functor ((:->) i) where+  fmap f (Follows z) = Follows ((fmap.fmap) f z)++instance Functor ((:>-) i) where+  fmap f (Leads   z) = Leads   ((fmap.fmap) f z)++instance Applicative ((:->) i) where+  pure x                  = Follows ((pure.pure) x)+  Follows f <*> Follows x = Follows (liftA2 (<*>) f x)++instance Applicative ((:>-) i) where+  pure x                  = Leads   ((pure.pure) x)+  Leads   f <*> Leads   x = Leads   (liftA2 (<*>) f x)+++-- | Wrap single-out follow as multi-out+follow1 :: Follow a b -> a :-> b +follow1 = Follows . fmap pure++-- | Wrap single-out lead as multi-out+lead1   :: Lead a b -> a :>- b+lead1   = Leads   . fmap pure+++-- | Start out leading+leads :: [b] -> a :-> b -> a :>- b+leads bs (Follows fol) = Leads (lead bs fol)++-- | Start out following+follows :: (a -> a :>- b) -> a :-> b+follows h = Follows (follow (unLeads . h))+++-- | Split lead into initial outputs and follow+splitL :: a :>- b -> ([b], a :-> b)+splitL (Leads (Lead (bs,f))) = (bs,Follows f)++-- | Initial outputs of a lead+initL :: a :>- b -> [b]+initL = fst . splitL++-- | The follow after initial outputs+followL :: a :>- b -> a :-> b+followL = snd . splitL+++{--------------------------------------------------------------------+    Filtering+--------------------------------------------------------------------}+++justF :: Maybe a :-> a+justF = Follows (arr maybeToList)++filterF :: (a -> Bool) -> a :-> a+filterF p = f ^>> justF+ where+   f a | p a       = Just a+       | otherwise = Nothing+++{--------------------------------------------------------------------+    Accumulation+--------------------------------------------------------------------}++-- | Analog to 'scanl', no initial @b@.+scanlF :: (b -> a -> b) -> b -> a :-> b+scanlF = (fmap.fmap) follow1 scanlF1++-- | Analog to 'scanl', with initial @b@.+scanlL :: (b -> a -> b) -> b -> a :>- b+scanlL = (fmap.fmap) lead1 scanlL1++-- | Accumulate function applications, no initial @a@.+accumF :: a -> (a->a) :-> a+accumF = scanlF (flip ($))++-- | Accumulate function applications, with initial @a@.+accumL :: a -> (a->a) :>- a+accumL = scanlL (flip ($))+
+ src/Data/Bot/Misc.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS -Wall -fno-warn-orphans #-}+{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances+  , GeneralizedNewtypeDeriving+  #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Bot.Misc+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Misc bot alternatives.  See+-- <http://conal.net/blog/posts/functional-reactive-chatter-bots/>.+----------------------------------------------------------------------++module Data.Bot.Misc+  (+   StreamBot, ChoosyBot(..)+  ) where++import Data.Monoid+import Control.Arrow hiding (pure)+import Control.Applicative++import Data.Stream hiding (zip,unzip,map,scanl,tail)++import Control.Arrow.Transformer.Stream++import Data.Bot.Mutant++-- | Function from streams to streams.  Instance of 'Arrow', 'Functor',+-- and 'Applicative' (partially applied for the latter two).+type StreamBot = StreamArrow (->)++deriving instance Monoid o => Monoid (StreamBot i o)+++-- | Bots who can choose whether or not to react to an input.  The+-- 'mappend' operation is left-biased in case of simultaneous reaction.+newtype ChoosyBot i o = Choosy (MutantBot i (First o)) deriving Monoid+++---- Move elsewhere++-- data Stream a = Cons a (Stream a) deriving (Show, Eq)++instance Monoid o => Monoid (Stream o) where+  mempty  = pure   mempty+  mappend = liftA2 mappend+++-- Standard Functor & Applicative instances for arrows.  See WrappedArrow.++instance Arrow (~>) => Functor (StreamArrow (~>) i) where fmap = (^<<)++instance Arrow (~>) => Applicative (StreamArrow (~>) i) where+  pure x        = arr (const x)+  fbot <*> xbot = fbot &&& xbot >>> arr (uncurry ($))
+ src/Data/Bot/Mutant.hs view
@@ -0,0 +1,87 @@+{-# 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 ($))+
+ src/Examples/Chatter.hs view
@@ -0,0 +1,89 @@+{-# 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)+
+ src/Examples/LeadFollow.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}+----------------------------------------------------------------------+-- |+-- Module      :  Examples.LeadFollow+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Examples for "Data.Bot.Bot"+----------------------------------------------------------------------++module Examples.LeadFollow where++import Control.Arrow hiding (pure)+import Control.Applicative+import Data.Monoid++import Data.Bot.LeadFollow+++-- Decode a pair edit+updPair :: Either c d -> (c,d) -> (c,d)+updPair = (first.const) `either` (second.const)++-- updPair (Left  c') (_,d) = (c',d)+-- updPair (Right d') (c,_) = (c,d')++-- Pair edit decoder lead+editPairL :: (c,d) -> Either c d :>- (c,d)+editPairL = leads.pure <*> editPairF++-- editPairL cd = leads [cd] (editPairF cd)++-- Pair edit decoder follow+editPairF :: (c,d) -> Either c d :-> (c,d)+editPairF cd = updPair ^>> accumF cd++-- Product of varying ints+prod :: (Int,Int) -> Either Int Int :>- Int+prod = (fmap.fmap) (uncurry (*)) editPairL+++count :: a :>- Int+count = scanlL (\ b _ -> b+1) 0++flipFlop :: a :>- Bool+flipFlop = scanlL (\ b _ -> not b) False++sum :: Num a => a :>- a+sum = scanlL (+) 0++coundOdd :: Integral a => a :-> Int+coundOdd = filterF odd >>> followL count++upDown :: forall a. (a -> Bool) -> (a -> Bool) -> a :>- Int+upDown isUp isDown = (up `mappend` down) `compFL` accumL 0+ where+   up, down :: a :-> (Int -> Int)+   up   = filterF isUp   >>> replace (+ 1)+   down = filterF isDown >>> replace (subtract 1)++-- Replace inputs with a fixed value+replace :: Arrow (~>) => b -> a ~> b+replace b = arr (const b)++-- Follow/lead composition+compFL :: a:->b -> b:>-c -> a:>-c+fab `compFL` lbc = leads cs0 (fab >>> fbc)+  where (cs0,fbc) = splitL lbc++-- compLF :: a:>-b -> b:->c -> a:>-c+-- lab `compLF` fbc = leads cs0 (fab >>> fbc)+--   where (bs0,fab) = splitL lab+--         (++-- fol >>>> Leads (Lead (cs0,bc)) =+--   leads cs0 $ fol >>> Follows bc++-- Follows fol >>>> Leads (Lead (cs0,bc)) =+--   leads cs0 $ Follows (fol >>> concatMB bc)++-- Follows fol >>>> Leads (Lead (cs0,bc)) =+--   Leads (Lead (cs0, fol >>> concatMB bc))+