In [the previous post] I discussed using traversals for batch operations.

I forgot to mention any libraries which actually do this. They are kind of hard to find, as often the `Traversable`

usage comes up very naturally.

One such example is `unification-fd`

. As the name suggests the library is for doing unification. One operation in the process is applying bindings, i.e. substituting the unification values with the terms they have been unified to. (I think that's what *zonking* is in GHC^{1}).

The function type signature is

```
applyBindings :: (...)
=> UTerm t v -> em m (UTerm t v)
```

*But* the library also provides the *batched* method:

```
applyBindingsAll :: (..., Traversable s)
=> s (UTerm t v) -> em m (s (UTerm t v))
```

And the docs say:

Same as applyBindings, but works on several terms simultaneously. This function preserves sharing across the entire collection of terms, whereas applying the bindings to each term separately would only preserve sharing within each term.

The library also has `freshen`

and `freshenAll`

.

When I was studying how `unification-fd`

works, having `applyBindingsAll`

operation with `Traversable`

is very natural, the library make use of `Traversable`

a lot already anyway.

There are probably more examples, but I cannot find them. (If you know any others, please tell me, I'll be happy to learn more, and maybe include them into this post).

One another example is `sat-simple`

, a *hopefully* simple SAT library (e.g. simpler than `ersatz`

).

/The/ operation of a library is

`solve :: Traversable model => model (Lit s) -> SAT s (model Bool)`

We have some `model`

with symbolic boolean variables (`Lit s`

), and the `solve`

finds a concrete assignment of them `Bool`

.

For comparison, `ersatz`

uses type-family (`Decoded`

):

```
solveWith :: (Monad m, HasSAT s, Default s, Codec a)
=> Solver s m -> StateT s m a -> m (Result, Maybe (Decoded a))
```

while `ersatz`

approach is arguably more expressive, find it somewhat more "magical": The `Decoded x`

value may look very different than `x`

.

I saw a comment on Twitter/X

If arguments can have different types then you need to generalize somehow, and product-profunctors is one sufficient generalization.

I never grasped `product-profunctors`

library. The `ProductProfunctor`

class looks like

```
class (forall a. Applicative p a, Profunctor p) => where
(***!) :: p a b -> p a' b' -> p (a, a') (b, b') -- Arrow has (***)
```

and it feels like a very ad-hoc collection of things.

There is an alternative solution to "if arguments can have different types". Often when you have singular thing, and you want to generalize to many things, you make an indexed version of the singular thing.

By indexed here I mean, changing `Type`

to `I -> Type`

for some index `I`

.

A simple example is recursive types. Suppose a language has recursive types, so we can write

`data Nat = Zero | Succ Nat`

but this language does not have *mutual* recursive types, but happens to have `DataKinds`

and `GADTs`

like features.

So we cannot write

```
data Even = Zero | SuccOdd Odd
data Odd = One | SuccEven Even
```

but we can write

```
data I = E | O
type :: I -> Type
data EvenOdd i where
Zero :: EvenOdd E
SuccOdd :: EvenOdd O -> EvenOdd E
One :: EvenOdd O
SuccEven :: EvenOdd E -> EvenOdd O
type Even = EvenOdd E
type Odd = EvenOdd O
```

And sometimes the latter encoding "works" better, e.g. mutual recursion becomes ordinary recursion on a single type. I remember having better time satisfying Coq termination checker with a similar trick.

So what does "indexed" `Traversable`

looks like. It looks like

```
type FTraversable :: ((k -> Type) -> Type) -> Constraint
class (...) => FTraversable t where
ftraverse :: Applicative m => (forall a. f a -> m (g a)) -> t f -> m (t g)
```

This class exists in many libraries on Hackage

I use `FTraversable`

in my `version-sat`

experiment.

It's like `simple-sat`

, but adds `Version`

literals. The `solve`

function has more general type, which however looks very similar.

`solve :: FTraversable model => model (Lit s) -> SAT s (model Identity)`

We can have symbolic booleans `Lit s Bool`

, but also symbolic versions `Lit s Version`

, the resulting model will have `Bool`

s and `Version`

s (wrapped in `Identity`

).

"Historical" note: `simple-sat`

started as `hkdsat`

, trying to allow encodings like in `ersatz`

, and maybe it eventually will, if I find simple way to add them. ^{2}

What I do with `version-sat`

. Well, it's just an experiment for now. One thing you can do, is to ask whether a `Cabal`

library has *any* build plan.

That is very straight-forward: convert a library stanza (conditional tree) information into proposition formula and ask whether it has any satisfiable models.

It turns out that 417 of 125991 libraries are unsatisfiable. For example `vector-0.12.1.1`

has been revisioned with `base <0`

bound.

I think that is fine number. Mistakes happen and 0.33% is a very small amount of b0rked releases. Many of these revisions are actually on my packages. And probably the number should be a bit larger, as people *deprecate* package version, which allows them still be installed, just less prioritized.

While you can look for unsatisfiable `build-depends`

syntactically, it's becomes less obvious with `if`

conditionals etc.

Throwing problem at a SAT solver in full generality is a *complete* (i.e. always give a definitive answer) approach.

Another question we can ask `version-sat`

is

Is there a install-plan which satisfies package definition with an automatic flag turned on *and* off.

That probably needs an explanation. In cabal-install solver as sat solver I briefly touched this topic.

Perfectly, the *automatic* flag assignment is disjoint, so the assignment made by dependency solver is deterministic (function of package versions in install plan).

The easy way to ensure it is to have disjoint constraints:

```
if flag(old-locale)
build-depends:
>=1.0.0.2 && <1.1
old-locale >=1.4 && <1.5
, time
elsebuild-depends: time >=1.5 && <1.7
```

The `time <1.5`

and `time >=1.5`

constraints are disjoint, so depending on which `time`

package version is picked, the value of `old-locale`

flag is forced.

I was surprised that 15776 of 136048 libraries are with non-disjoint automatic flags (11.60%). That number seems very high.

There are obvious false positives however, e.g. `semigroups`

has following structure

```
if impl(ghc < 7.11.20151002)
if flag(bytestring)
if flag(bytestring-builder)
-depends: bytestring >= 0.9 && < 0.10.4,
build-builder >= 0.10.4 && < 1
bytestringelse
-depends: bytestring >= 0.10.4 && < 1 build
```

An automatic `bytestring-builder`

flag has only an effect on old GHC and when manul `bytestring`

flag are on.

However, the dependency solver would still try to flip `bytestring-builder`

flag if it cannot satisfy the other dependencies. Not a terrible cost in case of `semigroups`

, but might be for some other packages (with non-trivial dependencies). A way to force it would be to have

```
if impl(ghc < 7.11.20151002)
...
elseif flag(bytestring-builder)
build-depends: base <0
```

Another example of invalid usage of automatic flag is e.g. `examples`

flag in `Earley`

(which have been fixed long ago: `examples`

is now a *manual* flag). The flag disables building of example `executables`

. When it was automatic dependency solver could unnecessarily flip it, and try to satisfy the example dependencies as well.

Unfortunately there are a lot of what I consider invalid usage of automatic flags. (Having flags automatic by default is really a wrong default, IMO).

But for example `accelerate`

, `atomic-primops`

, `hashtables`

, `unordered-containers`

have flags like `debug`

, `bounds-checks`

which affect the package code in a non-trivial way. You definitely don't want dependency solver flipping flags like that.

By default, Cabal will first try to satisfy dependencies with the default flag value and then, if that is not possible, with the negated value.

However, I don't think this can or should be relied upon. The build plans are generally non-comparable.

A somewhat contrived example is

```
flag foo: True
default
flag bar: True
default
library...
if flag(foo) && flag(bar)
-depends: base <0 build
```

the solver will need to make a (non-deterministic choice) to flip either flag.

Secondly, it restricts possible alternative solver implementations. I.e. they also would need to try hard to keep automatic flags at their default values. Luckily e.g. `minisat`

tries literals with `False`

first, so one can initialise flag literals so their default value matches. Still, SAT solver is a black box, there isn't hard guarantees it won't flip something just because it feels like that.

TL;DR from the cabal-install solver as sat solver post:

Only use automatic flags for encoding `if build-depends(...)` like constraints.

GHC relies heavily on mutability in the typechecker for efficient operation. For this reason, throughout much of the type checking process meta type variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable variables (known as TcRefs).

Zonking is the process of ripping out these mutable variables and replacing them with a real Type. This involves traversing the entire type expression, but the interesting part of replacing the mutable variables occurs in zonkTyVarOcc.↩︎

In my opinion, the

`Bool`

only,`Traversable`

based`solve`

is very simple to work with, when it's enough. And the`Version`

encoding in`version-sat`

is (ab)using mutability a lot, I haven't tried to do it in`ersatz`

.↩︎

Often enough we have an API which may (or need) to provide a batch operation: "give me many inputs, and I'll give you many outputs".

For example, `shake`

has operators like

```
-- Define a rule for building multiple files at the same time.
(&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
```

And the usage looks like

```
"*.o","*.hi"] &%> \[o,hi] -> do
[let hs = o -<.> "hs"
... -- all files the .hs import
need "ghc -c" [hs] cmd
```

but that is *terrible*. `\[o, hi] -> ...`

is a incomplete pattern match. Recent GHCs included `-Wincomplete-uni-patterns`

in `-Wall`

:

```
: [GHC-62161] [-Wincomplete-uni-patterns]
warningPattern match(es) are non-exhaustive
```

There is a relation: the inputs and outputs counts should match, but that is not encoded in the types, so compiler cannot know.

One option is to use `Vec`

:

`(&%>) :: Vec n FilePattern -> (Vec n FilePath -> Action ()) -> Rules ()`

Here it's clear that the output count will match the input count.

Than the usage will look like:

```
"*.o" ::: "*.hi" ::: Nil) &%> \(o ::: hi ::: Nil) -> do
(let hs = o -<.> "hs"
... -- all files the .hs import
need "ghc -c" [hs] cmd
```

This is slightly more noisy^{1} but the pattern match is *complete*.

Another alternative is to use *traversals*.

```
(&%>) :: Traversable t
=> t FilePattern -> (t FilePath -> Action ()) -> Rules ()
```

This abstracts over both previous usages. You may use `Vec`

s if you really don't like (turning off) the incomplete pattern warnings. Or you may continue use lists, as lists are `Traversable`

, and the signature of this variant of `(&%>)`

tells (and restricts the implementation) to just *traversing* the structure.

You can go one step further and use `Each`

class from `lens`

^{2}, which generalises `Traversable`

:

```
(&%>) :: Each FilePattern FilePath ps fs
=> ps -> (fs -> Action ()) -> Rules ()
```

As `Each`

has special instance for tuples (forcing them to be homogeneous), our running example can be written neatly as:

```
"*.o","*.hi") &%> \(o,hi) -> do
(let hs = o -<.> "hs"
... -- all files the .hs import
need "ghc -c" [hs] cmd
```

Each traversal `:: Applicative f => (a -> f b) -> s -> f t`

can be converted into a `s -> FunList a b t`

function and back:

```
data FunList a b t = Done t
| More a (FunList a b (b -> t))
-- this can be done more efficent using Curried Yoneda,
-- without using `append`.
-- See https://dl.acm.org/doi/10.1145/3236780
-- and https://gist.github.com/phadej/f5e8107e303265241e6b7b556db5ca48
funList :: (forall f. Applicative f => (a -> f b) -> s -> f t)
-> s -> FunList a b t
= trav singleton s
funList trav s
unfunList :: forall f s t a b. Applicative f => (s -> FunList a b t)
-> (a -> f b) -> s -> f t
= go (f s) where
unfunList f afb s go :: FunList a b r -> f r
Done t) = pure t
go (More x xs) = liftA2 (&) (afb x) (go xs) go (
```

where

```
empty :: t -> FunList a b t
= Done
empty
append :: (t -> s -> r) -> FunList a b t -> FunList a b s -> FunList a b r
Done t) ys = fmap (\s -> h t s) ys
append h (More x xs) ys = More x $ append (\bt s b -> h (bt b) s) xs ys
append h (
singleton :: a -> FunList a b b
= More x (Done id)
singleton x
instance Applicative (FunList a b) where
pure = empty
= append liftA2
```

so if your underlying implementation would be easier using a concrete type (instead of using traversal directly) then a `FunList`

is one candidate:

`(&%>) :: FunList FilePattern FilePath res -> (res -> Action ()) -> Rules ()`

that would be terrible to use, but it might be about as easy to implement as list variant.

Alternatively, you can "cheat" like `lens`

does in `partsOf`

implementation, by using a state monad:

Given an like operation `fooList :: Monad m => [k] -> m [v]`

, we can write a generalized version

```
fooTrav :: (Monad m, Traversable t) => t k -> m (t v)
= do
fooTrav ks -- convert to list and use fooList
<- fooList (toList ks)
vs
-- traverse ks again, replacing each k with a v from the state
traverse (\_k -> state un) vs) ks
evalStateT (where
= error "invalid traversal"
un [] :xs) = (x, xs) un (x
```

Implementation using `Each`

would look somewhat similar.

Finally, not only `Traversable`

-powered interface allows to use complete pattern matches as in `shake`

like use-cases, it also allows using more elaborate data-structures for batch operations.

For example, if you have a `Map Client [Key]`

and you want to lookup every value getting `Map Client [Value]`

back.

With `Traversable`

interface it's as easy as using `Compose`

, turning `Map Client [Key]`

into `Compose (Map Client) [] Key`

which fits the `Traversable`

interface perfectly, so you avoid bundling-and-distributing code in the use sites: `Map`

in, `Map`

out.

The answer is always `traverse`

.

And if we had different

`OverloadedLists`

, this could look like previous, though I'm not aware if anyone figure how to do overloaded pattern matches for list-like structures so that`Vec`

would fit it too.↩︎Which I'd like to split out into own tiny package https://github.com/ekmett/lens/issues/1050↩︎

Dependency resolution in Haskell ecosystem is a hard computational problem. While I'm unsure how hard problem is to picking individual package versions without any additional features, selecting assignment of *automatic package flags* seems to be very hard: it seems we encode arbitrary *boolean satisfiablity problems*, *SAT*, into automatic package flag selection problem.

Real world flag selection problems are easy. Yet, I wanted to try how well `cabal-install`

's solver copes with problems it haven't been tuned for.

In logic and computer science, the Boolean satisfiability problem is the problem of determining if there exists an interpretation that satisfies a given Boolean formula.

The problems are given to solvers in conjunctive normal form:

` (x₁ ∨ x₂) ∧ (x₃ ∨ x₄)`

and solvers job is to find an assignment making the formula true. In the example above there are many solutions, e.g. setting all variables to true.

One of go to examples of what you can do with a SAT solvers is solving sudoku puzzles.

Our running example will be a very simple 2×2 sudoku puzzle.

```
┌─────┬─────┐
│ 1 │ 4 │
│ 3 │ 2 │
├─────┼─────┤
│ │ 3 │
│ │ │
└─────┴─────┘
```

Problem encoding is somewhat of art form, but for sudoku its quite simple.

The problem variables are numbers in cells `i, j`

. We can encode each number using four variables, `x(i,j,k)`

, and requiring that exactly one is true. We could also use only two "bits" to encode four options (so called binary encoding), but using one-bit per option makes easier to encode the sudoku rules.

Recall the sudoku rules: each number have to occur exactly once in each row, column and subsquare.

With our number encoding the puzzle rules are easy to encode. For example for each row `i`

and number `k`

we require that exactly one literal in `x(i,j,k), j <- [1..4]`

is true And similarly for columns and subsquares.

For what it's worth, sudoku can be very neatly encoded using `Applicative`

s and `Traversable`

s. See the StackOverflow answer by Conor McBride.

SAT solvers consume a DIMACS format which looks like:

```
p cnf 64 453
-60 -64 0
-48 -64 0
-48 -60 0
-44 -64 0
-44 -60 0
-44 -48 0
44 48 60 64 0
-59 -63 0
-47 -63 0
-47 -59 0
-43 -63 0
-43 -59 0
-43 -47 0
43 47 59 63 0
-58 -62 0
...
```

Borrowing the DIMACS format explanation from varisat's documentation:

A DIMACS file begins with a header line of the form `p cnf <variables> <clauses>`

. Where `<variables>`

and `<clauses>`

are replaced with decimal numbers indicating the number of variables and clauses in the formula. Following the header line are the clauses of the formula. The clauses are encoded as a sequence of decimal numbers separated by spaces and newlines. For each clause the contained literals are listed followed by a `0`

.

The above is beginning of encoding of our sudoku problem. There are 4 × 4 cells and each number uses 4 variables, so in total there are 64 variables.

The exactly once encoding I used is done using naive (binomial) at most one encoding. You can see a pattern:

```
-60 -64 0
-48 -64 0
-48 -60 0
-44 -64 0
-44 -60 0
-44 -48 0
44 48 60 64 0
```

The last line is requiring that *at least one* of four variables (`44, 48, 60, 64`

) is true. The first 6 lines are pairwise requirements that *at most one* of the variables is true: n over 2 i.e. 6 pairs. All of sudoku rules are such exactly one of four constraints, which we have 64 in total: 16 for digits, 4 rows, columns and subsquares with four numbers, That is `7 × 64 = 448`

clauses.

The final 5 clauses are *initial value constraints*. As we know 5 numbers, we tell that the following bits must be true.

The `sudoku.cnf`

file indeed ends with five *unit* clauses:

```
...
43 0
30 0
23 0
12 0
5 0
```

When we run the SAT solver, e.g. `z3 -dimacs sudoku.cnf`

it will immediately give a solution which looks something like

```
sat
-1 2 -3 -4 5 -6 -7 -8 -9 -10 -11 12 -13 -14 15 -16
-17 -18 -19 20 -21 -22 23 -24 25 -26 -27 -28 -29 30 -31 -32
33 -34 -35 -36 -37 38 -39 -40 -41 -42 43 -44 -45 -46 -47 48
-49 -50 51 -52 -53 -54 -55 56 -57 58 -59 -60 61 -62 -63 -64
```

For each of 64 variables it prints whether the satisfying assignment for that variable is true (positive) or false (negative).

When we decode the solution we'll get a solution to our sudoku puzzle:

```
┌─────┬─────┐
│ 2 1 │ 4 3 │
│ 4 3 │ 1 2 │
├─────┼─────┤
│ 1 2 │ 3 4 │
│ 3 4 │ 2 1 │
└─────┴─────┘
```

So how can we encode a SAT problem as flag selection one?

It is hopefully obvious that each variable will be represented by an *automatic* flag, i.e. a flag which solver can (should) choose an assignment for:

```
flag 1: False
manual: False default
```

(Yes, flag names can be "numbers", they are still treated as strings).

The default value shouldn't matter, but it's probably better to pick `False`

as most variables in sudoku problem are indeed false.

Let's next think how to encode clauses. When the CNF is satisfiable each clause should evaluate to true. When CNF is *unsatisfiable* it's enough that *any* clause evaluate to false. Recall clauses are disjunctions of literals:

`x₁ ∨ ¬ x₂ ∨ ¬ x₃ ∨ x₄`

Then we can encode such clause as a conditional in a component stanza of `.cabal`

file. There shouldn't be an install plan if a clause value if false:

```
if !(flag(1) || !flag(2) || !flag(3) || flag(4))
build-depends: unsatisfiable <0
```

or equivalently:

```
if !flag(1) && flag(2) && flag(3) && !flag(4))
build-depends: unsatisfiable <0
```

The library stanze in the resulting `sudoku.cabal`

file looks like

```
library
if flag(60) && flag(64)
build-depends: unsatisfiable <0
if flag(48) && flag(64)
build-depends: unsatisfiable <0
if flag(48) && flag(60)
build-depends: unsatisfiable <0
if flag(44) && flag(64)
build-depends: unsatisfiable <0
if flag(44) && flag(60)
build-depends: unsatisfiable <0
if flag(44) && flag(48)
build-depends: unsatisfiable <0
if !flag(44) && !flag(48) && !flag(60) && !flag(64)
build-depends: unsatisfiable <0
...
if !flag(43)
build-depends: unsatisfiable <0
if !flag(30)
build-depends: unsatisfiable <0
if !flag(23)
build-depends: unsatisfiable <0
if !flag(12)
build-depends: unsatisfiable <0
if !flag(5)
build-depends: unsatisfiable <0
...
```

And we can ask `cabal-install`

to construct an install plan with

`cabal build --dry-run`

On my machine it took 17 seconds to complete. (I actually didn't know what to expect, I'd say 17 seconds is not bad).

`cabal-install`

writes out `plan.json`

file which contains the build plan. It's a JSON file which can be inspected directly or queried with `cabal-plan`

utility.

`cabal-plan topo --show-flags`

shows

```
sudoku-0 -1 -10 -11 +12 -13 -14 +15 -16 -17 -18 -19 +2 +20 -21 -22 +23
-24 +25 -26 -27 -28 -29 -3 +30 -31 -32 +33 -34 -35 -36 -37 +38 -39 -4
-40 -41 -42 +43 -44 -45 -46 -47 +48 -49 +5 -50 +51 -52 -53 -54 -55
+56 -57 +58 -59 -6 -60 +61 -62 -63 -64 -7 -8 -9
```

there is only one package in the install plan, and we asked `cabal-plan`

to also show the flag assignment, which it does. The output is almost the same as from `z3`

!

If we decode this solution, we get the same answer:

```
┌─────┬─────┐
│ 2 1 │ 4 3 │
│ 4 3 │ 1 2 │
├─────┼─────┤
│ 1 2 │ 3 4 │
│ 3 4 │ 2 1 │
└─────┴─────┘
```

We successfully used `cabal-install`

dependency solver as a SAT solver. It is terribly slow, but it's probably still faster at solving 2×2 sudoku puzzle than myself. The code is available on GitHub if you want to play with it.

However, it is not unheard that we need to encode some logical constraints in cabal file.

For example `transformers-compat`

encodes which `transformers`

version it depends on using kind of unary encoding: each bucket is encoded using single flag: Removing some unrelated bits:

```
...
if flag(four)
build-depends: transformers >= 0.4.1 && < 0.5
elsebuild-depends: transformers < 0.4 || >= 0.5
if flag(three)
build-depends: transformers >= 0.3 && < 0.4
elsebuild-depends: transformers < 0.3 || >= 0.4
...
```

The choice of `transformers`

versions forces assignments to the automatic flags (`four`

, `three`

, ...) and then we can alter build info of a package based on that.

That is an indirect way of writing (encoding!) something like

```
if build-depends(transformers >= 0.4.1 && <0.5)
...
if build-depends(transformers >= 0.3 && <0.4)
...
```

A common example in the past was adding `old-locale`

dependency when the old version of `time`

library was picked:

```
if flag(old-locale)
build-depends:
>=1.0.0.2 && <1.1
old-locale >=1.4 && <1.5
, time
elsebuild-depends: time >=1.5 && <1.7
```

which could be written as

```
build-depends: time >=1.4 && <1.7
if build-depends(time < 1.5)
build-depends: old-locale >=1.0.0.2 && <1.1
```

Another example is `functor-classes-compat`

which also encodes `transformers`

and `base`

version subsets, but it is using binary encoding of four options. There the implied constraints are also (hopefully) disjoint making flag assignment deterministic.

I think that automatic flags are good feature to have. It is a basic building block, but is a "low-level" feature. On the other hand `if build-depends(...)`

construct is more difficult to use wrong, and probably covers 99% of the use cases for automatic flags. If you are mindful that you encoding `if build-depends (...)`

constraint, then you'll probably use cabal's automatic flags correctly. Conversely, if you are using automatic flags to encode something else, like solving general SAT problems, most likely you are doing something wrong.

I found myself defining this kind of type alias and pattern synonym recently in many packages. You might find it nice too.

```
{-# LANGUAGE PatternSynonyms, TypeOperators #-}
-- | An operator for pair type.
type (:=) a b = (a, b)
-- | A proper operator for pair creation.
--
-- @(,)@ always need parentheses which is often annoying.
--
-- @(':=')@ binds very losely, so you can do:
--
-- >>> 'x' := reverse $ "foo" ++ "bar"
-- ('x',"raboof")
--
-- Or even nested pairs, if you feel LISPy
-- (right associativity is "inherited" from @('$')@):
--
-- >>> 'x' := True := "bar" := ()
-- ('x',(True,("bar",())))
--
-- A common use example is creating maps:
--
-- >>> import qualified Data.Map as Map
-- >>> Map.fromList [ "foo" := True, "bar" := False ]
-- fromList [("bar",False),("foo",True)]
--
pattern (:=) :: a -> b -> a := b
pattern (:=) a b = (a, b)
infixr 0 :=
{-# COMPLETE (:=) #-}
```

This post is a literate Agda file, where I try to define a category Δ of finite ordinals and monotone maps. Reed Mullanix wrote a post "Simple Simplices" around year and half ago about the topic suggesting an option.

That option, called `Δ⇒`

is implemented in `agda-categories`

package in `Categories.Category.Instance.Simplex`

module.

Reed asks for a decomposition:

`decompose : (Fin m → Fin n) → (m Δ⇒ n)`

I think I got it.

`module 2022-10-08-simplex where`

```
import Data.Nat as ℕ
open ℕ using (ℕ; zero; suc; z≤n; s≤s; _∸_)
open import Data.Nat.Properties using (≤-refl; ≤-trans)
open import Data.Fin using (Fin; zero; suc; _≤_; _<_; toℕ)
open import Data.Product using (Σ; _×_; _,_; proj₁; proj₂; map)
open import Data.Fin.Properties using (suc-injective; toℕ<n)
open import Relation.Binary.PropositionalEquality
using (_≡_; refl; cong; sym; trans)
open Relation.Binary.PropositionalEquality.≡-Reasoning
variable
: ℕ n m p
```

Reed mentions two options for implementing simplex category

- Define Δ as the category of finite ordinals and monotone maps.
- Define Δ as a free category generated by face and degeneracy maps, quotient by the simplicial identities.

Second one is just awful.

I assume the first option goes something like:

First we define the `isMonotone`

predicate on `Fin n → Fin m`

functions.

```
: (Fin n → Fin m) → Set
isMonotone = ∀ i j → i ≤ j → f i ≤ f j isMonotone f
```

Then a monotone function is a function together with a proof it is monotone

```
: ℕ → ℕ → Set
Monotone = Σ (Fin n → Fin m) isMonotone Monotone n m
```

And because it's a function in (ordinary) Agda we need to define an equality:

```
_≐_ : Monotone n m → Monotone n m → Set
(f , _) ≐ (g , _) = ∀ i → f i ≡ g i
```

The pointwise equality works well, and we don't actually care about `isMonotone`

proof. (Though I think it can be shown that it is hProp. so this is justified).

Reed mentions that this formulation is nice, except that we want to be able to define simplicial sets by how they act on the face and degeneracy maps, not some random monotonic map!

I actually don't know anything about face and boundary maps, but I trust others on that. (E.g. nLab also says that all morphism are generated by face and degeneracy maps)

Reed then proceed to define a *third* variant, which resembles free category definition, yet he doesn't quotient by simplicial identities, but instead he defines equality using the semantics (i.e. pointwise on a function "applying" his description to finite ordinal).

... but there is fourth (?) option to encode monotone maps.

And it is very simple! (It does resemble thinnings I wrote recently above, more on them below).

```
data Mono : ℕ → ℕ → Set where
: Mono zero zero
base : Mono n m → Mono n (suc m)
skip : Mono n (suc m) → Mono (suc n) (suc m) edge
```

The `base`

and `skip`

constructors are similar as in thinnings, but `edge`

as different then `keep`

. Where `keep`

always introduced a new "output", `edge`

requires there to be an element and maps new input to that same element.

So if we have a `Mono`

which looks like:

We can add a new edge which goes to already existing output with `edge`

:

It took some time to get this right.

`keep`

as in thinnings can be define as first adding a new output with `skip`

and then connecting an `edge`

there:

`pattern keep f = edge (skip f)`

We can define identity morphism and composition:

```
: Mono n n
id {zero} = base
id {suc n} = keep id
id
-- I'm rebel, using ⨟ for the composition
_⨟_ : Mono n m → Mono m p → Mono n p
= g
base ⨟ g = skip (skip f ⨟ g)
skip f ⨟ skip g = f ⨟ g
skip f ⨟ edge g = skip (edge f ⨟ g)
edge f ⨟ skip g = edge (f ⨟ edge g) edge f ⨟ edge g
```

I leave as an exercise to prove that category laws are satisfied.

Next we can define the semantics, i.e. how `Mono`

maps finite ordinals: The definition is simple, encoding the graphical intuition from above.

```
: Mono n m → Fin n → Fin m
apply (skip f) i = suc (apply f i)
apply (edge f) zero = zero
apply (edge f) (suc i) = apply f i apply
```

We can show that `apply`

, `id`

and `⨟`

work together as expected.

```
: (i : Fin n) → apply id i ≡ i
apply-id = refl
apply-id zero (suc i) = cong suc (apply-id i)
apply-id
: (f : Mono n m) (g : Mono m p) (i : Fin n)
apply-⨟ → apply g (apply f i) ≡ apply (f ⨟ g) i
(skip f) (skip g) i = cong suc (apply-⨟ (skip f) g i)
apply-⨟ (skip f) (edge g) i = apply-⨟ f g i
apply-⨟ (edge f) (skip g) i = cong suc (apply-⨟ (edge f) g i)
apply-⨟ (edge f) (edge g) zero = refl
apply-⨟ (edge f) (edge g) (suc i) = apply-⨟ f (edge g) i apply-⨟
```

Mono has a very nice property: *it uniquely represents a monotone map* In other words, if there are two `Mono n m`

, but for all `i : Fin n`

, they act the same, then `f`

and `g`

are propositionally equal:

```
: (f g : Mono n m) → (∀ i → apply f i ≡ apply g i) → f ≡ g
apply-inj = refl
apply-inj base base p (skip f) (skip g) p =
apply-inj (apply-inj f g λ i → suc-injective (p i))
cong skip (skip f) (edge g) p with p zero
apply-inj ... | ()
(edge f) (skip g) p with p zero
apply-inj ... | ()
(edge f) (edge g) p = cong edge (apply-inj f g λ i → p (suc i) ) apply-inj
```

As a sanity check, `apply f`

is indeed monotone:

```
: (f : Mono n m) → isMonotone (apply f)
isMonotone-apply (skip f) i j i≤j = s≤s (isMonotone-apply f i j i≤j)
isMonotone-apply (edge f) zero j 0≤j = z≤n
isMonotone-apply (edge f) (suc i) (suc j) (s≤s i≤j) = isMonotone-apply f i j i≤j isMonotone-apply
```

Combining the previous, we can map from `Mono`

(data) to `Monotone`

(Agda function).

```
: Mono n m → Monotone n m
Mono→Monotone = apply f , isMonotone-apply f Mono→Monotone f
```

Because the `Mono`

definition is so simple, we should try to convert back. The code in this section can be improved, but for now we only need the final result.

First we define "subtraction" and "addition" of finite ordinals. The `∸`

is *monus* on natural numbers (i.e. safe subtraction, defaulting to zero). In the same vein, `lower`

doesn't require `i ≤ j`

proof.

```
-- kind of j - i, no i ≤ j requirement, "monus"
: (i j : Fin (suc m)) → Fin (suc (m ∸ toℕ i))
lower = j
lower zero j {m = suc m} (suc i) zero = zero -- extra case, here i≤j
lower {m = suc m} (suc i) (suc j) = lower i j
lower
: (i : Fin (suc m)) → Fin (suc (m ∸ toℕ i)) → Fin (suc m)
raise = j
raise zero j {m = suc m} (suc i) j = suc (raise i j) raise
```

We can show that raise and lower cancel out, here we need `j ≤ i`

proof. (I noticed that I'm not consistent with `i`

and `j`

variables, but hopefully you get along).

```
: (i j : Fin (suc m)) (j≤i : j ≤ i) → i ≡ raise j (lower j i)
raise∘lower≡id = refl
raise∘lower≡id i zero j≤i {m = suc m} (suc i) (suc j) (s≤s j≤i) =
raise∘lower≡id (raise∘lower≡id i j j≤i) cong suc
```

Then we need a handful of lemmas.

`lower`

for fixed `k`

is monotone:

```
: ∀ (k : Fin (suc m)) → isMonotone (lower k)
isMonotone-lower = i≤j
isMonotone-lower zero i j i≤j {m = suc m} (suc k) zero j z≤0 = z≤n -- redundant case
isMonotone-lower {m = suc m} (suc k) (suc i) (suc j) (s≤s i≤j) = isMonotone-lower k i j i≤j isMonotone-lower
```

We can raise the `Mono`

, so we can commute `raise`

and `apply`

```
: ∀ p → Mono n (suc (m ∸ p)) → Mono n (suc m)
raise-mono' = f
raise-mono' zero f {m = zero} (suc p) f = f
raise-mono' {m = suc m} (suc p) f = skip (raise-mono' p f)
raise-mono'
: ∀ (k : Fin (suc m)) → Mono n (suc (m ∸ toℕ k)) → Mono n (suc m)
raise-mono = raise-mono' (toℕ k) raise-mono k
```

Then the idea is to define `Monotone`

to `Mono`

conversion by looking at `f zero`

input, and trimming `f`

using `lower`

.

For the lack of better name I call this new function `next`

:

```
: (f : Fin (suc n) → Fin (suc m)) → isMonotone f
next-f → Fin n → Fin (suc (m ∸ toℕ (f zero)))
= lower (f zero) (f (suc i)) next-f f f-mono i
```

And `next-f f`

is monotone if `f`

is:

```
: (f : Fin (suc n) → Fin (suc m)) (f-mono : isMonotone f)
next-mono → isMonotone (next-f f f-mono)
= isMonotone-lower
next-mono f f-mono i j i≤j (f zero)
(f (suc i))
(f (suc j))
(f-mono (suc i) (suc j) (s≤s i≤j))
: (f : Monotone (suc n) (suc m))
next → Monotone n (suc (m ∸ toℕ (proj₁ f zero)))
(f , f-mono) = next-f f f-mono , next-mono f f-mono next
```

Now we have (almost) all the ingredients to define `Monotone→Mono`

function:

```
: Mono zero n
absurd {zero} = base
absurd {suc n} = skip absurd
absurd
: (f : Fin n → Fin m) → isMonotone f → Mono n m
Monotone→Mono' {zero} f f-mono = absurd
Monotone→Mono' {suc n} {zero} f f-mono with f zero
Monotone→Mono' ... | ()
{suc n} {suc m} f f-mono = raise-mono (f zero)
Monotone→Mono' (edge (Monotone→Mono' (next-f f f-mono) (next-mono f f-mono)))
```

And `Monotone→Mono`

just packages that:

```
: Monotone n m → Mono n m
Monotone→Mono (f , f-mono) = Monotone→Mono' f f-mono Monotone→Mono
```

`Monotone→Mono`

and `Mono→Monotone`

are each others inverse.

First two lemmas, showing that `raise`

and `apply`

"commute" in a special case we need:

```
: (j : Fin (suc m))
raise-edge-apply-zero → (f : Mono n (suc (m ∸ toℕ j)))
→ j ≡ apply (raise-mono j (edge f)) zero
= refl
raise-edge-apply-zero zero f {m = suc m} (suc j) f =
raise-edge-apply-zero (raise-edge-apply-zero j f)
cong suc
: (j : Fin (suc m))
raise-edge-apply-suc → (i : Fin n)
→ (f : Mono n (suc (m ∸ toℕ j)))
→ raise j (apply f i)
(raise-mono j (edge f)) (suc i)
≡ apply = refl
raise-edge-apply-suc zero i f {m = suc m} (suc j) i f =
raise-edge-apply-suc (raise-edge-apply-suc j i f) cong suc
```

Using which we can show that `apply ∘ Monotone→Mono`

is the identity function: (Agda proofs are wide, layout of my blog looks horrible with those, I'm sorry).

```
: (f : Monotone n m)
apply-Monotone→Mono → (i : Fin n)
→ proj₁ f i ≡ apply (Monotone→Mono f) i
{suc n} {zero} f i with proj₁ f zero
apply-Monotone→Mono ... | ()
{suc n} {suc m} f zero = begin
apply-Monotone→Mono (proj₁ f zero) (Monotone→Mono (next f)) ⟩
proj₁ f zero ≡⟨ raise-edge-apply-zero (Monotone→Mono f) zero ∎
apply {suc n} {suc m} f (suc i) = begin
apply-Monotone→Mono (suc i) ≡⟨ raise∘lower≡id (proj₁ f (suc i)) (proj₁ f zero) (proj₂ f zero (suc i) z≤n) ⟩
proj₁ f (proj₁ f zero) (lower (proj₁ f zero) (proj₁ f (suc i))) ≡⟨ cong (raise (proj₁ f zero)) (apply-Monotone→Mono (next f) i) ⟩
raise (proj₁ f zero) (apply (Monotone→Mono (next f)) i) ≡⟨ raise-edge-apply-suc (proj₁ f zero) i _ ⟩
raise (Monotone→Mono f) (suc i) ∎ apply
```

And that is the same as saying that we can convert `Monotone`

to `Mono`

and back, and we get what we started with (in `≐`

sense):

```
: (f : Monotone n m)
Monotone→Mono→Monotone → f ≐ Mono→Monotone (Monotone→Mono f)
= apply-Monotone→Mono Monotone→Mono→Monotone
```

The other direction, i.e. starting with `Mono`

is simple to show as well using `apply-inj`

lemma, which is the benefit of `Mono`

having unique representation:

```
: (f : Mono n m)
Monotone→Mono→Mono → f ≡ Monotone→Mono (Mono→Monotone f)
= apply-inj
Monotone→Mono→Mono f
f(Monotone→Mono (Mono→Monotone f))
(apply-Monotone→Mono (Mono→Monotone f))
```

In this section we have shown that `Mono`

and `Monotone`

types are isomorphic. Great news!

Recall thinnings:

```
data Thin : ℕ → ℕ → Set where
: Thin zero zero
baseₜ : Thin n m → Thin n (suc m)
skipₜ : Thin n m → Thin (suc n) (suc m)
keepₜ
: Thin n m → Fin n → Fin m
applyₜ (skipₜ f) i = suc (applyₜ f i)
applyₜ (keepₜ f) zero = zero
applyₜ (keepₜ f) (suc i) = suc (applyₜ f i) applyₜ
```

These are strictly monotone functions:

```
: (Fin n → Fin m) → Set
isStrictlyMonotone = ∀ i j → i < j → f i < f j
isStrictlyMonotone f
: (f : Thin n m) → isStrictlyMonotone (applyₜ f)
isStrictlyMonotone-applyₜ (skipₜ f) i j i<j = s≤s (isStrictlyMonotone-applyₜ f i j i<j)
isStrictlyMonotone-applyₜ (keepₜ f) zero (suc j) (s≤s i<j) = s≤s z≤n
isStrictlyMonotone-applyₜ (keepₜ f) (suc i) (suc j) (s≤s i<j) = s≤s (isStrictlyMonotone-applyₜ f i j i<j) isStrictlyMonotone-applyₜ
```

Similarly: unique representation

```
: (f g : Thin n m) → (∀ i → applyₜ f i ≡ applyₜ g i) → f ≡ g
applyₜ-inj = refl
applyₜ-inj baseₜ baseₜ p (skipₜ f) (skipₜ g) p =
applyₜ-inj (applyₜ-inj f g λ i → suc-injective (p i))
cong skipₜ (skipₜ f) (keepₜ g) p with p zero
applyₜ-inj ... | ()
(keepₜ f) (skipₜ g) p with p zero
applyₜ-inj ... | ()
(keepₜ f) (keepₜ g) p =
applyₜ-inj (applyₜ-inj f g λ i → suc-injective (p (suc i))) cong keepₜ
```

But `applyₜ f`

maps are also injective, i.e. map different `Fin n`

s to to different `Fin m`

s:

```
: (f : Thin n m) (i j : Fin n) → applyₜ f i ≡ applyₜ f j → i ≡ j
applyₜ-inj₂ (skipₜ f) i j p = applyₜ-inj₂ f i j (suc-injective p)
applyₜ-inj₂ (keepₜ f) zero zero p = refl
applyₜ-inj₂ (keepₜ f) (suc i) (suc j) p = cong suc (applyₜ-inj₂ f i j (suc-injective p)) applyₜ-inj₂
```

Thinnings can be converted to `Mono`

:

```
: Thin n m → Mono n m
Thin→Mono = base
Thin→Mono baseₜ (skipₜ f) = skip (Thin→Mono f)
Thin→Mono (keepₜ f) = keep (Thin→Mono f) Thin→Mono
```

`Thin`

s are injective monotonic maps. Can we represent the surjective ones? Yes! This look very similar:

```
data Cntr : ℕ → ℕ → Set where
: Cntr zero zero
baseₖ : Cntr n (suc m) → Cntr (suc n) (suc m)
edgeₖ : Cntr n m → Cntr (suc n) (suc m)
keepₖ
: Cntr (suc n) m → Cntr (suc (suc n)) m
edgeₖ' (edgeₖ f) = edgeₖ (edgeₖ f)
edgeₖ' (keepₖ f) = edgeₖ (keepₖ f)
edgeₖ'
: Cntr n m → Fin n → Fin m
applyₖ (edgeₖ f) zero = zero
applyₖ (edgeₖ f) (suc i) = applyₖ f i
applyₖ (keepₖ f) zero = zero
applyₖ (keepₖ f) (suc i) = suc (applyₖ f i)
applyₖ
: (f : Cntr n m) → isMonotone (applyₖ f)
isMonotone-applyₖ (edgeₖ f) zero j 0≤j = z≤n
isMonotone-applyₖ (edgeₖ f) (suc i) (suc j) (s≤s i≤j) = isMonotone-applyₖ f i j i≤j
isMonotone-applyₖ (keepₖ f) zero j 0≤j = z≤n
isMonotone-applyₖ (keepₖ f) (suc i) (suc j) (s≤s i≤j) = s≤s (isMonotone-applyₖ f i j i≤j)
isMonotone-applyₖ
: (f : Cntr n m) (j : Fin m) → Σ (Fin n) λ i → applyₖ f i ≡ j
applyₖ-surjective (edgeₖ f) j with applyₖ-surjective f j
applyₖ-surjective ... | i , p = suc i , p
(keepₖ f) zero = zero , refl
applyₖ-surjective (keepₖ f) (suc j) with applyₖ-surjective f j
applyₖ-surjective ... | i , p = suc i , cong suc p
: Cntr n m → Mono n m
Cntr→Mono = base
Cntr→Mono baseₖ (edgeₖ f) = edge (Cntr→Mono f)
Cntr→Mono (keepₖ f) = keep (Cntr→Mono f) Cntr→Mono
```

We can show that `Mono`

can be decomposed into composition of `Cntr`

and `Thin`

.

We can define the type and smart constructors:

```
: ℕ → ℕ → Set
Cntr×Thin = Σ ℕ λ p → Cntr n p × Thin p m
Cntr×Thin n m
: Cntr×Thin zero zero
baseₖₜ = 0 , baseₖ , baseₜ
baseₖₜ
: Cntr×Thin n m → Cntr×Thin n (suc m)
skipₖₜ (p , f , g) = p , f , skipₜ g
skipₖₜ
: Cntr×Thin n (suc m) → Cntr×Thin (suc n) (suc m)
edgeₖₜ (p , f , skipₜ g) = suc p , keepₖ f , keepₜ g
edgeₖₜ (p , f , keepₜ g) = p , edgeₖ f , keepₜ g edgeₖₜ
```

Then conversion from `Mono`

is trivial to define:

```
: (f : Mono n m) → Cntr×Thin n m
Mono→Cntr×Thin = baseₖₜ
Mono→Cntr×Thin base (skip f) = skipₖₜ (Mono→Cntr×Thin f)
Mono→Cntr×Thin (edge f) = edgeₖₜ (Mono→Cntr×Thin f) Mono→Cntr×Thin
```

Other direction isn't tricky either:

```
: Cntr×Thin n m → Mono n m
Cntr×Thin→Mono (_ , f , g) = Cntr→Mono f ⨟ Thin→Mono g Cntr×Thin→Mono
```

We can show that starting from `Mono`

we can convert to a pair of `Cntr`

and `Thin`

, and if we convert back, we get what we started with:

```
: (f : Mono n m) (g : Mono m p) → f ⨟ skip g ≡ skip (f ⨟ g)
skip-⨟ = refl
skip-⨟ base g (skip f) g = refl
skip-⨟ (edge f) g = refl
skip-⨟
: (f : Cntr×Thin n m) → Cntr×Thin→Mono (skipₖₜ f) ≡ skip (Cntr×Thin→Mono f)
skip-pres (p , f , g) = skip-⨟ (Cntr→Mono f) (Thin→Mono g)
skip-pres
: (f : Cntr×Thin n (suc m)) → Cntr×Thin→Mono (edgeₖₜ f) ≡ edge (Cntr×Thin→Mono f)
edge-pres (p , f , skipₜ g) = refl
edge-pres (suc p , f , keepₜ g) = refl
edge-pres
: (f : Mono n m) → Cntr×Thin→Mono (Mono→Cntr×Thin f) ≡ f
Mono→CT→Mono = refl
Mono→CT→Mono base (skip f) = trans (skip-pres (Mono→Cntr×Thin f)) (cong skip (Mono→CT→Mono f))
Mono→CT→Mono (edge f) = trans (edge-pres (Mono→Cntr×Thin f)) (cong edge (Mono→CT→Mono f)) Mono→CT→Mono
```

This is an example of factoring a function into a composition of a surjective function followed by an injective one.

Reed's "Simple Simplices" blog post ended with a challenge writing

`decompose : (Fin m → Fin n) → (m Δ⇒ n)`

function.

As we can convert `Monotone`

to `Mono`

, maybe we can get close?

Let's try.

`open import Categories.Category.Instance.Simplex`

The other direction, from `Δ⇒`

to `Mono`

can be defined in systematic way. We define `faceₘ`

and `degenₘ`

and show that they behave like `face`

and `degen`

maps:

```
: Fin (suc n) → Mono n (suc n)
faceₘ = skip id
faceₘ zero {n = suc n} (suc i) = keep (faceₘ i)
faceₘ
: (i : Fin (suc n)) (j : Fin n) → face i j ≡ apply (faceₘ i) j
apply-faceₘ = cong suc (sym (apply-id j))
apply-faceₘ zero j (suc i) zero = refl
apply-faceₘ (suc i) (suc j) = cong suc (apply-faceₘ i j)
apply-faceₘ
: Fin n → Mono (suc n) n
degenₘ = edge id
degenₘ zero (suc i) = keep (degenₘ i)
degenₘ
: (i : Fin n) (j : Fin (suc n)) → degen i j ≡ apply (degenₘ i) j
apply-degenₘ {suc n} zero zero = refl
apply-degenₘ {suc n} zero (suc j) = sym (apply-id j)
apply-degenₘ {suc n} (suc i) zero = refl
apply-degenₘ {suc n} (suc i) (suc j) = cong suc (apply-degenₘ i j) apply-degenₘ
```

That is enough to define `Δ→Mono`

map. As we already showed that identity and composition respect `apply`

, We can show that so does respect `Δ→Mono`

.

```
: n Δ⇒ m → Mono n m
Δ→Mono = id
Δ→Mono ε (δ i) = faceₘ i
Δ→Mono (σ j) = degenₘ j
Δ→Mono (f ⊚ g) = Δ→Mono g ⨟ Δ→Mono f
Δ→Mono
: (f : n Δ⇒ m) (i : Fin n) → apply (Δ→Mono f) i ≡ ⟦ f ⟧ i
apply-Δ→Mono = apply-id j
apply-Δ→Mono ε j (δ i) j = sym (apply-faceₘ i j)
apply-Δ→Mono (σ i) j = sym (apply-degenₘ i j)
apply-Δ→Mono (f ⊚ g) j = begin
apply-Δ→Mono (Δ→Mono (f ⊚ g)) j ≡⟨ sym (apply-⨟ (Δ→Mono g) (Δ→Mono f) j) ⟩
apply (Δ→Mono f) (apply (Δ→Mono g) j) ≡⟨ cong (apply (Δ→Mono f)) (apply-Δ→Mono g j) ⟩
apply (Δ→Mono f) (⟦ g ⟧ j) ≡⟨ apply-Δ→Mono f (⟦ g ⟧ j) ⟩
apply ⟦ f ⊚ g ⟧ j ∎
```

The actual direction we are interested in is similar. We define smart constructors, and then proceed by structural induction.

First smart constructor is (maybe surprisingly) `keepₚ`

:

Note: it doesn't make `Δ⇒`

any bigger, it still has the same structure and as many face and degen maps.

```
: n Δ⇒ m → suc n Δ⇒ suc m
keepₚ = ε
keepₚ ε (δ i) = δ (suc i)
keepₚ (σ j) = σ (suc j)
keepₚ (f ⊚ g) = keepₚ f ⊚ keepₚ g
keepₚ
: (f : n Δ⇒ m) → ⟦ keepₚ f ⟧ zero ≡ zero
keepₚ-apply-zero = refl
keepₚ-apply-zero ε (δ i) = refl
keepₚ-apply-zero (σ j) = refl
keepₚ-apply-zero (f ⊚ g) = trans (cong ⟦ keepₚ f ⟧ (keepₚ-apply-zero g)) (keepₚ-apply-zero f)
keepₚ-apply-zero
: (f : n Δ⇒ m) (i : Fin n) → ⟦ keepₚ f ⟧ (suc i) ≡ suc (⟦ f ⟧ i)
keepₚ-apply-suc = refl
keepₚ-apply-suc ε j (δ i) j = refl
keepₚ-apply-suc (σ i) j = refl
keepₚ-apply-suc (f ⊚ g) j = trans (cong ⟦ keepₚ f ⟧ (keepₚ-apply-suc g j)) (keepₚ-apply-suc f (⟦ g ⟧ j) ) keepₚ-apply-suc
```

Base case is simple:

```
: zero Δ⇒ zero
baseₚ = ε baseₚ
```

Skip is using face map:

```
: n Δ⇒ m → n Δ⇒ suc m
skipₚ = δ zero ⊚ f
skipₚ f
: (f : n Δ⇒ m) (i : Fin n) → ⟦ skipₚ f ⟧ i ≡ suc (⟦ f ⟧ i)
skipₚ-apply = refl skipₚ-apply f i
```

And edge is using degen map:

```
: n Δ⇒ suc m → suc n Δ⇒ suc m
edgeₚ = σ zero ⊚ keepₚ f
edgeₚ f
: (f : n Δ⇒ suc m) → ⟦ edgeₚ f ⟧ zero ≡ zero
edgeₚ-apply-zero = cong (degen zero) (keepₚ-apply-zero f)
edgeₚ-apply-zero f
: (f : n Δ⇒ suc m) (i : Fin n) → ⟦ edgeₚ f ⟧ (suc i) ≡ ⟦ f ⟧ i
edgeₚ-apply-suc = cong (degen zero) (keepₚ-apply-suc f i) edgeₚ-apply-suc f i
```

Conversion from `Mono`

to `Δ⇒`

is then easy when you have the pieces. The size of `Δ⇒`

is `n`

face maps and `m`

degen maps, even for identity map. Thus it's not minimal in any sense, but it isn't enormous either.

```
: Mono n m → n Δ⇒ m
Mono→Δ = baseₚ
Mono→Δ base (skip f) = skipₚ (Mono→Δ f)
Mono→Δ (edge f) = edgeₚ (Mono→Δ f) Mono→Δ
```

Finally we can show that `Mono→Δ`

and `Δ→Mono`

for an isomorphism:

```
: (f : Mono n m) (i : Fin n) → ⟦ Mono→Δ f ⟧ i ≡ apply f i
apply-Mono→Δ (skip f) i = trans (skipₚ-apply (Mono→Δ f) i) (cong suc (apply-Mono→Δ f i))
apply-Mono→Δ (edge f) zero = edgeₚ-apply-zero (Mono→Δ f)
apply-Mono→Δ (edge f) (suc i) = trans (edgeₚ-apply-suc (Mono→Δ f) i) (apply-Mono→Δ f i)
apply-Mono→Δ
: (f : Mono n m) → Δ→Mono (Mono→Δ f) ≡ f
Mono→Δ→Mono = apply-inj (Δ→Mono (Mono→Δ f)) f λ i → trans (apply-Δ→Mono (Mono→Δ f) i) (apply-Mono→Δ f i)
Mono→Δ→Mono f
: (f : n Δ⇒ m) (i : Fin n) → ⟦ Mono→Δ (Δ→Mono f) ⟧ i ≡ ⟦ f ⟧ i
Δ→Mono→Δ' = trans (apply-Mono→Δ (Δ→Mono f) i) (apply-Δ→Mono f i)
Δ→Mono→Δ' f i
: (f : n Δ⇒ m) → Mono→Δ (Δ→Mono f) ≗ f
Δ→Mono→Δ = Δ-eq λ {i} → Δ→Mono→Δ' f i Δ→Mono→Δ f
```

Using this result, and iso between `Mono`

and `Monotone`

we can define conversion from `Monotone`

to `Δ⇒`

:

```
: Monotone n m → n Δ⇒ m
Monotone→Δ = Mono→Δ (Monotone→Mono f)
Monotone→Δ f
: (f : Monotone n m) (i : Fin n)
Monotone→Δ-correct → proj₁ f i ≡ ⟦ Monotone→Δ f ⟧ i
= begin
Monotone→Δ-correct f i
proj₁ f i ≡⟨ apply-Monotone→Mono f i ⟩(Monotone→Mono f) i ≡⟨ sym (apply-Mono→Δ (Monotone→Mono f) i) ⟩
apply ⟦ Monotone→Δ f ⟧ i ∎
```

The `Monotone→Δ`

is almost the `decompose`

Reed was asking about. We need to know that argument is also monotonic to do the conversion. I think it's possible to define

```
postulate
monotonise : (Fin m → Fin n) → Monotone m n
```

such that it is involutive on monotonic maps:

```
postulate
monotonise-inv : (f : Monotone n m) → f ≐ monotonise (proj₁ f)
```

But if we have `monotonise`

, then we can define

```
decompose : (Fin n → Fin m) → n Δ⇒ m
decompose f = Monotone→Δ (monotonise f)
```

First the maximum function, and few lemmas:

```
infix 5 _∨_
_∨_ : Fin n → Fin n → Fin n
= j
zero ∨ j = suc i
suc i ∨ zero = suc (i ∨ j)
suc i ∨ suc j
: (i j : Fin n) → i ≤ j ∨ i
i≤j∨i = z≤n
i≤j∨i zero j (suc i) zero = ≤-refl
i≤j∨i (suc i) (suc j) = s≤s (i≤j∨i i j)
i≤j∨i
: (i j : Fin n) → i ≤ i ∨ j
i≤i∨j = z≤n
i≤i∨j zero j (suc i) zero = ≤-refl
i≤i∨j (suc i) (suc j) = s≤s (i≤i∨j i j)
i≤i∨j
: (i j k : Fin n) → i ≤ j → i ∨ k ≤ j ∨ k
i≤j→i∨k≤i∨k = i≤j∨i k j
i≤j→i∨k≤i∨k zero j k 0≤j (suc i) (suc j) zero i≤j = i≤j
i≤j→i∨k≤i∨k (suc i) (suc j) (suc k) (s≤s i≤j) = s≤s (i≤j→i∨k≤i∨k i j k i≤j)
i≤j→i∨k≤i∨k
: (i j : Fin n) → i ≤ j → j ≡ j ∨ i
i≤j→j≡j∨i = refl
i≤j→j≡j∨i zero zero 0≤0 (suc j) i<j = refl
i≤j→j≡j∨i zero (suc i) (suc j) (s≤s i≤j) = cong suc (i≤j→j≡j∨i i j i≤j) i≤j→j≡j∨i
```

Then we can write an algorithm to make arbitrary `f`

monotone:

The idea is to raise the floor for larger inputs:

```
: (Fin (suc n) → Fin m) → (Fin n → Fin m)
monotonise-f' = f (suc k) ∨ f zero
monotonise-f' f k
: (Fin n → Fin m) → (Fin n → Fin m)
monotonise-f = f zero
monotonise-f f zero (suc i) = monotonise-f (monotonise-f' f) i monotonise-f f
```

The monotonised `f`

is greater then just `f`

:

```
: (f : Fin n → Fin m) (i j : Fin n)
monotonise-f-≤ → i ≤ j
→ f i ≤ monotonise-f f j
= ≤-refl
monotonise-f-≤ f zero zero i≤j {n = suc (suc n)} f zero (suc j) i≤1+j = ≤-trans
monotonise-f-≤ (i≤j∨i (f zero) (f (suc zero)))
(monotonise-f-≤ (monotonise-f' f) zero j z≤n)
(suc i) (suc j) (s≤s i≤j) = ≤-trans
monotonise-f-≤ f (i≤i∨j (f (suc i)) (f zero))
(monotonise-f-≤ (monotonise-f' f) i j i≤j)
```

And the result is indeed monotone:

```
: (f : Fin n → Fin m) → isMonotone (monotonise-f f)
monotonise-mono = ≤-refl
monotonise-mono f zero zero 0≤0 (suc j) 0≤j = monotonise-f-≤ f zero (suc j) z≤n
monotonise-mono f zero (suc i) (suc j) (s≤s i≤j) = monotonise-mono (monotonise-f' f) i j i≤j monotonise-mono f
```

So we can convert an arbitrary function to `Monotone n m`

:

```
: (Fin n → Fin m) → Monotone n m
monotonise = monotonise-f f , monotonise-mono f monotonise f
```

Finally we can prove that `monotonise`

is "involutive" when applied

```
: (f : Fin (suc n) → Fin m)
monotonise-f'-mono → isMonotone f
→ isMonotone (monotonise-f' f)
= i≤j→i∨k≤i∨k
monotonise-f'-mono f f-mono i j i≤j (f (suc i))
(f (suc j))
(f zero)
(f-mono (suc i) (suc j) (s≤s i≤j))
: (f : Fin n → Fin m) → isMonotone f → ∀ i → f i ≡ monotonise-f f i
monotonise-inv' = refl
monotonise-inv' f f-mono zero (suc i) = begin
monotonise-inv' f f-mono (suc i) ≡⟨ i≤j→j≡j∨i (f zero) (f (suc i)) (f-mono zero (suc i) z≤n) ⟩
f (monotonise-f' f) (monotonise-f'-mono f f-mono) i ⟩
monotonise-f' f i ≡⟨ monotonise-inv' (monotonise-f' f) i ∎
monotonise-f
: (f : Monotone n m) → f ≐ monotonise (proj₁ f)
monotonise-inv (f , f-mono) = monotonise-inv' f f-mono monotonise-inv
```

And finally we can define decompose!

```
: (Fin n → Fin m) → n Δ⇒ m
decompose = Monotone→Δ (monotonise f) decompose f
```

I was lately again thinking about thinnings.

Thinnings are a weaker form of renamings, which we use in well-scoped or well-typed implementations of programming languages. (Their proper name is *order-preserving embeddings*, mathematicians may know them as morphism in *augmented simplex category* Δ₊)

There is one well known and used implementation implementation for them. It's simple to use and write proofs about. However it's not super great. Especially it's not great in Haskell, as it cannot be given `Category`

instance. (Though you almost never need thinnings in Haskell, so the reason is a bit moot).

I'll show two other implementations, and show that they are equivalent, using *Cubical Agda* to state the equivalences. Before we dive in, Agda module prologue:

```
{-# OPTIONS --cubical --safe #-}
module 2022-09-30-thinnings where
open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Nat
open import Cubical.Data.Empty
open import Cubical.Data.Sigma
open import Cubical.Relation.Nullary
```

I will show only a well-scoped thinnings. So the context are simply natural numbers. As there are plenty of them, let us define few common variables.

```
variable
: ℕ n m p r
```

For the sake of this post, I call well known thinnings *orthodox*, and use ₒ subscript to indicate that.

```
data _⊑ₒ_ : ℕ → ℕ → Type where
: zero ⊑ₒ zero
nilₒ : n ⊑ₒ m → n ⊑ₒ suc m
skipₒ : n ⊑ₒ m → suc n ⊑ₒ suc m
keepₒ
= _⊑ₒ_ Orth
```

An example thinning is like

```
: 5 ⊑ₒ 7
exₒ = keepₒ (skipₒ (keepₒ (skipₒ (keepₒ (keepₒ (keepₒ nilₒ)))))) exₒ
```

Which would look like:

We can define identity thinning:

```
: n ⊑ₒ n
idₒ {zero} = nilₒ
idₒ {suc n} = keepₒ idₒ idₒ
```

Note how it pattern matches on the size (of the context). That what makes it impossible to defined `Category`

instance in Haskell.

We can also define composition, and weakening on top of the context

```
_⦂ₒ_ : n ⊑ₒ m → m ⊑ₒ p → n ⊑ₒ p
= δ₁
δ₁ ⦂ₒ nilₒ = skipₒ (δ₁ ⦂ₒ δ₂)
δ₁ ⦂ₒ skipₒ δ₂ = keepₒ (δ₁ ⦂ₒ δ₂)
keepₒ δ₁ ⦂ₒ keepₒ δ₂ = skipₒ (δ₁ ⦂ₒ δ₂)
skipₒ δ₁ ⦂ₒ keepₒ δ₂
: n ⊑ₒ suc n
wkₒ = skipₒ idₒ wkₒ
```

As said, the proofs about this formulation are simple. Plenty of equalities hold definitionally:

```
: keepₒ idₒ ≡ idₒ {suc n}
keep-id≡idₒ = refl keep-id≡idₒ
```

As mentioned in previous section the orthodox thinning is not very efficient. For example when implementing *normalization by evaluation* (NbE) we run into problems. There we need identity thinning when evaluating every application, so we will pay a price proportional to the size of the current context!

In his work Andras Kovacs makes a variant swapping `nilₒ`

for `idₒ`

. However then thinnings won't have unique representation anymore and proofs become more inconvenient to write.

We can make a special case for identity thinning without sacrificing unique representation for the cost of slightly more complicated definition. We just need to consider identity thinning and non-identity ones separately.

```
data _⊏ₛ_ : ℕ → ℕ → Type where
: n ⊏ₛ suc n
wkₛ : n ⊏ₛ m → suc n ⊏ₛ suc m
keepₛ : n ⊏ₛ m → n ⊏ₛ suc m
skipₛ
data _⊑ₙ_ : ℕ → ℕ → Type where
: n ⊑ₙ n
idₙ : n ⊏ₛ m → n ⊑ₙ m
strict
= _⊏ₛ_
Strict = _⊑ₙ_ NonStr
```

We can implement most operations without much problems. Note that also `wkₙ`

has a small, context-size independent, representation.

```
: zero ⊑ₙ zero
nilₙ = idₙ
nilₙ
: ∀ {n} → n ⊑ₙ suc n
wkₙ = strict wkₛ
wkₙ
: n ⊑ₙ m → n ⊑ₙ suc m
skipₙ = wkₙ
skipₙ idₙ (strict x) = strict (skipₛ x)
skipₙ
: n ⊑ₙ m → suc n ⊑ₙ suc m
keepₙ = idₙ
keepₙ idₙ (strict δ) = strict (keepₛ δ)
keepₙ
: keepₙ idₙ ≡ idₙ {suc n}
keep-id≡idₙ = refl keep-id≡idₙ
```

Composition is a bit more complicated then for orthodox variant, but not considerably:

```
_⦂ₛ_ : n ⊏ₛ m → m ⊏ₛ p → n ⊏ₛ p
= skipₛ δ₁
δ₁ ⦂ₛ wkₛ = skipₛ (δ₁ ⦂ₛ δ₂)
δ₁ ⦂ₛ skipₛ δ₂ = skipₛ δ₂
wkₛ ⦂ₛ keepₛ δ₂ = keepₛ (δ₁ ⦂ₛ δ₂)
keepₛ δ₁ ⦂ₛ keepₛ δ₂ = skipₛ (δ₁ ⦂ₛ δ₂)
skipₛ δ₁ ⦂ₛ keepₛ δ₂
_⦂ₙ_ : n ⊑ₙ m → m ⊑ₙ p → n ⊑ₙ p
= δ₁
δ₁ ⦂ₙ idₙ = strict δ₂
idₙ ⦂ₙ strict δ₂ = strict (δ₁ ⦂ₛ δ₂) strict δ₁ ⦂ₙ strict δ₂
```

**Are these orthodox and this thinning the same?**

Are `⊑ₒ`

and `⊑ₙ`

the same? We can construct an isomorphism between them to answer that question positively.

```
: n ⊑ₒ m → n ⊑ₙ m
Orth→NonStr = nilₙ
Orth→NonStr nilₒ (keepₒ δ) = keepₙ (Orth→NonStr δ)
Orth→NonStr (skipₒ δ) = skipₙ (Orth→NonStr δ)
Orth→NonStr
: n ⊏ₛ m → n ⊑ₒ m
Strict→Orth = wkₒ
Strict→Orth wkₛ (keepₛ δ) = keepₒ (Strict→Orth δ)
Strict→Orth (skipₛ δ) = skipₒ (Strict→Orth δ)
Strict→Orth
: n ⊑ₙ m → n ⊑ₒ m
NonStr→Orth = idₒ
NonStr→Orth idₙ (strict δ) = Strict→Orth δ NonStr→Orth
```

It is not enough to define conversion functions we also need to show that they cancel out. Luckily this is not difficult, we need few auxiliary homomorphism lemmas.

```
: (δ : n ⊑ₙ m) → NonStr→Orth (keepₙ δ) ≡ keepₒ (NonStr→Orth δ)
NonStr→Orth-keepₒ : (δ : n ⊑ₙ m) → NonStr→Orth (skipₙ δ) ≡ skipₒ (NonStr→Orth δ)
NonStr→Orth-skipₒ : ∀ n → Orth→NonStr idₒ ≡ idₙ {n} Orth→NonStr-id≡id
```

```
= refl
NonStr→Orth-keepₒ idₙ (strict _) = refl
NonStr→Orth-keepₒ
= refl
NonStr→Orth-skipₒ idₙ (strict _) = refl
NonStr→Orth-skipₒ
= refl
Orth→NonStr-id≡id zero (suc n) = cong keepₙ (Orth→NonStr-id≡id n) Orth→NonStr-id≡id
```

And finally we can show that `Orth→NonStr`

`NonStr→Orth`

are each others inverses.

```
: (δ : n ⊑ₒ m) → NonStr→Orth (Orth→NonStr δ) ≡ δ
Orth→NonStr→Orth : (δ : n ⊏ₛ m) → Orth→NonStr (Strict→Orth δ) ≡ strict δ
Strict→Orth→NonStr : (δ : n ⊑ₙ m) → Orth→NonStr (NonStr→Orth δ) ≡ δ NonStr→Orth→NonStr
```

```
= refl
Orth→NonStr→Orth nilₒ (keepₒ δ) = NonStr→Orth-keepₒ (Orth→NonStr δ) ∙ cong keepₒ (Orth→NonStr→Orth δ)
Orth→NonStr→Orth (skipₒ δ) = NonStr→Orth-skipₒ (Orth→NonStr δ) ∙ cong skipₒ (Orth→NonStr→Orth δ)
Orth→NonStr→Orth
= cong skipₙ (Orth→NonStr-id≡id _)
Strict→Orth→NonStr wkₛ (keepₛ δ) = cong keepₙ (Strict→Orth→NonStr δ)
Strict→Orth→NonStr (skipₛ δ) = cong skipₙ (Strict→Orth→NonStr δ)
Strict→Orth→NonStr
= Orth→NonStr-id≡id _
NonStr→Orth→NonStr idₙ (strict δ) = Strict→Orth→NonStr δ NonStr→Orth→NonStr
```

In *Cubical Agda* we can promote the above isomorphism to an equality.

```
: (n ⊑ₒ m) ≡ (n ⊑ₙ m)
Orth≡NonStr-pointwise = isoToPath
Orth≡NonStr-pointwise (iso Orth→NonStr NonStr→Orth NonStr→Orth→NonStr Orth→NonStr→Orth)
: Orth ≡ NonStr
Orth≡NonStr = Orth≡NonStr-pointwise {n} {m} i Orth≡NonStr i n m
```

But are they still the same?

Even the types are the same, are the operations we defined on them the same? We still need to show that the operations give the same results.

I'll define a simplified "category operations" type, with an identity and a composition:

```
: (ℕ → ℕ → Type) → Type
CatOps _↝_
CatOps = (∀ {n} → n ↝ n) -- identity
(∀ {n m p} → n ↝ m → m ↝ p → n ↝ p ) -- composition ×
```

Orthodox category ops are:

```
: CatOps Orth
CatOps-Orth = idₒ , _⦂ₒ_ CatOps-Orth
```

And NonStr ops are:

```
: CatOps NonStr
CatOps-NonStr = idₙ , _⦂ₙ_ CatOps-NonStr
```

And we can show transport orthodox ops along `Orth≡NonStr`

to get other variant

```
: CatOps NonStr
CatOps-NonStrₜ = subst CatOps Orth≡NonStr CatOps-Orth CatOps-NonStrₜ
```

The goal is to show that all these are equal.

First We can construct a path between two `CatOps NonStr`

structures,

For identity part we need identity homomorphism:

```
: Orth→NonStr idₒ ≡ idₙ {n}
Orth→NonStr-id {zero} = refl
Orth→NonStr-id {suc n} = cong keepₙ (Orth→NonStr-id {n}) Orth→NonStr-id
```

Then we can extract the transported identity, and show it is the same as `idₙ`

:

```
: n ⊑ₙ n
idₙₜ = fst CatOps-NonStrₜ
idₙₜ
: idₙₜ ≡ idₙ {n}
idₙₜ≡idₙ = transportRefl (Orth→NonStr idₒ) ∙ Orth→NonStr-id idₙₜ≡idₙ
```

The composition is slightly more complicated.

```
: (δ₁ : n ⊑ₙ m) → (δ₂ : m ⊑ₙ p)
skip-⦂ₙ → skipₙ (δ₁ ⦂ₙ δ₂) ≡ (δ₁ ⦂ₙ skipₙ δ₂)
= refl
skip-⦂ₙ idₙ idₙ (strict _) idₙ = refl
skip-⦂ₙ (strict _) = refl
skip-⦂ₙ idₙ (strict _) (strict _) = refl
skip-⦂ₙ
: (δ₁ : n ⊑ₙ m) (δ₂ : m ⊑ₙ p)
skip-keep-⦂ₙ → skipₙ (δ₁ ⦂ₙ δ₂) ≡ (skipₙ δ₁ ⦂ₙ keepₙ δ₂)
= refl
skip-keep-⦂ₙ δ₁ idₙ (strict _) = refl
skip-keep-⦂ₙ idₙ (strict _) (strict _) = refl
skip-keep-⦂ₙ
: (δ₁ : n ⊑ₙ m) (δ₂ : m ⊑ₙ p)
keep-keep-⦂ₙ → keepₙ (δ₁ ⦂ₙ δ₂) ≡ (keepₙ δ₁ ⦂ₙ keepₙ δ₂)
= refl
keep-keep-⦂ₙ δ₁ idₙ (strict x) = refl
keep-keep-⦂ₙ idₙ (strict _) (strict _) = refl keep-keep-⦂ₙ
```

We can show that `Orth→NonStr`

preserves composition.

```
: (δ₁ : n ⊑ₒ m) (δ₂ : m ⊑ₒ p)
Orth→NonStr-⦂ → Orth→NonStr (δ₁ ⦂ₒ δ₂) ≡ Orth→NonStr δ₁ ⦂ₙ Orth→NonStr δ₂
= refl
Orth→NonStr-⦂ δ₁ nilₒ (skipₒ δ₂) = cong skipₙ (Orth→NonStr-⦂ δ₁ δ₂) ∙ skip-⦂ₙ (Orth→NonStr δ₁) (Orth→NonStr δ₂)
Orth→NonStr-⦂ δ₁ (skipₒ δ₁) (keepₒ δ₂) = cong skipₙ (Orth→NonStr-⦂ δ₁ δ₂) ∙ skip-keep-⦂ₙ (Orth→NonStr δ₁) (Orth→NonStr δ₂)
Orth→NonStr-⦂ (keepₒ δ₁) (keepₒ δ₂) = cong keepₙ (Orth→NonStr-⦂ δ₁ δ₂) ∙ keep-keep-⦂ₙ (Orth→NonStr δ₁) (Orth→NonStr δ₂) Orth→NonStr-⦂
```

Using the above fact, we can show that and are pointwise equal. The proof looks complicated, but is pretty straightforward in the end.

```
_⦂ₙₜ_ : n ⊑ₙ m → m ⊑ₙ p → n ⊑ₙ p
_⦂ₙₜ_ = snd CatOps-NonStrₜ
: (δ₁ : n ⊑ₙ m) (δ₂ : m ⊑ₙ p) → δ₁ ⦂ₙₜ δ₂ ≡ δ₁ ⦂ₙ δ₂
⦂ₙₜ≡⦂ₙ {n} {m} {p} δ₁ δ₂ =
⦂ₙₜ≡⦂ₙ
transport refl expr₁ ≡⟨ transportRefl expr₁ ⟩
expr₁ ≡⟨ expr₁≡expr₂ ⟩(NonStr→Orth δ₁) (NonStr→Orth δ₂) ⟩
expr₂ ≡⟨ Orth→NonStr-⦂ (λ i → NonStr→Orth→NonStr δ₁ i ⦂ₙ
expr₃ ≡⟨ ) ⟩
NonStr→Orth→NonStr δ₂ i
δ₁ ⦂ₙ δ₂ ∎where
= Orth→NonStr (NonStr→Orth (transport refl δ₁) ⦂ₒ
expr₁ (transport refl δ₂))
NonStr→Orth = Orth→NonStr (NonStr→Orth δ₁ ⦂ₒ NonStr→Orth δ₂)
expr₂ = Orth→NonStr (NonStr→Orth δ₁) ⦂ₙ Orth→NonStr (NonStr→Orth δ₂)
expr₃
: expr₁ ≡ expr₂
expr₁≡expr₂ = Orth→NonStr (NonStr→Orth (transportRefl δ₁ i) ⦂ₒ
expr₁≡expr₂ i (transportRefl δ₂ i)) NonStr→Orth
```

And finally we can state that first equality:

```
: CatOps-NonStrₜ ≡ CatOps-NonStr
CatOps-NonStr≡ = idₙₜ≡idₙ i , λ δ₁ δ₂ → ⦂ₙₜ≡⦂ₙ δ₁ δ₂ i CatOps-NonStr≡ i
```

and the quality we actually wanted to say, that `CatOps-Orth`

and `CatOps-NonStr`

are equal (if we equate their types by `Orth≡NonStr`

)!!!

```
: (λ i → CatOps (Orth≡NonStr i))
CatOps-Orth≡NonStr
[ CatOps-Orth ≡ CatOps-NonStr ]= toPathP CatOps-NonStr≡ CatOps-Orth≡NonStr
```

*Cubical Agda* also supports *higher inductive types* (HITs), i.e. types with additional equalities. We can formalize Andras better performing thinning as a HIT, by throwing in an additional equality. *Agda* will then ensure that we always respect it.

```
data _⊑ₕ_ : ℕ → ℕ → Type where
: n ⊑ₕ n
idₕ : n ⊑ₕ m → suc n ⊑ₕ suc m
keepₕ : n ⊑ₕ m → n ⊑ₕ suc m
skipₕ
-- it is what it says: keep idₕ ≡ idₕ
: ∀ n → keepₕ (idₕ {n = n}) ≡ idₕ {n = suc n}
keep-id≡idₕ
= _⊑ₕ_ HIT
```

Composition for HIT-thinning looks very similar to the orthodox version...

```
_⦂ₕ_ : n ⊑ₕ m → m ⊑ₕ p → n ⊑ₕ p
= δ₁
δ₁ ⦂ₕ idₕ = skipₕ (δ₁ ⦂ₕ δ₂)
δ₁ ⦂ₕ skipₕ δ₂ = keepₕ δ₂
idₕ ⦂ₕ keepₕ δ₂ = keepₕ (δ₁ ⦂ₕ δ₂)
keepₕ δ₁ ⦂ₕ keepₕ δ₂ = skipₕ (δ₁ ⦂ₕ δ₂) skipₕ δ₁ ⦂ₕ keepₕ δ₂
```

... except that we have extra cases which deal with an extra equality we threw in.

We have to show that equations are consistent with `keep-id≡idₕ`

equality. The goals may be obfuscated, but relatively easy to fill.

```
= goal i
keep-id≡idₕ n i ⦂ₕ keepₕ δ₂ where
: ∀ {n m} → (δ : HIT n m) → idₕ ⦂ₕ δ ≡ δ
lemma = refl
lemma idₕ (keepₕ δ) = refl
lemma (skipₕ δ) = cong skipₕ (lemma δ)
lemma (keep-id≡idₕ n i) j = keep-id≡idₕ n i
lemma
: keepₕ (idₕ ⦂ₕ δ₂) ≡ keepₕ δ₂
goal = keepₕ (lemma δ₂ i)
goal i
= keep-id≡idₕ n i
idₕ ⦂ₕ keep-id≡idₕ n i = keepₕ δ₁
keepₕ δ₁ ⦂ₕ keep-id≡idₕ n i = skipₕ δ₁
skipₕ δ₁ ⦂ₕ keep-id≡idₕ n i .n i ⦂ₕ keep-id≡idₕ n j = goal i j
keep-id≡idₕ where
: Square refl (keep-id≡idₕ n) refl (keep-id≡idₕ n)
goal = keep-id≡idₕ n (i ∧ j) goal i j
```

We can try to prove that the HIT variant is the same as orthodox one. The conversion functions are extremely simple, because the data-type is almost the same:

```
: n ⊑ₒ m → n ⊑ₕ m
Orth→HIT = idₕ
Orth→HIT nilₒ (keepₒ δ) = keepₕ (Orth→HIT δ)
Orth→HIT (skipₒ δ) = skipₕ (Orth→HIT δ)
Orth→HIT
: n ⊑ₕ m → n ⊑ₒ m
HIT→Orth = idₒ
HIT→Orth idₕ (keepₕ δ) = keepₒ (HIT→Orth δ)
HIT→Orth (skipₕ δ) = skipₒ (HIT→Orth δ)
HIT→Orth (keep-id≡idₕ n i) = keep-id≡idₒ {n} i HIT→Orth
```

Converting orthodox representation to HIT and back doesn't change the thinning. The proof is straightforward structural induction.

```
: (δ : Orth n m) → HIT→Orth (Orth→HIT δ) ≡ δ
Orth→HIT→Orth = refl
Orth→HIT→Orth nilₒ (keepₒ δ) = cong keepₒ (Orth→HIT→Orth δ)
Orth→HIT→Orth (skipₒ δ) = cong skipₒ (Orth→HIT→Orth δ) Orth→HIT→Orth
```

On the other hand the opposite direction is tricky.

Easy part is to show that `Orth→HIT`

preserves the identity, that will show that `idₕ`

roundtrips.

```
: ∀ n → Orth→HIT idₒ ≡ idₕ {n}
Orth→HIT-id = refl
Orth→HIT-id zero (suc n) = cong keepₕ (Orth→HIT-id n) ∙ keep-id≡idₕ n Orth→HIT-id
```

We also have to show that `keep-id≡idₕ`

roundtrips. This is considerably more challenging. Luckily if you squint enough (and are familiar with `cubical`

library), you notice the pattern:

```
: ∀ n → Square
lemma (cong keepₕ (Orth→HIT-id n))
(cong keepₕ (Orth→HIT-id n) ∙ keep-id≡idₕ n)
(refl {x = keepₕ (Orth→HIT idₒ)})
(keep-id≡idₕ n)
= compPath-filler
lemma n {x = keepₕ (Orth→HIT idₒ)}
(cong keepₕ (Orth→HIT-id n))
(keep-id≡idₕ n)
```

(In general, proving the equalities about equalities in Cubical Agda, i.e. filling squares and cubes feels to be black magic).

Using these lemmas we can finish the equality proof:

```
: (δ : HIT n m) → Orth→HIT (HIT→Orth δ) ≡ δ
HIT→Orth→HIT = Orth→HIT-id _
HIT→Orth→HIT idₕ (keepₕ δ) = cong keepₕ (HIT→Orth→HIT δ)
HIT→Orth→HIT (skipₕ δ) = cong skipₕ (HIT→Orth→HIT δ)
HIT→Orth→HIT (keep-id≡idₕ n i) j = lemma n i j
HIT→Orth→HIT
: n ⊑ₒ m ≡ n ⊑ₕ m
Orth≡HIT-pointwise =
Orth≡HIT-pointwise (iso Orth→HIT HIT→Orth HIT→Orth→HIT Orth→HIT→Orth)
isoToPath
: Orth ≡ HIT
Orth≡HIT = Orth≡HIT-pointwise {n} {m} i Orth≡HIT i n m
```

And we can show that this thinning identity and composition behave as the orthodox one. The identity homomorphism we have already proven, composition is trivial as the HIT structure resembles the structure orthodox thinning:

```
: ∀ {n m p} (δ₁ : Orth n m) (δ₂ : Orth m p)
Orth→HIT-⦂ → Orth→HIT (δ₁ ⦂ₒ δ₂) ≡ Orth→HIT δ₁ ⦂ₕ Orth→HIT δ₂
= refl
Orth→HIT-⦂ δ₁ nilₒ (skipₒ δ₂) = cong skipₕ (Orth→HIT-⦂ δ₁ δ₂)
Orth→HIT-⦂ δ₁ (keepₒ δ₁) (keepₒ δ₂) = cong keepₕ (Orth→HIT-⦂ δ₁ δ₂)
Orth→HIT-⦂ (skipₒ δ₁) (keepₒ δ₂) = cong skipₕ (Orth→HIT-⦂ δ₁ δ₂) Orth→HIT-⦂
```

Then we can repeat what we did with previous thinning.

```
: CatOps HIT
CatOps-HIT = idₕ , _⦂ₕ_
CatOps-HIT
: CatOps HIT
CatOps-HITₜ = subst CatOps Orth≡HIT CatOps-Orth CatOps-HITₜ
```

Identities are equal:

```
: n ⊑ₕ n
idₕₜ = fst CatOps-HITₜ
idₕₜ
: idₕₜ ≡ idₕ {n}
idₕₜ≡idₕ = transportRefl (Orth→HIT idₒ) ∙ Orth→HIT-id _ idₕₜ≡idₕ
```

and composition (literally the same code as in previous section, it can be automated but it's not worth for a blog post)

```
_⦂ₕₜ_ : n ⊑ₕ m → m ⊑ₕ p → n ⊑ₕ p
_⦂ₕₜ_ = snd CatOps-HITₜ
: (δ₁ : n ⊑ₕ m) (δ₂ : m ⊑ₕ p) → δ₁ ⦂ₕₜ δ₂ ≡ δ₁ ⦂ₕ δ₂
⦂ₕₜ≡⦂ₕ {n} {m} {p} δ₁ δ₂ =
⦂ₕₜ≡⦂ₕ
transport refl expr₁ ≡⟨ transportRefl expr₁ ⟩
expr₁ ≡⟨ expr₁≡expr₂ ⟩(HIT→Orth δ₁) (HIT→Orth δ₂) ⟩
expr₂ ≡⟨ Orth→HIT-⦂ (λ i → HIT→Orth→HIT δ₁ i ⦂ₕ HIT→Orth→HIT δ₂ i) ⟩
expr₃ ≡⟨
δ₁ ⦂ₕ δ₂ ∎where
= Orth→HIT (HIT→Orth (transport refl δ₁) ⦂ₒ
expr₁ (transport refl δ₂))
HIT→Orth = Orth→HIT (HIT→Orth δ₁ ⦂ₒ HIT→Orth δ₂)
expr₂ = Orth→HIT (HIT→Orth δ₁) ⦂ₕ Orth→HIT (HIT→Orth δ₂)
expr₃
: expr₁ ≡ expr₂
expr₁≡expr₂ = Orth→HIT (HIT→Orth (transportRefl δ₁ i) ⦂ₒ
expr₁≡expr₂ i (transportRefl δ₂ i)) HIT→Orth
```

And the equalities of `CatOps`

:

```
: CatOps-HITₜ ≡ CatOps-HIT
CatOps-HIT≡ = idₕₜ≡idₕ i , λ δ₁ δ₂ → ⦂ₕₜ≡⦂ₕ δ₁ δ₂ i
CatOps-HIT≡ i
: (λ i → CatOps (Orth≡HIT i)) [ CatOps-Orth ≡ CatOps-HIT ]
CatOps-Orth≡HIT = toPathP CatOps-HIT≡ CatOps-Orth≡HIT
```

We have seen three definitions of thinnings. Orthodox one, one with identity constructor yet unique representation and variant using additional equality. Using Cubical Agda we verified that these three definitions are equal, and their identity and composition behave the same.

What we can learn from it?

Well. It is morally correct to define

```
data Thin n m where
ThinId :: Thin n n
ThinSkip :: Thin n m -> Thin n (S m)
ThinKeep :: Thin n m -> Thin (S n) (S m)
```

as long as you pay attention to not differentiate between `ThinKeep ThinId`

and `ThinId`

, you are safe. GHC won't point you if you wrote something inconsistent.

For example checking whether the thinning is an identity:

```
isThinId :: Thin n m -> Maybe (n :~: m)
ThinId = Just Refl
isThinId = Nothing isThinId _
```

is not correct, but will be accepted by GHC. (Won't be by Cubical Agda).

But if you don't trust yourself, you can go for slightly more complicated

```
data Thin n m where
ThinId :: Thin n n
Thin' :: Thin' n m -> Thin n m
data Thin' n m where
ThinWk :: Thin' n (S n)
ThinSkip :: Thin' n m -> Thin' n (S m)
ThinKeep :: Thin' n m -> Thin' (S n) (S m)
```

In either case you will be able to write `Category`

instance:

```
instance Category Thin where
id = ThinId
.) = _look_above_in_the_Agda_Code (
```

which is not possible with an orthodox thinning definition.

```
open import Cubical.Data.Nat.Order
-- thinnings can be converted to less-than-or-equal-to relation:
: n ⊑ₕ m → n ≤ m
⊑ₕ→≤ = 0 , refl
⊑ₕ→≤ idₕ (keepₕ δ) with ⊑ₕ→≤ δ
⊑ₕ→≤ ... | n , p = n , +-suc n _ ∙ cong suc p
(skipₕ δ) with ⊑ₕ→≤ δ
⊑ₕ→≤ ... | n , p = suc n , cong suc p
(keep-id≡idₕ n i) = lemma' i where
⊑ₕ→≤ : ⊑ₕ→≤ (keepₕ idₕ) ≡ ⊑ₕ→≤ (idₕ {suc n})
lemma' = Σ≡Prop (λ m → isSetℕ (m + suc n) (suc n)) (refl {x = 0})
lemma'
-- Then we can check whether thinning is an identity.
-- Agda forces us to not cheat.
-- (Well, and also → Dec (n ≡ m))
: n ⊑ₕ m → Dec (n ≡ m)
isThinId = yes refl
isThinId idₕ (keepₕ δ) with isThinId δ
isThinId ... | yes p = yes (cong suc p)
... | no ¬p = no λ p → ¬p (injSuc p)
{n} {m} (skipₕ δ) with ⊑ₕ→≤ δ
isThinId ... | (r , p) = no λ q → ¬m+n<m {m = n} {n = 0}
(r , (r + suc (n + 0) ≡⟨ +-suc r (n + 0) ⟩
(r + (n + 0)) ≡⟨ cong (λ x → suc (r + x)) (+-zero n) ⟩
suc (r + n) ≡⟨ cong suc p ⟩
suc _ ≡⟨ sym q ⟩
suc ))
n ∎
(keep-id≡idₕ n i) = yes (λ _ → suc n)
isThinId
-- Same for orthodox
: n ⊑ₒ m → n ≤ m
⊑ₒ→≤ = 0 , refl
⊑ₒ→≤ nilₒ (skipₒ δ) with ⊑ₒ→≤ δ
⊑ₒ→≤ ... | n , p = suc n , cong suc p
(keepₒ δ) with ⊑ₒ→≤ δ
⊑ₒ→≤ ... | n , p = n , +-suc n _ ∙ cong suc p
-- if indices match, δ is idₒ
: {A : Type} → ⊥ → A
⊥-elim ()
⊥-elim
: (δ : n ⊑ₒ n) → δ ≡ idₒ
idₒ-unique = refl
idₒ-unique nilₒ (skipₒ δ) = ⊥-elim (¬m<m (⊑ₒ→≤ δ))
idₒ-unique (keepₒ δ) = cong keepₒ (idₒ-unique δ)
idₒ-unique
-- or idₕ, for which direct proof is trickier.
: (δ : n ⊑ₕ n) → δ ≡ idₕ
idₕ-unique {n} = subst {A = Σ _ CatOps}
idₕ-unique (λ { (_⊑_ , (id , _⦂_)) → (δ : n ⊑ n) → δ ≡ id})
(λ i → Orth≡HIT i , CatOps-Orth≡HIT i)
idₒ-unique
```

The most important operation thinning support is their action on variables.

```
data Var : ℕ → Type where
: Var (suc n)
vz : Var n → Var (suc n) vs
```

Using each of the variants let us define the action:

```
: n ⊑ₒ m → Var n → Var m
thinₒ ()
thinₒ nilₒ (skipₒ δ) x = vs (thinₒ δ x)
thinₒ (keepₒ δ) vz = vz
thinₒ (keepₒ δ) (vs x) = vs (thinₒ δ x)
thinₒ
: n ⊏ₛ m → Var n → Var m
thinₛ = vs x
thinₛ wkₛ x (skipₛ δ) x = vs (thinₛ δ x)
thinₛ (keepₛ δ) vz = vz
thinₛ (keepₛ δ) (vs x) = vs (thinₛ δ x)
thinₛ
: n ⊑ₙ m → Var n → Var m
thinₙ = x
thinₙ idₙ x (strict δ) x = thinₛ δ x thinₙ
```

It's worth noticing that HIT forces to take into account the `keep≡id≡idₕ`

equality, so we cannot do silly stuff in `keepₕ`

cases.

```
: n ⊑ₕ m → Var n → Var m
thinₕ = x
thinₕ idₕ x (skipₕ δ) x = vs (thinₕ δ x)
thinₕ (keepₕ δ) vz = vz
thinₕ (keepₕ δ) (vs x) = vs (thinₕ δ x)
thinₕ
(keep-id≡idₕ n i) vz = vz
thinₕ (keep-id≡idₕ n i) (vs x) = vs x thinₕ
```

Let us prove that these definitions are compatible. First we need a simple lemma, that `thinₒ idₒ`

is an identity function.

```
: (x : Var n) → thinₒ idₒ x ≡ x
thin-idₒ {suc n} vz = refl
thin-idₒ {suc n} (vs x) = cong vs (thin-idₒ x) thin-idₒ
```

```
: ℕ → ℕ → (ℕ → ℕ → Type) → Type
Action _⊑_ = n ⊑ m → Var n → Var m
Action n m
: n ⊑ₙ m → Var n → Var m
thinₙₜ {n} {m} = subst (Action n m) Orth≡NonStr thinₒ
thinₙₜ
: (δ : n ⊏ₛ m) (x : Var n) → thinₒ (Strict→Orth δ) x ≡ thinₛ δ x
Strict→Orth-thin = cong vs (thin-idₒ x)
Strict→Orth-thin wkₛ x (skipₛ δ) x = cong vs (Strict→Orth-thin δ x)
Strict→Orth-thin (keepₛ δ) vz = refl
Strict→Orth-thin (keepₛ δ) (vs x) = cong vs (Strict→Orth-thin δ x)
Strict→Orth-thin
: (δ : n ⊑ₙ m) (x : Var n) → thinₒ (NonStr→Orth δ) x ≡ thinₙ δ x
NonStr→Orth-thin = thin-idₒ x
NonStr→Orth-thin idₙ x (strict δ) x = Strict→Orth-thin δ x
NonStr→Orth-thin
: (δ : n ⊑ₙ m) (x : Var n) → thinₙₜ δ x ≡ thinₙ δ x
thinₙₜ≡thinₙ-pointwise {n} {m} δ x
thinₙₜ≡thinₙ-pointwise = transportRefl (thinₒ (NonStr→Orth (transp (λ i → n ⊑ₙ m) i0 δ)) (transp (λ j → Var n) i0 x))
(cong NonStr→Orth (transportRefl δ)) (transportRefl x)
∙ cong₂ thinₒ
∙ NonStr→Orth-thin δ x
: (thinₙₜ {n} {m}) ≡ thinₙ
thinₙₜ≡thinₙ = thinₙₜ≡thinₙ-pointwise δ x i
thinₙₜ≡thinₙ i δ x
: (λ i → Action n m (Orth≡NonStr i)) [ thinₒ ≡ thinₙ ]
thinₒ≡thinₙ = toPathP thinₙₜ≡thinₙ thinₒ≡thinₙ
```

The HIT version is not much trickier, if any.

```
: n ⊑ₕ m → Var n → Var m
thinₕₜ {n} {m} = subst (Action n m) Orth≡HIT thinₒ
thinₕₜ
: (δ : n ⊑ₕ m) (x : Var n) → thinₒ (HIT→Orth δ) x ≡ thinₕ δ x
HIT→Orth-thin = thin-idₒ x
HIT→Orth-thin idₕ x (skipₕ δ) x = cong vs (HIT→Orth-thin δ x)
HIT→Orth-thin (keepₕ δ) vz = refl
HIT→Orth-thin (keepₕ δ) (vs x) = cong vs (HIT→Orth-thin δ x)
HIT→Orth-thin
(keep-id≡idₕ n i) vz = refl
HIT→Orth-thin (keep-id≡idₕ n i) (vs x) = cong vs (thin-idₒ x)
HIT→Orth-thin
: (δ : n ⊑ₕ m) (x : Var n) → thinₕₜ δ x ≡ thinₕ δ x
thinₕₜ≡thinₕ-pointwise {n} {m} δ x
thinₕₜ≡thinₕ-pointwise = transportRefl (thinₒ (HIT→Orth (transp (λ i → n ⊑ₕ m) i0 δ)) (transp (λ j → Var n) i0 x))
(cong HIT→Orth (transportRefl δ)) (transportRefl x)
∙ cong₂ thinₒ
∙ HIT→Orth-thin δ x
: (thinₕₜ {n} {m}) ≡ thinₕ
thinₕₜ≡thinₕ = thinₕₜ≡thinₕ-pointwise δ x i
thinₕₜ≡thinₕ i δ x
: (λ i → Action n m (Orth≡HIT i)) [ thinₒ ≡ thinₕ ]
thinₒ≡thinₕ = toPathP thinₕₜ≡thinₕ thinₒ≡thinₕ
```

At the end we have three variants of thinnings with identity and composition, and which act on variables the same way.

Now, if we prove properties of these operations, e.g. identity laws, composition associativity, or that composition and action commute, it would be enough to prove these for the orthodox implementation, then we can simply transport the proofs.

In other words, whatever we prove about one structure will hold for two others, like `idₕ-unique`

in previous section.

Some proofs are simple:

```
: (x : Var n) → thinₕ idₕ x ≡ x
thin-idₕ = refl thin-idₕ x
```

but we can get them through the equality anyway:

```
: (x : Var n) → thinₕ idₕ x ≡ x
thin-idₕ' {n} x = subst
thin-idₕ' {A = Σ _ (λ _⊑_ → Action n n _⊑_ × (n ⊑ n))} -- structure
(λ { (_⊑_ , thin , id) → thin id x ≡ x }) -- motif
(λ i → Orth≡HIT i , thinₒ≡thinₕ i , CatOps-Orth≡HIT i .fst) -- proof that structures are equal
(thin-idₒ x) -- proof to transport
```

You may be aware of `Foldable`

type-class. It’s quite useful one. For example, instead of writing your own `sum`

^{1} as

```
sum' :: Num a => [a] -> a
= Data.List.foldl' (+) 0 sum'
```

you may generalize it to an arbitrary `Foldable`

^{2}:

```
sum' :: (Foldable f, Num a) => f a -> a
= Data.Foldable.foldl' (+) 0 sum'
```

And the everything would be great...

... except if your data comes in unboxed vector. You may try to use that generic sum algorithm:

```
values :: U.Vector Double
= U.fromList [1,2,3,4,5,6,7,7,7]
values
result :: Double
= sum' values result
```

and then GHC says, without further explanation:

`No instance for (Foldable U.Vector) arising from a use of ‘sum'’`

"Why not?!" you wonder.

Unboxed vectors are backed by bytearrays, so you need an `Unbox`

instance to be able to *read* (or write) any values from there. (That’s different from e.g. `Set`

, which is `Foldable`

, as you can walk the structure of `Set`

without having `Ord`

instance for the elements).

Bummer.

One idea is to

```
data Bundle a where
Bundle :: U.Unbox a => U.Vector a -> Bundle a
```

When the `Unbox`

instance is next to the data, we will be able to write `Foldable`

instance: pattern match on the `Bundle`

, use the "local" instance to fold. However, people have told me, that sometimes it doesn’t work that well: GHC may not specialize things, even the dictionary is (almost) right there. Though in my small experiments it did:

```
sumU :: (Num a, U.Unbox a) => U.Vector a -> a
= sum' (Bundle xs) sumU xs
```

produced nice loops.

Yet, having to bundle instance feels somehow wrong. Distant *data type contexts* vibes, brr..

There is another way to make `Foldable`

work, with a

```
data Hack a b where
Hack :: U.Vector a -> Hack a a
```

This is a two type-parameter wrapper, but the types are always the same! (I wish that could be a `newtype`

). The `Foldable`

instance is simply:

```
instance U.Unbox a => Foldable (Hack a) where
foldr f z (Hack v) = U.foldr f z v
Hack v) = U.foldl' f z v
foldl' f z (
...
```

and specialized `sum'`

for unboxed vector looks the same as with `Bundle`

:

```
sumU :: (Num a, U.Unbox a) => U.Vector a -> a
= sum' (Hack xs) sumU xs
```

but now `Unbox`

instance comes from the "outside": it’s required by `Foldable (Hack a)`

instance, not to wrap vector in `Hack`

. When GHC sees just `Foldable (Hack X) ...`

it could already start simplifying stuff, if it knows something about `X`

(i.e. its `Unbox`

instance), without waiting to see what the members of the instance are applied to!

We could write also write

`{-# SPECIALIZE instance Foldable (UV Double) #-}`

to force GHC do some work in advance. We couldn’t with `Bundle`

approach.

Is this `Hack`

terrible or terrific? I’m not sure, yet.

Anyhow, that’s all I have this time. This (just a little) tongue-in-cheek post is "inspired" by the fact that `statistics`

package wants unboxed vectors everywhere, for "performance" reasons, and that is soooo inconvenient.

Please, use `Foldable`

for inputs you will fold over anyway. (Asking for a selector function, like `foldMap`

would avoid creating intermediate structures!). People can choose to `Bundle`

or `Hack`

their way around to provide unboxed (or storable) vectors or primarrays to your algorithm, and others don’t need to suffer when they play with your lib in the GHCi.

P.S. I leave this here:

```
data HackText a where
HackText :: Text -> HackText Char
```

P.P.S. I know there is `MonoFoldable`

, and `lens`

with its `Fold`

s and a lot of other stuff. But `Foldable`

is right there, in our `Prelude`

!

```
-- e.g. with optics' Each:
data O s a b where
O :: s -> O s a a
instance Each i s s a a => Foldable (O s a) where
foldMap f (O x) = foldMapOf each f x
foldr f z (O x) = foldrOf each f z x
O x) = foldlOf' each f z x
foldl' f z (
{-# SPECIALIZE instance Foldable (O (U.Vector Double) Double) #-}
-- works too
sumO :: (Num a, U.Unbox a) => U.Vector a -> a
= sum' (O xs) sumO xs
```

it’s already that way in

`base`

, check yourself https://hackage.haskell.org/package/base-4.16.0.0/docs/src/GHC.List.html#sum↩︎Though you probably should write it using strict

`foldMap'`

as in base https://hackage.haskell.org/package/base-4.16.0.0/docs/src/Data.Foldable.html#sum to let container decide how to do it best↩︎

Recently Ryan Scott wrote an article about Leibniz (and Martin-Löf) equality. Interestingly we can do the same thing for coercions (which are representational equalities). That exercise stumbles on the first-orderness of role system in GHC, making it a good example to be solved. (I’d like to have a solution, but I only have a problem).

```
{-# LANGUAGE GADTs, RankNTypes, QuantifiedConstraints #-}
{-# LANGUAGE StandaloneKindSignatures, PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables, TypeOperators, TypeApplications #-}
import Data.Coerce (Coercible, coerce)
import Data.Kind (Type)
import Data.Functor.Identity (Identity (..))
```

The `Coercion`

type defined in `Data.Type.Coercion`

is akin to Martin-Löf equality `(:~:)`

:

```
type Coercion :: k -> k -> Type
data Coercion a b where
Coercion :: Coercible a b => Coercion a b
```

compare that to alternative way^{1} to write `(:~:)`

:

```
type (:~:) :: k -> k -> Type
data a :~: b where
Refl :: a ~ b => a :~: b
```

There is an analog of `castWith`

function, called `coerceWith`

, a type-safe cast using representational equality:

```
coerceWith' :: Coercion a b -> a -> b
Coercion x = coerce x coerceWith'
```

Symmetry, transitivity etc combinators are defined similarly by pattern matching on the constructor.

What would Leibniz variant look like? Recall identity of indiscernibles: two objects are equal if and only if they satisfy the same properties. We encode that in Haskell as:

```
type (:=) :: k -> k -> Type
newtype a := b = Leibniz { subst' :: forall c. c a -> c b }
```

where `c`

is *all properties*, or *contexts*. For `Coercion`

we need to restrict that to the *representational* ^{2} contexts. We can encode representational contexts using `QuantifiedConstraints`

extension:

```
type Koerzion :: k -> k -> Type
newtype Koerzion a b = Koerzion
subst :: forall c. (forall x y. Coercible x y => Coercible (c x) (c y))
{=> c a -> c b
}
```

(Leibniz was German, and this is the first name I thought of. I do not know German, I’m sorry).

Another way to think about this is:

Everything should respect the nominal equality.

However, only representational things respect representational equality, i.e. coercions.

Next, lets defined define some basic combinators. Reflexivity is defined similarly as for the (nominal) Leibniz equality:

```
refl :: Koerzion a a
= Koerzion id refl
```

We can generalise it to arbitrary `Coercible`

types, that is the point of coercions:

```
koerzion :: Coercible a b => Koerzion a b
= Koerzion coerce koerzion
```

The type-safe cast do not pose any problems either:

```
coerceWith :: Koerzion a b -> a -> b
= runIdentity (subst ab (Identity a)) coerceWith ab a
```

With transitivity we step into a problem:

```
trans :: forall a b c. Koerzion a b -> Koerzion b c -> Koerzion a c
= subst bc ab trans ab bc
```

doesn’t work. Let’s ignore a problem for now, and follow David Feuer comment and defined transitivity as:

```
trans :: forall a b c. Koerzion a b -> Koerzion b c -> Koerzion a c
= Koerzion (subst bc . subst ab) trans ab bc
```

So far so good. We have defined reflexivity, transitivity, and type-safe cast.

If we try to define symmetry, following the nominal Leibniz equality example:

```
type Symm :: k -> k -> Type
newtype Symm a b = Symm { unsymm :: Koerzion b a }
sym :: forall a b. Koerzion a b -> Koerzion b a
= unsymm (subst ab (Symm refl)) sym ab
```

we get an error (which is similar to what we get in the first transitivity attempt):

```
Couldn't match representation of type: c y
• of: c x
with that of ‘subst’ arising from a use
```

though I’d expected

```
Couldn't match representation of type: Symm a a
• of: Symm a b
with that of ‘subst’ arising from a use
```

However, I believe that it caused by the same underlying reason: `Koerzion`

roles are not representational:

```
*Main> :i Koerzion
type role Koerzion nominal nominal nominal
type Koerzion :: forall k. k -> k -> *
```

In comparison, GADT variant `Coercion`

is:

```
*Main> :i Coercion
type Coercion :: forall k. k -> k -> *
type role Coercion nominal representational representational
```

This highlights the first-orderness of the role system. `Koerzion`

is morally representational in `a`

and `b`

, but GHC doesn’t want to infer it. (And there is no way to say *trust me*). The `QuantifiedConstraints`

"hack" to internalize representational contexts is not integrated into roles system and `Coercible`

constraint solver (AFAIK), so the things do not work out.

However, `Coercion`

and `Koerzion`

are equivalent:

```
toKoerzion :: Coercion a b -> Koerzion a b
Coercion = Koerzion coerce
toKoerzion
fromKoerzion :: forall a b. Koerzion a b -> Coercion a b
= subst ab @(Coercion a) (Coercion :: Coercion a a) fromKoerzion ab
```

And we can define `sym`

via that equivalence:

```
sym :: forall a b. Koerzion a b -> Koerzion b a
= toKoerzion . sym' . fromKoerzion
sym
sym' :: Coercion a b -> Coercion b a
Coercion = Coercion sym'
```

which justifies my "`Koerzion`

is morally representational" claim, because `Coercion`

is representational, `Koerzion`

should be too.

It would be very nice if GHC had higher-order roles. There are plenty of practical examples which run into the same problem (e.g. the core type in `pipes`

is not representational in any of its type arguments, though it should be). But maybe this `Koerzion`

example will nerd-snip someone to solve this problem :)

I’m not sure that the representation of this and original variant is exactly the same, i.e. whether the equality constraint is unboxed in both variants. That details is not important for us now.↩︎

Another Ryan’s blog post has a section about roles. GHC manual is also a good source of knowledge.↩︎

There are two widely used associative containers in Haskell:

`Map`

from`containers`

`HashMap`

from`unordered-containers`

`Map`

is using `Ord`

(total order), and most operations are . `HashMap`

is using `Hashable`

(some hash), and most operations are . `HashMap`

is obviously better!

**It depends**.

Sometimes `HashMap`

is the only choice, for example when the keys are `Unique`

which has `Hashable`

instance but does not have `Ord`

one. ^{1} Let us discard such cases and only consider situations when key type has both `Ord`

and `Hashable`

instances.

The thing we often forget to consider is *unordered* in `unordered-containers`

. `toList :: HashMap k v -> [(k, v)]`

^{2} doesn't not respect the equality. The order in the resulting list is arbitrary, it depends on how `HashMap`

is constructed.

We should be aware that we *trade stability for performance*, it is a trade-off, not a pure win.

And not only on that, hash functions provided by `hashable`

**are not stable**. They depend on a library version, operating system, architecture. The reason is simple: we should be able to tweak hash functions to whatever is the best for performance related properties (speed and collision resistance is own tradeoff already).

Today released `hashable-1.3.2.0`

optionally could randomise the hash seed on startup of final executable. If `random-init-seed`

flag is enabled, the initial seed is not a compile-time constant but a value initialized on the first use. I added the `random-init-seed`

flag to help find issues when we (unintentionally) depend on (non-existent) stability of the hash function. I immediately found a bug in the `lucid`

test suite. Even the test-suite took care of different orders already, there was a typo in test case.

I **do not recommend** enabling that flag in production, only in tests.

Why `lucid`

uses `HashMap`

(for HTML tag attributes) instead of `Map`

. *I actually don't know.* These attribute dictionaries are usually of "human size", at which point the performance difference doesn't show up. (Maybe a `Trie Text`

would be the best option. I'm not sure.) See my previous blog post on benchmarking discrimination package. `List.nub`

*is* faster then `Set`

or `HashSet`

based `ordNub`

and `hashNub`

with small inputs, even the member check in List has linear complexity. Constant factors matter. If `lucid`

used `Map`

, its output would be stable. Now it's not, attributes can appear in arbitrary order, and that causes problems, e.g. for `dhall-docs`

.^{3}

Another example is `aeson`

. It is using `HashMap`

for the representation of JSON objects. I don't have any data whether using `Map`

would be worse for performance in typical cases, I doubt. It might matter when JSON contains an actual dictionary mapping from keys to values, but "record objects" are small. Whether key-value mappings would be that big that it mattered, is also not unknown. We can argue that it would be better in worst case, as there is known DDoS attacks on HashMaps with deterministic (and weak, such `hashable`

) hash functions. If we would use stronger hash function, the constant factor will go up, and then `Map`

might be faster and safer by construction.

To conclude, I'm sorry that I broke all of your test-suites with `hashable-1.3.1.0`

release which changed initial seed of the default hash. On the other hand, I think it was good to realise how much we rely on something we shouldn't. Therefore `hashable-1.3.2.0`

introduces the `random-init-seed`

flag which you can use in your tests to find those issues. (N.B. I don't consider that flag to be a security feature). That release also finally mentions in haddocks the "known but hidden" fact that hash in `hashable`

is not stable. Don't rely on that.

I suggest you default to `Map`

when you need an associative container, and only consider `HashMap`

when you actually have a case for it Benchmark, don't guess, base your decision on data, rerun these benchmark periodically.

And concurrent one as in

`unique`

package cannot have`Ord`

instance.↩︎If you rely (directly or indirectly) on

`HashMap.toList`

or`HashSet.toList`

where the order may leak, they are likely wrong data structures. It is ok to use`toList`

if we remove order-dependency later for example by sorting the data at the end or folding with a commutative operation.↩︎I think

`dhall-docs`

should use e.g.`tagsoup`

to reparse the output, (normalise), and compare it as "tag tree", not as text. That's not very convenient, but it is more correct — even if`lucid`

had fully stable output.↩︎

Indexed optics are occasionally very useful. They generalize `mapWithKey`

-like operations found for various containers.

`% _2) :: (i -> b -> c) -> Map i (a, b) -> Map i (a, c) iover (imapped `

Indexed lens are constructed with `ilens`

combinator.

`ilens :: (s -> (i, a)) -> (s -> b -> t) -> IxLens i s t a b`

It is implicit that the getter and the (indexed) setter part have to satisfy usual lens laws.

However there are problematic combinators, e.g. `indices`

:

```
indices :: (Is k A_Traversal, is `HasSingleIndex` i)
=> (i -> Bool) -> Optic k is s t a a -> IxTraversal i s t a a
```

An example usage is

```
>>> toListOf (itraversed %& indices even) "foobar"
"foa"
```

If we **combine** `ilens`

and `indices`

we get a nasty thing:

```
-> indices p (ilens (\a -> (a,a)) (\_ b -> b))
\p :: (i -> Bool) -> IxTraversal i i i i i
```

That is (almost) the type of `unsafeFiltered`

, which has a warning sign:

```
Note: This is not a legal
````Traversal`

., unless you are very careful not to invalidate the predicate on the target.

However, neither `indices`

nor `ilens`

have warning attached.

*There should be an additional indexed lens law(s)*.

My proposal is to require that indices and values are independent, which for indexed lens can be checked by following equation:

*Whatever you put in, you cannot change the index.*

`fst (iview l s) ≡ fst (iview l (iover l f s))`

where `l :: IxLens i s t a b`

, `s :: s`

, `f :: i -> a -> b`

.

This law is generalisable to other optic kinds. For traversals replace `fst`

and `iview`

with `map fst`

and `itoList`

. For setters it is harder to specify, but the idea is the same.

Similarly we can talk about indexed prisms or even isomorphisms. The independence requirement would mean that that index have to be *boring* (i.e. isomorphic to `()`

), thus there isn't any additional power.

However sometimes violating laws might be justified, (e.g. when we quotient types would made program correct, but we don't have them in Haskell).

This new law doesn't prohibit having duplicate indices in a traversal.

This observation also extends in to `TraversableWithIndex`

. As far as I can tell, all instances satisfy the above requirement (of indices being independent of values). Should we make that (IMHO natural) assumption explicit?