LeadFollow.hs

{-# 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))