Part 6 of a 6-part series on Breadth-First Traversals

Tags: Haskell

I was looking again at one of my implementations of breadth-first traversals:

```
bfe :: Tree a -> [a]
bfe r = f r b []
where
f (Node x xs) fw bw = x : fw (xs : bw)
b [] = []
b qs = foldl (foldr f) b qs []
```

And I was wondering if I could *fuse* away the intermediate list. On the following line:

The `xs : bw`

is a little annoying, because we *know* it’s going to be consumed eventually by a fold. When that happens, it’s often a good idea to remove the list, and just inline the fold. In other words, if you see the following:

You should replace it with this:

If you try and do that with the above definition, you get something like the following:

```
bfenum :: Tree a -> [a]
bfenum t = f t b b
where
f (Node x xs) fw bw = x : fw (bw . flip (foldr f) xs)
b x = x b
```

The trouble is that the above comes with type errors:

`Cannot construct the infinite type: b ~ (b -> c) -> [a]`

This error shows up occasionally when you try and do heavy church-encoding in Haskell. You get a similar error when trying to encode the Y combinator:

`• Occurs check: cannot construct the infinite type: t0 ~ t0 -> t`

The solution for the y combinator is to use a newtype, where we can catch the recursion at a certain point to help the typechecker.

The trick for our queue is similar:

```
newtype Q a = Q { q :: (Q a -> [a]) -> [a] }
bfenum :: Tree a -> [a]
bfenum t = q (f t b) e
where
f (Node x xs) fw = Q (\bw -> x : q fw (bw . flip (foldr f) xs))
b = fix (Q . flip id)
e = fix (flip q)
```

This is actually equivalent to the continuation monad:

```
newtype Fix f = Fix { unFix :: f (Fix f) }
type Q a = Fix (ContT a [])
q = runContT . unFix
bfenum :: Tree a -> [a]
bfenum t = q (f t b) e
where
f (Node x xs) fw = Fix (mapContT (x:) (flip (foldr f) xs <$> unFix fw))
b = fix (Fix . pure)
e = fix (flip q)
```

There’s a problem though: this algorithm never checks for an end. That’s ok if there isn’t one, mind you. For instance, with the following “unfold” function:

```
infixr 9 #.
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c
(#.) _ = coerce
{-# INLINE (#.) #-}
bfUnfold :: (a -> (b,[a])) -> a -> [b]
bfUnfold f t = g t (fix (Q #. flip id)) (fix (flip q))
where
g b fw bw = x : q fw (bw . flip (foldr ((Q .) #. g)) xs)
where
(x,xs) = f b
```

We can write a decent enumeration of the rationals.

```
-- Stern-Brocot
rats1 :: [Rational]
rats1 = bfUnfold step ((0,1),(1,0))
where
step (lb,rb) = (n % d,[(lb , m),(m , rb)])
where
m@(n,d) = adj lb rb
adj (w,x) (y,z) = (w+y,x+z)
-- Calkin-Wilf
rats2 :: [Rational]
rats2 = bfUnfold step (1,1)
where
step (m,n) = (m % n,[(m,m+n),(n+m,n)])
```

However, if we *do* want to stop at some point, we need a slight change to the queue type.

```
newtype Q a = Q { q :: Maybe (Q a -> [a]) -> [a] }
bfenum :: Tree a -> [a]
bfenum t = q (f t b) e
where
f (Node x xs) fw = Q (\bw -> x : q fw (Just (m bw . flip (foldr f) xs)))
b = fix (Q . maybe [] . flip ($))
e = Nothing
m = fromMaybe (flip q e)
```

We can actually add in a monad to the above unfold without much difficulty.

```
newtype Q m a = Q { q :: Maybe (Q m a -> m [a]) -> m [a] }
bfUnfold :: Monad m => (a -> m (b,[a])) -> a -> m [b]
bfUnfold f t = g t b e
where
g s fw bw = f s >>=
\ ~(x,xs) -> (x :) <$> q fw (Just (m bw . flip (foldr ((Q .) #. g)) xs))
b = fix (Q #. maybe (pure []) . flip ($))
e = Nothing
m = fromMaybe (flip q e)
```

And it passes the torture tests for a linear-time breadth-first unfold from Feuer (2015). It breaks when you try and use it to build a tree, though.

Finally, we can try and make the above code a little more modular, by actually packaging up the queue type as a queue.

```
newtype Q a = Q { q :: Maybe (Q a -> [a]) -> [a] }
newtype Queue a = Queue { runQueue :: Q a -> Q a }
now :: a -> Queue a
now x = Queue (\fw -> Q (\bw -> x : q fw bw))
delay :: Queue a -> Queue a
delay xs = Queue (\fw -> Q (\bw -> q fw (Just (m bw . runQueue xs))))
where
m = fromMaybe (flip q Nothing)
instance Monoid (Queue a) where
mempty = Queue id
mappend (Queue xs) (Queue ys) = Queue (xs . ys)
run :: Queue a -> [a]
run (Queue xs) = q (xs b) Nothing
where
b = fix (Q . maybe [] . flip ($))
bfenum :: Tree a -> [a]
bfenum t = run (f t)
where
f (Node x xs) = now x <> delay (foldMap f xs)
```

At this point, our type is starting to look a lot like the `Phases`

type from Noah Easterly’s tree-traversals package. This is exciting: the `Phases`

type has the ideal interface for level-wise traversals. Unfortunately, it has the wrong time complexity for `<*>`

and so on: my suspicion is that the queue type above here is to `Phases`

as the continuation monad is to the free monad. In other words, we’ll get efficient construction at the expense of no inspection. Unfortunately, I can’t figure out how to turn the above type into an applicative. Maybe in a future post!

Finally, a lot of this is working towards finally understanding Smith (2009) and Allison (2006).

Allison, Lloyd. 2006. “Circular Programs and Self-Referential Structures.” *Software: Practice and Experience* 19 (2) (October 30): 99–109. doi:10.1002/spe.4380190202. http://users.monash.edu/~lloyd/tildeFP/1989SPE/.

Feuer, David. 2015. “Is a lazy, breadth-first monadic rose tree unfold possible?” Question. *Stack Overflow*. https://stackoverflow.com/q/27748526.

Smith, Leon P. 2009. “Lloyd Allison’s Corecursive Queues: Why Continuations Matter.” *The Monad.Reader*, July 29. https://meldingmonads.files.wordpress.com/2009/06/corecqueues.pdf.

Tags: Concatenative, Haskell

This post demonstrates a simple encoding of a (typed) concatenative language in Haskell.

Point-free style is one of the distinctive markers of functional programming languages. Want to sum a list? That’s as easy as:

Now I want to sum every number after adding one to it.

One more step to make this function truly abstract™ and general™: we’ll allow the user to supply their own number to add

And here the trouble begins. The above expression won’t actually type check. In fact, it’ll give a pretty terrible error message:

```
• Non type-variable argument in the constraint: Num [a]
(Use FlexibleContexts to permit this)
• When checking the inferred type
sumThoseThat :: forall a.
(Num [a], Foldable ((->) [a])) =>
a -> [a]
```

I remember as a beginner being confused by similar messages. What’s `FlexibleContexts`

? I had thought that the “point-free style” just meant removing the last variable from an expression if it’s also the last argument:

Why doesn’t it work here?

Well, it doesn’t work because the types don’t line up, but I’m going to try and explain a slightly different perspective on the problem, which is *associativity*.

To make it a little clearer, let’s see what happens when we point-fill the expression:

```
sumAdded n xs = (foldr(+) 0 . (map . (+))) n xs
=> foldr(+) 0 ((map . (+)) n) xs
=> foldr(+) 0 (map ((+) n)) xs
```

Indeed, the problem is the placement of the parentheses. What we want at the end is:

But, no matter. We have to jiggle the arguments around, or we could use something terrible like this:

Is there something, though, that could do this automatically?

We run into a similar problem in Agda. We’re forever having to prove statements like:

There are a couple of ways to get around the issue, and for monoids there’s a rich theory of techniques. I’ll just show one for now, which relies on the *endomorphism* monoid. This monoid is created by partially applying the monoid’s binary operator:

And you can get back to the underlying monoid by applying it to the neutral element:

Here’s the important parts: first, we can lift the underlying operation into the endomorphism:

```
_⊕_ : Endo → Endo → Endo
xs ⊕ ys = λ x → xs (ys x)
⊕-homo : ∀ n m → ⟦ ⟦ n ⇑⟧ ⊕ ⟦ m ⇑⟧ ⇓⟧ ≡ n + m
⊕-homo n m = cong (n +_) (+-identityʳ m)
```

And second, it’s *definitionally* associative.

These are all clues as to how to solve the composition problem in the Haskell code above. We need definitional associativity, somehow. Maybe we can get it from the endomorphism monoid?

You’re probably familiar with Haskell’s state monad:

It can help a lot when you’re threading around fiddly accumulators and so on.

```
nub :: Ord a => [a] -> [a]
nub = go Set.empty
where
go seen [] = []
go seen (x:xs)
| x `Set.member` seen = go seen xs
| otherwise = x : go (Set.insert x seen) xs
```

```
nub :: Ord a => [a] -> [a]
nub = flip evalState Set.empty . go
where
go [] = pure []
go (x:xs) = do
seen <- gets (Set.member x)
if seen
then go xs
else do
modify (Set.insert x)
(x:) <$> go xs
```

Of course, these days state is a transformer:

This lets us stack multiple effects on top of each other: error handling, IO, randomness, even another state monad. In fact, if you *do* stack another state monad on top, you might be surprised by the efficiency of the code it generates:

```
type DoubleState s1 s2 a = StateT s1 (State s2) a
=> s1 -> State s2 (a, s1)
=> s1 -> s2 -> ((a, s1), s2)
```

It’s nothing earth shattering, but it inlines and optimises well. That output is effectively a left-nested list, also.

If we can do one, and we can do two, why not more? Can we generalise the state pattern to an arbitrary number of variables? First we’ll need a generic tuple:

```
infixr 5 :-
data Stack (xs :: [Type]) :: Type where
Nil :: Stack '[]
(:-) :: x -> Stack xs -> Stack (x : xs)
```

Then, the state type.

We can actually clean the definition up a little: instead of a tuple at the other end, why not push it onto the stack.

In fact, let’s make this as polymorphic as possible. We should be able to change the state is we so desire.

And suddenly, our endomorphism type from above shows up again.

We can, of course, get back our original types.

And it comes with all of the instances you might expect:

```
instance Functor (State xs) where
fmap f xs = State (\s -> case runState xs s of
(x :- ys) -> f x :- ys)
instance Applicative (State xs) where
pure x = State (x :-)
fs <*> xs = State (\s -> case runState fs s of
(f :- s') -> case runState xs s' of
(x :- s'') -> f x :- s'')
instance Monad (State xs) where
xs >>= f = State (\s -> case runState xs s of
y :- ys -> runState (f y) ys)
```

But what’s the point? So far we’ve basically just encoded an unnecessarily complicated state transformer. Think back to the stacking of states. Written in the mtl style, the main advantage of stacking monads like that is you can write code like the following:

```
pop :: (MonadState [a] m, MonadError String m) => m a
pop = get >>= \case
[] -> throwError "pop: empty list"
x:xs -> do
put xs
pure x
```

In other words, we don’t care about the rest of `m`

, we just care that it has, somewhere, state for an `[a]`

.

This logic should apply to our stack transformer, as well. If it only cares about the top two variables, it shouldn’t care what the rest of the list is. In types:

And straight away we can write some of the standard combinators:

```
dup :: '[a] :-> '[a,a]
dup (x :- xs) = (x :- x :- xs)
swap :: '[x,y] :-> '[y,x]
swap (x :- y :- xs) = y :- x :- xs
drop :: '[x,y] :-> '[y]
drop (_ :- xs) = xs
infixl 9 !
(f ! g) x = g (f x)
```

You’ll immediately run into trouble if you try to work with some of the more involved combinators, though. Quote should have the following type, for instance:

But GHC complains again:

```
• Illegal polymorphic type: xs :-> ys
GHC doesn't yet support impredicative polymorphism
• In the type signature:
quote :: (xs :-> ys) -> '[] :-> '[xs :-> ys]
```

I won’t go into the detail of this particular error: if you’ve been around the block with Haskell you know that it means “wrap it in a newtype”. If we do *that*, though, we get yet more errors:

```
• Couldn't match type ‘ys ++ zs0’ with ‘ys ++ zs’
Expected type: Stack (xs ++ zs) -> Stack (ys ++ zs)
Actual type: Stack (xs ++ zs0) -> Stack (ys ++ zs0)
NB: ‘++’ is a type function, and may not be injective
```

This injectivity error comes up often. It means that GHC needs to prove that the input to two functions is equal, but it only knows that their outputs are. This is a doubly serious problem for us, as we can’t do type family injectivity on two type variables (in current Haskell). To solve the problem, we need to rely on a weird mishmash of type families and functional dependencies:

```
type family (++) xs ys where
'[] ++ ys = ys
(x : xs) ++ ys = x : (xs ++ ys)
class (xs ++ ys ~ zs) => Conc xs ys zs | xs zs -> ys where
conc :: Stack xs -> Stack ys -> Stack zs
instance Conc '[] ys ys where
conc _ ys = ys
instance Conc xs ys zs => Conc (x : xs) ys (x : zs) where
conc (x :- xs) ys = x :- conc xs ys
infixr 0 :->
type (:->) xs ys = forall zs yszs. Conc ys zs yszs => Stack (xs ++ zs) -> Stack yszs
```

And it does indeed work:

```
pure :: a -> '[] :-> '[a]
pure = (:-)
newtype (:~>) xs ys = Q { d :: xs :-> ys }
quote :: (xs :-> ys) -> '[] :-> '[ xs :~> ys ]
quote x = pure (Q x)
dot :: forall xs ys. ((xs :~> ys) : xs) :-> ys
dot (x :- xs) = d x xs
true :: (xs :~> ys) : (xs :~> ys) : xs :-> ys
true = swap ! drop ! dot
false :: (xs :~> ys) : (xs :~> ys) : xs :-> ys
false = drop ! dot
test :: '[] :-> '[ '[a] :~> '[a,a] ]
test = quote dup
```

Interestingly, these combinators represent the monadic operations on state (`dot`

= `join`

, `pure`

= `pure`

, etc.)

And can we get the nicer composition of the function from the intro? Kind of:

Here are some references for concatenative languages: Okasaki (2002), Purdy (2012), Kerby (2007), Okasaki (2003).

Kerby, Brent. 2007. “The Theory of Concatenative Combinators.” http://tunes.org/\%7Eiepos/joy.html.

Okasaki, Chris. 2002. “Techniques for embedding postfix languages in Haskell.” In *Proceedings of the ACM SIGPLAN workshop on Haskell - Haskell ’02*, 105–113. Pittsburgh, Pennsylvania: ACM Press. doi:10.1145/581690.581699. http://portal.acm.org/citation.cfm?doid=581690.581699.

———. 2003. “THEORETICAL PEARLS: Flattening combinators: Surviving without parentheses.” *Journal of Functional Programming* 13 (4) (July): 815–822. doi:10.1017/S0956796802004483. https://www.cambridge.org/core/journals/journal-of-functional-programming/article/theoretical-pearls/3E99993FE5464986AD94D292FF5EA275.

Purdy, Jon. 2012. “The Big Mud Puddle: Why Concatenative Programming Matters.” *The Big Mud Puddle*. https://evincarofautumn.blogspot.com/2012/02/why-concatenative-programming-matters.html.

Tags: Haskell

This post is a collection of some of the tricks I’ve learned for manipulating lists in Haskell. Each one starts with a puzzle: you should try the puzzle yourself before seeing the solution!

How can you split a list in half, in one pass, without taking its length?

This first one is a relatively well-known trick, but it occasionally comes in handy, so I thought I’d mention it. The naive way is as follows:

But it’s unsatisfying: we have to traverse the list twice, and we’re taking its length (which is almost always a bad idea). Instead, we use the following function:

```
splitHalf :: [a] -> ([a],[a])
splitHalf xs = go xs xs
where
go (y:ys) (_:_:zs) = first (y:) (go ys zs)
go ys _ = ([],ys)
```

The “tortoise and the hare” is the two arguments to `go`

: it traverses the second one twice as fast, so when it hits the end, we know that the first list must be halfway done.

Given two lists,

`xs`

and`ys`

, write a function which zips`xs`

with thereverseof`ys`

(in one pass).

There’s a lovely paper (Danvy and Goldberg 2005) which goes though a number of tricks for how to do certain list manipulations “in reverse”. Their technique is known as “there and back again”. However, I’d like to describe a different way to get to the same technique, using folds.

Whenever I need to do some list manipulation in reverse (i.e., I need the input list to be reversed), I first see if I can rewrite the function as a fold, and then just switch out `foldr`

for `foldl`

.

For our puzzle here, we need to first write `zip`

as a fold:

```
zip :: [a] -> [b] -> [(a,b)]
zip = foldr f b
where
f x k (y:ys) = (x,y) : k ys
f x k [] = []
b _ = []
```

If that looks complex, or difficult to write, don’t worry! There’s a systematic way to get to the above definition from the normal version of `zip`

. First, let’s start with a normal `zip`

:

Then, we need to turn it into a case-tree, where the first branch is on the list we want to fold over. In other words, we want the function to look like this:

To figure out the cases, we factor out the cases in the original function. Since the second clause (`zip xs [] = []`

) is only reachable when `xs /= []`

, it’s effectively a case for the `x:xs`

branch.

```
zip :: [a] -> [b] -> [(a,b)]
zip xs = case xs of
[] -> \_ -> []
x:xs -> \case
[] -> []
y:ys -> (x,y) : zip xs ys
```

Now, we rewrite the different cases to be auxiliary functions:

```
zip :: [a] -> [b] -> [(a,b)]
zip xs = case xs of
[] -> b
x:xs -> f x xs
where
b = \_ -> []
f = \x xs -> \case
[] -> []
y:ys -> (x,y) : zip xs ys
```

And finally, we *refactor* the recursive call to the first case expression.

```
zip :: [a] -> [b] -> [(a,b)]
zip xs = case xs of
[] -> b
x:xs -> f x (zip xs)
where
b = \_ -> []
f = \x xs -> \case
[] -> []
y:ys -> (x,y) : xs ys
```

Then those two auxiliary functions are what you pass to `foldr`

!

So, to reverse it, we simply take wherever we wrote `foldr f b`

, and replace it with `foldl (flip f) b`

:

```
zipRev :: [a] -> [b] -> [(a,b)]
zipRev = foldl (flip f) b
where
f x k (y:ys) = (x,y) : k ys
f x k [] = []
b _ = []
```

Of course, we’re reversing the wrong list here. Fixing that is simple:

```
zipRev :: [a] -> [b] -> [(a,b)]
zipRev = flip (foldl (flip f) b)
where
f y k (x:xs) = (x,y) : k xs
f y k [] = []
b _ = []
```

Rewrite the above function without using continuations.

`zipRev`

, as written above, actually uses *continuation-passing style*. In most languages (including standard ML, which was the one used in Danvy and Goldberg (2005)), this is pretty much equivalent to a direct-style implementation (modulo some performance weirdness). In a lazy language like Haskell, though, continuation-passing style often makes things unnecessarily strict.

Consider the church-encoded pairs:

```
newtype Pair a b
= Pair
{ runPair :: forall c. (a -> b -> c) -> c
}
firstC :: (a -> a') -> Pair a b -> Pair a' b
firstC f p = Pair (\k -> runPair p (k . f))
firstD :: (a -> a') -> (a, b) -> (a', b)
firstD f ~(x,y) = (f x, y)
fstD :: (a, b) -> a
fstD ~(x,y) = x
fstC :: Pair a b -> a
fstC p = runPair p const
>>> fstC (firstC (const ()) undefined)
undefined
>>> fstD (firstD (const ()) undefined)
()
```

So it’s sometimes worth trying to avoid continuations if there is a fast direct-style solution. (alternatively, continuations can give you extra strictness when you *do* want it)

First, I’m going to write a different version of `zipRev`

, which folds on the first list, not the second.

Then, we inline the definition of `foldl`

:

Then, as a hint, we tuple up the two accumulating parameters:

What we can see here is that we have two continuations stacked on top of each other. When this happens, they can often “cancel out”, like so:

And we have our direct-style implementation!

Note 14/05/2019: the “cancel-out” explanation there is a little handwavy, as I’m sure you’ll notice. However, there are a number of excellent explanations on this stackoverflow thread which explain it much better than I ever could. Thanks to Anders Kaseorg, Will Ness, user11228628, and to Joseph Sible (2019) for asking the question.

Detect that a list is a palindrome, in one pass.

We now know a good way to split a list in two, and a good way to zip a list with its reverse. We can *combine* the two to get a program that checks if a list is a palindrome. Here’s a first attempt:

But this is doing *three* passes!

To get around it, we can manually do some fusion. Fusion is a technique where we can spot scenarios like the following:

And translate them into a version without a list:

The trick is making sure that the consumer is written as a fold, and then we just put its `f`

and `b`

in place of the `:`

and `[]`

in the producer.

So, when we inline the definition of `splitHalf`

into `zipRev`

, we get the following:

```
zipRevHalf :: [a] -> [(a,a)]
zipRevHalf xs = snd (go xs xs)
where
go (y:ys) (_:_:zs) = f y (go ys zs)
go (_:ys) [_] = (ys,[])
go ys [] = (ys,[])
f x (y:ys,r) = (ys,(x,y):r)
isPal xs = all (uncurry (==)) (zipRevHalf xs)
```

(adding a special case for odd-length lists)

Finally, the `all (uncurry (==))`

is implemented as a fold also. So we can fuse it with the rest of the definitions:

```
isPal :: Eq a => [a] -> Bool
isPal xs = snd (go xs xs)
where
go (y:ys) (_:_:zs) = f y (go ys zs)
go (_:ys) [_] = (ys,True)
go ys [] = (ys,True)
f x (y:ys,r) = (ys,(x == y) && r)
```

You may have spotted the writer monad over `All`

there. Indeed, we can rewrite it to use the monadic bind:

```
isPal :: Eq a => [a] -> Bool
isPal xs = getAll (fst (go xs xs)) where
go (y:ys) (_:_:zs) = f y =<< go ys zs
go (_:ys) [_] = pure ys
go ys [] = pure ys
f y (z:zs) = (All (y == z), zs)
```

Construct a Braun tree from a list in linear time.

This is also a very well-known trick (Bird 1984), but today I’m going to use it to write a function for constructing Braun trees.

A Braun tree is a peculiar structure. It’s a binary tree, where adjacent branches can differ in size by only 1. When used as an array, it has $\mathcal{O}(\log n)$ lookup times. It’s enumerated like so:

```
┌─7
┌3┤
│ └11
┌1┤
│ │ ┌─9
│ └5┤
│ └13
0┤
│ ┌─8
│ ┌4┤
│ │ └12
└2┤
│ ┌10
└6┤
└14
```

The objective is to construct a tree from a list in linear time, in the order defined above. Okasaki (1997) observed that, from the list:

Each level in the tree is constructed from chucks of powers of two. In other words:

From this, we can write the following function:

```
rows k [] = []
rows k xs = (k , take k xs) : rows (2*k) (drop k xs)
build (k,xs) ts = zipWith3 Node xs ts1 ts2
where
(ts1,ts2) = splitAt k (ts ++ repeat Leaf)
fromList = head . foldr build [Leaf] . rows 1
```

The first place we’ll look to eliminate a pass is the `build`

function. It combines two rows by splitting the second in half, and zipping it with the first.

We don’t need to store the length of the first list, though, as we are only using it to split the second, and we can do *that* at the same time as the zipping.

```
zipUntil :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])
zipUntil _ [] ys = ([],ys)
zipUntil f (x:xs) (y:ys) = first (f x y:) (zipUntil f xs ys)
>>> zipUntil (,) [1,2] "abc"
([(1,'a'),(2,'b')],"c")
```

Using this function in `build`

looks like the following:

That top-level `zipWith`

is *also* unnecessary, though. If we make the program circular, we can produce `ts2`

as we consume it, making the whole thing single-pass.

```
build xs ts = ys
where
(ys,ts2) = zip3Node xs (ts ++ repeat Leaf) ts2
zip3Node (x:xs) (y:ys) ~(z:zs) = first (Node x y z:) (zip3Node xs ys zs)
zip3Node [] ys _ = ([], ys)
```

That `zip3Node`

is a good candidate for rewriting as a fold, also, making the whole thing look like this:

```
rows k [] = []
rows k xs = take k xs : rows (2*k) (drop k xs)
build xs ts = ys
where
(ys,zs) = foldr f b xs ts zs
f x xs (y:ys) ~(z:zs) = first (Node x y z:) (xs ys zs)
b ys _ = ([],ys)
fromList = head . foldr build (repeat Leaf) . rows 1
```

To fuse all of those definitions, we first will need to rewrite `rows`

as a fold:

```
rows xs = uncurry (:) (foldr f b xs 1 2)
where
b _ _ = ([],[])
f x k 0 j = ([], uncurry (:) (f x k j (j*2)))
f x k i j = first (x:) (k (i-1) j)
```

Once we have everything as a fold, the rest of the transformation is pretty mechanical. At the end of it all, we get the following linear-time function for constructing a Braun tree from a list:

```
fromList :: [a] -> Tree a
fromList xs = head (l (foldr f b xs 1 2))
where
b _ _ ys zs = (repeat Leaf, (repeat Leaf, ys))
l k = let (xs, ys) = uncurry k ys in xs
f x k 0 j ys zs = ([], (l (f x k j (j*2)), ys))
f x k i j ~(y:ys) ~(z:zs) = first (Node x y z:) (k (i-1) j ys zs)
```

Bird, R. S. 1984. “Using Circular Programs to Eliminate Multiple Traversals of Data.” *Acta Inf.* 21 (3) (October): 239–250. doi:10.1007/BF00264249. http://dx.doi.org/10.1007/BF00264249.

Danvy, Olivier, and Mayer Goldberg. 2005. “There and Back Again.” *BRICS Report Series* 12 (3). doi:10.7146/brics.v12i3.21869. https://tidsskrift.dk/brics/article/view/21869.

Okasaki, Chris. 1997. “Three Algorithms on Braun Trees.” *Journal of Functional Programming* 7 (6) (November): 661–666. doi:10.1017/S0956796897002876. https://www.eecs.northwestern.edu/~robby/courses/395-495-2013-fall/three-algorithms-on-braun-trees.pdf.

Sible, Joseph. 2019. “How can two continuations cancel each other out?” *Stack Overflow*. https://stackoverflow.com/questions/56122022/how-can-two-continuations-cancel-each-other-out.

Tags: Agda, Probability

Cubical Agda has just come out, and I’ve been playing around with it for a bit. There’s a bunch of info out there on the theory of cubical types, and Homotopy Type Theory more generally (cubical type theory is kind of like an “implementation” of Homotopy type theory), but I wanted to make a post demonstrating cubical Agda in practice, and one of its cool uses from a programming perspective.

I don’t really know! Cubical type theory is quite complex (even for a type theory), and I’m not nearly qualified to properly explain it. In lieu of a proper first-principles explanation, then, I’ll try and give a few examples of how it differs from normal Agda, before moving on to the main example of this post.

{-# OPTIONS --cubical #-} open import ProbabilityModule.Semirings module ProbabilityModule.Monad {s} (rng : Semiring s) where open import Cubical.Core.Everything open import Cubical.Relation.Everything open import Cubical.Foundations.Prelude hiding (_≡⟨_⟩_) renaming (_∙_ to _;_) open import Cubical.HITs.SetTruncation open import ProbabilityModule.Utils

- Extensionality
- One of the big annoyances in standard Agda is that we can’t prove the following:
extensionality : ∀ {f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g

It’s emblematic of a wider problem in Agda: we can’t say “two things are equal if they always behave the same”. Infinite types, for instance (like streams) are often only equal via bisimulation: we can’t translate this into normal equality in standard Agda. Cubical type theory, though, has a different notion of “equality”, which allow a wide variety of things (including bisimulations and extensional proofs) to be translated into a proper equalityextensionality = funExt

- Isomorphisms
- One of these such things we can promote to a “proper equality” is an isomorphism. In the cubical repo this is used to prove things about binary numbers: by proving that there’s an isomorphism between the Peano numbers and binary numbers, they can lift any properties on the Peano numbers to the binary numbers.

So those are two useful examples, but the *most* interesting use I’ve seen so far is the following:

module NormalList where data List {a} (A : Set a) : Set a where [] : List A _∷_ : A → List A → List A

They allow us to add new equations to a type, as well as constructors. To demonstrate what this means, as well as why you’d want it, I’m going to talk about free objects.

Very informally, a free object on some algebra is the *minimal* type which satisfies the laws of the algebra. Lists, for instance, are the free monoid. They satisfy all of the monoid laws ($\bullet$ is `++`

and $\epsilon$ is `[]`

):

$(x \bullet y) \bullet z = x \bullet (y \bullet z)$ $x \bullet \epsilon = x$ $\epsilon \bullet x = x$

But *nothing else*. That means they don’t satisfy any extra laws (like, for example, commutativity), and they don’t have any extra structure they don’t need.

How did we get to the definition of lists from the monoid laws, though? It doesn’t look anything like them. It would be nice if there was some systematic way to construct the corresponding free object given the laws of an algebra. Unfortunately, in normal Agda, this isn’t possible. Consider, for instance, if we added the commutativity law to the algebra: $x \bullet y = y \bullet x$ Not only is it not obvious how we’d write the corresponding free object, it’s actually *not possible* in normal Agda!

This kind of problem comes up a lot: we have a type, and we want it to obey just *one more* equation, but there is no inductive type which does so. Higher Inductive Types solve the problem in quite a straightforward way. So we want lists to satisfy another equation? Well, just add it to the definition!

module OddList where mutual data List {a} (A : Set a) : Set a where [] : List A _∷_ : A → List A → List A comm : ∀ xs ys → xs ++ ys ≡ ys ++ xs postulate _++_ : List A → List A → List ANow, when we write a function that processes lists, Agda will check that the function behaves the same on

`xs ++ ys`

and `ys ++ xs`

. As an example, here’s how you might define the free monoid as a HIT:
data FreeMonoid {a} (A : Set a) : Set a where [_] : A → FreeMonoid A _∙_ : FreeMonoid A → FreeMonoid A → FreeMonoid A ε : FreeMonoid A ∙ε : ∀ x → x ∙ ε ≡ x ε∙ : ∀ x → ε ∙ x ≡ x assoc : ∀ x y z → (x ∙ y) ∙ z ≡ x ∙ (y ∙ z)

It’s quite a satisfying definition, and very easy to see how we got to it from the monoid laws.

Now, when we write functions, we have to prove that those functions themselves also obey the monoid laws. For instance, here’s how we would take the length:module Length where open import ProbabilityModule.Semirings.Nat open Semiring +-*-𝕊 length : FreeMonoid A → ℕ length [ x ] = 1 length (xs ∙ ys) = length xs + length ys length ε = 0 length (∙ε xs i) = +0 (length xs) i length (ε∙ xs i) = 0+ (length xs) i length (assoc xs ys zs i) = +-assoc (length xs) (length ys) (length zs) i

The first three clauses are the actual function: they deal with the three normal constructors of the type. The next three clauses prove that those previous clauses obey the equalities defined on the type.

With the preliminary stuff out of the way, let’s get on to the type I wanted to talk about:

First things first, let’s remember the classic definition of the probability monad:

Definitionally speaking, this doesn’t really represent what we’re talking about. For instance, the following two things express the same distribution, but have different representations:

So it’s the perfect candidate for an extra equality clause like we had above.

Second, in an effort to generalise, we won’t deal specifically with `Rational`

, and instead we’ll use any semiring. After all of that, we get the following definition:

open Semiring rng module Initial where infixr 5 _&_∷_ data 𝒫 (A : Set a) : Set (a ⊔ s) where [] : 𝒫 A _&_∷_ : (p : R) → (x : A) → 𝒫 A → 𝒫 A dup : ∀ p q x xs → p & x ∷ q & x ∷ xs ≡ p + q & x ∷ xs com : ∀ p x q y xs → p & x ∷ q & y ∷ xs ≡ q & y ∷ p & x ∷ xs del : ∀ x xs → 0# & x ∷ xs ≡ xs

The three extra conditions are pretty sensible: the first removes duplicates, the second makes things commutative, and the third removes impossible events.

Let’s get to writing some functions, then:

∫ : (A → R) → 𝒫 A → R ∫ f [] = 0# ∫ f (p & x ∷ xs) = p * f x + ∫ f xs ∫ f (dup p q x xs i) = begin[ i ] p * f x + (q * f x + ∫ f xs) ≡˘⟨ +-assoc (p * f x) (q * f x) (∫ f xs) ⟩ (p * f x + q * f x) + ∫ f xs ≡˘⟨ cong (_+ ∫ f xs) (⟨+⟩* p q (f x)) ⟩ (p + q) * f x + ∫ f xs ∎ ∫ f (com p x q y xs i) = begin[ i ] p * f x + (q * f y + ∫ f xs) ≡˘⟨ +-assoc (p * f x) (q * f y) (∫ f xs) ⟩ p * f x + q * f y + ∫ f xs ≡⟨ cong (_+ ∫ f xs) (+-comm (p * f x) (q * f y)) ⟩ q * f y + p * f x + ∫ f xs ≡⟨ +-assoc (q * f y) (p * f x) (∫ f xs) ⟩ q * f y + (p * f x + ∫ f xs) ∎ ∫ f (del x xs i) = begin[ i ] 0# * f x + ∫ f xs ≡⟨ cong (_+ ∫ f xs) (0* (f x)) ⟩ 0# + ∫ f xs ≡⟨ 0+ (∫ f xs) ⟩ ∫ f xs ∎

This is much more involved than the free monoid function, but the principle is the same: we first write the actual function (on the first three lines), and then we show that the function doesn’t care about the “rewrite rules” we have in the next three clauses.

Before going any further, we will have to amend the definition a little. The problem is that if we tried to prove something about any function on our `𝒫`

type, we’d have to prove equalities *between equalities* as well. I’m sure that this is possible, but it’s very annoying, so I’m going to use a technique I saw in this repository. We add another rule to our type, stating that all equalities on the type are themselves equal. The new definition looks like this:

infixr 5 _&_∷_ data 𝒫 (A : Set a) : Set (a ⊔ s) where [] : 𝒫 A _&_∷_ : (p : R) → (x : A) → 𝒫 A → 𝒫 A dup : ∀ p q x xs → p & x ∷ q & x ∷ xs ≡ p + q & x ∷ xs com : ∀ p x q y xs → p & x ∷ q & y ∷ xs ≡ q & y ∷ p & x ∷ xs del : ∀ x xs → 0# & x ∷ xs ≡ xs trunc : isSet (𝒫 A)

Unfortunately, after adding that case we have to deal with it explicitly in every pattern-match on `𝒫`

. We can get around it by writing an eliminator for the type which deals with it itself. Eliminators are often irritating to work with, though: we give up the nice pattern-matching syntax we get when we program directly. It’s a bit like having to rely on church encoding everywhere.

However, we can get back some pattern-like syntax if we use *copatterns*. Here’s an example of what I mean, for folds on lists:

module ListElim where open NormalList open import ProbabilityModule.Semirings.Nat open Semiring +-*-𝕊 renaming (_+_ to _ℕ+_) record [_↦_] (A : Set a) (B : Set b) : Set (a ⊔ b) where field [_][] : B [_]_∷_ : A → B → B [_]↓ : List A → B [ [] ]↓ = [_][] [ x ∷ xs ]↓ = [_]_∷_ x [ xs ]↓ open [_↦_] sum-alg : [ ℕ ↦ ℕ ] [ sum-alg ][] = 0 [ sum-alg ] x ∷ xs = x ℕ+ xs sum : List ℕ → ℕ sum = [ sum-alg ]↓

For the probability monad, there’s an eliminator for the whole thing, and eliminator for propositional proofs, and a normal eliminator for folding. Their definitions are quite long, but mechanical.

record ⟅_↝_⟆ {a ℓ} (A : Set a) (P : 𝒫 A → Set ℓ) : Set (a ⊔ ℓ ⊔ s) where constructor elim field ⟅_⟆-set : ∀ {xs} → isSet (P xs) ⟅_⟆[] : P [] ⟅_⟆_&_∷_ : ∀ p x xs → P xs → P (p & x ∷ xs) private z = ⟅_⟆[]; f = ⟅_⟆_&_∷_ field ⟅_⟆-dup : (∀ p q x xs pxs → PathP (λ i → P (dup p q x xs i)) (f p x (q & x ∷ xs) (f q x xs pxs)) (f (p + q) x xs pxs)) ⟅_⟆-com : (∀ p x q y xs pxs → PathP (λ i → P (com p x q y xs i)) (f p x (q & y ∷ xs) (f q y xs pxs)) (f q y (p & x ∷ xs) (f p x xs pxs))) ⟅_⟆-del : (∀ x xs pxs → PathP (λ i → P (del x xs i)) (f 0# x xs pxs) pxs) ⟅_⟆⇓ : (xs : 𝒫 A) → P xs ⟅ [] ⟆⇓ = z ⟅ p & x ∷ xs ⟆⇓ = f p x xs ⟅ xs ⟆⇓ ⟅ dup p q x xs i ⟆⇓ = ⟅_⟆-dup p q x xs ⟅ xs ⟆⇓ i ⟅ com p x q y xs i ⟆⇓ = ⟅_⟆-com p x q y xs ⟅ xs ⟆⇓ i ⟅ del x xs i ⟆⇓ = ⟅_⟆-del x xs ⟅ xs ⟆⇓ i ⟅ trunc xs ys p q i j ⟆⇓ = elimSquash₀ (λ xs → ⟅_⟆-set {xs}) (trunc xs ys p q) ⟅ xs ⟆⇓ ⟅ ys ⟆⇓ (cong ⟅_⟆⇓ p) (cong ⟅_⟆⇓ q) i j open ⟅_↝_⟆ public elim-syntax : ∀ {a ℓ} → (A : Set a) → (𝒫 A → Set ℓ) → Set (a ⊔ ℓ ⊔ s) elim-syntax = ⟅_↝_⟆ syntax elim-syntax A (λ xs → Pxs) = [ xs ∈𝒫 A ↝ Pxs ] record ⟦_⇒_⟧ {a ℓ} (A : Set a) (P : 𝒫 A → Set ℓ) : Set (a ⊔ ℓ ⊔ s) where constructor elim-prop field ⟦_⟧-prop : ∀ {xs} → isProp (P xs) ⟦_⟧[] : P [] ⟦_⟧_&_∷_⟨_⟩ : ∀ p x xs → P xs → P (p & x ∷ xs) private z = ⟦_⟧[]; f = ⟦_⟧_&_∷_⟨_⟩ ⟦_⟧⇑ = elim (isProp→isSet ⟦_⟧-prop) z f (λ p q x xs pxs → toPathP (⟦_⟧-prop (transp (λ i → P (dup p q x xs i)) i0 (f p x (q & x ∷ xs) (f q x xs pxs))) (f (p + q) x xs pxs) )) (λ p x q y xs pxs → toPathP (⟦_⟧-prop (transp (λ i → P (com p x q y xs i)) i0 (f p x (q & y ∷ xs) (f q y xs pxs))) (f q y (p & x ∷ xs) (f p x xs pxs)))) λ x xs pxs → toPathP (⟦_⟧-prop (transp (λ i → P (del x xs i)) i0 ((f 0# x xs pxs))) pxs) ⟦_⟧⇓ = ⟅ ⟦_⟧⇑ ⟆⇓ open ⟦_⇒_⟧ public elim-prop-syntax : ∀ {a ℓ} → (A : Set a) → (𝒫 A → Set ℓ) → Set (a ⊔ ℓ ⊔ s) elim-prop-syntax = ⟦_⇒_⟧ syntax elim-prop-syntax A (λ xs → Pxs) = ⟦ xs ∈𝒫 A ⇒ Pxs ⟧ record [_↦_] {a b} (A : Set a) (B : Set b) : Set (a ⊔ b ⊔ s) where constructor rec field [_]-set : isSet B [_]_&_∷_ : R → A → B → B [_][] : B private f = [_]_&_∷_; z = [_][] field [_]-dup : ∀ p q x xs → f p x (f q x xs) ≡ f (p + q) x xs [_]-com : ∀ p x q y xs → f p x (f q y xs) ≡ f q y (f p x xs) [_]-del : ∀ x xs → f 0# x xs ≡ xs [_]⇑ = elim [_]-set z (λ p x _ xs → f p x xs) (λ p q x xs → [_]-dup p q x) (λ p x q y xs → [_]-com p x q y) (λ x xs → [_]-del x) [_]↓ = ⟅ [_]⇑ ⟆⇓ open [_↦_] public

Here’s one in action, to define `map`

:

map : (A → B) → 𝒫 A → 𝒫 B map = λ f → [ map′ f ]↓ module Map where map′ : (A → B) → [ A ↦ 𝒫 B ] [ map′ f ] p & x ∷ xs = p & f x ∷ xs [ map′ f ][] = [] [ map′ f ]-set = trunc [ map′ f ]-dup p q x xs = dup p q (f x) xs [ map′ f ]-com p x q y xs = com p (f x) q (f y) xs [ map′ f ]-del x xs = del (f x) xs

And here’s how we’d define union, and then prove that it’s associative:

infixr 5 _∪_ _∪_ : 𝒫 A → 𝒫 A → 𝒫 A _∪_ = λ xs ys → [ union ys ]↓ xs module Union where union : 𝒫 A → [ A ↦ 𝒫 A ] [ union ys ]-set = trunc [ union ys ] p & x ∷ xs = p & x ∷ xs [ union ys ][] = ys [ union ys ]-dup = dup [ union ys ]-com = com [ union ys ]-del = del ∪-assoc : (xs ys zs : 𝒫 A) → xs ∪ (ys ∪ zs) ≡ (xs ∪ ys) ∪ zs ∪-assoc = λ xs ys zs → ⟦ ∪-assoc′ ys zs ⟧⇓ xs module UAssoc where ∪-assoc′ : ∀ ys zs → ⟦ xs ∈𝒫 A ⇒ xs ∪ (ys ∪ zs) ≡ (xs ∪ ys) ∪ zs ⟧ ⟦ ∪-assoc′ ys zs ⟧-prop = trunc _ _ ⟦ ∪-assoc′ ys zs ⟧[] = refl ⟦ ∪-assoc′ ys zs ⟧ p & x ∷ xs ⟨ P ⟩ = cong (p & x ∷_) P

There’s a lot more stuff here that I won’t bore you with.

infixl 7 _⋊_ _⋊_ : R → 𝒫 A → 𝒫 A _⋊_ = λ p → [ p ⋊′ ]↓ module Cond where _⋊′ : R → [ A ↦ 𝒫 A ] [ p ⋊′ ]-set = trunc [ p ⋊′ ][] = [] [ p ⋊′ ] q & x ∷ xs = p * q & x ∷ xs [ p ⋊′ ]-com q x r y xs = com (p * q) x (p * r) y xs [ p ⋊′ ]-dup q r x xs = p * q & x ∷ p * r & x ∷ xs ≡⟨ dup (p * q) (p * r) x xs ⟩ p * q + p * r & x ∷ xs ≡˘⟨ cong (_& x ∷ xs) (*⟨+⟩ p q r) ⟩ p * (q + r) & x ∷ xs ∎ [ p ⋊′ ]-del x xs = p * 0# & x ∷ xs ≡⟨ cong (_& x ∷ xs) (*0 p) ⟩ 0# & x ∷ xs ≡⟨ del x xs ⟩ xs ∎ ∫ : (A → R) → 𝒫 A → R ∫ = λ f → [ ∫′ f ]↓ module Expect where ∫′ : (A → R) → [ A ↦ R ] [ ∫′ f ]-set = sIsSet [ ∫′ f ] p & x ∷ xs = p * f x + xs [ ∫′ f ][] = 0# [ ∫′ f ]-dup p q x xs = p * f x + (q * f x + xs) ≡˘⟨ +-assoc (p * f x) (q * f x) xs ⟩ (p * f x + q * f x) + xs ≡˘⟨ cong (_+ xs) (⟨+⟩* p q (f x)) ⟩ (p + q) * f x + xs ∎ [ ∫′ f ]-com p x q y xs = p * f x + (q * f y + xs) ≡˘⟨ +-assoc (p * f x) (q * f y) (xs) ⟩ p * f x + q * f y + xs ≡⟨ cong (_+ xs) (+-comm (p * f x) (q * f y)) ⟩ q * f y + p * f x + xs ≡⟨ +-assoc (q * f y) (p * f x) (xs) ⟩ q * f y + (p * f x + xs) ∎ [ ∫′ f ]-del x xs = 0# * f x + xs ≡⟨ cong (_+ xs) (0* (f x)) ⟩ 0# + xs ≡⟨ 0+ (xs) ⟩ xs ∎ syntax ∫ (λ x → e) = ∫ e 𝑑 x pure : A → 𝒫 A pure x = 1# & x ∷ [] ∪-cons : ∀ p (x : A) xs ys → xs ∪ p & x ∷ ys ≡ p & x ∷ xs ∪ ys ∪-cons = λ p x xs ys → ⟦ ∪-cons′ p x ys ⟧⇓ xs module UCons where ∪-cons′ : ∀ p x ys → ⟦ xs ∈𝒫 A ⇒ xs ∪ p & x ∷ ys ≡ p & x ∷ xs ∪ ys ⟧ ⟦ ∪-cons′ p x ys ⟧-prop = trunc _ _ ⟦ ∪-cons′ p x ys ⟧[] = refl ⟦ ∪-cons′ p x ys ⟧ r & y ∷ xs ⟨ P ⟩ = cong (r & y ∷_) P ; com r y p x (xs ∪ ys) ⋊-distribʳ : ∀ p q → (xs : 𝒫 A) → p ⋊ xs ∪ q ⋊ xs ≡ (p + q) ⋊ xs ⋊-distribʳ = λ p q → ⟦ ⋊-distribʳ′ p q ⟧⇓ module JDistrib where ⋊-distribʳ′ : ∀ p q → ⟦ xs ∈𝒫 A ⇒ p ⋊ xs ∪ q ⋊ xs ≡ (p + q) ⋊ xs ⟧ ⟦ ⋊-distribʳ′ p q ⟧-prop = trunc _ _ ⟦ ⋊-distribʳ′ p q ⟧[] = refl ⟦ ⋊-distribʳ′ p q ⟧ r & x ∷ xs ⟨ P ⟩ = p ⋊ (r & x ∷ xs) ∪ q ⋊ (r & x ∷ xs) ≡⟨ ∪-cons (q * r) x (p ⋊ (r & x ∷ xs)) (q ⋊ xs) ⟩ q * r & x ∷ p ⋊ (r & x ∷ xs) ∪ q ⋊ xs ≡⟨ cong (_∪ q ⋊ xs) (dup (q * r) (p * r) x (p ⋊ xs)) ⟩ q * r + p * r & x ∷ p ⋊ xs ∪ q ⋊ xs ≡˘⟨ cong (_& x ∷ (p ⋊ xs ∪ q ⋊ xs)) (⟨+⟩* q p r) ⟩ (q + p) * r & x ∷ p ⋊ xs ∪ q ⋊ xs ≡⟨ cong ((q + p) * r & x ∷_) P ⟩ (q + p) * r & x ∷ (p + q) ⋊ xs ≡⟨ cong (λ pq → pq * r & x ∷ (p + q) ⋊ xs) (+-comm q p) ⟩ (p + q) * r & x ∷ (p + q) ⋊ xs ≡⟨⟩ _⋊_ (p + q) (r & x ∷ xs) ∎ ⋊-distribˡ : ∀ p → (xs ys : 𝒫 A) → p ⋊ xs ∪ p ⋊ ys ≡ p ⋊ (xs ∪ ys) ⋊-distribˡ = λ p xs ys → ⟦ ⋊-distribˡ′ p ys ⟧⇓ xs module JDistribL where ⋊-distribˡ′ : ∀ p ys → ⟦ xs ∈𝒫 A ⇒ p ⋊ xs ∪ p ⋊ ys ≡ p ⋊ (xs ∪ ys) ⟧ ⟦ ⋊-distribˡ′ p ys ⟧-prop = trunc _ _ ⟦ ⋊-distribˡ′ p ys ⟧[] = refl ⟦ ⋊-distribˡ′ p ys ⟧ q & x ∷ xs ⟨ P ⟩ = p ⋊ (q & x ∷ xs) ∪ p ⋊ ys ≡⟨⟩ p * q & x ∷ p ⋊ xs ∪ p ⋊ ys ≡⟨ cong (p * q & x ∷_) P ⟩ p * q & x ∷ p ⋊ (xs ∪ ys) ≡⟨⟩ p ⋊ ((q & x ∷ xs) ∪ ys) ∎ ∪-idʳ : (xs : 𝒫 A) → xs ∪ [] ≡ xs ∪-idʳ = ⟦ ∪-idʳ′ ⟧⇓ module UIdR where ∪-idʳ′ : ⟦ xs ∈𝒫 A ⇒ xs ∪ [] ≡ xs ⟧ ⟦ ∪-idʳ′ ⟧-prop = trunc _ _ ⟦ ∪-idʳ′ ⟧[] = refl ⟦ ∪-idʳ′ ⟧ p & x ∷ xs ⟨ P ⟩ = cong (p & x ∷_) P ∪-comm : (xs ys : 𝒫 A) → xs ∪ ys ≡ ys ∪ xs ∪-comm = λ xs ys → ⟦ ∪-comm′ ys ⟧⇓ xs module UComm where ∪-comm′ : ∀ ys → ⟦ xs ∈𝒫 A ⇒ xs ∪ ys ≡ ys ∪ xs ⟧ ⟦ ∪-comm′ ys ⟧-prop = trunc _ _ ⟦ ∪-comm′ ys ⟧[] = sym (∪-idʳ ys) ⟦ ∪-comm′ ys ⟧ p & x ∷ xs ⟨ P ⟩ = cong (p & x ∷_) P ; sym (∪-cons p x ys xs) 0⋊ : (xs : 𝒫 A) → 0# ⋊ xs ≡ [] 0⋊ = ⟦ 0⋊′ ⟧⇓ module ZeroJ where 0⋊′ : ⟦ xs ∈𝒫 A ⇒ 0# ⋊ xs ≡ [] ⟧ ⟦ 0⋊′ ⟧-prop = trunc _ _ ⟦ 0⋊′ ⟧[] = refl ⟦ 0⋊′ ⟧ p & x ∷ xs ⟨ P ⟩ = 0# ⋊ (p & x ∷ xs) ≡⟨⟩ 0# * p & x ∷ 0# ⋊ xs ≡⟨ cong (_& x ∷ 0# ⋊ xs) (0* p) ⟩ 0# & x ∷ 0# ⋊ xs ≡⟨ del x (0# ⋊ xs) ⟩ 0# ⋊ xs ≡⟨ P ⟩ [] ∎

However, I *can* demonstrate the monadic bind:

_>>=_ : 𝒫 A → (A → 𝒫 B) → 𝒫 B xs >>= f = [ f =<< ]↓ xs module Bind where _=<< : (A → 𝒫 B) → [ A ↦ 𝒫 B ] [ f =<< ] p & x ∷ xs = p ⋊ (f x) ∪ xs [ f =<< ][] = [] [ f =<< ]-set = trunc [ f =<< ]-del x xs = cong (_∪ xs) (0⋊ (f x)) [ f =<< ]-dup p q x xs = p ⋊ (f x) ∪ q ⋊ (f x) ∪ xs ≡⟨ ∪-assoc (p ⋊ f x) (q ⋊ f x) xs ⟩ (p ⋊ (f x) ∪ q ⋊ (f x)) ∪ xs ≡⟨ cong (_∪ xs) (⋊-distribʳ p q (f x) ) ⟩ _⋊_ (p + q) (f x) ∪ xs ∎ [ f =<< ]-com p x q y xs = p ⋊ (f x) ∪ q ⋊ (f y) ∪ xs ≡⟨ ∪-assoc (p ⋊ f x) (q ⋊ f y) xs ⟩ (p ⋊ (f x) ∪ q ⋊ (f y)) ∪ xs ≡⟨ cong (_∪ xs) (∪-comm (p ⋊ f x) (q ⋊ f y)) ⟩ (q ⋊ (f y) ∪ p ⋊ (f x)) ∪ xs ≡˘⟨ ∪-assoc (q ⋊ f y) (p ⋊ f x) xs ⟩ q ⋊ (f y) ∪ p ⋊ (f x) ∪ xs ∎

And we can prove the monad laws, also:

1⋊ : (xs : 𝒫 A) → 1# ⋊ xs ≡ xs 1⋊ = ⟦ 1⋊′ ⟧⇓ module OneJoin where 1⋊′ : ⟦ xs ∈𝒫 A ⇒ 1# ⋊ xs ≡ xs ⟧ ⟦ 1⋊′ ⟧-prop = trunc _ _ ⟦ 1⋊′ ⟧[] = refl ⟦ 1⋊′ ⟧ p & x ∷ xs ⟨ P ⟩ = 1# ⋊ (p & x ∷ xs) ≡⟨⟩ 1# * p & x ∷ 1# ⋊ xs ≡⟨ cong (_& x ∷ 1# ⋊ xs) (1* p) ⟩ p & x ∷ 1# ⋊ xs ≡⟨ cong (p & x ∷_) P ⟩ p & x ∷ xs ∎ >>=-distrib : (xs ys : 𝒫 A) (g : A → 𝒫 B) → (xs ∪ ys) >>= g ≡ (xs >>= g) ∪ (ys >>= g) >>=-distrib = λ xs ys g → ⟦ >>=-distrib′ ys g ⟧⇓ xs module BindDistrib where >>=-distrib′ : (ys : 𝒫 A) (g : A → 𝒫 B) → ⟦ xs ∈𝒫 A ⇒ ((xs ∪ ys) >>= g) ≡ (xs >>= g) ∪ (ys >>= g) ⟧ ⟦ >>=-distrib′ ys g ⟧-prop = trunc _ _ ⟦ >>=-distrib′ ys g ⟧[] = refl ⟦ >>=-distrib′ ys g ⟧ p & x ∷ xs ⟨ P ⟩ = (((p & x ∷ xs) ∪ ys) >>= g) ≡⟨⟩ (p & x ∷ xs ∪ ys) >>= g ≡⟨⟩ p ⋊ g x ∪ ((xs ∪ ys) >>= g) ≡⟨ cong (p ⋊ g x ∪_) P ⟩ p ⋊ g x ∪ ((xs >>= g) ∪ (ys >>= g)) ≡⟨ ∪-assoc (p ⋊ g x) (xs >>= g) (ys >>= g) ⟩ (p ⋊ g x ∪ (xs >>= g)) ∪ (ys >>= g) ≡⟨⟩ ((p & x ∷ xs) >>= g) ∪ (ys >>= g) ∎ *-assoc-⋊ : ∀ p q (xs : 𝒫 A) → (p * q) ⋊ xs ≡ p ⋊ (q ⋊ xs) *-assoc-⋊ = λ p q → ⟦ *-assoc-⋊′ p q ⟧⇓ module MAssocJ where *-assoc-⋊′ : ∀ p q → ⟦ xs ∈𝒫 A ⇒ (p * q) ⋊ xs ≡ p ⋊ (q ⋊ xs) ⟧ ⟦ *-assoc-⋊′ p q ⟧-prop = trunc _ _ ⟦ *-assoc-⋊′ p q ⟧[] = refl ⟦ *-assoc-⋊′ p q ⟧ r & x ∷ xs ⟨ P ⟩ = p * q ⋊ (r & x ∷ xs) ≡⟨⟩ p * q * r & x ∷ (p * q ⋊ xs) ≡⟨ cong (_& x ∷ (p * q ⋊ xs)) (*-assoc p q r) ⟩ p * (q * r) & x ∷ (p * q ⋊ xs) ≡⟨ cong (p * (q * r) & x ∷_) P ⟩ p * (q * r) & x ∷ (p ⋊ (q ⋊ xs)) ≡⟨⟩ p ⋊ (q ⋊ (r & x ∷ xs)) ∎ ⋊-assoc->>= : ∀ p (xs : 𝒫 A) (f : A → 𝒫 B) → (p ⋊ xs) >>= f ≡ p ⋊ (xs >>= f) ⋊-assoc->>= = λ p xs f → ⟦ ⋊-assoc->>=′ p f ⟧⇓ xs module JDistribB where ⋊-assoc->>=′ : ∀ p (f : A → 𝒫 B) → ⟦ xs ∈𝒫 A ⇒ (p ⋊ xs) >>= f ≡ p ⋊ (xs >>= f) ⟧ ⟦ ⋊-assoc->>=′ p f ⟧-prop = trunc _ _ ⟦ ⋊-assoc->>=′ p f ⟧[] = refl ⟦ ⋊-assoc->>=′ p f ⟧ q & x ∷ xs ⟨ P ⟩ = (p ⋊ (q & x ∷ xs)) >>= f ≡⟨⟩ (p * q & x ∷ p ⋊ xs) >>= f ≡⟨⟩ ((p * q) ⋊ f x) ∪ ((p ⋊ xs) >>= f) ≡⟨ cong (((p * q) ⋊ f x) ∪_) P ⟩ ((p * q) ⋊ f x) ∪ (p ⋊ (xs >>= f)) ≡⟨ cong (_∪ (p ⋊ (xs >>= f))) (*-assoc-⋊ p q (f x)) ⟩ (p ⋊ (q ⋊ f x)) ∪ (p ⋊ (xs >>= f)) ≡⟨ ⋊-distribˡ p (q ⋊ f x) (xs >>= f) ⟩ p ⋊ ((q & x ∷ xs) >>= f) ∎ >>=-idˡ : (x : A) → (f : A → 𝒫 B) → (pure x >>= f) ≡ f x >>=-idˡ x f = pure x >>= f ≡⟨⟩ (1# & x ∷ []) >>= f ≡⟨⟩ 1# ⋊ f x ∪ [] >>= f ≡⟨⟩ 1# ⋊ f x ∪ [] ≡⟨ ∪-idʳ (1# ⋊ f x) ⟩ 1# ⋊ f x ≡⟨ 1⋊ (f x) ⟩ f x ∎ >>=-idʳ : (xs : 𝒫 A) → xs >>= pure ≡ xs >>=-idʳ = ⟦ >>=-idʳ′ ⟧⇓ module Law1 where >>=-idʳ′ : ⟦ xs ∈𝒫 A ⇒ xs >>= pure ≡ xs ⟧ ⟦ >>=-idʳ′ ⟧-prop = trunc _ _ ⟦ >>=-idʳ′ ⟧[] = refl ⟦ >>=-idʳ′ ⟧ p & x ∷ xs ⟨ P ⟩ = ((p & x ∷ xs) >>= pure) ≡⟨⟩ p ⋊ (pure x) ∪ (xs >>= pure) ≡⟨⟩ p ⋊ (1# & x ∷ []) ∪ (xs >>= pure) ≡⟨⟩ p * 1# & x ∷ [] ∪ (xs >>= pure) ≡⟨⟩ p * 1# & x ∷ (xs >>= pure) ≡⟨ cong (_& x ∷ (xs >>= pure)) (*1 p) ⟩ p & x ∷ xs >>= pure ≡⟨ cong (p & x ∷_) P ⟩ p & x ∷ xs ∎ >>=-assoc : (xs : 𝒫 A) → (f : A → 𝒫 B) → (g : B → 𝒫 C) → ((xs >>= f) >>= g) ≡ xs >>= (λ x → f x >>= g) >>=-assoc = λ xs f g → ⟦ >>=-assoc′ f g ⟧⇓ xs module Law3 where >>=-assoc′ : (f : A → 𝒫 B) → (g : B → 𝒫 C) → ⟦ xs ∈𝒫 A ⇒ ((xs >>= f) >>= g) ≡ xs >>= (λ x → f x >>= g) ⟧ ⟦ >>=-assoc′ f g ⟧-prop = trunc _ _ ⟦ >>=-assoc′ f g ⟧[] = refl ⟦ >>=-assoc′ f g ⟧ p & x ∷ xs ⟨ P ⟩ = (((p & x ∷ xs) >>= f) >>= g) ≡⟨⟩ ((p ⋊ f x ∪ (xs >>= f)) >>= g) ≡⟨ >>=-distrib (p ⋊ f x) (xs >>= f) g ⟩ ((p ⋊ f x) >>= g) ∪ ((xs >>= f) >>= g) ≡⟨ cong ((p ⋊ f x) >>= g ∪_) P ⟩ ((p ⋊ f x) >>= g) ∪ (xs >>= (λ y → f y >>= g)) ≡⟨ cong (_∪ (xs >>= (λ y → f y >>= g))) (⋊-assoc->>= p (f x) g) ⟩ p ⋊ (f x >>= g) ∪ (xs >>= (λ y → f y >>= g)) ≡⟨⟩ ((p & x ∷ xs) >>= (λ y → f y >>= g)) ∎

I’ve really enjoyed working with cubical Agda so far, and the proofs above were a pleasure to write. I think I can use the above definition to get a workable differential privacy monad, also.

Anyway, all the code is available here.

]]>A naive—and wrong—way to shuffle a list is to assign each element in the list a random number, and then sort it. It might not be immediately obvious why: Kiselyov (2002) has a good explanation as to the problem. One way to think about it is like this: choosing $n$ random numbers each in the range $[0,n)$ has $n^n$ possible outcomes, whereas there are $n!$ permutations. Since these don’t necessarily divide evenly into each other, you’re going to have some bias.

The first part of the fix is to figure out a way to get some random data that has only $n!$ possible values. The trick here will be to mimic the structure of a factorial itself: taking $n = 5$, the previous technique would have yielded:

$5 \times 5 \times 5 \times 5 \times 5 = 5^5$

possible values. But we want:

$5 \times 4 \times 3 \times 2 \times 1 = 5!$

The solution is simple, then! Simply decrement the range by one for each position in the output list. In Haskell:

As an aside, what we’ve done here is constructed a list of digits in the factorial number system.

Unfortunately, while we’ve figured out a way to get properly distributed random data, we can’t yet sort it to shuffle our list. If we look at the 6 factorial numbers generated for $n = 5$, we can see the problem:

```
000
010
100
110
200
210
```

Different values in the list will produce the same sort: `100`

and `200`

, for instance.

We need a way to map the numbers above to a particular permutations: that’s precisely the problem solved by Lehmer codes. For the numbers `110`

, we can think of each digit as the relative position to put that item from the string into. Some Haskell code might make it clear:

```
insert :: Int -> a -> [a] -> [a]
insert 0 x xs = x : xs
insert i x (y:ys) = y : insert (i-1) x ys
shuffle :: [a] -> [Int] -> [a]
shuffle xs ys = foldr (uncurry insert) [] (zip ys xs)
```

And we can step through its execution:

```
shuffle "abc" [1,1,0]
foldr (uncurry insert) [] [(1,'a'),(1,'b'),(0,'c')]
insert 1 'a' (insert 1 'b' (insert 0 'c' []))
insert 1 'a' (insert 1 'b' "c")
insert 1 'a' "cb"
'c' : insert 0 'a' "b"
"cab"
```

Notice the similarity of the function above to a standard insertion sort:

```
insert :: Ord a => a -> [a] -> [a]
insert x [] = x : []
insert x (y:ys)
| x <= y = x : y : ys
| otherwise = y : insert x ys
insertSort :: Ord a => [a] -> [a]
insertSort = foldr insert []
```

The “comparison” is a little strange—we have to take into account relative position—but the shape is almost identical. Once I spot something like that, my first thought is to see if the relationship extends to a better $\mathcal{O}(n \log n)$ sort, but there’s something else I’d like to look at first.

“A Duality of Sorts” (Hinze, Magalhães, and Wu 2013) is a paper based on the interesting symmetry between insertion sort and selection sort (There’s also a video of Graham Hutton explaining the idea; Haran 2016).

With that paper in mind, can we rewrite `shuffle`

as a selection-based algorithm? We can indeed!

```
pop :: [(Int,a)] -> Maybe (a, [(Int,a)])
pop [] = Nothing
pop ((0,x):xs) = Just (x, xs)
pop ((i,x):xs) = (fmap.fmap) ((i-1,x):) (pop xs)
shuffle :: [a] -> [Int] -> [a]
shuffle xs ys = unfoldr pop (zip ys xs)
```

While the symmetry is pleasing, the paper details how to make the relationship explicit, using the same function for both selection and insertion sort:

```
swop Nil = Nil
swop (Cons a (x , Nil)) = Cons a (Left x)
swop (Cons a (x , Cons b x'))
| fst a == 0 = Cons a (Left x)
| otherwise = Cons b (Right (Cons (first pred a) x'))
ishuffle :: [(Int,a)] -> [(Int,a)]
ishuffle = cata (apo (swop . fmap (id &&& project)))
sshuffle :: [(Int,a)] -> [(Int,a)]
sshuffle = ana (para (fmap (id ||| embed) . swop))
```

So now we have to upgrade our sorts: in the paper, merge sort is the more efficient sort chosen, similarly to what I chose previously.

```
merge [] ys = ys
merge xs [] = xs
merge ((x,i):xs) ((y,j):ys)
| i <= j = (x,i) : merge xs ((y,j-i):ys)
| otherwise = (y,j) : merge ((x,i-j-1):xs) ys
treeFold :: (a -> a -> a) -> a -> [a] -> a
treeFold f = go
where
go x [] = x
go a (b:l) = go (f a b) (pairMap l)
pairMap (x:y:rest) = f x y : pairMap rest
pairMap xs = xs
shuffle xs inds = map fst $ treeFold merge [] $ map pure $ zip xs inds
```

However, I feel like merge sort is an upgrade of *insertion* sort, not selection sort. Indeed, if you do the “split” step of merge sort badly, i.e. by splitting very unevenly, merge sort in fact *becomes* insertion sort!

So there’s a missing bit of this table:

Insertion | Selection | |
---|---|---|

$\mathcal{O}(n^2)$ | Insertion sort | Selection sort |

$\mathcal{O}(n \log n)$ | Merge sort | ??? |

I think it’s clear that quicksort is the algorithm that fits in there: again, done badly it degrades to selection sort (if you intentionally pick the pivot to be the worst element possible, i.e. the smallest element).

There are more symmetries: merge sort splits the lists using their structure, and merges them using the ordering of the elements. Quicksort is the opposite, merging by concatenation, but splitting using order. Finally, in merge sort adjacent elements are in the correct order after the recursive call, but the two sides of the split are not. Again, quicksort is precisely the opposite: adjacent elements have not been compared (*before* the recursive call), but the two sides of the split are correctly ordered.

Anyway, I haven’t yet formalised this duality (and I don’t know if I can), but we *can* use it to produce a quicksort-based shuffle algorithm:

```
partition = foldr f (const ([],[]))
where
f (y,j) ys i
| i <= j = fmap ((y,j-i):) (ys i)
| otherwise = first ((y,j):) (ys (i-1))
shuffle :: [a] -> [Int] -> [a]
shuffle xs ys = go (zip xs ys)
where
go [] = []
go ((x,i):xs) = case partition xs i of
(ls,rs) -> go ls ++ [x] ++ go rs
```

That’s all for this post! The algorithms can all be translated into Agda or Idris: I’m currently working on a way to represent permutations that isn’t $\mathcal{O}(n^2)$ using them. If I figure out a way to properly dualise quicksort and merge sort I’ll do a small write up as well (I’m currently working my way through Hinze et al. 2012 for ideas). Finally, I’d like to explore some other sorting algorithms as permutation algorithms: sorting networks seem especially related to “permutations by swapping”.

Haran, Brady. 2016. “Sorting Secret.” https://www.youtube.com/watch?v=pcJHkWwjNl4.

Hinze, Ralf, Daniel W.H. James, Thomas Harper, Nicolas Wu, and José Pedro Magalhães. 2012. “Sorting with bialgebras and distributive laws.” In *Proceedings of the 8th ACM SIGPLAN workshop on Generic programming - WGP ’12*, 69. Copenhagen, Denmark: ACM Press. doi:10.1145/2364394.2364405.

Hinze, Ralf, José Pedro Magalhães, and Nicolas Wu. 2013. “A Duality of Sorts.” In *The Beauty of Functional Code: Essays Dedicated to Rinus Plasmeijer on the Occasion of His 61st Birthday*, ed by. Peter Achten and Pieter Koopman, 151–167. Lecture Notes in Computer Science. Berlin, Heidelberg: Springer Berlin Heidelberg. doi:10.1007/978-3-642-40355-2_11.

Kiselyov, Oleg. 2002. “Provably perfect random shuffling and its pure functional implementations.” *http://okmij.org*. http://okmij.org/ftp/Haskell/AlgorithmsH.html#perfect-shuffle.

Part 1 of a 1-part series on Binary Numbers

When working with numbers in Agda, we usually use the following definition:

Haskell

Agda

In Haskell it’s less common, for obvious reasons:

Operation | Complexity |
---|---|

$n + m$ | $\mathcal{O}(n)$ |

$n \times m$ | $\mathcal{O}(nm)$ |

Why use them at all, then? Well, in Agda, we need them so we can *prove* things about the natural numbers. Machine-level integers are fast, but they’re opaque: their implementation isn’t written in Agda, and therefore it’s not available for the compiler to reason about.

In Haskell, they occasionally find uses due to their *laziness*. This can help in Agda as well. By lazy here I mean that operations on them don’t have to inspect the full structure before giving some output.

In Haskell, as we can see, this lets us run computations without scrutinising some arguments. Agda benefits similarly: here it lets the compiler see more “obvious” facts that it may have missed otherwise.

It’s not *completely* lazy, though. In particular, it tends to be left-biased:

Like Boolean short-circuiting operators, operations on Peano numbers will usually have to scrutinise the left-hand-side argument quite a bit before giving an output.

So, Peano numbers are good because:

- We can prove things about them.
- They’re lazy.

In this post, I’m going to look at some other number representations that maintain these two desirable properties, while improving on the efficiency somewhat.

The first option for an improved representation is binary numbers. We can represent binary numbers as a list of bits:

As we’re using these to represent natural numbers, we’ll need to define a way to convert between them:

And here we run into our first problem: redundancy. There are multiple ways to represent the same number according to the semantics defined above. We can actually prove this in Agda:

In English: “There are two binary numbers which are not the same, but which do evaluate to the same natural number”. (This proof was actually automatically filled in for me after writing the signature)

This represents a huge problem for proofs. It means that even simple things like $x \times 0 = 0$ aren’t true, depending on how multiplication is implemented. On to our next option:

Instead of looking at the bits directly, let’s think about a binary number as a list of chunks of 0s, each followed by a 1. In this way, we simply *can’t* have trailing zeroes, because the definition implies that every number other than 0 ends in 1.

This guarantees a unique representation. As in the representation above, it has much improved time complexities for the familiar operations:

Operation | Complexity |
---|---|

$n + m$ | $\mathcal{O}(\log_2 n)$ |

$n \times m$ | $\mathcal{O}(\log_2 (n + m))$ |

Encoding the zeroes as gaps also makes multiplication much faster in certain cases: multiplying by a high power of 2 is a constant-time operation, for instance.

It does have one disadvantage, and it’s to do with the increment function:

With all of their problems, Peano numbers performed this operation in constant time. The above implementation is only *amortised* constant-time, though, with a worst case of $\mathcal{O}(\log_2 n)$ (same as the list-of-bits version). There are a number of ways to remedy this, the most famous being:

This encoding has three digits: 0, 1, and 2. To guarantee a unique representation, we add the condition that there can be at most one 2 in the number, which must be the first non-zero digit if it’s present.

To represent this we’ll encode “gaps”, as before, with the condition that if the second gap is 0 it *actually* represents a 2 digit in the preceding position. That weirdness out of the way, we are rewarded with an `inc`

implementation which is clearly $\mathcal{O}(1)$.

Unfortunately, though, we’ve lost the other efficiencies! Addition and multiplication have no easy or direct encoding in this system, so we have to convert back and forth between this and regular binary to perform them.

The key problem with incrementing in the normal binary system is that it can cascade: when we hit a long string of 1s, all the 1s become 0 followed by a single 1. We can turn this problem to our advantage if we use a representation which encodes both 1s and 0s as strings of gaps. We’ll have to use a couple more tricks to ensure a unique representation, but all in all this is what we have (switching to just Agda now):

```
data 0≤_ (A : Set) : Set where
0₂ : 0≤ A
0<_ : A → 0≤ A
mutual
record 𝔹₀ : Set where
constructor _0&_
inductive
field
H₀ : ℕ
T₀ : 𝔹₁
record 𝔹₁ : Set where
constructor _1&_
inductive
field
H₁ : ℕ
T₁ : 0≤ 𝔹₀
open 𝔹₀ public
open 𝔹₁ public
data 𝔹⁺ : Set where
B₀_ : 𝔹₀ → 𝔹⁺
B₁_ : 𝔹₁ → 𝔹⁺
𝔹 : Set
𝔹 = 0≤ 𝔹⁺
inc⁺ : 𝔹 → 𝔹⁺
inc⁺ 0₂ = B₁ 0 1& 0₂
inc⁺ (0< B₀ zero 0& y 1& xs ) = B₁ suc y 1& xs
inc⁺ (0< B₀ suc x 0& y 1& xs ) = B₁ 0 1& 0< x 0& y 1& xs
inc⁺ (0< B₁ x 1& 0₂ ) = B₀ x 0& 0 1& 0₂
inc⁺ (0< B₁ x 1& 0< zero 0& z 1& xs) = B₀ x 0& suc z 1& xs
inc⁺ (0< B₁ x 1& 0< suc y 0& z 1& xs) = B₀ x 0& 0 1& 0< y 0& z 1& xs
inc : 𝔹 → 𝔹
inc x = 0< inc⁺ x
```

Perfect! Increments are obviously $\mathcal{O}(1)$, and we’ve guaranteed a unique representation.

I’ve been working on this type for a couple of days, and you can see my code here. So far, I’ve done the following:

- Defined
`inc`

, addition, and multiplication These were a little tricky to get right (addition is particularly hairy), but they’re all there, and maximally lazy.

- Proved Homomorphism
For each one of the functions, you want them to correspond precisely to the equivalent functions on Peano numbers. Proving that fact amounts to filling in definitions for the following:

- Proved Bijection
As we went to so much trouble, it’s important to prove that these numbers form a one-to-one correspondence with the Peano numbers. As well as that, once done, we can use it to prove facts about the homomorphic functions above, by reusing any proofs about the same functions on Peano numbers. For instance, here is a proof of commutativity of addition:

So now that we have our nice number representation, what can we do with it? One use is as a general-purpose number type in Agda: it represents a good balance between speed and “proofiness”, and Coq uses a similar type in its standard library.

There are other, more unusual uses of such a type, though.

It’s a well-known technique to build a data structure out of some number representation (Hinze 1998): in fact, all of the representations above are explored in Okasaki (1999, chap. 9.2).

Logic programming languages like Prolog let us write programs in a backwards kind of way. We say what the output looks like, and the unifier will figure out the set of inputs that generates it.

In Haskell, we have a very rough approximation of a similar system: the list monad.

```
pyth :: [(Int,Int,Int)]
pyth = do
x <- [1..10]
y <- [1..10]
z <- [1..10]
guard (x*x + y*y == z*z)
return (x,y,z)
```

There are tons of inefficiencies in the above code: for us, though, we can look at one: the number representation. In the equation:

$x^2 + y^2 = z^2$

If we know that $x$ and $y$ are both odd, then $z$ must be even. If the calculation of the equation is expensive, this is precisely the kind of shortcut we’d want to take advantage of. Luckily, our binary numbers do just that: it is enough to scrutinise just the first bits of $x$ and $y$ in order to determine the first bit of the output.

After seeing that example, you may be thinking that lazy evaluation is a perfect fit for logic programming. You’re not alone! Curry (Hanus (ed.) 2016) is a lazy, functional logic programming language, with a similar syntax to Haskell. It also uses lazy binary numbers to optimise testing.

In order for queries to be performed efficiently on binary numbers, we will also need a way to describe lazy *predicates* on them. A lot of these predicates are more easily expressible on the list-of-bits representation above, so we’ll be working with that representation for this bit. Not to worry, though: we can convert from the segmented representation into the list-of-bits, and we can prove that the conversion is injective:

Here’s the curious problem: since our binary numbers are expressed least-significant-bit-first, we have to go to the end before knowing which is bigger. Luckily, we can use one of my favourite Haskell tricks, involving the ordering monoid:

```
data Ordering : Set where
lt eq gt : Ordering
_∙_ : Ordering → Ordering → Ordering
lt ∙ y = lt
eq ∙ y = y
gt ∙ y = gt
cmpBit : Bit → Bit → Ordering
cmpBit O O = eq
cmpBit O I = lt
cmpBit I O = gt
cmpBit I I = eq
compare : Bits → Bits → Ordering
compare [] [] = eq
compare [] (_ ∷ _) = lt
compare (_ ∷ _) [] = gt
compare (x ∷ xs) (y ∷ ys) = compare xs ys ∙ cmpBit x y
```

Thanks to laziness, this function first compares the length of the lists, and then does a lexicographical comparison in reverse only if the lengths are the same. This is exactly what we want for our numbers.

That’s all I have for now, but I’m interested to formalise the laziness of these numbers in Agda. Usually that’s done with coinduction: I would also like to see the relationship with exact real arithmetic.

I wonder if it can be combined with O’Connor (2016) to get some efficient proof search algorithms, or with Escardo (2014) to get more efficient exhaustive search.

Escardo, Martin. 2014. “Seemingly impossible constructive proofs | Mathematics and Computation.” *Mathematics and Computation*. http://math.andrej.com/2014/05/08/seemingly-impossible-proofs/.

Hanus (ed.), M. 2016. *Curry: An Integrated Functional Logic Language (Vers. 0.9.0)*. Available at http://www.curry-language.org. https://www-ps.informatik.uni-kiel.de/currywiki/.

Hinze, Ralf. 1998. *Numerical Representations as Higher-Order Nested Datatypes*. Institut für Informatik III, Universität Bonn. http://www.cs.ox.ac.uk/ralf.hinze/publications/\#R5.

O’Connor, Liam. 2016. “Applications of Applicative Proof Search.” In *Proceedings of the 1st International Workshop on Type-Driven Development*, 43–55. TyDe 2016. New York, NY, USA: ACM. doi:10.1145/2976022.2976030. http://doi.acm.org/10.1145/2976022.2976030.

Okasaki, Chris. 1999. *Purely Functional Data Structures*. Cambridge University Press.

Part 2 of a 2-part series on Agda Tips

Tags: Agda

For including Agda code in LaTeX files, Agda’s built-in literate programming support is a great tool. It typesets code well, and ensures that it typechecks which can help avoid typos.

I write the LaTeX document in one file, and the Agda code in another `.lagda`

file. Using the catchfilebetweentags LaTeX package, I can then embed snippets of the Agda code into the LaTeX document. For instance, in a file named `Lists.lagda`

I can have the following:

```
%<*head-type>
\begin{code}
head : List A → Maybe A
\end{code}
%</head-type>
\begin{code}
head [] = nothing
head (x ∷ xs) = just x
\end{code}
```

Then, after compiling the Agda file with `agda --latex --output-dir=. Lists.lagda`

, I can embed the snippet `head : List A → Maybe A`

into the TeX file like so:

Most Agda source code will be Unicode-heavy, which doesn’t work well in LaTeX. There are a few different ways to deal with this: you could use XeTeX, which handles Unicode better, for instance. I found it easier to use the ucs package, and write a declaration for each Unicode character as I came across it. For the `∷`

character above, for instance, you can write:

For plain LaTeX code, I use Spacemacs and Skim to get live reloading. When I save the LaTeX source code, the Skim window refreshes and jumps to the point my editing cursor is at. I use elisp code from this blog post.

For Agda code, live reloading gets a little trickier. If I edit an Agda source file, the LaTeX won’t automatically recompile it. However, based on this stack exchange answer, you can put the following `.latexmkrc`

file in the same directory as your `.lagda`

files and your `.tex`

file:

```
add_cus_dep('lagda','tex',0,'lagda2tex');
sub lagda2tex {
my $base = shift @_;
return system('agda', '--latex', '--latex-dir=.', "$base.lagda");
}
```

This will recompile the literate Agda files whenever they’re changed. Unfortunately, it doesn’t automate it the *first* time you do it: it needs to see the `.tex`

files to see the dependency. You can fix this yourself, by running `agda --latex --output-dir=.`

when you add a new `.lagda`

file (just once, after that the automation will take over), or you can use a script like the following:

```
#!/bin/bash
find . -type f -name '*.lagda' | while read -r code ; do
dir=$(dirname "$code")
file=$(basename "$code" .lagda).tex
if [ ! -e "$dir/$file" ]
then
agda --latex --latex-dir=. "$code"
fi
done
```

This will compile any `.lagda`

file it finds that *doesn’t* have a corresponding `.tex`

file (so it won’t slow things down). Then call that script on the first line of your `.latexmkrc`

, like so:

```
system("bash ./init-missing-lagda.sh");
add_cus_dep('lagda','tex',0,'lagda2tex');
sub lagda2tex {
my $base = shift @_;
return system('agda', '--latex', '--latex-dir=.', "$base.lagda");
}
```

There are a number of undocumented flags you can pass to Agda which are absolutely invaluable when it comes to debugging. One of them can tell you more about termination checking, another reports on type checking (`tc`

), another for profiling (`profile`

), and so on. Set the verbosity level (`agda -v 100`

) to get more or less info.

Agda does type checking from left to right. This isn’t always desired: as an example, if we want to annotate a value with its type, we can use the following function:

Coming from Haskell, though, this is the wrong way around. We usually prefer to write something like `3 :: Int`

. We can’t write that as a simple function in Agda, though, so we instead use a syntax declaration:

Changing the order of type checking can also speed up typechecking in some cases. There’s more information about syntax declarations in Agda’s documentation.

]]>
Tags: Agda

This whole post is written with clickable identifiers and ascii art at the above link. I also provide the normal version below in case there are any problems rendering.

As I have talked about previously, a large class of divide-and conquer algorithms rely on “good” partitioning for the divide step. If you then want to make the algorithms incremental, you keep all of those partitions (with their summaries) in some “good” arrangement (Mu, Chiang, and Lyu 2016). Several common data structures are designed around this principle: binomial heaps, for instance, store partitions of size $2^n$. Different ways of storing partitions favours different use cases: switch from a binomial heap to a skew binomial, for instance, and you get constant-time `cons`

.

The standout data structure in this area is Hinze and Paterson’s finger tree (Hinze and Paterson 2006). It caches summaries in a pretty amazing way, allowing for (amortised) $\mathcal{O}(1)$ `cons`

and `snoc`

and $\mathcal{O}(\log n)$ `split`

and `append`

. These features allow it to be used for a huge variety of things: Data.Sequence uses it as a random-access sequence, but it can also work as a priority queue, a search tree, a priority search tree (Hinze 2001), an interval tree, an order statistic tree…

All of these applications solely rely on an underlying monoid. As a result, I thought it would be a great data structure to implement in Agda, so that you’d get all of the other data structures with minimal effort (similar thinking motivated a Coq implementation; Sozeau 2007).

There would be no real point to implementing a finger tree in Agda if we didn’t also prove some things about it. The scope of the proofs I’ve done so far are intrinsic proofs of the summaries in the tree. In other words, the type of `cons`

is as follows:

This is enough to prove things about the derived data structures (like the correctness of sorting if it’s used as a priority queue), but it’s worth pointing out what I *haven’t* proved (yet):

- Invariants on the structure (“safe” and “unsafe” digits and so on).
- The time complexity or performance of any operations.

To be honest, I’m not even sure that my current implementation is correct in these regards! I’ll probably have a go at proving them in the future (possibly using Danielsson 2008).

The bad news is that finger trees are a relatively complex data structure, and we’re going to need a *lot* of proofs to write a verified version. The good news is that monoids (in contrast to rings) are extremely easy to prove automatically. In this project, I used reflection to do so, but I think it should be possible to do with instance resolution also.

First things first, we need a way to talk about the summaries of elements we’re interested in. This is captured by the following record type:

`𝓡`

is the type of the summaries, and `μ`

means “summarise”. The silly symbols are used for brevity: we’re going to be using this thing everywhere, so it’s important to keep it short. Here’s an example instance for lists:

```
instance
σ-List : ∀ {a} {Σ : Set a} → ⦃ _ : σ Σ ⦄ → σ (List Σ)
μ ⦃ σ-List ⦄ = List.foldr (_∙_ ∘ μ) ε
```

As I mentioned, the tree is going to be verified intrinsically. In other word its type will look something like this:

But before running off to define that the obvious way, I should mention that I made the annoying decision to use a setoid (rather than propositional equality) based monoid. This means that we don’t get substitution, making the obvious definition untenable.

I figured out a solution to the problem, but I’m not sure if I’m happy with it. That’s actually the main motivation for writing this post: I’m curious if other people have better techniques for this kind of thing.

To clarify: “this kind of thing” is writing intrinsic (correct-by-construction) proofs when a setoid is involved. Intrinsic proofs usually lend themselves to elegance: to prove that `map`

preserves a vector’s length, for instance, basically requires no proof at all:

```
map : ∀ {a b n} {A : Set a} {B : Set b}
→ (A → B)
→ Vec A n
→ Vec B n
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs
```

But that’s because pattern matching works well with propositional equality: in the first clause, `n`

is set to `0`

automatically. If we were working with setoid equality, we’d instead maybe get a proof that `n ≈ 0`

, and we’d have to figure a way to work that into the types.

The first part of the solution is to define a wrapper type which stores information about the size of the thing it contains:

```
record μ⟨_⟩≈_ {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ (𝓂 : 𝓡) : Set (a ⊔ r ⊔ m) where
constructor _⇑[_]
field
𝓢 : Σ
𝒻 : μ 𝓢 ≈ 𝓂
```

Technically speaking, I think this is known as a “fibre”. `μ⟨ Σ ⟩≈ 𝓂`

means “There exists a `Σ`

such that `μ Σ ≈ 𝓂`

”. Next, we’ll need some combinators to work with:

```
infixl 2 _≈[_]
_≈[_] : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ {x : 𝓡} → μ⟨ Σ ⟩≈ x → ∀ {y} → x ≈ y → μ⟨ Σ ⟩≈ y
𝓢 (xs ≈[ y≈z ]) = 𝓢 xs
𝒻 (xs ≈[ y≈z ]) = trans (𝒻 xs) y≈z
```

This makes it possible to “rewrite” the summary, given a proof of equivalence.

The wrapper on its own isn’t enough to save us from hundreds of lines of proofs. Once you do computation on its contents, you still need to join it up with its original proof of equivalence. In other words, you’ll need to drill into the return type of a function, find the place you used the relevant type variable, and apply the relevant proof from the type above. This can really clutter proofs. Instead, we can use Agda’s new support for do notation to try and get a cleaner notation for everything. Here’s a big block of code:

```
infixl 2 arg-syntax
record Arg {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ (𝓂 : 𝓡) (f : 𝓡 → 𝓡) : Set (m ⊔ r ⊔ a) where
constructor arg-syntax
field
⟨f⟩ : Congruent₁ f
arg : μ⟨ Σ ⟩≈ 𝓂
open Arg
syntax arg-syntax (λ sz → e₁) xs = xs [ e₁ ⟿ sz ]
infixl 1 _>>=_
_>>=_ : ∀ {a b} {Σ₁ : Set a} {Σ₂ : Set b} ⦃ _ : σ Σ₁ ⦄ ⦃ _ : σ Σ₂ ⦄ {𝓂 f}
→ Arg Σ₁ 𝓂 f
→ ((x : Σ₁) → ⦃ x≈ : μ x ≈ 𝓂 ⦄ → μ⟨ Σ₂ ⟩≈ f (μ x))
→ μ⟨ Σ₂ ⟩≈ f 𝓂
arg-syntax cng xs >>= k = k (𝓢 xs) ⦃ 𝒻 xs ⦄ ≈[ cng (𝒻 xs) ]
```

First, we define a wrapper for types parameterised by their summary, with a way to lift an underlying equality up into some expression `f`

. The `>>=`

operator just connects up all of the relevant bits. An example is what’s needed:

```
listToTree : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → (xs : List Σ) → μ⟨ Tree Σ ⟩≈ μ xs
listToTree [] = empty ⇑
listToTree (x ∷ xs) = [ ℳ ↯ ]≈ do
ys ← listToTree xs [ μ x ∙> s ⟿ s ]
x ◂ ys
```

The first line is the base case, nothing interesting going on there. The second line begins the do-notation, but first applies `[ ℳ ↯ ]≈`

: this calls the automated solver. The second line makes the recursive call, and with the syntax:

It tells us where the size of the bound variable will end up in the outer expression.

Danielsson, Nils Anders. 2008. “Lightweight Semiformal Time Complexity Analysis for Purely Functional Data Structures.” In *Proceedings of the 35th Annual ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages*, 133–144. POPL ’08. New York, NY, USA: ACM. doi:10.1145/1328438.1328457.

Hinze, Ralf. 2001. “A Simple Implementation Technique for Priority Search Queues.” In *Proceedings of the 2001 International Conference on Functional Programming*, 110–121. ACM Press. doi:10.1145/507635.507650.

Hinze, Ralf, and Ross Paterson. 2006. “Finger Trees: A Simple General-purpose Data Structure.” *Journal of Functional Programming* 16 (2): 197–217.

Mu, Shin-Cheng, Yu-Hsi Chiang, and Yu-Han Lyu. 2016. “Queueing and Glueing for Optimal Partitioning (Functional Pearl).” In *Proceedings of the 21st ACM SIGPLAN International Conference on Functional Programming*, 158–167. ICFP 2016. New York, NY, USA: ACM. doi:10.1145/2951913.2951923.

Sozeau, Matthieu. 2007. “Program-ing Finger Trees in Coq.” In *Proceedings of the 12th ACM SIGPLAN International Conference on Functional Programming*, 13–24. ICFP ’07. New York, NY, USA: ACM. doi:10.1145/1291151.1291156.

Tags: Agda

I’m finally a the point where I feel like I can make the project I’ve been working on for the past few months public: A Ring Solver for Agda. The focus of the project is ergonomics and ease-of-use: hopefully the interface to the solver is simpler and more friendly than the one that’s already there. It can do step-by-step solutions (like Wolfram Alpha). It’s also asymptotically faster than the old solver (and actually faster! The usual optimizations you might apply don’t actually work here, so this bit definitely took the most work).

Anyway, this work is all for my undergrad final year project, but I’m hoping to submit it to a conference or something in the next few weeks.

]]>
Part 3 of a 3-part series on Balanced Folds

Tags: Haskell

When we started the series, we wanted to find a “better” fold: one that was more balanced than either `foldl`

or `foldr`

(in its placement of parentheses). Both of these are about as unbalanced as you can get:

The first better fold I found was Jon Fairbairn’s simple `treeFold`

:

```
treeFold :: (a -> a -> a) -> a -> [a] -> a
treeFold f = go
where
go x [] = x
go a (b:l) = go (f a b) (pairMap l)
pairMap (x:y:rest) = f x y : pairMap rest
pairMap xs = xs
>>> treeFold (+) 0 [1,2,3]
(0 + 1) + (2 + 3)
```

Already this function was kind of magical: if your binary operator merges two sorted lists, `foldr`

will give you insertion sort, whereas `treeFold`

will give you merge sort; for summing floats, `treeFold`

has a lower error growth than `sum`

. By dividing up the work better, we were able to improve the characteristics of many algorithms automatically. We also saw that it could easily be made parallel:

```
parseq :: a -> b -> b
parseq a b =
runST
(bool (par a b) (seq a b) <$>
unsafeIOToST (liftA2 (>) numSparks getNumCapabilities))
treeFoldParallel :: (a -> a -> a) -> a -> [a] -> a
treeFoldParallel f =
treeFold
(\l r ->
r `parseq` (l `parseq` f l r))
```

In the next post, we saw how we could make the fold incremental, by using binary number representations for data structures. This let us do 2 things: it meant the fold was structurally terminating, so it would pass the termination checker (efficiently) in languages like Agda or Idris, and it meant we could write `scanl`

using the fold. The `scanl`

was also efficient: you could run the fold at any point in $\mathcal{O}(\log n)$ time, and work would be shared between subsequent runs. Effectively, this let us use it to solve greedy optimization problems. We also saw how it was effectively constructing an implicit binomial priority queue under the hood, and how it exploited laziness to get sharing.

I’ve gotten huge mileage out of this fold and the general ideas about it, and today I’m going to show one more use of it. We’re going to improve some of the asymptotics of the data structure presented in Lampropoulos, Spector-Zabusky, and Foner (2017).

The paper opens with the problem:

Suppose you have an urn containing two red balls, four green balls, and three blue balls. If you take three balls out of the urn, what is the probability that two of them are green?

If you were to take just *one* ball out of the earn, calculating the associated probabilities would be easy. Once you get to the second, though, you have to update the previous probability *based on what ball was removed*. In other words, we need to be able to dynamically update the distribution.

Using lists, this would obviously become an $\mathcal{O}(n)$ operation. In the paper, an almost-perfect binary tree is used. This turns the operation into one that’s $\mathcal{O}(\log n)$. The rest of the operations have the following complexities:

Operation | Complexity |
---|---|

`insert` |
$\mathcal{O}(\log n)$ |

`remove` |
$\mathcal{O}(\log n)$ |

`fromList` |
$\mathcal{O}(n)$ |

As a quick spoiler, the improved version presented here has these complexities:

Operation | Complexity |
---|---|

`insert` |
$\mathcal{O}(1)$ |

`remove` |
$\mathcal{O}(\log n)$ |

`merge` |
$\mathcal{O}(\log n)$ |

`fromList` |
$\mathcal{O}(n)$ |

We add another operation (`merge`

), which means that the new structure is viable as an instance of `Alternative`

, `Monad`

, and so on, making it an efficient monad for weighted backtracking search.

The key thing to notice in the paper which will let us improve the structure is that what they’re designing is actually a *priority queue*. Well, a weird looking priority queue, but a priority queue nonetheless.

Think about it like a max-priority queue (pop returns the largest element first), with a degree of “randomization”. In other words, when you go to do a pop, all of the comparisons between the ordering keys (the weights in this case) sprinkles some randomness into the equation, meaning that instead of `1 < 2`

returning `True`

, it returns `True`

$\frac{2}{3}$ of the time, and `False`

the other $\frac{1}{3}$.

This way of doing things means that not every priority queue is suitable: we want to run comparisons at `pop`

time (not `insert`

), so a binary heap (for instance) won’t do. At branches (non-leaves), the queue will only be allowed store *summaries* of the data, not the “max element”.

The one presented in the paper is something like a Braun priority queue: the $\mathcal{O}(n)$ `fromList`

implementation is reminiscent of the one in Okasaki (1997).

So what priority queue can we choose to get us the desired efficiency? Why, a binomial one of course!

The urn structure itself looks a lot like a binomial heap:

```
data Tree a
= Tree
{ weight :: {-# UNPACK #-} !Word
, branch :: Node a
}
data Node a
= Leaf a
| Branch (Tree a) (Node a)
data Heap a
= Nil
| Cons {-# UNPACK #-} !Word (Tree a) (Heap a)
data Urn a =
Urn {-# UNPACK #-} !Word
!(Heap a)
```

By avoiding the usual `Skip`

constructors you often see in a binomial heap we save a huge amount of space. Instead, we store the “number of zeroes before this bit”. Another thing to point out is that only left branches in the trees store their weight: the same optimization is made in the paper.

Insertion is not much different from insertion for a usual binomial priority queue, although we don’t need to do anything to merge the trees:

```
insertHeap :: Word -> a -> Heap a -> Heap a
insertHeap i' x' = go 0 (Tree i' (Leaf x'))
where
go !i x Nil = Cons i x Nil
go !i x (Cons 0 y ys) = go (i+1) (mergeTree x y) ys
go !i x (Cons j y ys) = Cons i x (Cons (j-1) y ys)
mergeTree :: Tree a -> Tree a -> Tree a
mergeTree xs ys =
Tree
(weight xs + weight ys)
(Branch xs (branch ys))
insert :: Word -> a -> Urn a -> Urn a
insert i x (Urn w xs) = Urn (w+i) (insertHeap i x xs)
```

We *could* potentially get insertion from amortized $\mathcal{O}(1)$ to worst-case $\mathcal{O}(1)$ by using skew binary instead of binary (in fact I am almost sure it’s possible), but then I think we’d lose the efficient merge. I’ll leave exploring that for another day.

To get randomness, we’ll write a very simple class that encapsulates only what we need:

You can later instantiate this to whatever random monad you end up using. (The same approach was taken in the paper, although we only require `Functor`

here, not `Monad`

).

Sampling (with replacement) first randomly chooses a tree from the top-level list, and then we drill down into that tree with binary search.

```
sample :: (Functor m, Sample m) => Urn a -> Maybe (m a)
sample (Urn _ Nil) = Nothing
sample (Urn w' (Cons _ x' xs')) = Just (fmap (go x' xs') (inRange 0 (w' - 1)))
where
go x Nil !w = go' w (branch x)
go x (Cons _ y ys) !w
| w < weight x = go' w (branch x)
| otherwise = go y ys (w - weight x)
go' !_ (Leaf x) = x
go' !i (Branch xs ys)
| i < weight xs = go' i (branch xs)
| otherwise = go' (i - weight xs) ys
```

So we’re off to a good start, but `remove`

is a complex operation. We take the same route taken in the paper: first, we perform an “uncons”-like operation, which pops out the last inserted element. Then, we randomly choose a point in the tree (using the same logic as in `sample`

), and replace it with the popped element^{1}.

```
remove :: (Functor m, Sample m) => Urn a -> Maybe (m ((a, Word), Urn a))
remove (Urn w hp) = fmap go' (Heap.uninsert hp)
where
go' (vw,v,hp') = fmap (`go` hp') (inRange 0 (w-1))
where
go !_ Nil = ((v, vw), Urn 0 Nil)
go !rw vs@(Cons i' x' xs')
| rw < vw = ((v, vw), Urn (w - vw) vs)
| otherwise = replace (rw - vw) i' x' xs'
(\ys yw y -> ((y, yw), Urn (w - yw) ys))
replace !rw i x Nil k = replaceTree rw x (\t -> k (Cons i t Nil))
replace !rw i x xs@(Cons j y ys) k
| rw < weight x = replaceTree rw x (\t -> k (Cons i t xs))
| otherwise = replace (rw - weight x) j y ys (k . Cons i x)
replaceTree !_ (Tree tw (Leaf x)) k = k (Tree vw (Leaf v)) tw x
replaceTree !rw (Tree tw (Branch xs ys)) k
| rw < weight xs = replaceTree rw xs
(\t -> k (Tree (tw + (weight t - weight xs)) (Branch t ys)))
| otherwise = replaceTree (rw - weight xs)
(Tree (tw - weight xs) ys)
(\t -> k (Tree (weight xs + weight t) (Branch xs (branch t))))
```

Merge is the same as on binomial heaps:

```
mergeHeap :: Heap a -> Heap a -> Heap a
mergeHeap Nil = id
mergeHeap (Cons i' x' xs') = merger i' x' xs'
where
merger !i x xs Nil = Cons i x xs
merger !i x xs (Cons j y ys) = merge' i x xs j y ys
merge' !i x xs !j y ys = case compare i j of
LT -> Cons i x (merger (j-i-1) y ys xs)
GT -> Cons j y (merger (i-j-1) x xs ys)
EQ -> mergec (succ i) (mergeTree x y) xs ys
mergec !p !t Nil = carryLonger p t
mergec !p !t (Cons i x xs) = mergecr p t i x xs
mergecr !p !t !i x xs Nil = carryLonger' p t i x xs
mergecr !p !t !i x xs (Cons j y ys) = mergec' p t i x xs j y ys
mergec' !p t !i x xs !j y ys = case compare i j of
LT -> mergecr'' p t i x xs (j-i-1) y ys
GT -> mergecr'' p t j y ys (i-j-1) x xs
EQ -> Cons p t (mergec i (mergeTree x y) xs ys)
mergecr'' !p !t 0 x xs !j y ys = mergecr (p+1) (mergeTree t x) j y ys xs
mergecr'' !p !t !i x xs !j y ys = Cons p t (Cons (i-1) x (merger j y ys xs))
carryLonger !i !t Nil = Cons i t Nil
carryLonger !i !t (Cons j y ys) = carryLonger' i t j y ys
carryLonger' !i !t 0 y ys = carryLonger (succ i) (mergeTree t y) ys
carryLonger' !i !t !j y ys = Cons i t (Cons (j-1) y ys)
merge :: Urn a -> Urn a -> Urn a
merge (Urn i xs) (Urn j ys) = Urn (i+j) (mergeHeap xs ys)
```

Again, the cleverness of all the tree folds is that they intelligently batch summarizing operations, allowing you to efficiently so prefix-scan-like operations that exploit sharing.

The bare-bones version just uses binary numbers: you can upgrade the `cons`

operation to worst-case constant-time if you use *skew* binary. Are there other optimizations? Yes! What if we wanted to stick something on to the *other* end, for instance? What if we wanted to reverse?

If you figure out a way to do *all* these optimizations, and put them into one big data structure, you get the mother-of-all “batching” data structures: the finger tree. This is the basis for Haskell’s Data.Sequence, but it can also implement priority queues, urns (I’d imagine), fenwick-tree-like structures, and more.

First and foremost, I should test the above implementations! I’m pretty confident the asymptotics are correct, but I’m certain the implementations have bugs.

The efficient `merge`

is intriguing: it means that `Urn`

could conceivably be `Alternative`

, `MonadPlus`

, etc. I have yet to see a use for that, but it’s interesting nonetheless! I’m constantly looking for a way to express something like Dijkstra’s algorithm algebraicly, using the usual `Alternative`

combinators; I don’t know if this is related.

The other interesting point is that, for this to be an instance of `Applicative`

, it would need some analogue for multiplication for the weights. I’m not sure what that should be.

This is inherently *max*-priority. It’s not obvious how to translate what we have into a min-priority queue version.

Finally, it might be worth trying out different priority queues (a pairing heap is very similar in structure to this). Also, we could rearrange the weights so that larger ones are higher in each tree: this might give a performance boost.

Lampropoulos, Leonidas, Antal Spector-Zabusky, and Kenneth Foner. 2017. “Ode on a random urn (functional pearl).” In, 26–37. ACM Press. doi:10.1145/3122955.3122959.

Okasaki, Chris. 1997. “Three Algorithms on Braun Trees.” *Journal of Functional Programming* 7 (6) (November): 661–666. doi:10.1017/S0956796897002876.

There’s one extra step I haven’t mentioned: we also must allow the first element (the last inserted) to be chosen, so we run the random-number generator once to check if that’s the element we want to choose.↩

Part 2 of a 3-part series on Balanced Folds

Previously I tried to figure out a way to fold lists in a more balanced way. Usually, when folding lists, you’ve got two choices for your folds, both of which are extremely unbalanced in one direction or another. Jon Fairbairn wrote a more balanced version, which looked something like this:

```
treeFold :: (a -> a -> a) -> a -> [a] -> a
treeFold f = go
where
go x [] = x
go a (b:l) = go (f a b) (pairMap l)
pairMap (x:y:rest) = f x y : pairMap rest
pairMap xs = xs
```

The fold above is kind of magical: for a huge class of algorithms, it kind of “automatically” improves some factor of theirs from $\mathcal{O}(n)$ to $\mathcal{O}(\log n)$. For instance: to sum a list of floats, `foldl' (+) 0`

will have an error growth of $\mathcal{O}(n)$; `treeFold (+) 0`

, though, has an error rate of $\mathcal{O}(\log n)$. Similarly, using the following function to merge two sorted lists:

```
merge :: Ord a => [a] -> [a] -> [a]
merge [] ys = ys
merge (x:xs) ys = go x xs ys
where
go x xs [] = x : xs
go x xs (y:ys)
| x <= y = x : go y ys xs
| otherwise = y : go x xs ys
```

We get either insertion sort ($\mathcal{O}(n^2)$) or merge sort ($\mathcal{O}(n \log n)$) just depending on which fold you use.

I’ll give some more examples later, but effectively it gives us a better “divide” step in many divide and conquer algorithms.

As it was such a useful fold, and so integral to many tricky algorithms, I really wanted to have it available in Agda. Unfortunately, though, the functions (as defined above) aren’t structurally terminating, and there doesn’t *look* like there’s an obvious way to make it so. I tried to make well founded recursion work, but the proofs were ugly and slow.

However, we can use some structures from a previous post: the nested binary sequence, for instance. It has some extra nice properties: instead of nesting the types, we can just apply the combining function.

```
mutual
data Tree {a} (A : Set a) : Set a where
2^_×_+_ : ℕ → A → Node A → Tree A
data Node {a} (A : Set a) : Set a where
⟨⟩ : Node A
⟨_⟩ : Tree A → Node A
module TreeFold {a} {A : Set a} (_*_ : A → A → A) where
infixr 5 _⊛_ 2^_×_⊛_
2^_×_⊛_ : ℕ → A → Tree A → Tree A
2^ n × x ⊛ 2^ suc m × y + ys = 2^ n × x + ⟨ 2^ m × y + ys ⟩
2^ n × x ⊛ 2^ zero × y + ⟨⟩ = 2^ suc n × (x * y) + ⟨⟩
2^ n × x ⊛ 2^ zero × y + ⟨ ys ⟩ = 2^ suc n × (x * y) ⊛ ys
_⊛_ : A → Tree A → Tree A
_⊛_ = 2^ 0 ×_⊛_
⟦_⟧↓ : Tree A → A
⟦ 2^ _ × x + ⟨⟩ ⟧↓ = x
⟦ 2^ _ × x + ⟨ xs ⟩ ⟧↓ = x * ⟦ xs ⟧↓
⟦_⟧↑ : A → Tree A
⟦ x ⟧↑ = 2^ 0 × x + ⟨⟩
⦅_,_⦆ : A → List A → A
⦅ x , xs ⦆ = ⟦ foldr _⊛_ ⟦ x ⟧↑ xs ⟧↓
```

Alternatively, we can get $\mathcal{O}(1)$ cons with the skew array:

```
infixr 5 _⊛_
_⊛_ : A → Tree A → Tree A
x ⊛ 2^ n × y + ⟨⟩ = 2^ 0 × x + ⟨ 2^ n × y + ⟨⟩ ⟩
x ⊛ 2^ n × y₁ + ⟨ 2^ 0 × y₂ + ys ⟩ = 2^ suc n × (x * (y₁ * y₂)) + ys
x ⊛ 2^ n × y₁ + ⟨ 2^ suc m × y₂ + ys ⟩ = 2^ 0 × x + ⟨ 2^ n × y₁ + ⟨ 2^ m × y₂ + ys ⟩ ⟩
```

Using this, a proper and efficient merge sort is very straightforward:

```
data Total {a r} {A : Set a} (_≤_ : A → A → Set r) (x y : A) : Set (a ⊔ r) where
x≤y : ⦃ _ : x ≤ y ⦄ → Total _≤_ x y
y≤x : ⦃ _ : y ≤ x ⦄ → Total _≤_ x y
module Sorting {a r}
{A : Set a}
{_≤_ : A → A → Set r}
(_≤?_ : ∀ x y → Total _≤_ x y) where
data [∙] : Set a where
⊥ : [∙]
[_] : A → [∙]
data _≥_ (x : A) : [∙] → Set (a ⊔ r) where
instance ⌈_⌉ : ∀ {y} → y ≤ x → x ≥ [ y ]
instance ⌊⊥⌋ : x ≥ ⊥
infixr 5 _∷_
data Ordered (b : [∙]) : Set (a ⊔ r) where
[] : Ordered b
_∷_ : ∀ x → ⦃ x≥b : x ≥ b ⦄ → (xs : Ordered [ x ]) → Ordered b
_∪_ : ∀ {b} → Ordered b → Ordered b → Ordered b
[] ∪ ys = ys
(x ∷ xs) ∪ ys = ⟅ x ∹ xs ∪ ys ⟆
where
⟅_∹_∪_⟆ : ∀ {b} → ∀ x ⦃ _ : x ≥ b ⦄ → Ordered [ x ] → Ordered b → Ordered b
⟅_∪_∹_⟆ : ∀ {b} → Ordered b → ∀ y ⦃ _ : y ≥ b ⦄ → Ordered [ y ] → Ordered b
merge : ∀ {b} x y ⦃ _ : x ≥ b ⦄ ⦃ _ : y ≥ b ⦄
→ Total _≤_ x y
→ Ordered [ x ]
→ Ordered [ y ]
→ Ordered b
⟅ x ∹ xs ∪ [] ⟆ = x ∷ xs
⟅ x ∹ xs ∪ y ∷ ys ⟆ = merge x y (x ≤? y) xs ys
⟅ [] ∪ y ∹ ys ⟆ = y ∷ ys
⟅ x ∷ xs ∪ y ∹ ys ⟆ = merge x y (x ≤? y) xs ys
merge x y x≤y xs ys = x ∷ ⟅ xs ∪ y ∹ ys ⟆
merge x y y≤x xs ys = y ∷ ⟅ x ∹ xs ∪ ys ⟆
open TreeFold
sort : List A → Ordered ⊥
sort = ⦅ _∪_ , [] ⦆ ∘ map (_∷ [])
```

It would be nice if we could verify these optimizated versions of folds. Luckily, by writing them using `foldr`

, we’ve stumbled into well-trodden ground: the *foldr fusion law*. It states that if you have some transformation $f$, and two binary operators $\oplus$ and $\otimes$, then:

This fits right in with the function we used above. $f$ is `⟦_⟧↓`

, $\oplus$ is `_⊛_`

, and $\otimes$ is whatever combining function was passed in. Let’s prove the foldr fusion law, then, before we go any further.

```
module Proofs
{a r}
{A : Set a}
{R : Rel A r}
where
infix 4 _≈_
_≈_ = R
open import Algebra.FunctionProperties _≈_
foldr-universal : Transitive _≈_
→ ∀ {b} {B : Set b} (h : List B → A) f e
→ ∀[ f ⊢ Congruent₁ ]
→ (h [] ≈ e)
→ (∀ x xs → h (x ∷ xs) ≈ f x (h xs))
→ ∀ xs → h xs ≈ foldr f e xs
foldr-universal _○_ h f e f⟨_⟩ ⇒[] ⇒_∷_ [] = ⇒[]
foldr-universal _○_ h f e f⟨_⟩ ⇒[] ⇒_∷_ (x ∷ xs) =
(⇒ x ∷ xs) ○ f⟨ foldr-universal _○_ h f e f⟨_⟩ ⇒[] ⇒_∷_ xs ⟩
foldr-fusion : Transitive _≈_
→ Reflexive _≈_
→ ∀ {b c} {B : Set b} {C : Set c} (f : C → A) {_⊕_ : B → C → C} {_⊗_ : B → A → A} e
→ ∀[ _⊗_ ⊢ Congruent₁ ]
→ (∀ x y → f (x ⊕ y) ≈ x ⊗ f y)
→ ∀ xs → f (foldr _⊕_ e xs) ≈ foldr _⊗_ (f e) xs
foldr-fusion _○_ ∎ h {f} {g} e g⟨_⟩ fuse =
foldr-universal _○_ (h ∘ foldr f e) g (h e) g⟨_⟩ ∎ (λ x xs → fuse x (foldr f e xs))
```

We’re not using the proofs in Agda’s standard library because these are tied to propositional equality. In other words, instead of using an abstract binary relation, they prove things over *actual* equality. That’s all well and good, but as you can see above, we don’t need propositional equality: we don’t even need the relation to be an equivalence, we just need transitivity and reflexivity.

After that, we can state precisely what correspondence the tree fold has, and under what conditions it does the same things as a fold:

```
module _ {_*_ : A → A → A} where
open TreeFold _*_
treeFoldHom : Transitive _≈_
→ Reflexive _≈_
→ Associative _*_
→ RightCongruent _*_
→ ∀ x xs
→ ⦅ x , xs ⦆ ≈ foldr _*_ x xs
treeFoldHom _○_ ∎ assoc *⟨_⟩ b = foldr-fusion _○_ ∎ ⟦_⟧↓ ⟦ b ⟧↑ *⟨_⟩ (⊛-hom zero)
where
⊛-hom : ∀ n x xs → ⟦ 2^ n × x ⊛ xs ⟧↓ ≈ x * ⟦ xs ⟧↓
⊛-hom n x (2^ suc m × y + ⟨⟩ ) = ∎
⊛-hom n x (2^ suc m × y + ⟨ ys ⟩) = ∎
⊛-hom n x (2^ zero × y + ⟨⟩ ) = ∎
⊛-hom n x (2^ zero × y + ⟨ ys ⟩) = ⊛-hom (suc n) (x * y) ys ○ assoc x y ⟦ ys ⟧↓
```

Consider the following implementation of the tree above in Haskell:

```
type Tree a = [(Int,a)]
cons :: (a -> a -> a) -> a -> Tree a -> Tree a
cons (*) = cons' 0
where
cons' n x [] = [(n,x)]
cons' n x ((0,y):ys) = cons' (n+1) (x * y) ys
cons' n x ((m,y):ys) = (n,x) : (m-1,y) : ys
```

The `cons`

function “increments” that list as if it were the bits of a binary number. Now, consider using the `merge`

function from above, in a pattern like this:

What does `f`

build? A list of lists, right?

Kind of. That’s what’s built in terms of the observable, but what’s actually stored in memory us a bunch of thunks. The shape of *those* is what I’m interested in. We can try and see what they look like by using a data structure that doesn’t force on merge:

Using a handy tree-drawing function, we can see what `f [1..13]`

looks like:

```
[(0,*),(1,*),(0,*)]
└1 │ ┌2 │ ┌6
│┌┤ │ ┌┤
││└3 │ │└7
└┤ │┌┤
│┌4 │││┌8
└┤ ││└┤
└5 ││ └9
└┤
│ ┌10
│┌┤
││└11
└┤
│┌12
└┤
└13
```

It’s a binomial heap! It’s a list of trees, each one contains $2^n$ elements. But they’re not in heap order, you say? Well, as a matter of fact, they *are*. It just hasn’t been evaluated yet. Once we force—say—the first element, the rest will shuffle themselves into a tree of thunks.

This illustrates a pretty interesting similarity between binomial heaps and merge sort. Performance-wise, though, there’s another interesting property: the thunks *stay thunked*. In other words, if we do a merge sort via:

We could instead freeze the fold, and look at it at every point:

```
sortPrefixes = map (foldr (merge . snd) []) . scanl (flip (cons merge . pure)) []
>>> [[],[1],[1,4],[1,2,4],[1,2,3,4],[1,2,3,4,5]]
```

And `sortPrefixes`

is only $\mathcal{O}(n^2)$ (rather than $\mathcal{O}(n^2 \log n)$). I confess I don’t know of a use for sorted prefixes, but it should illustrate the general idea: we get a pretty decent batching of operations, with the ability to freeze at any point in time. The other nice property (which I mentioned in the last post) is that any of the tree folds are extremely parallel.

There’s a great article on shuffling in Haskell which provides an $\mathcal{O}(n \log n)$ implementation of a perfect random shuffle. Unfortunately, the Fisher-Yates shuffle isn’t applicable in a pure functional setting, so you have to be a little cleverer.

The first implementation most people jump to (certainly the one I thought of) is to assign everything in the sequence a random number, and then sort according to that number. Perhaps surprisingly, this *isn’t* perfectly random! It’s a little weird, but the example in the article explains it well: basically, for $n$ elements, your random numbers will have $n^n$ possible values, but the output of the sort will have $n!$ possible values. Since they don’t divide into each other evenly, you’re going to have some extra weight on some permutations, and less on others.

Instead, we can generate a random *factoradic* number. A factoradic number is one where the $n$th digit is in base $n$. Because of this, a factoradic number with $n$ digits has $n!$ possible values: exactly what we want.

In the article, the digits of the number are used to pop values from a binary tree. Because the last digit will have $n$ possible values, and the second last $n-1$, and so on, you can keep popping without hitting an empty tree.

This has the correct time complexity—$\mathcal{O}(n \log n)$—but there’s a lot of overhead. Building the tree, then indexing into it, the rebuilding after each pop, etc.

We’d *like* to just sort the list, according to the indices. The problem is that the indices are relative: if you want to `cons`

something onto the list, you have to increment the rest of the indices, as they’ve all shifted right by one.

What we’ll do instead is use the indices as *gaps*. Our merge function looks like the following:

```
merge [] ys = ys
merge xs [] = xs
merge ((x,i):xs) ((y,j):ys)
| i <= j = (x,i) : merge xs ((y,j-i):ys)
| otherwise = (y,j) : merge ((x,i-j-1):xs) ys
```

With that, and the same `cons`

as above, we get a very simple random shuffle algorithm:

```
shuffle xs = map fst
. foldr (merge . snd) []
. foldr f (const []) xs
where
f x xs (i:is) = cons merge [(x,i)] (xs is)
```

The other interesting thing about this algorithm is that it can use Peano numbers with taking too much of a performance hit:

```
merge : ∀ {a} {A : Set a} → List (A × ℕ) → List (A × ℕ) → List (A × ℕ)
merge xs [] = xs
merge {A = A} xs ((y , j) ∷ ys) = go-r xs y j ys
where
go-l : A → ℕ → List (A × ℕ) → List (A × ℕ) → List (A × ℕ)
go-r : List (A × ℕ) → A → ℕ → List (A × ℕ) → List (A × ℕ)
go : ℕ → ℕ → A → ℕ → List (A × ℕ) → A → ℕ → List (A × ℕ) → List (A × ℕ)
go i zero x i′ xs y j′ ys = (y , j′) ∷ go-l x i xs ys
go zero (suc j) x i′ xs y j′ ys = (x , i′) ∷ go-r xs y j ys
go (suc i) (suc j) = go i j
go-l x i xs [] = (x , i) ∷ xs
go-l x i xs ((y , j) ∷ ys) = go i j x i xs y j ys
go-r [] y j ys = (y , j) ∷ ys
go-r ((x , i) ∷ xs) y j ys = go i j x i xs y j ys
shuffle : ∀ {a} {A : Set a} → List A → List ℕ → List A
shuffle {a} {A} xs i = map proj₁ (⦅ [] , zip-inds xs i ⦆)
where
open TreeFold {a} {List (A × ℕ)} merge
zip-inds : List A → List ℕ → List (List (A × ℕ))
zip-inds [] inds = []
zip-inds (x ∷ xs) [] = ((x , 0) ∷ []) ∷ zip-inds xs []
zip-inds (x ∷ xs) (i ∷ inds) = ((x , i) ∷ []) ∷ zip-inds xs inds
```

I don’t know exactly what the complexity of this is, but I *think* it should be better than the usual approach of popping from a vector.

This is just a collection of random thoughts for now, but I intend to work on using these folds to see if there are any other algorithms they can be useful for. In particular, I think I can write a version of Data.List.permutations which benefits from sharing. And I’m interested in using the implicit binomial heap for some search problems.

]]>
Part 5 of a 6-part series on Breadth-First Traversals

Tags: Haskell

Today, I’m going to look at extending the previous breadth-first traversal algorithms to arbitrary graphs (rather than just trees). Graphs with cycles are notoriously cumbersome in functional languages, so this actually proves to be a little trickier than I thought it would be. First, a quick recap.

So far, we have three major ways to traverse a tree in breadth-first order. The first is the simplest, and the fastest:

```
bfe :: Tree a -> [a]
bfe r = f r b []
where
f (Node x xs) fw bw = x : fw (xs : bw)
b [] = []
b qs = foldl (foldr f) b qs []
```

Given a tree like the following:

```
┌4
┌2┤
│ │ ┌8
│ └5┤
│ └9
1┤
│ ┌10
│ ┌6┘
└3┤
└7
```

We get:

It also demonstrates a theme that will run through this post: lists are the only *visible* data structure (other than the tree, of course). However, we are carefully batching the operations on those lists (the `foldl`

is effectively a reverse) so that they have the same complexity as if we had used a queue. In actual fact, when lists are used this way, they *are* queues: “corecursive” ones (Allison 2006; Smith 2009).

The next two functions perform a breadth-first traversal “level-wise”: instead of just returning all the nodes of the tree, we get them delimited by how far they are from the root.

```
lwe :: Tree a -> [[a]]
lwe r = f b r [] []
where
f k (Node x xs) ls qs = k (x : ls) (xs : qs)
b _ [] = []
b k qs = k : foldl (foldl f) b qs [] []
>>> lwe tree
[[1],[2,3],[4,5,6,7],[8,9,10]]
```

The above function is very clearly related to the `bfe`

function: we just add another queue (representing the current level), and work from there.

The third of these functions also does level-wise enumeration, but in a direct style (without continuations).

```
lwe :: Tree a -> [[a]]
lwe r = f r []
where
f (Node x xs) (q:qs) = (x:q) : foldr f qs xs
f (Node x xs) [] = [x] : foldr f [] xs
```

There are more techniques out there than just these three (including the one in Data.Tree), but these are my favorite, and they’re what I’ll be looking at today.

Functional programming in general excels at working with trees and similar data structures. Graphs, though, are trickier. There’s been a lot of recent work in improving the situation (Mokhov 2017), but I’m going to keep it simple today: a graph is just a function.

So the tree from above could be represented as:

As it happens, all of the algorithms that follow will work on graphs represented as rose trees (or represented any way, really).

So let’s fire up our first traversal!

```
bfs :: Graph a -> Graph a
bfs g r = f r b []
where
f x fw bw = x : fw (g x : bw)
b [] = []
b qs = foldl (foldr f) b qs []
>>> bfs graph 1
[1,2,3,4,5,6,7,8,9,10]
```

Unfortunately, this won’t handle cycles properly:

```
graph 1 = [2,3]
graph 2 = [4,5,1]
graph 3 = [6,7]
graph 5 = [8,9]
graph 6 = [10]
graph _ = []
>>> bfs graph 1
[1,2,3,4,5,1,6,7,8,9,2,3,10,4,5,1,6,7,8,9,2,3,10,4,5,1,6,7,8,9,2,3,10,4,5...
```

We need a way to mark off what we’ve already seen. The following isn’t good enough, also:

It will hang without finishing the list. The solution is to mark off nodes as we find them, with some set structure:

```
bfs :: Ord a => Graph a -> Graph a
bfs g ts = f ts b [] Set.empty
where
f x fw bw s
| Set.member x s = fw bw s
| otherwise = x : fw (g x : bw) (Set.insert x s)
b [] _ = []
b qs s = foldl (foldr f) b qs [] s
>>> bfs graph 1
[1,2,3,4,5,6,7,8,9,10]
```

The levelwise algorithm is similar:

```
lws :: Ord a => Graph a -> a -> [[a]]
lws g r = f b r [] [] Set.empty
where
f k x ls qs s
| Set.member x s = k ls qs s
| otherwise = k (x : ls) (g x : qs) (Set.insert x s)
b _ [] _ = []
b k qs s = k : foldl (foldl f) b qs [] [] s
```

The other levelwise algorithm *doesn’t* translate across so easily. To see why, let’s look at the version without cycle detection:

```
lws :: Graph a -> a -> [[a]]
lws g r = f r []
where
f x (q:qs) = (x:q) : foldr f qs (g x)
f x [] = [x] : foldr f [] (g x)
```

The recursive call is being made *depth*-first, not breadth-first. The result, of course, is breadth-first, but that’s only because the recursive call zips as it goes.

Just looking at the fourth line for now:

We want whatever process built up that `q`

to be denied access to `x`

. The following doesn’t work:

As well as being terribly slow, the later computation can diverge when it finds a cycle, and filtering won’t do anything to help that.

The solution is to “tie the knot”. We basically do two passes over the data: one to build up the “seen so far” list, and then another to do the actual search. The trick is to do both of these passes at once, and feed the result back into the demanding computation.

```
lws g r = takeWhile (not.null) (map fst (fix (f r . push)))
where
push xs = ([],Set.empty) : [ ([],seen) | (_,seen) <- xs ]
f x q@((l,s):qs)
| Set.member x s = q
| otherwise = (x:l, Set.insert x s) : foldr f qs (g x)
```

And it works!

I got the idea for this trick from the appendix of Okasaki (2000). There’s something similar in Kiselyov (2002).

Allison, Lloyd. 2006. “Circular Programs and Self-Referential Structures.” *Software: Practice and Experience* 19 (2) (October): 99–109. doi:10.1002/spe.4380190202.

Kiselyov, Oleg. 2002. “Pure-functional transformations of cyclic graphs and the Credit Card Transform.” http://okmij.org/ftp/Haskell/AlgorithmsH.html#ccard-transform.

Mokhov, Andrey. 2017. “Algebraic Graphs with Class (Functional Pearl).” In *Proceedings of the 10th ACM SIGPLAN International Symposium on Haskell*, 2–13. Haskell 2017. New York, NY, USA: ACM. doi:10.1145/3122955.3122956.

Okasaki, Chris. 2000. “Breadth-first Numbering: Lessons from a Small Exercise in Algorithm Design.” In *Proceedings of the Fifth ACM SIGPLAN International Conference on Functional Programming*, 131–136. ICFP ’00. New York, NY, USA: ACM. doi:10.1145/351240.351253.

Smith, Leon P. 2009. “Lloyd Allison’s Corecursive Queues: Why Continuations Matter.” *The Monad.Reader* 14 (14) (July): 28.

Part 2 of a 2-part series on Prime Sieves

Tags: Agda

Prime numbers in Agda are *slow*. First, they’re Peano-based, so a huge chunk of optimizations we might make in other languages are out of the window. Second, we really often want to *prove* that they’re prime, so the generation code has to carry verification logic with it (I won’t do that today, though). And third, as always in Agda, you have to convince the compiler of termination. With all of that in mind, let’s try and write a (very slow, very basic) prime sieve in Agda.

First, we can make an “array” of numbers that we cross off as we go.

```
primes : ∀ n → List (Fin n)
primes zero = []
primes (suc zero) = []
primes (suc (suc zero)) = []
primes (suc (suc (suc m))) = sieve (tabulate (just ∘ Fin.suc))
where
cross-off : Fin _ → List (Maybe (Fin _)) → List (Maybe (Fin _))
sieve : List (Maybe (Fin _)) → List (Fin _)
sieve [] = []
sieve (nothing ∷ xs) = sieve xs
sieve (just x ∷ xs) = suc x ∷ sieve (cross-off x xs)
cross-off p fs = foldr f (const []) fs p
where
B = ∀ {i} → Fin i → List (Maybe (Fin (2 + m)))
f : Maybe (Fin (2 + m)) → B → B
f _ xs zero = nothing ∷ xs p
f x xs (suc y) = x ∷ xs y
```

Very simple so far: we run through the list, filtering out the multiples of each prime as we see it. Unfortunately, this won’t pass the termination checker. This recursive call to `sieve`

is the problem:

Agda finds if a function is terminating by checking that at least one argument gets (structurally) smaller on every recursive call. `sieve`

only takes one argument (the input list), so that’s the one that needs to get smaller. In the line above, if we replaced it with the following:

We’d be good to go: `xs`

is definitely smaller than `(just x ∷ xs)`

. `cross-off x xs`

, though? The thing is, `cross-off`

returns a list of the same length that it’s given. But the function call is opaque: Agda can’t automatically see the fact that the length stays the same. Reaching for a proof here is the wrong move, though: you can get all of the same benefit by switching out the list for a length-indexed vector.

```
primes : ∀ n → List (Fin n)
primes zero = []
primes (suc zero) = []
primes (suc (suc zero)) = []
primes (suc (suc (suc m))) = sieve (tabulate (just ∘ Fin.suc))
where
cross-off : ∀ {n} → Fin _ → Vec (Maybe _) n → Vec (Maybe _) n
sieve : ∀ {n} → Vec (Maybe (Fin (2 + m))) n → List (Fin (3 + m))
sieve [] = []
sieve (nothing ∷ xs) = sieve xs
sieve (just x ∷ xs) = suc x ∷ sieve (cross-off x xs)
cross-off p fs = foldr B f (const []) fs p
where
B = λ n → ∀ {i} → Fin i → Vec (Maybe (Fin (2 + m))) n
f : ∀ {n} → Maybe (Fin (2 + m)) → B n → B (suc n)
f _ xs zero = nothing ∷ xs p
f x xs (suc y) = x ∷ xs y
```

Actually, my explanation above is a little bit of a lie. Often, the way I think about dependently-typed programs has a lot to do with my intuition for “proofs” and so on. But this leads you down the wrong path (and it’s why writing a proof that `cross-off`

returns a list of the same length is the wrong move).

The actual termination checking algorithm is very simple, albeit strict: the argument passed recursively must be *structurally* smaller. That’s it. Basically, the recursive argument has to be contained in one of the arguments passed. It has nothing to do with Agda “seeing” inside the function `cross-off`

or anything like that. What we’ve done above (to make it terminate) is add another argument to the function: the length of the vector. The argument is implicit, but if we were to make it explicit in the recursive call:

We can see that it does indeed get structurally smaller.

A simple improvement we should be able to make is stopping once we hit the square root of the limit. Since we don’t want to be squaring as we go, we’ll use the following identity:

$(n + 1)^2 = n^2 + 2n + 1$

to figure out the square of the next number from the previous. In fact, we’ll just pass in the limit, and reduce it by $2n + 1$ each time, until it reaches zero:

```
primes : ∀ n → List (Fin n)
primes zero = []
primes (suc zero) = []
primes (suc (suc zero)) = []
primes (suc (suc (suc m))) = sieve 1 m (Vec.tabulate (just ∘ Fin.suc ∘ Fin.suc))
where
cross-off : ∀ {n} → ℕ → Vec (Maybe _) n → Vec (Maybe _) n
sieve : ∀ {n} → ℕ → ℕ → Vec (Maybe (Fin (3 + m))) n → List (Fin (3 + m))
sieve _ zero = List.mapMaybe id ∘ Vec.toList
sieve _ (suc _) [] = []
sieve i (suc l) (nothing ∷ xs) = sieve (suc i) (l ∸ i ∸ i) xs
sieve i (suc l) (just x ∷ xs) = x ∷ sieve (suc i) (l ∸ i ∸ i) (cross-off i xs)
cross-off p fs = Vec.foldr B f (const []) fs p
where
B = λ n → ℕ → Vec (Maybe (Fin (3 + m))) n
f : ∀ {i} → Maybe (Fin (3 + m)) → B i → B (suc i)
f _ xs zero = nothing ∷ xs p
f x xs (suc y) = x ∷ xs y
```

A slight variation on the code above (the first version) will give us the prime factors of a number:

```
primeFactors : ∀ n → List (Fin n)
primeFactors zero = []
primeFactors (suc zero) = []
primeFactors (suc (suc zero)) = []
primeFactors (suc (suc (suc m))) = sieve (Vec.tabulate (just ∘ Fin.suc))
where
sieve : ∀ {n} → Vec (Maybe (Fin (2 + m))) n → List (Fin (3 + m))
sieve [] = []
sieve (nothing ∷ xs) = sieve xs
sieve (just x ∷ xs) = Vec.foldr B remove b xs sieve x
where
B = λ n → ∀ {i}
→ (Vec (Maybe (Fin (2 + m))) n
→ List (Fin (3 + m)))
→ Fin i
→ List (Fin (3 + m))
b : B 0
b k zero = suc x ∷ k []
b k (suc _) = k []
remove : ∀ {n} → Maybe (Fin (2 + m)) → B n → B (suc n)
remove y ys k zero = ys (k ∘ (nothing ∷_)) x
remove y ys k (suc j) = ys (k ∘ (y ∷_)) j
```

Adding the squaring optimization complicates things significantly:

```
primeFactors : ∀ n → List (Fin n)
primeFactors zero = []
primeFactors (suc zero) = []
primeFactors (suc (suc zero)) = []
primeFactors (suc (suc (suc m))) = sqr (suc m) m suc sieve
where
_2F-_ : ∀ {n} → ℕ → Fin n → ℕ
x 2F- zero = x
zero 2F- suc y = zero
suc zero 2F- suc y = zero
suc (suc x) 2F- suc y = x 2F- y
sqr : ∀ n
→ ℕ
→ (Fin n → Fin (2 + m))
→ (∀ {i} → Vec (Maybe (Fin (2 + m))) i → ℕ → List (Fin (3 + m)))
→ List (Fin (3 + m))
sqr n zero f k = k [] n
sqr zero (suc l) f k = k [] zero
sqr (suc n) (suc l) f k =
let x = f zero
in sqr n (l 2F- x) (f ∘ suc) (k ∘ (just x ∷_))
sieve : ∀ {n} → Vec (Maybe (Fin (2 + m))) n → ℕ → List (Fin (3 + m))
sieve xs′ i = go xs′
where
go : ∀ {n} → Vec (Maybe (Fin (2 + m))) n → List (Fin (3 + m))
go [] = []
go (nothing ∷ xs) = go xs
go (just x ∷ xs) = Vec.foldr B remove (b i) xs x go
where
B = λ n → ∀ {i}
→ Fin i
→ (Vec (Maybe (Fin (2 + m))) n → List (Fin (3 + m)))
→ List (Fin (3 + m))
b : ℕ → B 0
b zero zero k = suc x ∷ k []
b zero (suc y) k = k []
b (suc n) zero k = b n x k
b (suc n) (suc y) k = b n y k
remove : ∀ {n} → Maybe (Fin (2 + m)) → B n → B (suc n)
remove y ys zero k = ys x (k ∘ (nothing ∷_))
remove y ys (suc j) k = ys j (k ∘ (y ∷_))
```

The above sieve aren’t “true” in that each `remove`

is linear, so the performance is $\mathcal{O}(n^2)$ overall. This is the same problem we ran into with the naive infinite sieve in Haskell.

Since it bears such a similarity to the infinite sieve, we have to ask: can *this* sieve be infinite? Agda supports a notion of infinite data, so it would seem like it:

```
infixr 5 _◂_
record Stream (A : Set) : Set where
constructor _◂_
coinductive
field
head : A
tail : Stream A
open Stream
primes : Stream ℕ
primes = sieve 1 nats
where
nats : Stream ℕ
head nats = 0
tail nats = nats
sieve : ℕ → Stream ℕ → Stream ℕ
head (sieve i xs) = suc i
tail (sieve i xs) = remove i (head xs) (tail xs) (sieve ∘ suc ∘ (_+ i))
where
remove : ℕ → ℕ → Stream ℕ → (ℕ → Stream ℕ → Stream ℕ) → Stream ℕ
remove zero zero zs k = remove i (head zs) (tail zs) (k ∘ suc)
remove zero (suc z) zs k = remove i z zs (k ∘ suc)
remove (suc y) zero zs k = k zero (remove y (head zs) (tail zs) _◂_)
remove (suc y) (suc z) zs k = remove y z zs (k ∘ suc)
```

But this won’t pass the termination checker. What we actually need to prove to do so is that there are infinitely many primes: a nontrivial task in Agda.

]]>One of the favorite pastimes of both Haskell and Agda programmers alike is verifying data structures. Among my favorite examples are Red-Black trees (Might 2015; Weirich 2014, verified for balance), perfect binary trees (Hinze 1999), square matrices (Okasaki 1999a), search trees (McBride 2014, verified for balance and order), and binomial heaps (Hinze 1998, verified for structure).

There are many ways to verify data structures. One technique which has had recent massive success is to convert Haskell code to Coq, and then verify the Coq translation: this was the route taken by Breitner et al. (2018) to verify `Set`

and `IntSet`

in containers (a mammoth achievement, in my opinion).

This approach has some obvious advantages: you separate implementation from testing (which is usually a good idea), and your verification language can be different from your implementation language, with each tailored towards its particular domain.

LiquidHaskell (Bakst et al. 2018) (and other tools like it) adds an extra type system to Haskell tailor-made for verification. The added type system (refinement types) is more automated (the typechecker uses Z3), more suited for “invariant”-like things (it supports subtyping), and has a bunch of domain-specific built-ins (reasoning about sets, equations, etc.). I’d encourage anyone who hasn’t used it to give it a try: especially if you’re experienced writing any kind of proof in a language like Agda or Idris, LiquidHaskell proofs are *shockingly* simple and easy.

What I’m going to focus on today, though, is writing *correct-by-construction* data structures, using Haskell and Agda’s own type systems. In particular, I’m going to look at how to write *fast* verification. In the other two approaches, we don’t really care about the “speed” of the proofs: sure, it’s nice to speed up compilation and so on, but we don’t have to worry about our implementation suffering at runtime because of some complex proof. When writing correct-by-construction code, though, our task is doubly hard: we now have to worry about the time complexity of both the implementation *and the proofs*.

In this post, I’m going to demonstrate some techniques to write proofs that stay within the complexity bounds of the algorithms they’re verifying (without cheating!). Along the way I’m going to verify some data structures I haven’t seen verified before (a skew-binary random-access list).

To demonstrate the first two techniques, we’re going to write a type for modular arithmetic. For a more tactile metaphor, think of the flip clock:

Each digit can be incremented $n$ times, where $n$ is whatever base you’re using (12 for our flip-clock above). Once you hit the limit, it flips the next digit along. We’ll start with just one digit, and then just string them together to get our full type. That in mind, our “digit” type has two requirements:

- It should be incrementable.
- Once it hits its limit, it should flip back to zero, and let us know that a flip was performed.

Anyone who’s used a little Agda or Idris will be familiar with the `Fin`

type:

`Fin n`

is the standard way to encode “numbers smaller than `n`

”. However, for digits they’re entirely unsuitable: since the limit parameter changes on successor, the kind of increment we want is $\mathcal{O}(n)$:

```
try-suc : ∀ {n} → Fin n → Maybe (Fin n)
try-suc (suc x) = Maybe.map suc (try-suc x)
try-suc {suc n} zero with n
... | zero = nothing
... | suc _ = just (suc zero)
suc-flip : ∀ {n} → Fin n → Fin n × Bool
suc-flip {suc n} x = maybe (_, false) (zero , true) (try-suc x)
suc-flip {zero} ()
```

If we keep going down this path with proofs in mind, we might next look at the various $\leq$ proofs in the Agda standard library (here, here, and here), and see if we can we can wrangle them into doing what we want.

For me, though, this wasn’t a fruitful approach. Instead, we’ll try and think of how we’d do this without proving anything, and then see if there’s any place in the resulting data structure we can hang some proof.

So, in an unproven way, let’s start with some numbers. Since we’re going to be incrementing, they’d better be unary:

And then, for the “flippable” type, we’ll just store the limit alongside the value:

We’re not there yet: to check if we’ve gone over the limit, we’ll still have to compare `val`

and `lim`

. Hopefully you can guess the optimization we’ll make: instead of storing the limit, we’ll store the space left:

And we get our flip function:

```
suc-flip : Flipper → Flipper × Bool
suc-flip (zero & n) = (suc n & zero ), true
suc-flip (suc m & n) = (m & suc n), false
```

When there’s no space left, the digit must be maximal (9 in decimal, for instance), so it’ll be one less than the base. That lets us stick it in for the base, rather than recalculating. In the other case, we just take one from the space left, and add it to the value.

So, to “prove” this implementation, we might first reach for an equality proof that `val + space`

is equal to your base. Don’t! Both `val`

and `space`

are inductive structures, which could be giving us information on every application of `suc`

! Let’s set our sights on `val`

and see how we can hang our proofs off of it.

We’re going to upgrade our Peano number with some information, which means that our resulting type is going to look an awful lot like a Peano number. In other words, two cases: `zero`

and `suc`

.

For the `suc-case`

, remember we only want to be allowed to increment it when the space left is more than zero. So let’s encode it:

And for the `zero-case`

, the space left is just the base. So let’s stick the base into the type as well:

```
data Val (base : ℕ) : ℕ → Set where
zero-case : Val base base
suc-case : ∀ {space} → Val base (suc space) → Val base space
```

(We’ve changed around the way “base” works: it’s now one smaller. So to encode base-10 you’d have `Val 9 space`

. You can get back to the other encoding with a simple wrapper, this way just makes things slightly easier from now on).

Finally, our flipper:

```
record Flipper (base : ℕ) : Set where
constructor _&_
field
space : ℕ
val : Val base space
suc-flip : ∀ {n} → Flipper n → Flipper n × Bool
suc-flip (zero & m) = (_ & zero-case) , true
suc-flip (suc n & m) = (n & suc-case m) , false
```

Great! Everything works.

You may have noticed that the `Val`

type is actually a proof for $\geq$ in disguise:

And the flipper itself is just an existential in disguise:

```
Flipper : ℕ → Set
Flipper n = ∃ (n ≥_)
suc-flip : ∀ {n} → Flipper n → Flipper n × Bool
suc-flip (zero , m) = (_ , m≥m ), true
suc-flip (suc n , m) = (n , m≥p m), false
```

Hopefully this explanation will help you understand how to get from the specification to those 8 lines. This technique is going to come in especially handy later when we base data structures off of number systems.

For this next trick, we’ll add an extra operation to the flipper type above: conversion from a natural number. We want to be able to do it in $\mathcal{O}(n)$ time, and we won’t allow ourselves to change the original type definition. Here’s the type we’re aiming for:

We pass in a proof that the natural number we’re converting from is indeed in range (it’s marked irrelevant so we don’t pay for it). Here’s a non-answer:

While this looks fine, it’s actually the *inverse* of what we want. We defined the inductive structure to be indicated by the inequality proof itself. Let’s make the desired output explicit:

```
toNat : ∀ {n m} → n ≥ m → ℕ
toNat m≥m = zero
toNat (m≥p n≥m) = suc (toNat n≥m)
fromNat-≡ : ∀ {n} m
→ .(n≥m : n ≥ m)
→ Σ[ n-m ∈ Flipper n ] toNat (proj₂ n-m) ≡ m
```

And finally we can try an implementation:

In the `???`

there, we want some kind of successor function. The problem is that we would also need to prove that we *can* do a successor call. Except we don’t want to do that: proving that there’s space left is an expensive operation, and one we can avoid with another trick: first, we *assume* that there’s space left.

```
fromNat-≡ zero n≥m = ( _ , m≥m) , refl
fromNat-≡ (suc n) n≥m with fromNat-≡ n (m≥p n≥m)
... | (suc space , n-1), x≡m = (space , m≥p n-1), cong suc x≡m
... | (zero , n-1), refl = ???
```

But what about the second case? Well, we have to prove this impossible. What if it’s an extremely complex, expensive proof? It doesn’t matter! It will never be run! In contrast to proving the “happy path” correct, if we can confine all of the ugly complex cases to the unhappy paths, we can spend as long as we want proving them impossible without having to worry about runtime cost. Here’s the full function.

`fromNat`

implementation ```
fromNat-≡ : ∀ {n} m
→ .(n≥m : n ≥ m)
→ Σ[ n-m ∈ Flipper n ] toNat (proj₂ n-m) ≡ m
fromNat-≡ zero n≥m = ( _ , m≥m) , refl
fromNat-≡ (suc n) n≥m with fromNat-≡ n (m≥p n≥m)
... | (suc space , n-1), x≡m = (space , m≥p n-1), cong suc x≡m
... | (zero , n≥0), refl = Irrel.⊥-elim (contra _ zero n≥0 n≥m)
where
import Data.Nat.Properties as Prop
n≱sk+n : ∀ n k {sk+n} → sk+n ≡ suc k ℕ.+ n → n ≥ sk+n → ⊥
n≱sk+n n k wit (m≥p n≥sk+n) = n≱sk+n n (suc k) (cong suc wit) n≥sk+n
n≱sk+n n k wit m≥m with Prop.+-cancelʳ-≡ 0 (suc k) wit
... | ()
contra : ∀ n m → (n≥m : n ≥ m) → n ≥ suc (m ℕ.+ toNat n≥m) → ⊥
contra n m m≥m n≥st = n≱sk+n n zero (cong suc (Prop.+-identityʳ n)) n≥st
contra n m (m≥p n≥m) n≥st =
contra
n
(suc m)
n≥m
(subst (λ x → n ≥ suc x) (Prop.+-suc m (toNat n≥m)) n≥st)
fromNat : ∀ {n} m → .(n≥m : n ≥ m) → Flipper n
fromNat m n≥m = proj₁ (fromNat-≡ m n≥m)
```

We’re going to switch into Haskell now, and in particular to functional arrays. These are data structures which aren’t real arrays, but they offer you the kind of interface you’d want from an array in a functional setting. You can’t get better than $\mathcal{O}(\log n)$ indexing, unfortunately (Ben-Amram and Galil 1992), but often it’s enough.

The first “functional array” we’re going to be looking at nested binary random-access lists. It has $\mathcal{O}(\log n)$ indexing, as you might expect, and amortized single-threaded $\mathcal{O}(1)$ `cons`

.

It starts out like a binary random-access list (“random-access list” is another name for “functional array”). You can find a full explanation of the structure in your nearest copy of Purely Functional Data Structures (Okasaki 1999b), but briefly: the structure mimics a binary number, in that it’s a list of “bits”. At each set bit, it stores a tree with $2^i$ elements, where $i$ is the position in the list. In this way, every binary number $n$ has an analogous list of “bits” which contains, in total, $n$ elements.

The “nested” part refers to how we’re going to implement the trees. It works a little like this:

You might have to squint at that definition for a second to understand it: instead of storing two trees at the `Node`

constructor (which is what you’d usually do), we store a tree with double the elements. This has two advantages: all of the children have the same number of elements (this tree, for instance, is always some power of 2), and it also cuts down on memory use.

For the binary random-access list, we’ll use the nested encoding of trees to encode the contents of each bit. There’s an implementation of this very thing on Hackage (Komuves and Divianszky 2016), and Okasaki himself wrote something very similar to it (1999a), but we’re going to go a little further than both of those by indexing the type by its size. Here it is:

```
data Bit = O | I
data Seq ns a where
Nil :: Seq '[] a
Even :: Seq xs (a,a) -> Seq (O : xs) a
Odd :: a -> Seq xs (a,a) -> Seq (I : xs) a
```

The operations we’re interested will be `cons`

and `uncons`

: for the indices, they correspond to incrementing and decrementing the numbers, respectively. As such, we’ll need type-level functions for those:

```
type family Inc (ns :: [Bit]) :: [Bit] where
Inc '[] = '[I]
Inc (O : xs) = I : xs
Inc (I : xs) = O : Inc xs
```

And now the `cons`

function:

```
cons :: a -> Seq ns a -> Seq (Inc ns) a
cons x Nil = Odd x Nil
cons x (Even xs) = Odd x xs
cons x (Odd y ys) = Even (cons (x,y) ys)
```

However, we’re going to run into trouble if we try to write `uncons`

:

```
type family Dec (ns :: [Bit]) :: [Bit] where
Dec (I : xs) = O : xs
Dec (O : xs) = I : Dec xs
Dec '[] = ???
uncons :: Seq ns a -> (a, Seq (Dec ns) a)
uncons (Odd x xs) = (x, Even xs)
uncons (Even xs) = case uncons xs of
((x,y),ys) -> (x, Odd y ys)
uncons Nil = ???
```

We *should* be able to write this function without returning a `Maybe`

. Because we statically know the size, we can encode “only nonempty sequences”. The problem is that `Seq [] a`

isn’t the only non-empty sequence: there’s also `Seq [O] a`

and `Seq [O,O] a`

, and so on. Our binary number system is redundant, because it contains trailing zeroes.

We could add some kind of proof into the data structure, but that would (again) be expensive. Instead, we can make the index *itself* correct-by-construction, by choosing a non-redundant representation of binary numbers.

Here’s the trick: instead of having a list of bits, we’re going to have a list of “the distance to the next one”. This eliminates the redundancy, and translates into our data structure like so:

```
data N = Z | S N
data Nest n ns a where
Odd :: a -> (Seq ns (a,a)) -> Nest Z ns a
Even :: (Nest n ns (a,a)) -> Nest (S n) ns a
data Seq ns a where
Nil :: Seq '[] a
Cons :: Nest n ns a -> Seq (n : ns) a
```

Lovely! Crucially for our `uncons`

, we now know that any non-empty list of bits is a non-zero list of bits, so we can type “nonempty sequence” easily:

```
type family Dec (n :: N) (ns :: [N]) = (r :: [N]) | r -> n ns where
Dec (S n) ns = Z : Dec n ns
Dec Z '[] = '[]
Dec Z (n : ns) = S n : ns
uncons :: Seq (n : ns) a -> (a, Seq (Dec n ns) a)
uncons (Cons xs') = go xs'
where
go :: Nest n ns a -> (a, Seq (Dec n ns) a)
go (Odd x Nil) = (x, Nil)
go (Odd x (Cons xs)) = (x, Cons (Even xs))
go (Even xs) = case go xs of ((x,y),ys) -> (x, Cons (Odd y ys))
```

We’re still not done, though: here’s our new type family for incrementing things.

```
type family Inc (ns :: [N]) :: [N] where
Inc '[] = '[Z]
Inc (S n : ns) = Z : n : ns
Inc (Z : ns) = Carry (Inc ns)
type family Carry (ns :: [N]) :: [N] where
Carry '[] = '[]
Carry (n : ns) = S n : ns
```

The `Carry`

there is ugly, and that ugliness carries into the `cons`

function:

```
cons :: a -> Seq ns a -> Seq (Inc ns) a
cons x Nil = Cons (Odd x Nil)
cons x' (Cons xs') = go x' xs'
where
go :: a -> Nest n ns a -> Seq (Inc (n:ns)) a
go x (Even xs) = Cons (Odd x (Cons xs))
go x (Odd y Nil) = Cons (Even (Odd (x,y) Nil))
go x (Odd y (Cons ys)) = carry (go (x,y) ys)
carry :: Seq ns (a,a) -> Seq (Carry ns) a
carry Nil = Nil
carry (Cons xs) = Cons (Even xs)
```

To clean it up, we’re going to use another technique.

You occasionally see people wonder about the usual definition of addition on Peano numbers:

It’s very simple, with only two equations. When someone sees the following error, then:

`couldn't match type n with n + 0`

They might be tempted to add it as an equation to the function:

Similarly, when someone sees the other error commonly found with $+$:

`couldn't match type S n + m with n + S m`

They’ll add that equation in too! In fact, that particular equation will provide a valid definition of $+$:

So why is the first definition of + the one almost always used? Because it *maximizes output information from minimal input*. Take the second implementation above, the one with the zero on the right. In this function, we have to look at the second argument in the second clause: in other words, we don’t get to find out about the output until we’ve looked at both `n`

and `m`

. In the usual definition, if you know the first argument is `suc`

something, you also know the *output* must be `suc`

something.

Similarly with the third implementation: we have to examine the first argument in its *entirety* before we wrap the output in a constructor. Yes, we can of course prove that they’re all equivalent, but remember: proofs are expensive, and we’re looking for speed here. So the first definition of $+$ is our best bet, since it tells us the most without having to prove anything.

Looking back at our definition of `Inc`

, we can actually provide more information a little sooner:

```
type family Inc (ns :: [N]) :: [N] where
Inc '[] = '[Z]
Inc (S n : ns) = Z : n : ns
Inc (Z : ns) = Carry (Inc ns)
```

In all of the outputs, the list is non-empty. We can encode that, by having two different functions for the head and tail of the list:

```
type family IncHead (ns :: [N]) :: N where
IncHead '[] = Z
IncHead (n : ns) = IncHead' n ns
type family IncHead' (n :: N) (ns :: [N]) :: N where
IncHead' (S n) ns = Z
IncHead' Z ns = S (IncHead ns)
type family IncTail (ns :: [N]) :: [N] where
IncTail '[] = '[]
IncTail (n : ns) = IncTail' n ns
type family IncTail' (n :: N) (ns :: [N]) :: [N] where
IncTail' (S n) ns = n : ns
IncTail' Z ns = IncTail ns
type Inc (ns :: [N]) = IncHead ns : IncTail ns
```

This tells the typechecker that we’re not returning an empty sequence right away, so we don’t have to pattern-match to prove it later, giving us a more efficient function.

```
cons :: a -> Seq ns a -> Seq (Inc ns) a
cons x' xs' = Cons (go x' xs')
where
go :: a -> Seq ns a -> Nest (IncHead ns) (IncTail ns) a
go x Nil = Odd x Nil
go x (Cons (Even xs)) = Odd x (Cons xs)
go x (Cons (Odd y ys)) = Even (go (x,y) ys)
```

Briefly after introducing the binary random-access list, Okasaki describes the *skew-binary* random-access list. As well as having the same indexing cost as the type above, it supports $\mathcal{O}(1)$ `cons`

. But wait—didn’t the previous structure have $\mathcal{O}(1)$ `cons`

? Not really. Unfortunately, in a pure functional setting, imperative-style amortization measurements aren’t always valid. Say we perform a `cons`

in the worst case, and it takes $\log n$ time. In an imperative setting, that’s no problem, because all of the rest of the operations are not going to be on the worst-case. In a pure setting, though, the old structure is still sitting around. You can still access it, and you can still get that awful worst-case time.

This is where the skew binary tree comes in. It’s based on the skew binary numbers: these work similarly to binary, but you’re allowed have (at most) a single 2 digit before any ones. This gives you $\mathcal{O}(1)$ incrementing and decrementing, which is what we need here. Let’s get started.

First, our type-level numbers. We’re going to use the sparse encoding as above, but we need some way to encode “you’re only allowed one 2”. The most lightweight way to do it I can think of is by implicitly assuming the second number in the list of gaps is one less than the others. In other words, we encode a 2 with `[n, 0, m]`

. That `0`

means that at position `n`

there’s a 2, not a 1.

The corresponding type families for increment and decrement are clearly $\mathcal{O}(1)$:

```
type family Inc (ns :: [N]) = (ms :: [N]) | ms -> ns where
Inc '[] = Z : '[]
Inc (x : '[]) = Z : x : '[]
Inc (x : Z : xs) = S x : xs
Inc (x1 : S x2 : xs) = Z : x1 : x2 : xs
type family Dec (n :: N) (ns :: [N]) = (ms :: [N]) | ms -> n ns where
Dec (S x) xs = x : Z : xs
Dec Z '[] = '[]
Dec Z (x : '[]) = x : '[]
Dec Z (x1 : x2 : xs) = x1 : S x2 : xs
```

We don’t need to split this into head and tail families as we did before because there’s no recursive call: we know all we’re ever going to know about the output following *any* match on the input.

There’s another problem before we write the implementation: we can’t use the `Nest`

construction that we had before, because then the head would be buried in $\log n$ constructors (or thereabouts). Instead, we’re going to have to use GADTs to encode the “gap” type, alongside the relevant tree. This gap type is going to be very similar to the $\geq$ proof we had for the modular counters, but with an extra parameter:

`Gap n g m`

means there is a gap of `g`

between `n`

and `m`

. Or, stated another way, it means `n + g = m`

. Its inductive structure mimics the `g`

parameter (it’s basically the `g`

parameter itself with some added information).

With all of that together, here’s the definition of the array itself:

```
type family Tree (n :: N) (a :: Type) where
Tree Z a = a
Tree (S n) a = Node n a
data Node n a = Node a (Tree n a) (Tree n a)
data SeqTail (n :: N) (ns :: [N]) (a :: Type) where
NilT :: SeqTail n '[] a
ConsT :: Gap n g m
-> Tree m a
-> SeqTail (S m) ms a
-> SeqTail n (g : ms) a
data Seq (ns :: [N]) (a :: Type) where
Nil :: Seq '[] a
Cons :: Gap Z g n
-> Tree n a
-> SeqTail n ns a
-> Seq (g : ns) a
```

The `cons`

operation again mimics the increment function, but there’s one final snag before it’ll typecheck:

```
cons :: a -> Seq ns a -> Seq (Inc ns) a
cons x Nil = Cons Zy x NilT
cons x (Cons zn y NilT) = Cons Zy x (ConsT zn y NilT)
cons x (Cons zn y1 (ConsT Zy y2 ys)) = Cons(Sy zn) (Node x y1 y2) ys
cons x (Cons zn y1 (ConsT (Sy nm) y2 ys)) =
Cons Zy x (ConsT zn y1 (ConsT ??? y2 ys))
```

On the final line, the `???`

is missing. In the unverified version, `nm`

would slot right in there. Here, though, if we try it we get an error, which basically amounts to:

At this point, I’d usually throw out the inductive-style proof, and replace it with a proof of equality, which I’d aggressively erase in all of the functions. I said at the beginning I wouldn’t cheat, though, so here’s what I’ll do instead:

```
gapr :: Gap n g m -> Gap (S n) g (S m)
gapr Zy = Zy
gapr (Sy pnm) = Sy (gapr pnm)
cons :: a -> Seq ns a -> Seq (Inc ns) a
cons x Nil = Cons Zy x NilT
cons x (Cons zn y NilT) = Cons Zy x (ConsT zn y NilT)
cons x (Cons zn y1 (ConsT Zy y2 ys)) = Cons (Sy zn) (Node x y1 y2) ys
cons x (Cons zn y1 (ConsT (Sy nm) y2 ys)) =
Cons Zy x (ConsT zn y1 (ConsT (gapr nm) y2 ys))
```

At first glance, we’ve lost the complexity bounds. That `gapr`

operation is $\log n$ (or something), and we’re performing it pretty frequently. We might keep the amortized bounds, but isn’t that not really worthy in a pure setting?

That would all be true, if it weren’t for laziness. Because we *delay* the evaluation of `gapr`

, we won’t have to pay for it all in one big thunk. In fact, because it’s basically a unary number, we only have to pay for one part of it at a time. I haven’t yet fully worked out the proofs, but I’m pretty sure we’re guaranteed $\mathcal{O}(1)$ worst-case time here too.

About a year ago, I tried to write a verified version of binomial heaps, which could then be used for sorting traversable containers. Unfortunately, I couldn’t figure out how to write delete-min, and gave up. I *did* recognize that the redundancy of the binary representation was a problem, but I couldn’t figure out much more than that.

Now, though, we have a new non-redundant representation of binary numbers, and some handy techniques to go along with it.

Unfortunately, I ran into a similar roadblock in the implementation. Here’s the point where I was stuck:

```
data Zipper a n xs = Zipper a (Node n a) (Binomial n xs a)
slideLeft :: Zipper a (S n) xs -> Zipper a n (Z : xs)
slideLeft (Zipper m (t :< ts) hs) = Zipper m ts (Cons (Odd t hs))
minView :: Ord a => Binomial n (x : xs) a -> (a, Binomial n (Decr x xs) a)
minView (Cons xs') = unZipper (go xs')
where
unZipper (Zipper x _ xs) = (x, xs)
go :: forall a n x xs. Ord a => Nest n x xs a -> Zipper a n (Decr x xs)
go (Even xs) = slideLeft (go xs)
go (Odd (Root x ts) Empty) = Zipper x ts Empty
go (Odd c@(Root x ts) (Cons xs)) =
case go xs of
(Zipper m (t' :< _) hs)
| m >= x -> Zipper x ts (Cons (Even xs))
| otherwise ->
Zipper m ts
(case hs of
Empty -> Cons (Even (Odd (mergeTree c t') Empty))
Cons hs' -> Cons (Even (carryOneNest (mergeTree c t') hs')))
```

The last two lines don’t typecheck! The errors were complex, but effectively they stated:

`Could not deduce`

`x : xs ~ [Z]`

`from the context`

`Decr x xs ~ []`

and:

`Could not deduce`

`x : xs ~ Inc (y : ys)`

`from the context`

`Decr x xs ~ y : ys`

The thing is, all of those look pretty provable. So, for this technique, we first figure out what proofs we need, and *assume* we have them. This means changing `minView`

to the following:

```
data Zipper a n xs = Zipper a (Node n a) (Binomial n xs a)
slideLeft :: Zipper a (S n) xs -> Zipper a n (Z : xs)
slideLeft (Zipper m (t :< ts) hs) = Zipper m ts (Cons (Odd t hs))
minView :: Ord a => Binomial n (x : xs) a -> (a, Binomial n (Decr x xs) a)
minView (Cons xs') = unZipper (go xs')
where
unZipper (Zipper x _ xs) = (x, xs)
go :: forall a n x xs. Ord a => Nest n x xs a -> Zipper a n (Decr x xs)
go (Even xs) = slideLeft (go xs)
go (Odd (Root x ts) Empty) = Zipper x ts Empty
go (Odd c@(Root x ts) (Cons xs)) =
case go xs of
(Zipper m (t' :< _) (hs :: Binomial (S n) (Decr y ys) a))
| m >= x -> Zipper x ts (Cons (Even xs))
| otherwise ->
Zipper m ts
(case hs of
Empty -> gcastWith (lemma1 @y @ys Refl)
Cons (Even (Odd (mergeTree c t') Empty))
Cons hs' -> gcastWith (lemma2 @y @ys Refl)
Cons (Even (carryOneNest (mergeTree c t') hs')))
```

And writing in the templates for our lemmas:

```
lemma1 :: forall x xs. Decr x xs :~: '[] -> x : xs :~: Z : '[]
lemma1 = _
lemma2 :: forall x xs y ys. Decr x xs :~: y : ys -> x : xs :~: Inc (y : ys)
lemma2 = _
```

We now need to provide the *implementations* for `lemma1`

and `lemma2`

. With this approach, even if we fail to do the next steps, we can cop out here and sub in `unsafeCoerce Refl`

in place of the two proofs, maintaining the efficiency. We won’t need to, though!

Unlike in Agda, the types for those proofs won’t be around at runtime, so we won’t have anything to pattern match on. We’ll need to look for things in the surrounding area which could act like singletons for the lemmas.

It turns out that the `xs`

and `hs'`

floating around can do exactly that: they tell us about the type-level `y`

and `x`

. So we just pass them to the lemmas (where they’re needed). This changes the last 4 lines of `minView`

to:

```
Empty -> gcastWith (lemma1 Refl xs)
Cons (Even (Odd (mergeTree c t') Empty))
Cons hs' -> gcastWith (lemma2 Refl xs hs')
Cons (Even (carryOneNest (mergeTree c t') hs'))
```

Now, we just have to fill in the lemmas! If we were lucky, they’d actually be constant-time.

```
lemma1 :: forall x xs n a. Decr x xs :~: '[]
-> Nest n x xs a
-> x : xs :~: Z : '[]
lemma1 Refl (Odd _ Empty) = Refl
lemma2 :: forall x xs y ys n a.
Decr x xs :~: y : ys
-> Nest n x xs a
-> Nest n y ys a
-> x : xs :~: Inc (y : ys)
lemma2 Refl (Even (Odd _ Empty)) (Odd _ Empty) = Refl
lemma2 Refl (Odd _ (Cons _)) (Even _) = Refl
lemma2 Refl (Even xs) (Odd _ (Cons ys)) =
gcastWith (lemma2 Refl xs ys) Refl
```

If they *had* been constant-time, that would have let us throw them out: each proof would essentially show you what cases needed to be scrutinized to satisfy the typechecker. You then just scrutinize those cases in the actual function, and it should all typecheck.

As it is, `lemma2`

is actually ok. It does cost $\mathcal{O}(\log n)$, but so does `carryOneNest`

: we’ve maintained the complexity! We *could* stop here, satisfied.

There’s another option, though, one that I picked up from Stephanie Weirich’s talk (2017): you thread the requirement through the function as an equality constraint. It won’t always work, but when your function’s call graph matches that of the proof, the constraint will indeed be satisfied, with no runtime cost. In this case, we can whittle down the proof obligation to the following:

Now we change the recursive `go`

into continuation-passing style, and add that constraint to its signature, and everything works!

```
minView :: Ord a => Binomial n (x : xs) a -> (a, Binomial n (Decr x xs) a)
minView (Cons xs') = go xs' \(Zipper x _ xs) -> (x,xs)
where
go :: Ord a
=> Nest n x xs a
-> (Inc (Decr x xs) ~ (x : xs) => Zipper a n (Decr x xs) -> b) -> b
go (Even xs) k = go xs \(Zipper m (t :< ts) hs) -> k (Zipper m ts (Cons (Odd t hs)))
go (Odd (Root x ts) Empty) k = k (Zipper x ts Empty)
go (Odd c@(Root x cs) (Cons xs)) k =
go xs
\case
Zipper m _ _ | m >= x ->
k (Zipper x cs (Cons (Even xs)))
Zipper m (t :< ts) Empty ->
k (Zipper m ts (Cons (Even (Odd (mergeTree c t) Empty))))
Zipper m (t :< ts) (Cons hs) ->
k (Zipper m ts (Cons (Even (carryOneNest (mergeTree c t) hs))))
```

As I mentioned in the beginning, a huge amount of this stuff is *much* easier using other systems. On top of that, there’s currently a lot of work being done on dependent type erasure, so that proofs like the above don’t even exist at runtime. In other words, there’s a chance that all of these techniques will soon be useless!

Efficient proof-carrying code makes for an interesting puzzle, though, even if it is a bit of a hair shirt.

Fuller implementations of the structures here are in this git repository.

Bakst, Alexander, Ranjit Jhala, Ming Kawaguchi, Patrick Rondon, Eric Seidel, Michael Smith, Anish Tondwalkar, Chris Tetreault, and Niki Vazou. 2018. “LiquidHaskell: Liquid Types For Haskell.” ucsd-progsys. https://github.com/ucsd-progsys/liquidhaskell.

Ben-Amram, Amir M., and Zvi Galil. 1992. “On Pointers Versus Addresses.” *J. ACM* 39 (3) (July): 617–648. doi:10.1145/146637.146666. http://doi.acm.org/10.1145/146637.146666.

Breitner, Joachim, Antal Spector-Zabusky, Yao Li, Christine Rizkallah, John Wiegley, and Stephanie Weirich. 2018. “Ready, Set, Verify! Applying Hs-to-coq to Real-world Haskell Code (Experience Report).” *Proc. ACM Program. Lang.* 2 (ICFP) (July): 89:1–89:16. doi:10.1145/3236784. http://doi.acm.org/10.1145/3236784.

*Numerical Representations as Higher-Order Nested Datatypes*. Institut für Informatik III, Universität Bonn. http://www.cs.ox.ac.uk/ralf.hinze/publications/\#R5.

———. 1999. *Perfect Trees and Bit-reversal Permutations*.

Komuves, Balazs, and Peter Divianszky. 2016. “Nested-sequence: List-like data structures with O(Log(n)) random access.” http://hackage.haskell.org/package/nested-sequence.

McBride, Conor Thomas. 2014. “How to Keep Your Neighbours in Order.” In *Proceedings of the 19th ACM SIGPLAN International Conference on Functional Programming*, 297–309. ICFP ’14. New York, NY, USA: ACM. doi:10.1145/2628136.2628163. https://personal.cis.strath.ac.uk/conor.mcbride/pub/Pivotal.pdf.

Might, Matthew. 2015. “Missing method: How to delete from Okasaki’s red-black trees.” *matt.might.net*. http://matt.might.net/articles/red-black-delete/.

Okasaki, Chris. 1999a. “From Fast Exponentiation to Square Matrices: An Adventure in Types.” In *Proceedings of the ACM SIGPLAN International Conference on Functional Programming (ICFP’99), Paris, France, September 27-29, 1999*, 34:28. ACM. http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.456.357\&rep=rep1\&type=pdf.

———. 1999b. *Purely Functional Data Structures*. Cambridge University Press.

Weirich, Stephanie. 2014. “Depending on Types.” In *Proceedings of the 19th ACM SIGPLAN International Conference on Functional Programming*, 241–241. ICFP ’14. New York, NY, USA: ACM. doi:10.1145/2628136.2631168. https://www.cis.upenn.edu/~sweirich/talks/icfp14.pdf.

———. 2017. “Dependent Types in Haskell.” St. Louis, MO, USA. https://www.youtube.com/watch?v=wNa3MMbhwS4.

Part 1 of a 2-part series on Prime Sieves

Tags: Haskell

A few days ago, the Computerphile YouTube channel put up a video about infinite lists in Haskell (Haran 2018). It’s pretty basic, but finishes up with a definition of an infinite list of prime numbers. The definition was something like this:

This really demonstrates the elegance of list comprehensions coupled with lazy evaluation. If we’re being totally pedantic, however, this *isn’t* a genuine sieve of Eratosthenes. And this makes sense: the “true” sieve of Eratosthenes (O’Neill 2009) is probably too complex to demonstrate in a video meant to be an introduction to Haskell. This isn’t because Haskell is bad at this particular problem, mind you: it’s because a lazy, infinite sieve is something very hard to implement indeed.

Anyway, I’m going to try today to show a very simple prime sieve that (hopefully) rivals the simplicity of the definition above.

Visualizations of the sieve of Eratosthenes often rely on metaphors of “crossing out” on some large table. Once you hit a prime, you cross off all of its multiples in the rest of the table, and then you move to the next crossed-off number.

Working with a finite array, it should be easy to see that this is extremely efficient. You’re crossing off every non-prime exactly once, only using addition and squaring.

To extend it to infinite lists, we will use the following function:

```
[] \\ ys = []
xs \\ [] = xs
(x:xs) \\ (y:ys) = case compare x y of
LT -> x : xs \\ (y:ys)
EQ -> xs \\ ys
GT -> (x:xs) \\ ys
```

We’re “subtracting” the right list from the left. Crucially, it works with infinite lists:

Finally, it only works if both lists are ordered and don’t contain duplicates, but our sieve does indeed satisfy that requirement. Using this, we’ve already got a sieve:

No division, just addition and squaring, as promised. Unfortunately, though, this doesn’t have the time complexity we want. See, in the `(\\)`

operation, we have to test every entry in the sieve against the prime factor: when we’re crossing off from an array, we just jump to the next composite number.

The way we speed up the “crossing-off” section of the algorithms is by using a priority queue: this was the optimization provided in O’Neill (2009). Before we go any further, then, let’s put one together:

```
infixr 5 :-
data Queue a b = Queue
{ minKey :: !a
, minVal :: b
, rest :: List a b
}
data List a b
= Nil
| (:-) {-# UNPACK #-} !(Queue a b)
(List a b)
(<+>) :: Ord a => Queue a b -> Queue a b -> Queue a b
(<+>) q1@(Queue x1 y1 ts1) q2@(Queue x2 y2 ts2)
| x1 <= x2 = Queue x1 y1 (q2 :- ts1)
| otherwise = Queue x2 y2 (q1 :- ts2)
mergeQs :: Ord a => List a b -> Queue a b
mergeQs (t :- ts) = mergeQs1 t ts
mergeQs Nil = errorWithoutStackTrace "tried to merge empty list"
mergeQs1 :: Ord a => Queue a b -> List a b -> Queue a b
mergeQs1 t1 Nil = t1
mergeQs1 t1 (t2 :- Nil) = t1 <+> t2
mergeQs1 t1 (t2 :- t3 :- ts) = (t1 <+> t2) <+> mergeQs1 t3 ts
insert :: Ord a => a -> b -> Queue a b -> Queue a b
insert !k !v = (<+>) (singleton k v)
singleton :: a -> b -> Queue a b
singleton !k !v = Queue k v Nil
```

These are pairing heaps: I’m using them here because they’re relatively simple and very fast. A lot of their speed comes from the fact that the top-level constructor (`Queue`

) is *non-empty*. Since, in this algorithm, we’re only actually going to be working with non-empty queues, this saves us a pattern match on pretty much every function. They’re also what’s used in Data.Sequence for sorting.

With that, we can write our proper sieve:

```
insertPrime x xs = insert (x*x) (map (*x) xs)
adjust x q@(Queue y (z:zs) qs)
| y <= x = adjust x (insert z zs (mergeQs qs))
| otherwise = q
sieve (x:xs) = x : sieve' xs (singleton (x*x) (map (*x) xs))
where
sieve' (x:xs) table
| minKey table <= x = sieve' xs (adjust x table)
| otherwise = x : sieve' xs (insertPrime x xs table)
primes = 2 : sieve [3,5..]
```

The priority queue stores lists alongside their keys: what you might notice is that those lists are simply sequences of the type $[x, 2x, 3x, 4x...]$ and so on. Rather than storing the whole list, we can instead store just the head and the step. This also simplifies (and greatly speeds up) the expensive `map (*x)`

operation to just *two* multiplications. If you wanted, you could just sub in this representation of streams for all the lists above:

```
data Stepper a = Stepper { start :: a, step :: a }
nextStep :: Num a => Stepper a -> (a, Stepper a)
nextStep (Stepper x y) = (x, Stepper (x+y) y)
pattern x :- xs <- (nextStep -> (x,xs))
(^*) :: Num a => Stepper a -> a -> Stepper a
Stepper x y ^* f = Stepper (x * f) (y * f)
```

If you were so inclined, you could even make it conform to `Foldable`

:

```
data Stepper a where
Stepper :: Num a => a -> a -> Stepper a
nextStep (Stepper x y) = (x, Stepper (x+y) y)
pattern x :- xs <- (nextStep -> (x,xs))
instance Foldable Stepper where
foldr f b (x :- xs) = f x (foldr f b xs)
```

But that’s overkill for what we need here.

Second observation is that if we remove the wheel (from 2), the “start” is simply the *key* in the priority queue, again cutting down on space.

Finally, we get the implementation:

```
primes = 2 : sieve 3 (singleton 4 2)
where
adjust !x q@(Queue y z qs)
| x < y = q
| otherwise = adjust x (mergeQs1 (singleton (y + z) z) qs)
sieve !x q
| x < minKey q = x : sieve (x + 1) (insert (x * x) x q)
| otherwise = sieve (x + 1) (adjust x q)
```

8 lines for a lazy prime sieve isn’t bad!

I haven’t tried a huge amount to optimize the function, but it might be worth looking in to how to add back the wheels. I noticed that for no wheels, the queue contains only two elements per key; for one (the 2 wheel), we needed 3. I wonder if this pattern continues: possibly we could represent wheels as finite lists at each key in the queue. Maybe in a later post.

Haran, Brady. 2018. “To Infinity & Beyond - Computerphile.” https://www.youtube.com/watch?v=bnRNiE_OVWA&feature=youtu.be.

O’Neill, Melissa E. 2009. “The Genuine Sieve of Eratosthenes.” *Journal of Functional Programming* 19 (01) (January): 95. doi:10.1017/S0956796808007004.

Part 1 of a 1-part series on Total Combinatorics

Here’s a quick puzzle: from a finite alphabet, produce an infinite list of infinite strings, each of them unique.

It’s not a super hard problem, but here are some examples of what you might get. Given the alphabet of `0`

and `1`

, for instance, you could produce the following:

```
0000000...
1000000...
0100000...
1100000...
0010000...
1010000...
0110000...
1110000...
0001000...
```

In other words, the enumeration of the binary numbers (least-significant-digit first). We’ll just deal with bits first:

```
data Bit = O | I
instance Show Bit where
showsPrec _ O = (:) '0'
showsPrec _ I = (:) '1'
showList xs s = foldr f s xs
where
f O a = '0' : a
f I a = '1' : a
```

Thinking recursively, we can see that the tail of each list is actually the original sequence, doubled-up:

` 0000000... `

1000000...

0100000...

1100000...

0010000...

1010000...

0110000...

1110000...

0001000...

As it happens, we get something like this pattern with the monad instance for lists *anyway*:

Well, actually it’s the wrong way around. We want to loop through the *first* list the quickest, incrementing the second slower. No worries, we can just use a flipped version of `<*>`

:

```
infixl 4 <<>
(<<>) :: Applicative f => f (a -> b) -> f a -> f b
fs <<> xs = flip ($) <$> xs <*> fs
>>> (,) <$> [O,I] <<> "abc"
[(0,'a'),(1,'a'),(0,'b'),(1,'b'),(0,'c'),(1,'c')]
```

Brilliant! So we can write our function now, yes?

Nope! That won’t ever produce an answer, unfortunately.

The issue with our definition above is that it’s not lazy enough: it demands information that it hasn’t produced yet, so it gets caught in an infinite loop before it can do anything!

We need to kick-start it a little, so it can produce output *before* it asks itself for more. Because we know what the first line is going to be, we can just tell it that:

```
bins = (:) <$> [O,I] <<> (repeat O : tail bins)
>>> mapM_ print (take 8 (map (take 3) bins))
000
100
010
110
001
101
011
111
```

The property that this function has that the previous didn’t is *productivity*: the dual of termination. See, we want to avoid a *kind* of infinite loops in `bins`

, but we don’t want to avoid infinite things altogether: the list it produces is meant to be infinite, for goodness’ sake. Instead, what it needs to do is produce every new value in *finite* time.

In total languages, like Agda, termination checking is a must. To express computation like that above, though, you often also want a *productivity* checker. Agda can do that, too.

Let’s get started then. First, a stream:

```
infixr 5 _◂_
record Stream {a} (A : Set a) : Set a where
coinductive
constructor _◂_
field
head : A
tail : Stream A
open Stream
```

In Haskell, there was no need to define a separate stream type: the type of lists contains both finite and infinite lists.

Agda can get a little more specific: here, we’ve used the `coinductive`

keyword, which means we’re free to create infinite `Stream`

s. Rather than the usual termination checking (which would kick in when we consume a recursive, inductive type), we now get productivity checking: when creating a `Stream`

, the `tail`

must always be available in finite time. For a finite type, we’d have used the `inductive`

keyword instead; this wouldn’t be much use, though, since there’s no way to create a finite `Stream`

without a nil constructor!^{1}

One of the interesting things about working with infinite data (when you’re forced to notice that it’s infinite, as you are in Agda) is that *everything* gets flipped. So you have to prove productivity, not totality; you use product types, rather than sums; and to define functions, you use *co*patterns, rather than patterns.

Copatterns are a handy syntactic construct for writing functions about record types. Let’s start with an example, and then I’ll try explain a little:

Here, we’re defining `pure`

on streams: `pure x`

produces an infinite stream of `x`

. Its equivalent would be repeat in Haskell:

Except instead of describing what it *is*, you describe how it *acts* (it’s kind of an intensional vs. extensional thing). In other words, if you want to make a stream `xs`

, you have to answer the questions “what’s the head of `xs`

?” and “what’s the tail of `xs`

?”

Contrast this with pattern-matching: we’re producing (rather than consuming) a value, and in pattern matching, you have to answer a question for each *case*. If you want to consume a list `xs`

, you have to answer the questions “what do you do when it’s nil?” and “what do you do when it’s cons?”

Anyway, I think the symmetry is kind of cool. Let’s get back to writing our functions.

Unfortunately, we don’t have enough to prove productivity yet. As an explanation why, let’s first try produce the famous `fibs`

list. Written here in Haskell:

Instead of `zipWith`

, let’s define `<*>`

. That will let us use idiom brackets.

```
_<*>_ : ∀ {a b} {A : Set a} {B : Set b}
→ Stream (A → B)
→ Stream A
→ Stream B
head (fs <*> xs) = head fs (head xs)
tail (fs <*> xs) = tail fs <*> tail xs
```

And here’s `fibs`

:

But it doesn’t pass the productivity checker! Because we use a higher-order function (`<*>`

), Agda won’t look at how much it dips into the infinite supply of values. This is a problem: we need it to know that `<*>`

only needs the heads of its arguments to produce a head, and so on. The solution? Encode this information in the types.

```
infixr 5 _◂_
record Stream {i : Size} {a} (A : Set a) : Set a where
coinductive
constructor _◂_
field
head : A
tail : ∀ {j : Size< i} → Stream {j} A
open Stream
```

Now, `Stream`

has an implicit *size* parameter. Basically, `Stream {i} A`

can produce `i`

more values. So `cons`

, then, gives a stream one extra value to produce:

```
cons : ∀ {i a} {A : Set a} → A → Stream {i} A → Stream {↑ i} A
head (cons x xs) = x
tail (cons x xs) = xs
```

Conversely, we can write a different definition of `tail`

that consumes one value^{2}:

For `<*>`

, we want to show that its result can produce just as much values as its inputs can:

```
_<*>_ : ∀ {i a b} {A : Set a} {B : Set b}
→ Stream {i} (A → B)
→ Stream {i} A
→ Stream {i} B
head (fs <*> xs) = head fs (head xs)
tail (fs <*> xs) = tail fs <*> tail xs
```

How does this help the termination/productivity checker? Well, for terminating functions, we have to keep giving the `tail`

field smaller and smaller sizes, meaning that we’ll eventually hit zero (and terminate). For productivity, we now have a way to talk about “definedness” in types, so we can make sure that a recursive call doesn’t dip into a supply it hasn’t produced yet.

One more thing: `Size`

types have strange typing rules, mainly for ergonomic purposes (this is why we’re not just using an `ℕ`

parameter). One of them is that if you don’t specify the size, it’s defaulted to `∞`

, so functions written without size annotations don’t have to be changed with this new definition:

Finally `fibs`

:

```
fibs : ∀ {i} → Stream {i} ℕ
head fibs = 0
head (tail fibs) = 1
tail (tail fibs) = ⦇ fibs + tail fibs ⦈
```

Before I show the Agda solution, I’d like to point out some bugs that were revealed in the Haskell version by trying to implement it totally. First of all, the function signature. “Takes an alphabet and produces unique strings” seems like this:

But what should you produce in this case:

So it must be a non-empty list, giving us the following type and definition:

```
strings :: NonEmpty a -> [[a]]
strings (x :| xs) = (:) <$> (x:xs) <<> (repeat x : tail (strings (x :| xs)))
```

But this has a bug too! What happens if we pass in the following:

So this fails the specification: there is only one unique infinite string from that alphabet (`pure x`

). Interestingly, though, our implementation above also won’t produce any output beyond the first element. I suppose, in a way, these things cancel each other out: our function does indeed produce all of the unique strings, it’s just a pity that it goes into an infinite loop to do so!

Finally, we have our function:

```
strings : ∀ {i a} {A : Set a} → A × A × List A → Stream {i} (Stream A)
head (strings (x , _ , _)) = pure x
tail (strings {A = A} xs@(x₁ , x₂ , xt)) = go x₂ xt (strings xs)
where
go : ∀ {i} → A → List A → Stream {i} (Stream A) → Stream {i} (Stream A)
head (head (go y ys zs)) = y
tail (head (go y ys zs)) = head zs
tail (go _ [] zs) = go x₁ (x₂ ∷ xt) (tail zs)
tail (go _ (y ∷ ys) zs) = go y ys zs
```

As you can see, we do need to kick-start it without a recursive call (the first line is `pure x`

). Then, `go`

takes as a third argument the “tails” argument, and does the kind of backwards Cartesian product we want. However, since we’re into the second element of the stream now, we want to avoid repeating what we already said, which is why we have to give `go`

`x₂`

, rather than `x₁`

. This is what forces us to take at least two elements, rather than at least one, also: we can’t just take the tail of the call to `go`

(this is what we did in the Haskell version of `strings`

with the `NonEmpty`

list), as the recursive call to strings then doesn’t decrease in size:

```
strings : ∀ {i a} {A : Set a} → A × List A → Stream {i} (Stream A)
head (strings (x , _)) = pure x
tail (strings {A = A} xs@(x , xt)) = tail (go x xt (strings xs))
where
go : ∀ {i} → A → List A → Stream {i} (Stream A) → Stream {i} (Stream A)
head (head (go y ys zs)) = y
tail (head (go y ys zs)) = head zs
tail (go _ [] zs) = go x xt (tail zs)
tail (go _ (y ∷ ys) zs) = go y ys zs
```

Agda will warn about termination on this function. Now, if you slap a pragma on it, it *will* produce the correct results for enough arguments, but give it one and you’ll get an infinite loop, just as you were warned!

I’m having a lot of fun with copatterns for various algorithms (especially combinatorics). I’m planning on working on two particular tasks with them for the next posts in this series:

- Proving
`strings`

I’d like to prove that

`strings`

does indeed produce a stream of unique values. Following from that, it would be cool to do a Cantor diagonalisation on its output.- Permutations
Haskell’s permutations implementation in Data.List does some interesting tricks to make it as lazy as possible. It would be great to write an implementation that is verified to be as lazy as possible: the pattern of “definedness” is complex, though, so I don’t know if it’s possible with Agda’s current sized types.

Thanks to gelisam for pointing out the poor phrasing here. Updated on 2018/10/16↩

You might wonder why the definition of

`tail`

doesn’t have this signature to begin with. The reason is that our record type must be*parameterized*(not indexed) over its size (as it’s a record type), so we use a less-than proof instead.↩

Part 1 of a 2-part series on Agda Tips

Tags: Agda

I’m in the middle of quite a large Agda project at the moment, and I’ve picked up a few tips and tricks in the past few weeks. I’d imagine a lot of these are quite obvious once you get to grips with Agda, so I’m writing them down before I forget that they were once confusing stumbling blocks. Hopefully this helps other people trying to learn the language!

Agda lets you parameterize modules, just as you can datatypes, with types, values, etc. It’s extremely handy for those situations where you want to be generic over some type, but that type won’t change inside the generic code. The keys to dictionaries is a good example: you can start the module with:

And now, where in Haskell you’d have to write something like `Ord a => Map a`

… in pretty much any function signature, you can just refer to `Key`

, and you’re good to go. It’s kind of like a dynamic type synonym, in that way.

Here’s the strangeness, though: what if you don’t supply one of the arguments?

This won’t give you a type error, strange as it may seem. This will perform *lambda lifting*, meaning that now, every function exported by the module will have the type signature:

Preceding its normal signature. In other words, it changes it into what you would have had to write in Haskell.

This is a powerful feature, but it can also give you some confusing errors if you don’t know about it (especially if the module has implicit arguments).

If you’ve got a hole in your program, you can put the cursor in it and press `SPC-m-a`

(in spacemacs), and Agda will try and find the automatic solution to the problem. For a while, I didn’t think much of this feature, as rare was the program which Agda could figure out. Turns out I was just using it wrong! Into the hole you should type the options for the proof search: enabling case-splitting (`-c`

), enabling the use of available definitions (`-r`

), and listing possible solutions (`-l`

).

Often, a program will not be obviously terminating (according to Agda’s termination checker). The first piece of advice is this: *don’t* use well-founded recursion. It’s a huge hammer, and often you can get away with fiddling with the function (try inlining definitions, rewriting generic functions to monomorphic versions, or replacing with-blocks with helper functions), or using one of the more lightweight techniques out there.

However, sometimes it really is the best option, so you have to grit your teeth and use it. What I expected (and what I used originally) was a recursion combinator, with a type something like:

So we’re trying to generate a function of type `A → B`

, but there’s a hairy recursive call in there somewhere. Instead we use this function, and pass it a version of our function that uses the supplied function rather than making a recursive call:

In other words, instead of calling the function itself, you call `recursive-call`

above. Along with the argument, you supply a proof that it’s smaller than the outer argument (`y < x`

; assume for now that the definition of `<`

is just some relation like `_<_`

in Data.Nat).

But wait! You don’t have to use it! Instead of all that, you can just pass the `Acc _<_ x`

type as a parameter to your function. In other words, if you have a dangerous function:

Instead write:

Once you pattern match on the accessibility relation, the termination checker is satisfied. This is much easier to understand (for me anyway), and made it *much* easier to write proofs about it.

Thanks to Oleg Grenrus (phadej) on irc for helping me out with this! Funnily enough, he actually recommended the `Acc`

approach, and I instead originally went with the recursion combinator. Would have saved a couple hours if I’d just listened! Also worth mentioning is the approach recommended by Guillaume Allais (gallais), detailed here. Haven’t had time to figure it out, so this article may be updated to recommend it instead in the future.

This one is really important. If I hadn’t read the exact explanation here I think I may have given up with Agda (or at the very least the project I’m working on) out of frustration.

Basically the problem arises like this. Say you’re writing a function to split a vector in two. You can specify the type pretty precisely:

Try to pattern-match on `xs`

, though, and you’ll get the following error:

```
I'm not sure if there should be a case for the constructor [],
because I get stuck when trying to solve the following unification
problems (inferred index ≟ expected index):
zero ≟ n + m
when checking that the expression ? has type Vec .A .n × Vec .A .m
```

What?! That’s weird. Anyway, you fiddle around with the function, end up pattern matching on the `n`

instead, and continue on with your life.

What about this, though: you want to write a type for proofs that one number is less than or equal to another. You go with something like this:

And you want to use it in a proof. Here’s the example we’ll be using: if two numbers are less than some limit `u`

, then their maximum is also less than that limit:

```
max : ℕ → ℕ → ℕ
max zero m = m
max (suc n) zero = suc n
max (suc n) (suc m) = suc (max n m)
max-≤ : ∀ n m {u} → n ≤ u → m ≤ u → max n m ≤ u
max-≤ n m (proof k) m≤u = {!!}
```

It won’t let you match on `m≤u`

! Here’s the error:

```
I'm not sure if there should be a case for the constructor proof,
because I get stuck when trying to solve the following unification
problems (inferred index ≟ expected index):
m₁ + k₂ ≟ n₁ + k₁
when checking that the expression ? has type max n m ≤ n + k
```

What do you *mean* you’re not sure if there’s a case for the constructor `proof`

: it’s the *only* case!

The problem is that Agda is trying to *unify* two types who both have calls to user-defined functions in them, which is a hard problem. As phrased by Conor McBride:

When combining prescriptive and descriptive indices, ensure both are in constructor form. Exclude defined functions which yield difficult unification problems.

So if you ever get the “I’m not sure if…” error, try either to:

- Redefine the indices so they use constructors, not functions.
- Remove the index, instead having a proof inside the type of equality. What does that mean? Basically, transform the definition of
`≤`

above into the one in Data.Nat.

The use-case I had for this is a little long, I’m afraid (too long to include here), but it *did* come in handy. Basically, if you’re trying to prove something about a function, you may well want to *run* that function and pattern match on the result.

This is a little different from the normal way of doing things, where you’d pattern match on the argument. It is a pattern you’ll sometimes need to write, though. And here’s the issue: that `y`

has nothing to do with `f x`

, as far as Agda is concerned. All you’ve done is introduced a new variable, and that’s that.

This is exactly the problem `inspect`

solves: it runs your function, giving you a result, but *also* giving you a proof that the result is equal to running the function. You use it like this:

```
f-is-the-same-as-g : ∀ x → f x ≡ g x
f-is-the-same-as-g x with f x | inspect f x
f-is-the-same-as-g x | y | [ fx≡y ] = {!!}
```

Because the Agda standard library is a big fan of type synonyms (`Op₂ A`

instead of `A → A → A`

for example), it’s handy to know that pressing `SPC-G-G`

(in spacemacs) over any identifier will bring you to the definition. Also, you can normalize a type with `SPC-m-n`

.

This one is a little confusing, because Agda’s notion of “irrelevance” is different from Idris’, or Haskell’s. In all three languages, irrelevance is used for performance: it means that a value doesn’t need to be around at runtime, so the compiler can elide it.

That’s where the similarities stop though. In Haskell, *all* types are irrelevant: they’re figments of the typechecker’s imagination. You can’t get a type at runtime full stop.

In dependently typed languages, this isn’t a distinction we can rely on. The line between runtime entities and compile-time entities is drawn elsewhere, so quite often types *need* to exist at runtime. As you might guess, though, they don’t always need to. The length of a length-indexed vector, for instance, is completely determined by the structure of the vector: why would you bother storing all of that information at runtime? This is what Idris recognizes, and what it tries to remedy: it analyses code for these kinds of opportunities for elision, and does so when it can. Kind of like Haskell’s fusion, though, it’s an invisible optimization, and there’s no way to make Idris throw a type error when it can’t elide something you want it to elide.

Agda is totally different. Something is irrelevant in Agda if it’s *unique*. Or, rather, it’s irrelevant if all you rely on is its existence. It’s used for proofs that you carry around with you: in a rational number type, you might use it to say that the numerator and denominator have no common factors. The only information you want from this proof is whether it holds or not, so it’s the perfect candidate for irrelevance.

Weirdly, this means it’s useless for the length-indexed vector kind of stuff mentioned above. In fact, it doe exactly the opposite of what you might expect: if the length parameter is marked as irrelevant, the the types `Vec A n`

and `Vec A (suc n)`

are the same!

The way you *can* use it is to pattern-match if it’s impossible. Again, it’s designed for eliding proofs that you may carry with you otherwise.

Once I’m finished the project, I’ll try write up a guide on how to do literate Agda files. There were a couple of weird nuances that I had to pick up on the way, mainly to do with getting unicode to work.

]]>I’ve been writing a lot of Agda recently, and had the occasion to write a Fenwick tree that did some rebalancing. I went with AVL-style rebalancing (rather than red-black or trees of bounded balance). I’d written pretty full implementations of the other two before, and the Agda standard library (Danielsson 2018) has an implementation already that I was able to use as a starting point. Also, apparently, AVL trees seem to perform better than red-black trees in practice (Pfaff 2004).

This post will be similar in style to Stephanie Weirich’s talk (2014), which compares an Agda implementation of verified red-black trees to a Haskell one. When there’s two columns of code side-by-side, the left-hand side is Haskell, the right Agda.

The method of constructing the ordering proof is taken from “How to Keep Your Neighbours in Order” (2014) by Conor McBride; the structural proofs are somewhat inspired by the implementation in the Agda standard library, but are mainly my own.

AVL trees are more strictly balanced than red-black trees: the height of neighboring subtrees can differ by at most one. To store the height, we will start as every dependently-typed program does: with Peano numbers.

Haskell

The trees will be balanced one of three possible ways: left-heavy, right-heavy, or even. We can represent these three cases in a GADT in the case of Haskell, or an indexed datatype in the case of Agda:

Those unfamiliar with Agda might be a little intimidated by the mixfix operator in the balance definition: we’re using it here because the type can be seen of a proof that:

$max(x,y) = z$

Or, using the $\sqcup$ operator:

$(x \sqcup y) = z$

We’ll use this proof in the tree itself, as we’ll need to know the maximum of the height of a node’s two subtrees to find the height of the node. Before we do that, we’ll need a couple helper functions for manipulating the balance:

Along with the verification of the structure of the tree, we will also want to verify that its contents are ordered correctly. Unfortunately, this property is a little out of reach for Haskell, but it’s 100% doable in Agda. First, we’ll need a way to describe orders on a data type. In Haskell, we might write:

That `Bool`

throws away any information gained in the comparison, though: we want to supply a proof with the result of the comparison. First, equality:

This is one of the many ways to describe equality in Agda. It’s a type with only one constructor, and it can only be constructed when its two arguments are the same. When we pattern match on the constructor, then, we’re given a proof that whatever things those arguments refer to must be the same.

Next, we need to describe an order. For this, we’ll need two types: the empty type, and the unit type.

These are kind of like type-level Bools, with one extra, powerful addition: they keep their proof after construction. Because `⊥`

has no constructors, if someone tells you they’re going to give you one, you can be pretty sure they’re lying. How do we use this? Well, first, on the numbers:

Therefore, if we ask for something of type `x ℕ< y`

(for some `x`

and `y`

), we know that it only exists when `x`

really is less than `y`

(according to the definition above).

For our actual code, we’ll parameterize the whole thing over some abstract key type. We’ll do this using a module (a feature recently added to Haskell, as it happens). That might look something like this:

(the `k`

and `r`

here, as well as the `Lift`

ing noise below, are to do with Agda’s universe system, which I’ll try explain in a bit)

Now, the trick for the ordering is to keep a proof that two neighboring values are ordered correctly in the tree at each leaf (as there’s a leaf between every pair of nodes, this is exactly the place you *should* store such a proof). A problem arises with the extremal leaves in the tree (leftmost and rightmost): each leaf is missing one neighboring value, so how can it store a proof of order? The solution is to affix two elements to our key type which we define as the greatest and least elements of the set.

After all that, we can get bring back Haskell into the story, and define or tree types:

The two definitions are similar, but have a few obvious differences. The Agda version stores the ordering proof at the leaves, as well as the bounds as indices. Its *universe* is also different: briefly, universes are one of the ways to avoid Russell’s paradox when you’re dealing with dependent types.

In normal, standard Haskell, we think of types as things that describe values (how quaint!). When you’ve got a list, everything in the list has the same type, and that is good and right.

These days, though, we’re not so constrained:

This can quite happily store elements of different types:

And look at that bizarre-looking list on the wrong side of “`::`

”! Types aren’t just describing values, they’re acting like values themselves. What type does `[Bool, String, Integer]`

even have, anyway? Why, `[Type]`

of course!

So we see that types can be put in lists, and types have types: the natural question then is:

And this is where Haskell and Agda diverge: in Haskell, we say `Type :: Type`

(as the old extension `TypeInType`

implied), and that’s that. From a certain point of view, we’ve opened the door to Russell’s paradox (we’ve allowed a set to be a member of itself). This isn’t an issue in Haskell, though, as the type-level language was already inconsistent.

Agda goes another way, saying that `Set`

(Agda’s equivalent for `Type`

) has the type `Set₁`

, and `Set₁`

has the type `Set₂`

, and so on^{1}. These different sets are called “universes” and their numbers “levels”. When we write `k ⊔ v ⊔ r`

, we’re saying we want to take the greatest universe level from those three possible levels: the level of the key, the value, and the relation, respectively.

AVL trees maintain their invariants through relatively simple rotations. We’ll start with the right rotation, which fixes an imbalance of two on the left. Because the size of the tree returned might change, we’ll need to wrap it in a datatype:

We could actually have the Agda definition be the same as Haskell’s, it doesn’t make much difference. I’m mainly using it here to demonstrate dependent pairs in Agda. The first member of the pair is just a boolean (increased in height/not increased in height). The second member is a tree whose height *depends* on the actual value of the boolean. The `∃`

business is just a fancy syntax; it also waggles its eyebrows at the way a (dependent) pair of type `(x , y)`

means “There exists an x such that y”.

Using this, we can write the type for right-rotation:

There are two possible cases, single rotation:

And double:

I won’t bore you with left-rotation: suffice to say, it’s the opposite of right-rotation.

Finally, the main event: insertion. Once the above functions have all been defined, it’s not very difficult, as it happens: by and large, the types guide you to the right answer. Of course, this is only after we decided to use the pivotal pragmatism and balance approach.

```
insertWith
:: Ord k
=> (v -> v -> v)
-> k
-> v
-> Tree h k v
-> Tree k v ++? h
insertWith _ v vc Leaf =
Incr (Node v vc O Leaf Leaf)
insertWith f v vc (Node k kc bl tl tr) =
case compare v k of
LT ->
case insertWith f v vc tl of
Stay tl' ->
Stay (Node k kc bl tl' tr)
Incr tl' -> case bl of
L -> rotr k kc tl' tr
O -> Incr (Node k kc L tl' tr)
R -> Stay (Node k kc O tl' tr)
EQ ->
Stay (Node v (f vc kc) bl tl tr)
GT ->
case insertWith f v vc tr of
Stay tr' ->
Stay (Node k kc bl tl tr')
Incr tr' -> case bl of
L -> Stay (Node k kc O tl tr')
O -> Incr (Node k kc R tl tr')
R -> rotl k kc tl tr'
```

```
insert : ∀ {l u h v}
{V : Key → Set v}
(k : Key)
→ V k
→ (V k → V k → V k)
→ Tree V l u h
→ l < k < u
→ Tree V l u 1?+⟨ h ⟩
insert v vc f (leaf l<u) (l , u) =
1+ (node v vc ▽ (leaf l) (leaf u))
insert v vc f (node k kc bl tl tr) prf
with compare v k
insert v vc f (node k kc bl tl tr) (l , _)
| tri< a _ _ with insert v vc f tl (l , a)
... | 0+ tl′ = 0+ (node k kc bl tl′ tr)
... | 1+ tl′ with bl
... | ◿ = rotʳ k kc tl′ tr
... | ▽ = 1+ (node k kc ◿ tl′ tr)
... | ◺ = 0+ (node k kc ▽ tl′ tr)
insert v vc f (node k kc bl tl tr) _
| tri≈ _ refl _ =
0+ (node k (f vc kc) bl tl tr)
insert v vc f (node k kc bl tl tr) (_ , u)
| tri> _ _ c with insert v vc f tr (c , u)
... | 0+ tr′ = 0+ (node k kc bl tl tr′)
... | 1+ tr′ with bl
... | ◿ = 0+ (node k kc ▽ tl tr′)
... | ▽ = 1+ (node k kc ◺ tl tr′)
... | ◺ = rotˡ k kc tl tr′
```

Overall, I’ve been enjoying programming in Agda. The things I liked and didn’t like surprised me:

- Editor Support
Is excellent. I use spacemacs, and the whole thing worked pretty seamlessly. Proof search and auto was maybe not as powerful as Idris’, although that might be down to lack of experience (note—as I write this, I see you can enable case-splitting in proof search, so it looks like I was right about my lack of experience). In many ways, it was much better than Haskell’s editor support: personally, I have never managed to get case-splitting to work in my Haskell setup, never mind some of the fancier features that you get in Agda.

It’s worth noting that my experience with Idris is similar: maybe it’s something about dependent types?

Of course, I missed lots of extra tools, like linters, code formatters, etc., but the tight integration with the compiler was so useful it more than made up for it.

Also, I’d implore anyone who’s had trouble with emacs before to give spacemacs a go. It works well out-of-the-box, and has a system for keybinding discovery that

*actually works*.- Documentation
Pretty good, considering. There are some missing parts (rewriting and telescopes are both stubs on the documentation site), but there seemed to be more fully worked-out examples available online for different concepts when I needed to figure them out.

Now, the thing about a lot of these complaints/commendations (*especially* with regards to tooling and personal setups) is that people tend to be pretty bad about evaluating how difficult finicky tasks like editor setups are. Once you’ve gotten the hang of some of this stuff, you forget that you ever didn’t. Agda is the second dependently-typed language I’ve really gone for a deepish dive on, and I’ve been using spacemacs for a while, so YMMV.

One area of the language itself that I would have liked to see more on was irrelevance. Looking back at the definition of the tree type, in the Haskell version there’s no singleton storing the height (the balance type stores all the information we need), which means that it definitely doesn’t exist at runtime. As I understand it, that implies that the type should be irrelevant in the equivalent Agda. However, when I actually mark it as irrelevant, everything works fine, except that missing cases warnings start showing up. I couldn’t figure out why: Haskell was able to infer full case coverage without the index, after all. Equality proof erasure, also: is it safe? Consistent?

All in all, I’d encourage more Haskellers to give Agda a try. It’s fun, interesting, and $\mathcal{Unicode}$!

No “deletion is left as an exercise to the reader” here, no sir! Fuller implementations of both the Haskell and Agda versions of the code here are available: first, a pdf of the Agda code with lovely colours is here. The accompanying repository is here, and the equivalent for the Haskell code is here. Of course, if you would rather read something by someone who knows what they’re talking about, please see the

Danielsson, Nils Anders. 2018. “The Agda standard library.”

McBride, Conor Thomas. 2014. “How to Keep Your Neighbours in Order.” In *Proceedings of the 19th ACM SIGPLAN International Conference on Functional Programming*, 297–309. ICFP ’14. New York, NY, USA: ACM. doi:10.1145/2628136.2628163.

Pfaff, Ben. 2004. “Performance Analysis of BSTs in System Software.” In *Proceedings of the Joint International Conference on Measurement and Modeling of Computer Systems*, 410–411. SIGMETRICS ’04/Performance ’04. New York, NY, USA: ACM. doi:10.1145/1005686.1005742.

Weirich, Stephanie. 2014. “Depending on Types.” In *Proceedings of the 19th ACM SIGPLAN International Conference on Functional Programming*, 241–241. ICFP ’14. New York, NY, USA: ACM. doi:10.1145/2628136.2631168.

My phrasing is maybe a little confusing here. When

`Set`

“has the type”`Set₁`

it means that`Set`

is*in*`Set₁`

, not the other way around.↩

Tags: Haskell, Probability

Here are the slides for a short talk I gave to a reading group I’m in at Harvard today. The speaker notes are included in the pdf, code and the tex is available in the repository.

]]>
Tags: Probability, Haskell

Ever since the famous pearl by Erwig and Kollmansberger (2006), probabilistic programming with monads has been an interesting and diverse area in functional programming, with many different approaches.

I’m going to present five here, some of which I have not seen before.

As presented in the paper, a simple and elegant formulation of probability distributions looks like this:

It’s a list of possible events, each tagged with their probability of happening. Here’s the probability distribution representing a die roll, for instance:

The semantics can afford to be a little fuzzy: it doesn’t hugely matter if the probabilities don’t add up to 1 (you can still extract meaningful answers when they don’t). However, I can’t see a way in which either negative probabilities or an empty list would make sense. It would be nice if those states were unrepresentable.

Its monadic structure multiplies conditional events:

```
instance Functor Prob where
fmap f xs = Prob [ (f x, p) | (x,p) <- runProb xs ]
instance Applicative Prob where
pure x = Prob [(x,1)]
fs <*> xs
= Prob
[ (f x,fp*xp)
| (f,fp) <- runProb fs
, (x,xp) <- runProb xs ]
instance Monad Prob where
xs >>= f
= Prob
[ (y,xp*yp)
| (x,xp) <- runProb xs
, (y,yp) <- runProb (f x) ]
```

In most of the examples, we’ll need a few extra functions in order for the types to be useful. First is support:

And second is expectation:

```
expect :: (a -> Rational) -> Prob a -> Rational
expect p xs = sum [ p x * xp | (x,xp) <- runProb xs ]
probOf :: (a -> Bool) -> Prob a -> Rational
probOf p = expect (bool 0 1 . p)
```

It’s useful to be able to construct uniform distributions:

```
uniform xs = Prob [ (x,n) | x <- xs ]
where
n = 1 % toEnum (length xs)
die = uniform [1..6]
>>> probOf (7==) $ do
x <- die
y <- die
pure (x+y)
1 % 6
```

As elegant as the above approach is, it leaves something to be desired when it comes to efficiency. In particular, you’ll see a combinatorial explosion at every step. To demonstrate, let’s take the example above, using three-sided dice instead so it doesn’t take up too much space.

The probability table looks like this:

```
2 1/9
3 2/9
4 1/3
5 2/9
6 1/9
```

But the internal representation looks like this:

```
2 1/9
3 1/9
4 1/9
3 1/9
4 1/9
5 1/9
4 1/9
5 1/9
6 1/9
```

States are duplicated, because the implementation has no way of knowing that two outcomes are the same. We could collapse equivalent outcomes if we used a `Map`

, but then we can’t implement `Functor`

, `Applicative`

, or `Monad`

. The types:

```
class Functor f where
fmap :: (a -> b) -> f a -> f b
class Functor f => Applicative f where
pure :: a -> f a
(<*>) :: f (a -> b) -> f a -> f b
class Applicative f => Monad f where
(>>=) :: f a -> (a -> f b) -> f b
```

Don’t allow an `Ord`

constraint, which is what we’d need to remove duplicates. We can instead make our own classes which *do* allow constraints:

```
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeFamilies #-}
import Prelude hiding (Functor(..),Applicative(..),Monad(..))
import Data.Kind
class Functor f where
type Domain f a :: Constraint
type Domain f a = ()
fmap :: Domain f b => (a -> b) -> f a -> f b
class Functor f => Applicative f where
{-# MINIMAL pure, liftA2 #-}
pure :: Domain f a => a -> f a
liftA2 :: Domain f c => (a -> b -> c) -> f a -> f b -> f c
(<*>) :: Domain f b => f (a -> b) -> f a -> f b
(<*>) = liftA2 ($)
class Applicative f => Monad f where
(>>=) :: Domain f b => f a -> (a -> f b) -> f b
fail :: String -> a
fail = error
return :: (Applicative f, Domain f a) => a -> f a
return = pure
```

This setup gets over a couple common annoyances in Haskell, like making `Data.Set`

a Monad:

```
instance Functor Set where
type Domain Set a = Ord a
fmap = Set.map
instance Applicative Set where
pure = Set.singleton
liftA2 f xs ys = do
x <- xs
y <- ys
pure (f x y)
instance Monad Set where
(>>=) = flip foldMap
```

And, of course, the probability monad:

```
newtype Prob a = Prob
{ runProb :: Map a Rational
}
instance Functor Prob where
type Domain Prob a = Ord a
fmap f = Prob . Map.mapKeysWith (+) f . runProb
instance Applicative Prob where
pure x = Prob (Map.singleton x 1)
liftA2 f xs ys = do
x <- xs
y <- ys
pure (f x y)
instance Ord a => Monoid (Prob a) where
mempty = Prob Map.empty
mappend (Prob xs) (Prob ys) = Prob (Map.unionWith (+) xs ys)
instance Monad Prob where
Prob xs >>= f
= Map.foldMapWithKey ((Prob .) . flip (Map.map . (*)) . runProb . f) xs
support = Map.keys . runProb
expect p = getSum . Map.foldMapWithKey (\k v -> Sum (p k * v)) . runProb
probOf p = expect (bool 0 1 . p)
uniform xs = Prob (Map.fromList [ (x,n) | x <- xs ])
where
n = 1 % toEnum (length xs)
ifThenElse True t _ = t
ifThenElse False _ f = f
die = uniform [1..6]
>>> probOf (7==) $ do
x <- die
y <- die
pure (x + y)
1 % 6
```

Coming up with the right implementation all at once is quite difficult: luckily, there are more general techniques for designing DSLs that break the problem into smaller parts, which also give us some insight into the underlying composition of the probability monad.

The technique relies on an algebraic concept called “free objects”. A free object for some class is a minimal implementation of that class. The classic example is lists: they’re the free monoid. Monoid requires that you have an additive operation, an empty element, and that the additive operation be associative. Lists have all of these things: what makes them *free*, though, is that they have nothing else. For instance, the additive operation on lists (concatenation) isn’t commutative: if it was, they wouldn’t be the free monoid any more, because they satisfy an extra law that’s not in monoid.

For our case, we can use the free monad: this takes a functor and gives it a monad instance, in a way we know will satisfy all the laws. This encoding is used in several papers (Ścibior, Ghahramani, and Gordon 2015; Larsen 2011).

The idea is to first figure out what primitive operation you need. We’ll use weighted choice:

Then you encode it as a functor:

We’ll say the left-hand-choice has chance $p$, and the right-hand $1-p$. Then, you just wrap it in the free monad:

And you already have a monad instance. Support comes from the `Foldable`

instance:

Expectation is an “interpreter” for the DSL:

```
expect :: (a -> Rational) -> Prob a -> Rational
expect p = iter f . fmap p
where
f (Choose c l r) = l * c + r * (1-c)
```

For building up the tree, we can use Huffman’s algorithm:

```
fromList :: (a -> Rational) -> [a] -> Prob a
fromList p = go . foldMap (\x -> singleton (p x) (Pure x))
where
go xs = case minView xs of
Nothing -> error "empty list"
Just ((xp,x),ys) -> case minView ys of
Nothing -> x
Just ((yp,y),zs) ->
go (insertHeap (xp+yp) (Free (Choose (xp/(xp+yp)) x y)) zs)
```

And finally, it gets the same notation as before:

```
uniform = fromList (const 1)
die = uniform [1..6]
probOf p = expect (bool 0 1 . p)
>>> probOf (7==) $ do
x <- die
y <- die
pure (x + y)
1 % 6
```

One of the advantages of the free approach is that it’s easy to define multiple interpreters. We could, for instance, write an interpreter that constructs a diagram:

```
>>> drawTree ((,) <$> uniform "abc" <*> uniform "de")
┌('c','d')
┌1 % 2┤
│ └('c','e')
1 % 3┤
│ ┌('a','d')
│ ┌1 % 2┤
│ │ └('a','e')
└1 % 2┤
│ ┌('b','d')
└1 % 2┤
└('b','e')
```

There’s a lot to be said about free objects in category theory, also. Specifically, they’re related to initial and terminal (also called final) objects. The encoding above is initial, the final encoding is simply `Cont`

:

Here, also, we get the monad instance for free. In contrast to previously, expect is free:

Support, though, isn’t possible.

This version is also called the Giry monad: there’s a deep and fascinating theory behind it, which I probably won’t be able to do justice to here. Check out Jared Tobin’s post (2017) for a good deep dive on it.

The branching structure of the tree captures the semantics of the probability monad well, but it doesn’t give us much insight into the original implementation. The question is, how can we deconstruct this:

Eric Kidd (2007) pointed out that the monad is the composition of the writer and list monads:

but that seems unsatisfying: in contrast to the tree-based version, we don’t encode any branching structure, we’re able to have empty distributions, and it has the combinatorial explosion problem.

Adding a weighting to nondeterminism is encapsulated more concretely by the `ListT`

transformer. It looks like this:

It’s a cons-list, with an effect before every layer^{1}.

While this can be used to give us the monad we need, I’ve found that something more like this fits the abstraction better:

It’s a nonempty list, with the first element exposed. Turns out this is very similar to the cofree comonad:

Just like the initial free encoding, we can start with a primitive operation:

And we get all of our instances as well:

```
newtype Prob a
= Prob
{ runProb :: Cofree Perhaps a
} deriving (Functor,Foldable)
instance Comonad Prob where
extract (Prob xs) = extract xs
duplicate (Prob xs) = Prob (fmap Prob (duplicate xs))
foldProb :: (a -> Rational -> b -> b) -> (a -> b) -> Prob a -> b
foldProb f b = r . runProb
where
r (x :< Impossible) = b x
r (x :< WithChance p xs) = f x p (r xs)
uniform :: [a] -> Prob a
uniform (x:xs) = Prob (coiterW f (EnvT (length xs) (x :| xs)))
where
f (EnvT 0 (_ :| [])) = Impossible
f (EnvT n (_ :| (y:ys)))
= WithChance (1 % fromIntegral n) (EnvT (n - 1) (y:|ys))
expect :: (a -> Rational) -> Prob a -> Rational
expect p = foldProb f p
where
f x n xs = (p x * n + xs) / (n + 1)
probOf :: (a -> Bool) -> Prob a -> Rational
probOf p = expect (\x -> if p x then 1 else 0)
instance Applicative Prob where
pure x = Prob (x :< Impossible)
(<*>) = ap
append :: Prob a -> Rational -> Prob a -> Prob a
append = foldProb f (\x y -> Prob . (x :<) . WithChance y . runProb)
where
f e r a p = Prob . (e :<) . WithChance ip . runProb . a op
where
ip = p * r / (p + r + 1)
op = p / (r + 1)
instance Monad Prob where
xs >>= f = foldProb (append . f) f xs
```

We see here that we’re talking about gambling-style odds, rather than probability. I wonder if the two representations are dual somehow?

The application of comonads to streams (`ListT`

) has been explored before (Uustalu and Vene 2005); I wonder if there are any insights to be gleaned from this particular probability comonad.

Erwig, Martin, and Steve Kollmansberger. 2006. “Functional pearls: Probabilistic functional programming in Haskell.” *Journal of Functional Programming* 16 (1): 21–34. doi:10.1017/S0956796805005721.

Kidd, Eric. 2007. “Build your own probability monads.”

Larsen, Ken Friis. 2011. “Memory Efficient Implementation of Probability Monads.”

Ścibior, Adam, Zoubin Ghahramani, and Andrew D. Gordon. 2015. “Practical Probabilistic Programming with Monads.” In *Proceedings of the 2015 ACM SIGPLAN Symposium on Haskell*, 50:165–176. Haskell ’15. New York, NY, USA: ACM. doi:10.1145/2804302.2804317.

Tobin, Jared. 2017. “Implementing the Giry Monad.” *jtobin.io*.

Uustalu, Tarmo, and Varmo Vene. 2005. “The Essence of Dataflow Programming.” In *Proceedings of the Third Asian Conference on Programming Languages and Systems*, 2–18. APLAS’05. Berlin, Heidelberg: Springer-Verlag. doi:10.1007/11575467_2.

Note this is

*not*the same as the`ListT`

in transformers; instead it’s a “ListT done right”.↩

Part 4 of a 6-part series on Breadth-First Traversals

Tags: Haskell

After the last post, Noah Easterly pointed me to their tree-traversals library, and in particular the `Phases`

applicative transformer. It allows you to batch applicative effects to be run together: for the breadth-first traversal, we can batch the effects from each level together, giving us a lovely short solution to the problem.

```
breadthFirst c = runPhasesForwards . go
where
go (x:<xs) = liftA2 (:<) (now (c x)) (delay (traverse go xs))
```

In my efforts to speed this implementation up, I came across a wide and interesting literature on scheduling effects, which I’ll go through a little here.

The first thing that jumps to mind, for me, when I think of “scheduling” is coroutines. These are constructs that let you finely control the order of execution of effects. They’re well explored in Haskell by now, and most libraries will let you do something like the following:

We first print `1`

, then, after a delay, we print `2`

. The `delay`

doesn’t make a difference if we just run the whole thing:

But you can see its effect when we use the `interleave`

combinator:

Hopefully you can see how useful this might be, and the similarity to the `Phases`

construction.

The genealogy of most coroutine libraries in Haskell seems to trace back to Blažević (2011) or Kiselyov (2012): the implementation I have been using in these past few examples (`IterT`

) comes from a slightly different place. Let’s take a quick detour to explore it a little.

In functional programming, there are several constructions for modeling error-like states: `Maybe`

for your nulls, `Either`

for your exceptions. What separates these approaches from the “unsafe” variants (null pointers, unchecked exceptions) is that we can *prove*, in the type system, that the error case is handled correctly.

Conspicuously absent from the usual toolbox for modeling partiality is a way to model *nontermination*. At first glance, it may seem strange to attempt to do so in Haskell. After all, if I have a function of type:

I can prove that I won’t throw any errors (with `Either`

, that is), because the type `Int`

doesn’t contain `Left _`

. I’ve also proved, miraculously, that I won’t make any null dereferences, because `Int`

also doesn’t contain `Nothing`

. I *haven’t* proved, however, that I won’t loop infinitely, because (in Haskell), `Int`

absolutely *does* contain $\bot$.

So we’re somewhat scuppered. On the other hand, While we can’t *prove* termination in Haskell, we can:

- Model it.
- Prove it in something else.

Which is exactly what Venanzio Capretta did in the fascinating (and quite accessible) talk “Partiality is an effect” (Capretta, Altenkirch, and Uustalu 2004)^{1}.

The monad in question looks like this:

We’re writing in Idris for the time being, so that we can prove termination and so on. The “recursive call” to `Iter`

is guarded by the `Inf`

type: this turns on a different kind of totality checking in the compiler. Usually, Idris will prevent you from constructing infinite values. But that’s exactly what we want to do here. Take the little-known function `until`

:

It’s clearly not necessarily total, and the totality checker will complain as such when we try and implement it directly:

But we can use `Iter`

to model that possible totality:

```
until : (a -> Bool) -> (a -> a) -> a -> Iter a
until p f x = if p x then Now x else Later (until p f (f x))
```

Of course, nothing’s for free: when we get the ability to construct infinite values, we lose the ability to consume them.

We get an error on the `run`

function. However, as you would expect, we can run *guarded* iteration: iteration up until some finite point.

```
runUntil : Nat -> Iter a -> Maybe a
runUntil Z _ = Nothing
runUntil (S n) (Now x) = Just x
runUntil (S n) (Later x) = runUntil n x
```

Making our way back to Haskell, we must first—as is the law—add a type parameter, and upgrade our humble monad to a monad transformer:

The semantic meaning of the extra `m`

here is interesting: each layer adds not just a recursive step, or a single iteration, but a single effect. Interpreting things in this way gets us back to the original goal:

The `Later`

constructor above can be translated to a `delay`

function on the transformer:

And using this again, we can write the following incredibly short definition for `unfoldTreeM_BF`

:

```
unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = retract . go
where
go b = do
(x,xs) <- lift (f b)
fmap (Node x) (interleave (map (delay . go) xs))
```

It would be nice to bring this back to traversals, but alas, `IterT`

is pretty monad-centric. What’s more, if it’s analogous to `Phases`

it certainly doesn’t look like it:

However, in the documentation for `IterT`

, there’s the following little note:

Where `FreeT`

is the free monad transformer. This seems to strongly hint that we could get the same thing for applicatives with `ApT`

. Let’s try it:

The `Applicative`

instance is a little hairy, but it *seems* correct:

```
instance Applicative f =>
Applicative (Phases f) where
pure = Phases . pure
liftA2 f' (Phases (ApT xs')) (Phases (ApT ys')) =
Phases (ApT (liftA2 (go f') xs' ys'))
where
go
:: ∀ a b c.
(a -> b -> c)
-> ApF Identity f a
-> ApF Identity f b
-> ApF Identity f c
go f (Pure x) ys = fmap (f x) ys
go f xs (Pure y) = fmap (`f` y) xs
go f (Ap x (ApT xs)) (Ap y (ApT ys)) =
Ap
(liftA2 (,) x y)
(ApT (liftA2 (go (\xx yy -> uncurry f . (xx *** yy))) xs ys))
```

(on a side note: thank *goodness* for `liftA2`

finally getting into `Applicative`

)

And we get all the normal combinators:

```
delay :: Applicative f => Phases f a -> Phases f a
delay = Phases . ApT . pure . Ap (pure ()) . fmap const . runPhases
lift :: Functor f => f a -> Phases f a
lift = Phases . liftApO
```

The issue comes with running the thing at the end: `Monad`

creeps back in.

```
retract :: Monad f => Phases f a -> f a
retract = fmap (runIdentity . retractAp) . joinApT . runPhases
```

Because the effects are all layered on top of each other, you need to flatten them out at the end, which requires `join`

. Mind you, it does work: it’s just not as general as it could be.

All’s not lost, though. Turns out, we never needed the transformer in the first place: we could just define the different applicative instance straight off.

```
newtype Phases f a = Phases
{ runPhases :: Ap f a
} deriving Functor
instance Applicative f =>
Applicative (Phases f) where
pure = Phases . Pure
liftA2 f' (Phases xs') (Phases ys') = Phases (go f' xs' ys')
where
go :: ∀ a b c.
(a -> b -> c)
-> Ap f a
-> Ap f b
-> Ap f c
go f (Pure x) ys = fmap (f x) ys
go f xs (Pure y) = fmap (`f` y) xs
go f (Ap x xs) (Ap y ys) =
Ap
(liftA2 (,) x y)
(go (\xx yy -> uncurry f . (xx *** yy)) xs ys)
delay :: Applicative f => Phases f a -> Phases f a
delay = Phases . Ap (pure ()) . fmap const . runPhases
retract :: Applicative f => Phases f a -> f a
retract = retractAp . runPhases
lift :: f a -> Phases f a
lift = Phases . liftAp
```

In the wonderful article Coroutine Pipelines (Blažević 2011), several different threads on coroutine-like constructions are unified. What I’ve demonstrated above isn’t yet as powerful as what you might see in a full coroutine library: ideally, you’d want generators and sinks. As it turns out, when we look back at the note from `IterT`

:

We can get both of those other constructs by swapping out `Identity`

^{2}:

(`Sink`

is usually called an `Iteratee`

)

This is the fundamental abstraction that underlies things like the pipes library (Gonzalez 2018).

The only missing part from the first coroutine example by now is `interleave`

. In the free library, it has the following signature:

But we should be able to spot that, really, it’s a traversal. And, as a traversal, it should rely on some underlying `Applicative`

instance. Let’s try and come up with one:

```
newtype Parallel m f a = Parallel
{ runParallel :: FreeT m f a
}
instance (Functor f, Functor m) =>
Functor (Parallel m f) where
fmap f = Parallel . FreeT . fmap go . runFreeT . runParallel
where
go = bimap f (FreeT . fmap go . runFreeT)
instance (Applicative f, Applicative m) =>
Applicative (Parallel m f) where
pure = Parallel . FreeT . pure . Pure
Parallel fs' <*> Parallel xs' = Parallel (unw fs' xs')
where
unw (FreeT fs) (FreeT xs) = FreeT (liftA2 go fs xs)
go (Pure f) = bimap f (runParallel . fmap f . Parallel)
go (Free fs) = Free . \case
Pure x -> fmap (runParallel . fmap ($x) . Parallel) fs
Free xs -> liftA2 unw fs xs
```

Now, interleave is just `sequenceA`

!

So we can see that there’s a “parallel” applicative for both the free monad and the free applicative. To try and understand this type a little better, we can leverage our intuition about a much simpler, more familiar setting: lists. There’s an interesting similarity between lists and the free monad: `FreeT ((,) a)`

) looks a lot like “`ListT`

done right” (so much so, in fact, that most coroutine libraries provide their own version of it). More concretely, list also has a famous “parallel” applicative: `ZipList`

!

```
newtype ZipList a
= ZipList
{ getZipList :: [a]
} deriving Functor
instance Applicative ZipList where
pure = ZipList . repeat
liftA2 f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys)
```

We’ll use some of our knowledge about `ZipList`

to help us in the next section.

We’ve seen that efforts to model both coroutines and partiality end up in the same neighborhood: there’s yet another way to get there, which seems (at first) almost the opposite of the second. It starts with a blog post from Conor McBride (2009) called “Time flies like an applicative functor”. Curiously, here too breadth-first labeling is the focus. Remember first the lovely circular solution from (**???**):

```
data Tree a = Leaf | Node a (Tree a) (Tree a)
relabel :: Tree x -> [[a]] -> (Tree a, [[a]])
relabel Leaf xss = (Leaf,xss)
relabel (Node _ l r) ((x:xs):xss0) =
let (l',xss1) = relabel l xss0
(r',xss2) = relabel r xss1
in (Node x l' r',xs:xss2)
bflabel :: Tree x -> [a] -> Tree a
bflabel tr xs = u
where
(u,xss) = relabel tr (xs:xss)
```

As lovely as it is, spare a thought for the poor totality checker: it’s hard to imagine how it would even *start* to show that something so lazy and circular would terminate. `IterT`

won’t help us here, either: it can help us express programs that *might* diverge, not weird-looking ones that definitely won’t.

The solution presented is a type (`De`

) which has a limited set of combinators: a fixpoint (`fix :: (De x -> x) -> x`

), and an applicative instance. As long as all problematic recursive calls are instead expressed using those combinators, the termination checker should be satisfied.

`De`

can be thought of as a “delay” wrapper. Values of type `De a`

are one step in the future, `De (De a)`

are two, and so on. This idea was later expanded upon in Atkey (2011) and Atkey and McBride (2013) to *clock variables*. Instead of types with a delay, types are tagged with how much more time they have (something like “fuel” in the Idris sense, maybe). So a value of type $a^\mathsf{K}$ is tagged with time $\mathsf{K}$, effectively meaning “I have $\mathsf{K}$ productive steps left before I diverge”. “Productive steps” will mean something different for every data type: for lists, it could mean that it can produce up until the $\mathsf{K}$th cons-cell. In the paper (Atkey and McBride 2013) this is fleshed out a little more, with fixpoint combinators and so on. As a concrete example, take the type of the cons operator on streams:

It increments the clock on the type, saying that it has one more productive step than it did before. This is kind of the opposite of a “delay”: previously, the scheduling types have meant “this is available $\mathsf{K}$ number of steps in the future” rather than “this is available for another $\mathsf{K}$ steps”. We can still describe delays in this system, though, using the $\rhd^\mathsf{K}$ notation:

$\begin{equation} \text{Cons} : \text{a} \rightarrow \rhd^\mathsf{K}\text{Stream a} \rightarrow \text{Stream a} \end{equation}$Let’s first try express some of this in the free monad:

```
data K = Z | S K
data Delay :: K -> (Type -> Type) -> (Type -> Type) -> Type -> Type where
Now :: a -> Delay n f m a
Later :: f (DelayT n f m a) -> Delay (S n) f m a
instance (Functor f, Functor m) => Functor (Delay n f m) where
fmap f (Now x) = Now (f x)
fmap f (Later xs) = Later (fmap (fmap f) xs)
newtype DelayT n f m a = DelayT { runDelayT :: m (Delay n f m a) }
instance (Functor f, Functor m) =>
Functor (DelayT n f m) where
fmap f = DelayT . fmap (fmap f) . runDelayT
```

We can straight away express one of the combinators from the paper, `force`

:

```
force :: Functor m => (∀ k. DelayT k f m a) -> m a
force (DelayT xs) = fmap f xs
where
f :: Delay Z f m a -> a
f (Now x) = x
```

Similar trick to `runST`

here: if the type is delayed however long we want it to be, then it mustn’t really be delayed at all.

Next, remember that we have types for streams (generators) from the `IterT`

monad:

And cons does indeed have the right type:

```
cons :: Applicative m => a -> Stream n a m b -> Stream (S n) a m b
cons x xs = DelayT (pure (Later (x,xs)))
```

We also get an applicative:

```
instance (Applicative f, Applicative m) =>
Applicative (DelayT n f m) where
pure = DelayT . pure . Now
DelayT fs' <*> DelayT xs' = DelayT (liftA2 go fs' xs')
where
go :: ∀ k a b. Delay k f m (a -> b) -> Delay k f m a -> Delay k f m b
go (Now f) = fmap f
go (Later fs) = Later . \case
Now x -> fmap (fmap ($x)) fs
Later xs -> liftA2 (<*>) fs xs
```

Now, I’m not sure how much this stuff actually corresponds to the paper, but what caught my eye is the statement that `De`

is a classic “applicative-not-monad”: just like `ZipList`

. However, under the analogy that the free monad is listy, and the parallel construction is ziplist-y, what we have in the `DelayT`

is the equivalent of a length-indexed list. These have an applicative instance similar to ziplists: but they also have a monad. Can we apply the same trick here?

There’s a lot of fascinating stuff out there—about clock variables, especially—that I hope to get a chance to learn about once I get a chance. What I’m particularly interested to follow up on includes:

- Comonads and their relationship to these constructions. Streams are naturally expressed as comonads, could they be used as a basis on which to build a similar “delay” mechanism?
- I’d love to explore more efficient implementations like the ones in Spivey (2017).
- I’m interested to see the relationship between these types, power series, and algebras for combinatorial search (Spivey 2009).

Atkey, Robert. 2011. “How to be a Productive Programmer - by putting things off until tomorrow.” Heriot-Watt University.

Atkey, Robert, and Conor McBride. 2013. “Productive coprogramming with guarded recursion.” In, 197. ACM Press. doi:10.1145/2500365.2500597.

Blažević, Mario. 2011. “Coroutine Pipelines.” *The Monad.Reader* 19 (19) (August): 29–50.

Capretta, Venanzio, Thorsten Altenkirch, and Tarmo Uustalu. 2004. “Partiality is an effect.” In *Dependently Typed Programming*, 04381:20. Dagstuhl Seminar Proceedings. Dagstuhl, Germany: Internationales Begegnungs- und Forschungszentrum für Informatik (IBFI), Schloss Dagstuhl, Germany.

Gonzalez, Gabriel. 2018. “Pipes: Compositional pipelines.”

Kiselyov, Oleg. 2012. “Iteratees.” In *Proceedings of the 11th International Conference on Functional and Logic Programming*, 166–181. Lecture Notes in Computer Science. Berlin, Heidelberg: Springer, Berlin, Heidelberg. doi:10.1007/978-3-642-29822-6_15.

McBride, Conor. 2009. “Time flies like an applicative functor.” *Epilogue for Epigram*.

Spivey, J. Michael. 2009. “Algebras for combinatorial search.” *Journal of Functional Programming* 19 (3-4) (July): 469–487. doi:10.1017/S0956796809007321.

Spivey, Michael. 2017. “Faster coroutine pipelines.” *Proceedings of the ACM on Programming Languages* 1 (ICFP) (August): 1–23. doi:10.1145/3110249.

There is a later, seemingly more formal version of the talk available (

**???**), but the one from 2004 was a little easier for me to understand, and had a lot more Haskell code.↩Small note:

`(,) a`

and`(->) a`

are adjunct. I wonder if there is any implication from this? Certainly, producers and consumers seem adjunct, but there’s no instance I can find for it in adjunctions.↩

Part 3 of a 6-part series on Breadth-First Traversals

Tags: Haskell

After looking at the algorithms I posted last time, I noticed some patterns emerging which I thought deserved a slightly longer post. I’ll go through the problem (Gibbons 2015) in a little more detail, and present some more algorithms to go along with it.

The original question was posed by Etian Chatav:

What is the correct way to write breadth first traversal of a

`[Tree]`

?

The breadth-first traversal here is a traversal in the lensy sense, i.e:

The `Tree`

type we’re referring to here is a rose tree; we can take the one defined in `Data.Tree`

:

Finally, instead of solving the (somewhat intermediate) problem of traversing a forest, we’ll look directly at traversing the tree itself. In other words, our solution should have the type:

As in Gibbons (2015), let’s first look at just converting the tree to a list in breadth-first order. In other words, given the tree:

```
┌3
┌2┤
│ └4
1┤
│ ┌6
└5┤
└7
```

We want the list:

Last time I looked at this problem, the function I arrived at was as follows:

```
breadthFirstEnumerate :: Tree a -> [a]
breadthFirstEnumerate ts = f ts b []
where
f (Node x xs) fw bw = x : fw (xs : bw)
b [] = []
b qs = foldl (foldr f) b qs []
```

It’s admittedly a little difficult to understand, but it’s really not too complex: we’re popping items off the front of a queue, and pushing the subforest onto the end. `fw`

is the recursive call here: that’s where we send the queue with the element pushed on. Even though it may *look* like we’re pushing onto the front (as we’re using a cons), this is really the *end* of the queue, since it’s being consumed in reverse, with `foldl`

.

We can compare it to the technique used in Allison (2006) and Smith (2009), where it’s called *corecursive queues*. Breadth-first enumeration is accomplished as follows in Smith (2009):

```
levelOrder :: Tree a -> [a]
levelOrder tr = map rootLabel qs
where
qs = enqs [tr] 0 qs
enqs [] n xs = deq n xs
enqs (t:ts) n xs = t : enqs ts (n+1) xs
deq 0 _ = []
deq n (x:xs) = enqs (subForest x) (n-1) xs
```

We get to avoid tracking the length of the queue, however.

Before we go the full way to traversal, we can try add a little structure to our breadth-first enumeration, by delimiting between levels in the tree. We want our function to have the following type:

Looking back at our example tree:

```
┌3
┌2┤
│ └4
1┤
│ ┌6
└5┤
└7
```

We now want the list:

This function is strictly more powerful than `breadthFirstEnumerate`

, as we can define one in terms of the other:

It’s also just a generally useful function, so there are several example implementations available online.

The one provided in Data.Tree is as follows:

Pretty nice, but it looks to me like it’s doing a lot of redundant work. We could write it as an unfold:

```
levels t = unfoldr (f . concat) [[t]]
where
f [] = Nothing
f xs = Just (unzip [(y,ys) | Node y ys <- xs])
```

The performance danger here lies in `unzip`

: one could potentially optimize that for a speedup.

Another definition, in the style of `breadthFirstEnumerate`

above, is as follows:

```
levels ts = f b ts [] []
where
f k (Node x xs) ls qs = k (x : ls) (xs : qs)
b _ [] = []
b k qs = k : foldl (foldl f) b qs [] []
```

Here, we maintain a stack building up the current level, as well as a queue that we send to the next level. Because we’re consing onto the front of the stack, the subforest needs to be traversed in reverse, to build up the output list in the right order. This is why we’re using a second `foldl`

here, whereas the original had `foldr`

on the inner loop.

Looking at the implicit queue version, I noticed that it’s just using a church-encoded pair to reverse the direction of the fold. Instead of doing both reversals, we can use a normal pair, and run it in one direction:

```
levels ts = b (f ts ([],[]))
where
f (Node x xs) (ls,qs) = (x:ls,xs:qs)
b (_,[]) = []
b (k,qs) = k : b (foldr (flip (foldr f)) ([],[]) qs)
```

Secondly, we’re running a fold on the second component of the pair: why not run the fold immediately, rather than building the intermediate list. In fact, we’re running a fold over the *whole* thing, which we can do straight away:

```
levels ts = f ts []
where
f (Node x xs) (q:qs) = (x:q) : foldr f qs xs
f (Node x xs) [] = [x] : foldr f [] xs
```

After looking at it for a while, I realized it’s similar to an inlined version of the algorithm presented in Gibbons (2015):

```
levels t = [rootLabel t] : foldr (lzw (++)) [] (map levels (subForest t))
where
lzw f (x:xs) (y:ys) = f x y : lzw f xs ys
lzw _ xs [] = xs
lzw _ [] ys = ys
```

Before going any further, all of the functions so far can be redefined to work on the cofree comonad:

When `f`

is specialized to `[]`

, we get the original rose tree. So far, though, all we actually require is `Foldable`

.

From now on, then, we’ll use `Cofree`

instead of `Tree`

.

Finally, we can begin on the traversal itself. We know how to execute the effects in the right order, what’s missing is to build the tree back up in the right order.

First thing we’ll use is a trick with `Traversable`

, where we fill a container from a list. In other words:

With the state monad (or applicative, in this case, I suppose), we can define a “pop” action, which takes an element from the supply:

And then we `traverse`

that action over our container:

When we use fill, it’ll have the following type:

```
breadthFirst :: (Applicative f, Traversable t)
=> (a -> f b) -> Cofree t a -> f (Cofree t b)
breadthFirst = ...
where
...
fill :: t (Cofree t a) -> State [Cofree t b] (t (Cofree t b))
fill = traverse (const pop)
```

Hopefully that makes sense: we’re going to get the subforest from here:

And we’re going to fill it with the result of the traversal, which changes the contents from `a`

s to `b`

s.

One of the nice things about working with applicatives is that they compose, in a variety of different ways. In other words, if I have one effect, `f`

, and another `g`

, and I want to run them both on the contents of some list, I can do it in one pass, either by layering the effects, or putting them side-by-side.

In our case, we need to deal with two effects: the one generated by the traversal, (the one the caller wants to use), and the internal state we’re using to fill up the forests in our tree. We could use `Compose`

explicitly, but we can avoid some calls to `pure`

if we write the combinators we’re going to use directly:

```
map2
:: (Functor f, Functor g)
=> (a -> b -> c) -> f a -> g b -> f (g c)
map2 f x xs =
fmap (\y -> fmap (f y) xs) x
app2
:: (Applicative f, Applicative g)
=> (a -> b -> c -> d) -> f a -> g b -> f (g c) -> f (g d)
app2 f x xs =
liftA2 (\y -> liftA2 (f y) xs) x
```

The outer applicative (`f`

) will be the user’s effect, the inner will be `State`

.

First we’ll try convert the zippy-style `levels`

to a traversal. First, convert the function over to the cofree comonad:

```
levels tr = f tr []
where
f (x:<xs) (q:qs) = (x:q) : foldr f qs xs
f (x:<xs) [] = [x] : foldr f [] xs
```

Next, instead of building up a list of just the root labels, we’ll pair them with the subforests:

```
breadthFirst tr = f tr []
where
f (x:<xs) (q:qs) = ((x,xs):q) : foldr f qs xs
f (x:<xs) [] = [(x,xs)] : foldr f [] xs
```

Next, we’ll fill the subforests:

```
breadthFirst tr = f tr []
where
f (x:<xs) (q:qs) = ((x,fill xs):q) : foldr f qs xs
f (x:<xs) [] = [(x,fill xs)] : foldr f [] xs
```

Then, we can run the applicative effect on the root label:

```
breadthFirst c tr = f tr []
where
f (x:<xs) (q:qs) = ((c x,fill xs):q) : foldr f qs xs
f (x:<xs) [] = [(c x,fill xs)] : foldr f [] xs
```

Now, to combine the effects, we can use the combinators we defined before:

```
breadthFirst c tr = f tr []
where
f (x:<xs) (q:qs) =
app2 (\y ys zs -> (y:<ys) : zs) (c x) (fill xs) q : foldr f qs xs
f (x:<xs) [] =
map2 (\y ys -> [y:<ys]) (c x) (fill xs) : foldr f [] xs
```

This builds a list containing all of the level-wise traversals of the tree. To collapse them into one, we can use a fold:

```
breadthFirst :: (Traversable t, Applicative f)
=> (a -> f b)
-> Cofree t a
-> f (Cofree t b)
breadthFirst c tr =
head <$> foldr (liftA2 evalState) (pure []) (f tr [])
where
f (x:<xs) (q:qs) =
app2 (\y ys zs -> (y:<ys):zs) (c x) (fill xs) q : foldr f qs xs
f (x:<xs) [] =
map2 (\y ys -> [y:<ys]) (c x) (fill xs) : foldr f [] xs
```

Converting the queue-based implementation is easy once we’ve done it with the zippy one. The result is (to my eye) a little easier to read, also:

```
breadthFirst
:: (Applicative f, Traversable t)
=> (a -> f b) -> Cofree t a -> f (Cofree t b)
breadthFirst c tr =
fmap head (f b tr e [])
where
f k (x:<xs) ls qs =
k (app2 (\y ys zs -> (y:<ys):zs) (c x) (fill xs) ls) (xs:qs)
b _ [] = pure []
b l qs = liftA2 evalState l (foldl (foldl f) b qs e [])
e = pure (pure [])
```

There are a couple things to notice here: first, we’re not using `map2`

anywhere. That’s because in the zippy version we were able to notice when the queue was exhausted, so we could just output the singleton effect. Here, instead, we’re using `pure (pure [])`

: this is potentially a source of inefficiency, as `liftA2 f (pure x) y`

is less efficient than `fmap (f x) y`

for some applicatives.

On the other hand, we don’t build up a list of levels to be combined with `foldr (liftA2 evalState)`

at any point: we combine them at every level immediately. You may be able to do the same in the zippy version, but I haven’t figured it out yet.

The final point to make here is to do with the very last thing we do in the traversal: `fmap head`

. Strictly speaking, any `fmap`

s in the code should be unnecessary: we *should* be able to fuse them all with any call to `liftA2`

. This transformation is often called the “Yoneda embedding”. We can use it here like so:

```
breadthFirst
:: ∀ t a f b. (Traversable t, Applicative f)
=> (a -> f b) -> Cofree t a -> f (Cofree t b)
breadthFirst c tr = f (b head) tr e []
where
f k (x:<xs) ls qs =
k (app2 (\y ys zs -> (y:<ys) : zs) (c x) (fill xs) ls) (xs : qs)
b :: ∀ x. ([Cofree t b] -> x)
-> f (State [Cofree t b] [Cofree t b])
-> [t (Cofree t a)]
```