# Solutions to exercises in Programming with Arrows

Since John Hughes wrote his paper, Arrows have become part of the
Haskell standard library. The now-standard version differs
incompatibly from the one described in the paper, in that Arrows have
to be instances of the
Category
typeclass, so these solutions have been updated to run under the
modern, standard definition of Haskell Arrows. The program depends on
a similarly updated `Sim`

module, which can be found here.
The updated Circuits module might also be of interest.
The code has been written with explicit type signatures for top-level
bindings and with an attempt to remove all compiler warnings (although
GHC changes so rapidly that it may well complain about something new
by the time you read this).

## Formalia

The Arrows language pragma enables the pointed Arrow notation in GHC.

```
{-# LANGUAGE Arrows #-}
import Control.Arrow
import Control.Category
import Control.Monad
import Control.Monad.Fix
import Data.Either
```

Function composition and the identity operation are both defined more
generally in `Control.Category`

than in the Prelude, and we hide the
names `and`

and `or`

so we can use them to name circuit components
without getting compiler warnings.

`import Prelude hiding ((.), id, and, or)`

We prefer the definition of `nor`

from the `Sim`

module. While
`Circuits.nor`

works with any Arrow, `Sim.nor`

simulates gate delay,
which is useful when we actually need to use `nor`

.

```
import Circuits hiding (nor)
import Sim
```

## The SF arrow

Copied from the paper, apart from factoring part of the Arrow instance out as the Category instance.

```
newtype SF a b = SF { runSF :: [a] -> [b] }
instance Category SF where
id = SF id
SF f . SF g = SF (f . g)
instance Arrow SF where
= SF (map f)
arr f SF f) = SF (unzip >>> first f >>> uncurry zip)
first (
instance ArrowChoice SF where
SF f) = SF $ \xs -> combine xs (f $ lefts xs)
left (where combine (Left _:xs) (z:zs) = Left z : combine xs zs
Right y:xs) zs = Right y : combine xs zs
combine (= []
combine [] _ = error "Something impossible happened in ArrowChoice SF"
combine _ _
instance ArrowLoop SF where
SF f) = SF $ \as ->
loop (let (bs,cs) = unzip (f (zip as (stream cs))) in bs
where stream ~(x:xs) = x:stream xs
instance ArrowCircuit SF where
= SF (init . (x:)) delay x
```

## Exercise 2.5-1

See Exercise 3.5-3 below for a prettier version using pointed arrow notation. This implementation is merely a desugared version of that one.

```
filterA :: ArrowChoice arr => arr a Bool -> arr [a] [a]
= arr listcase >>> -- Check if list is empty.
filterA p const []) ||| -- Empty, so stop.
(arr (fst >>> p) &&& id -- Check if head of list fulfills predicate.
((arr >>> arr check -- Convert tuple with bool to Left/Right.
>>> ((arr snd >>> filterA p) ||| -- Discard head.
id *** filterA p >>> arr (uncurry (:)))))) -- Keep head.
(arr where listcase [] = Left ()
:xs) = Right (x,xs)
listcase (xFalse, v) = Left v
check (True, v) = Right v check (
```

## Exercise 2.5-2

```
data SP a b = Put b (SP a b) | Get (a -> SP a b)
runSP :: SP a b -> [a] -> [b]
Put b s) as = b:runSP s as
runSP (Get k) (a:as) = runSP (k a) as
runSP (Get _) [] = []
runSP (
instance Category SP where
id = Get $ flip Put id
Put v f . g = Put v (f . g)
Get f . Put v g = f v . g
Get f . Get g = Get $ \x -> Get f . g x
```

Defining first presents a problem, as consuming one element of input does not necessarily produce exactly one element of output. The synchronisation function I have implemented opts to never throw away and never duplicate data, but that implies that the lists of “delayed” I/O may grow with no upper bound. It is not hard to modify the function to follow some other strategy with constant upper bounds on buffering requirements. And of course, the use of lists here is highly inefficient, a proper deque (Data.Sequence, for example) should be used.

```
instance Arrow SP where
= Get $ \x -> Put (f x) (arr f)
arr f = sync f [] []
first f
sync :: SP a c -> [a] -> [b] -> SP (a, b) (c, b)
Put v f) xs (y:ys) = Put (v,y) (sync f xs ys)
sync (Put v f) xs [] = Get $ \(x,y) -> Put (v,y) (sync f (xs++[x]) [])
sync (Get f) (x:xs) ys = sync (f x) xs ys
sync (Get f) [] ys = Get $ \(x,y) -> sync (f x) [] (ys++[y])
sync (
instance ArrowChoice SP where
Put v f) = Put (Left v) (left f)
left (Get f) = Get g
left (where g (Left x) = left $ f x
Right x) = Put (Right x) (left $ Get f) g (
```

We traverse down the stream function to look for an ‘initial’ state, then run the function with that state. This depends critically on lazy evaluation.

```
instance ArrowLoop SP where
= let (f',s) = next f s in f'
loop f where next (Put (v,s) f') _ = (Put v (fst $ next f' s), s)
Get f') s = (Get $ \x -> let (f'',s') = next (f' (x,s')) s
next (in f'', s)
instance ArrowCircuit SP where
= Put v id delay v
```

## Exercise 3.5-1

```
halfAdd :: Arrow arr => arr (Bool,Bool) (Bool, Bool)
= arr $ \(x,y) -> (x&&y, x/=y)
halfAdd
fullAdd :: Arrow arr => arr (Bool, Bool, Bool) (Bool, Bool)
= proc (x,y,c) -> do
fullAdd <- halfAdd -< (x,y)
(c1,s1) <- halfAdd -< (s1, c)
(c2,s2) -< (c1||c2,s2) returnA
```

It is instructive to see the desugared version:

```
fullAddNoSugar :: Arrow arr => arr (Bool, Bool, Bool) (Bool, Bool)
= arr (\(x,y,c) -> ((x,y), c))
fullAddNoSugar >>> first halfAdd
>>> arr (\((c1,s1),c) -> ((s1,c), c1))
>>> first halfAdd
>>> arr (\((c2,s2),c1) -> (c1||c2,s2))
```

The *n*-bit adder takes an argument, `m`

, which is the number of bits
in the inputs, and the adder will fail if the input lists are not each
of length `m`

. The helper function `more`

constructs the `m`

adders,
connecting the carry-out of one to the carry-in of the next. The
carry-in of the first adder is always wired to `False`

, and the
carry-out of the last one is passed out of the entire adder.

```
adder :: Arrow arr => Int -> arr ([Bool], [Bool]) ([Bool],Bool)
= proc (x, y) -> more m -< (x,y,False)
adder m where more 0 = proc (_,_,cout) -> returnA -< ([],cout)
= proc (x':xs,y':ys,cin) -> do
more n <- fullAdd -< (x',y',cin)
(carry,b) <- more (n-1) -< (xs,ys,carry)
(z,cout) -< (b:z, cout) returnA
```

## Exercise 3.5-2

```
bsadd :: ArrowCircuit arr => arr (Bool,Bool) Bool
= proc (x,y) -> do
bsadd <- fullAdd -< (x,y,cin)
rec (cout,b) <- delay False -< cout
cin -< b returnA
```

## Exercise 3.5-3

## (a)

```
filterA' :: ArrowChoice arr => arr a Bool -> arr [a] [a]
= proc xs ->
filterA' p case xs of
-> returnA -< []
[] :xs' -> do c <- p -< x
x<- filterA' p -< xs'
l if c then arr (uncurry (:)) -< (x,l)
else returnA -< l
```

## (b)

I admit that I do not yet have much intuition for command combinators.

```
filterC :: ArrowChoice arr => arr (env,a) Bool -> arr (env,[a]) [a]
= proc (env, xs) ->
filterC p case xs of
-> returnA -< []
[] :xs' -> do c <- p -< (env,x)
x<- filterC p -< (env,xs')
l if c then arr (uncurry (:)) -< (x,l)
else returnA -< l
```

## Exercise 3.5-4

## (a)

```
rowC :: Arrow arr =>
Int -> arr (env,(a,b)) (c,a) -> arr (env,(a,[b])) ([c],a)
0 _ = proc (_,(a,[])) -> returnA -< ([],a)
rowC = proc (env,(a,b:bs)) -> do
rowC n f <- f -< (env,(a,b))
(c,a') <- rowC (n-1) f -< (env, (a',bs))
(cs,a'') -< (c:cs,a'') returnA
```

## (b)

```
counter1bit :: ArrowCircuit arr => arr Bool (Bool,Bool)
= proc b -> do
counter1bit <- delay False -< sum
rec sumin sum) <- halfAdd -< (sumin,b)
(carry,-< (sum, carry) returnA
```

## (c)

```
counternbit :: ArrowCircuit arr => Int -> arr Bool ([Bool],Bool)
= proc bs ->
counternbit n |(rowC n) (\(b,_) -> counter1bit -< b)|) (bs, [0..n-1]) (
```

## (d)

```
counter1bit' :: ArrowCircuit arr => arr (Bool,Bool) (Bool,Bool)
= proc (b,rst) -> do
counter1bit' <- delay False -< sum
rec sumin sum) <- halfAdd -< (not rst && sumin,not rst && b)
(carry,-< (sum, carry)
returnA
counternbit' :: ArrowCircuit arr => Int -> arr (Bool,Bool) ([Bool],Bool)
= proc (bs,rsts) ->
counternbit' n |(rowC n) (\(b,rst) -> counter1bit' -< (b,rst))|) (bs, replicate n rsts) (
```

## Exercise 5.6-1

Note that since Sim is an Arrow, the trivial solution to this exercise
is to simple reuse the previous definitions. Instead, I will define
“realistic” circuits using NOR logic. Since the `nor`

gate simulates
gate delay, this means all derived gates will also have proper delays.

```
and :: Monad m => Sim m (Bool,Bool) Bool
and = proc (a,b) -> do
<- nor -< (a,a)
a' <- nor -< (b,b)
b' <<< nor -< (a',b')
nubA
or :: Monad m => Sim m (Bool,Bool) Bool
or = proc (a,b) -> do
<- nor -< (a,b)
a' <- nor -< (a,b)
b' <<< nor -< (a',b')
nubA
lnot :: Monad m => Sim m Bool Bool
= nubA <<< nor <<< id &&& id
lnot
xor :: Monad m => Sim m (Bool, Bool) Bool
= proc (a,b) -> do
xor <- and -< (a,b)
c <- nor -< (a,b)
d <<< nor -< (c,d)
nubA
halfAddSim :: Monad m => Sim m (Bool,Bool) (Bool,Bool)
= proc (x,y) -> do
halfAddSim <- and -< (x,y)
c <- xor -< (x,y)
s -< (c,s) nubA
```

From here on, the definitions are mostly trivial substitutions of the previous ones, as they are all ultimately built on top of half-adders. In fact, rowC is not changed at all. nubA has been used to remove glitches. Note that the circuits are now highly sensitive to timing issues and should be extended with a clock input to be useful for anything.

```
fullAdd' :: Monad m => Sim m (Bool,Bool,Bool) (Bool,Bool)
= proc (x,y,c) -> do
fullAdd' <- halfAddSim -< (x,y)
(c1,s1) <- halfAddSim -< (s1,c)
(c2,s2) <- or -< (c1,c2)
c' -< (c',s2)
nubA
bsadd' :: MonadFix m => Sim m (Bool,Bool) Bool
= proc (x,y) -> do
bsadd' <- (|afix (\ ~(_,cin) -> do
(b,_) <- initially False nubA -< cin
cin' <- fullAdd' -< (x,y,cin')
(cout,b) -< (b,cout))|)
returnA -< b
returnA
counter1bit'' :: Sim IO (Bool,Bool) (Bool,Bool)
= proc (b,rst) ->
counter1bit'' |afix (\ ~(sumin,_) -> do
(<- initially False nubA -< sumin
sumin' <- and <<< first lnot <<< delay1 0.2 -< (rst,sumin')
x <- and <<< first lnot <<< nubA -< (rst,b)
y <- halfAddSim -< (x,y)
(c,s) -< (s,c))|)
returnA
counternbit'' :: Int -> Sim IO (Bool,Bool) ([Bool],Bool)
= proc (bs,rsts) ->
counternbit'' n |(rowC n) (\(b,rst) -> counter1bit'' -< (b,rst))|) (bs, replicate n rsts) (
```

Note that the following is an orphan instance, since it is defined outside the modules where Sim or ArrowChoice is defined.

```
instance Monad m => ArrowChoice (Sim m) where
Sim f) = sim left'
left (where left' (Left b) = do (c,s) <- f b
return (Left c,leftState b s)
Right d) = return (Right d, untilLeft f)
left' (
untilLeft :: Monad m => (b -> m (c, State m b c))
-> (State m (Either b d) (Either c d))
= Wait infinity undefined $ \e ->
untilLeft f case value e of
Right d -> Ready (Event (time e) (Right d)) (untilLeft f)
Left b -> Lift $ do
<- f b
(c,s) return $ Ready (Event (time e) (Left c)) (leftState b s)
leftState :: Monad m => b -> State m b c -> State m (Either b d) (Either c d)
Ready e s) = Ready (e {value = Left (value e)}) (leftState b s)
leftState b (Lift m) = Lift (liftM (leftState b) m)
leftState b (Wait t s k) = Wait t (leftState b s) $ \e ->
leftState b (case value e of
Left b' -> leftState b' $ k e { value = b' }
Right d -> Ready (Event (time e) (Right d))
$ k e { value = b })
(leftState b
maybeneg :: Monad m => Sim m (Bool,Bool) Bool
= proc (x,neg) -> if neg then returnA -< not x
maybeneg else returnA -< x
```