> module Part1 where

> import Monad

> infixr 3 ***
> infixr 3 &&&
> infixr 2 +++
> infixr 2 |||
> infixr 1 >>>

> infixr 9 .*.

Notions of computation

> add :: (b -> Int) -> (b -> Int) -> b -> Int
> add f g b = f b + g b

Adding the results of two state transformers

> type StateTrans'1 s b c = (s,b) -> (s,c)

> addST :: StateTrans'1 s b Int -> StateTrans'1 s b Int ->
>		StateTrans'1 s b Int
> addST f g (s,b) = 	let	(s', x) = f (s, b)
>				(s'', y) = g (s', b)
>			in	(s'', x+y)

Backtracking

> type Backtrack'1 b c = b -> [c]

> addBT :: Backtrack'1 b Int -> Backtrack'1 b Int ->
>		Backtrack'1 b Int
> addBT f g b = [x+y | x <- f b, y <- g b]

> addBT'1 f g b =
>	concat (map (\x -> map (\y -> x+y) (g b)) (f b))

Stream processors

> type StreamProc'1 b c = [b] -> [c]

> addSP :: StreamProc'1 b Int -> StreamProc'1 b Int ->
>		StreamProc'1 b Int
> addSP f g bs = map (\(x,y) -> (x+y)) (zip (f bs) (g bs))

The arrow class

> class Arrow a where

>	pure :: (b -> c) -> a b c

>	(>>>) :: a b c -> a c d -> a b d

>	first :: a b c -> a (b,d) (c,d)

There is no need to assume second

> second :: Arrow a => a b c -> a (d,b) (d,c)
> second f = pure swap >>> first f >>> pure swap
>		where	swap ~(x,y) = (y,x)

Some instances

> instance Arrow (->) where
>	pure f = f
>	f >>> g = g . f
>	first f (x,y) = (f x, y)

> newtype StateTrans s b c = ST ((s,b) -> (s,c))

> fetch :: StateTrans s b s
> fetch = ST (\(s,_) -> (s,s))

> store :: StateTrans s s ()
> store = ST (\(_,s) -> (s,()))

> instance Arrow (StateTrans s) where
>	pure f = ST (\(s, b) -> (s, f b))
>	ST f >>> ST g = ST (g . f)
>	first (ST f) = ST (\(s, (b,d)) ->
>		let	(s', c) = f (s, b)
>		in	(s', (c, d)))

Backtracking

> newtype Backtrack b c = BT (b -> [c])

> instance Arrow Backtrack where
>	pure f = BT (\b -> [f b])
>	BT f >>> BT g = BT (\b -> [y | x <- f b, y <- g x])
>	first (BT f) = BT (\(b,d) -> [(c, d) | c <- f b])

Stream processors

> newtype StreamProc b c = SP ([b] -> [c])

> instance Arrow StreamProc where
>	pure f = SP (map f)
>	SP f >>> SP g = SP (g . f)
>	first (SP f) = SP (\bds ->
>		zip (f (map fst bds)) (map snd bds))

> delay :: b -> StreamProc b b
> delay b = SP (b:)

General add combinators

> addA :: Arrow a => a b Int -> a b Int -> a b Int
> addA f g = pure (\b -> (b,b)) >>>
>		first f >>> second g >>> pure (\(x,y) -> x+y)

> addA' :: Arrow a => a b Int -> a b Int -> a b Int
> addA' f g = pure (\b -> (b,b)) >>>
>		second g >>> first f >>> pure (\(x,y) -> x+y)

Derived combinators

> (***) :: Arrow a => a b c -> a b' c' -> a (b,b') (c,c')
> f *** g = first f >>> second g

> (&&&) :: Arrow a => a b c -> a b c' -> a b (c,c')
> f &&& g = pure (\b -> (b,b)) >>> f *** g

> addA'1 f g = f &&& g >>> pure (\(x,y) -> x+y)

Static properties

> data Count a b c = Count Int (a b c)

> instance Arrow a => Arrow (Count a) where
>	pure f = Count 0 (pure f)
>	Count n1 f1 >>> Count n2 f2 =
>		Count (n1+n2) (f1 >>> f2)
>	first (Count n f) = Count n (first f)

Axioms of first

> (.*.) :: (a -> a') -> (b -> b') -> (a,b) -> (a',b')
> (f .*. g) (a,b) = (f a, g b)

Elimination and associativity

> assoc :: ((a,b),c) -> (a,(b,c))
> assoc ((a,b),c) = (a,(b,c))

Output as an arrow

> newtype Writer b c = W (b -> (String, c))

> write :: Show b => Writer b ()
> write = W (\b -> (show b, ()))

> instance Arrow Writer where
>	pure f = W (\b -> ([], f b))
>	W f >>> W g = W (\b ->
>		let	(s1, c) = f b
>			(s2, d) = g c
>		in	(s1++s2, d))
>	first (W f) = W (\(b,d) ->
>		let	(s, c) = f b
>		in	(s, (c,d)))

Map transformers

> newtype MapTrans s b c = MT ((s -> b) -> (s -> c))

> instance Arrow (MapTrans s) where
>	pure f = MT (\h -> f . h)
>	MT f >>> MT g = MT (g . f)
>	first (MT f) = MT (\h s -> (f (fst . h) s, snd (h s)))

Continuation-passing style

> newtype CPS r b c = CPS ((c -> r) -> (b -> r))

> instance Arrow (CPS r) where
>	pure f = CPS (\k -> k . f)
>	CPS f >>> CPS g = CPS (f . g)
>	first (CPS f) = CPS (\k -> \(b,d) -> f (\c -> k (c,d)) b)

Simple automata

> newtype Auto b c = A (b -> (c, Auto b c))

> instance Arrow Auto where
>	pure f = A (\b -> (f b, pure f))
>	A f >>> A g = A (\b ->	let	(c, f') = f b
>					(d, g') = g c
>				in	(d, f' >>> g'))
>	first (A f) = A (\(b,d) ->	let	(c, f') = f b
>					in	((c,d), first f'))

> delay'1 :: b -> Auto b b
> delay'1 b = A (\b' -> (b, delay'1 b'))

Conditionals

> class Arrow a => ArrowChoice a where
>	left :: a b c -> a (Either b d) (Either c d)

> instance ArrowChoice (->) where
>	left f (Left x) = Left (f x)
>	left f (Right y) = Right y

> instance ArrowChoice (StateTrans s) where
>	left (ST f) = ST (\(s,x) -> case x of
>			Left b -> let (s', c) = f (s,b)
>				  in  (s', Left c)
>			Right d -> (s, Right d))

Auxilliary definitions

> right :: ArrowChoice a => a b c -> a (Either d b) (Either d c)
> right f = pure mirror >>> left f >>> pure mirror
>		where	mirror (Left x) = Right x
>			mirror (Right y) = Left y

> (+++) :: ArrowChoice a => a b c -> a b' c' ->
>		a (Either b b') (Either c c')
> f +++ g = left f >>> right g

> (|||) :: ArrowChoice a => a b d -> a c d -> a (Either b c) d
> f ||| g = f +++ g >>> pure untag
>		where	untag (Left x) = x
>			untag (Right y) = y

ArrowChoice instances

> instance ArrowChoice Backtrack where
>	left (BT f) = BT (\x -> case x of
>			Left b -> map Left (f b)
>			Right d -> [Right d])

> instance ArrowChoice a => ArrowChoice (Count a) where
>	left (Count n f) = Count n (left f)

> instance ArrowChoice Auto where
>	left (A f) = A (\x -> case x of
>			Left b ->	let	(c, f') = f b
>					in 	(Left c, left f')
>			Right d -> (Right d, left (A f)))

Next week: arrow notation

> prodA f g =	pure (\(s,(x,y)) -> ((s,x),y)) >>> first f >>>
>		pure (\((s',x'),y) -> ((s',y),x')) >>> first g >>>
>		pure (\((s'',y'),x') -> (s'',(x',y')))

Hyper-functions

> newtype Hyper b c = H (Hyper c b -> c)

> instance Arrow Hyper where
>	pure f = H (\(H k) -> f (k (pure f)))
>	f >>> H g = H (\k -> g (k >>> f))
>	first (H f) = H (\(H k) ->
>		(f (H (\k' -> fst (k (first k')))),
>		 snd (k (first (H f)))))