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).


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
  arr f = SF (map f)
  first (SF f) = SF (unzip >>> first f >>> uncurry zip)

instance ArrowChoice SF where
  left (SF f) = SF $ \xs -> combine xs (f $ lefts xs)
    where combine (Left _:xs) (z:zs) = Left z : combine xs zs
          combine (Right y:xs) zs = Right y : combine xs zs
          combine [] _ = []
          combine _  _ = error "Something impossible happened in ArrowChoice SF"

instance ArrowLoop SF where
  loop (SF f) = SF $ \as ->
    let (bs,cs) = unzip (f (zip as (stream cs))) in bs
      where stream ~(x:xs) = x:stream xs

instance ArrowCircuit SF where
  delay x = SF (init . (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]
filterA p = arr listcase >>> -- Check if list is empty.
            (arr (const []) ||| -- Empty, so stop.
             ((arr fst >>> p) &&& id -- Check if head of list fulfills predicate.
              >>> arr check -- Convert tuple with bool to Left/Right.
              >>> ((arr snd >>> filterA p) ||| -- Discard head.
                   (arr id *** filterA p >>> arr (uncurry (:)))))) -- Keep head.
  where listcase [] = Left ()
        listcase (x:xs) = Right (x,xs)
        check (False, v) = Left v
        check (True, v)  = Right v

Exercise 2.5-2

data SP a b = Put b (SP a b) | Get (a -> SP a b)

runSP :: SP a b -> [a] -> [b]
runSP (Put b s) as = b:runSP s as
runSP (Get k) (a:as) = runSP (k a) as
runSP (Get _) [] = []

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
  arr f = Get $ \x -> Put (f x) (arr f)
  first f = sync f [] []

sync :: SP a c -> [a] -> [b] -> SP (a, b) (c, b)
sync (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])

instance ArrowChoice SP where
  left (Put v f) = Put (Left v) (left f)
  left (Get f) = Get g
    where g (Left x)  = left $ f x
          g (Right x) = Put (Right x) (left $ Get f)

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
  loop f = let (f',s) = next f s in f'
    where next (Put (v,s) f') _ = (Put v (fst $ next f' s), s)
          next (Get f')       s = (Get $ \x -> let (f'',s') = next (f' (x,s')) s
                                               in f'', s)

instance ArrowCircuit SP where
  delay v = Put v id

Exercise 3.5-1

halfAdd :: Arrow arr => arr (Bool,Bool) (Bool, Bool)
halfAdd = arr $ \(x,y) -> (x&&y, x/=y)

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

It is instructive to see the desugared version:

fullAddNoSugar :: Arrow arr => arr (Bool, Bool, Bool) (Bool, Bool)
fullAddNoSugar = arr (\(x,y,c) -> ((x,y), c))
                 >>> 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)
adder m = proc (x, y) -> more m -< (x,y,False)
  where more 0 = proc (_,_,cout) -> returnA -< ([],cout)
        more n = proc (x':xs,y':ys,cin) -> do
          (carry,b) <- fullAdd -< (x',y',cin)
          (z,cout) <- more (n-1) -< (xs,ys,carry)
          returnA -< (b:z, cout)

Exercise 3.5-2

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

Exercise 3.5-3


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


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

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

Exercise 3.5-4


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


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


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


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

counternbit' :: ArrowCircuit arr => Int -> arr (Bool,Bool) ([Bool],Bool)
counternbit' n = proc (bs,rsts) ->
  (|(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
        a' <- nor -< (a,a)
        b' <- nor -< (b,b)
        nubA <<< nor -< (a',b')

or :: Monad m => Sim m (Bool,Bool) Bool
or = proc (a,b) -> do
        a' <- nor -< (a,b)
        b' <- nor -< (a,b)
        nubA <<< nor -< (a',b')

lnot :: Monad m => Sim m Bool Bool
lnot = nubA <<< nor <<< id &&& id

xor :: Monad m => Sim m (Bool, Bool) Bool
xor = proc (a,b) -> do
        c <- and -< (a,b)
        d <- nor -< (a,b)
        nubA <<< nor -< (c,d)

halfAddSim :: Monad m => Sim m (Bool,Bool) (Bool,Bool)
halfAddSim = proc (x,y) -> do
             c <- and -< (x,y)
             s <- xor -< (x,y)
             nubA -< (c,s)

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)
fullAdd' = proc (x,y,c) -> do
             (c1,s1) <- halfAddSim -< (x,y)
             (c2,s2) <- halfAddSim -< (s1,c)
             c'      <- or -< (c1,c2)
             nubA -< (c',s2)

bsadd' :: MonadFix m => Sim m (Bool,Bool) Bool
bsadd' = proc (x,y) -> do
           (b,_) <- (|afix (\ ~(_,cin) -> do
                              cin' <- initially False nubA -< cin
                              (cout,b) <- fullAdd' -< (x,y,cin')
                              returnA -< (b,cout))|)
           returnA -< b

counter1bit'' :: Sim IO (Bool,Bool) (Bool,Bool)
counter1bit'' = proc (b,rst) ->
                (|afix (\ ~(sumin,_) -> do
                          sumin' <- initially False nubA -< sumin
                          x <- and <<< first lnot <<< delay1 0.2 -< (rst,sumin')
                          y <- and <<< first lnot <<< nubA -< (rst,b)
                          (c,s) <- halfAddSim -< (x,y)
                          returnA -< (s,c))|)

counternbit'' :: Int -> Sim IO (Bool,Bool) ([Bool],Bool)
counternbit'' n = proc (bs,rsts) ->
  (|(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
  left (Sim f) = sim left'
    where left' (Left b) = do (c,s) <- f b
                              return (Left c,leftState b s)
          left' (Right d) = return (Right d, untilLeft f)

untilLeft :: Monad m => (b -> m (c, State m b c))
          -> (State m (Either b d) (Either c d))
untilLeft f = Wait infinity undefined $ \e ->
              case value e of
                Right d -> Ready (Event (time e) (Right d)) (untilLeft f)
                Left  b -> Lift $ do
                             (c,s) <- f b
                             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)
leftState b (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 ->
                           case value e of
                             Left b' -> leftState b' $ k e { value = b' }
                             Right d -> Ready (Event (time e) (Right d))
                                        (leftState b $ k e { value = b })

maybeneg :: Monad m => Sim m (Bool,Bool) Bool
maybeneg = proc (x,neg) -> if neg then returnA -< not x
                           else returnA -< x