Curried Intuitions

This is not a culinary but a logical exploration. There is continuous interest on the Curry-Howard correspondence not only from logicians but also from practicioners of typeful programming. I link just to the last two to appear on Reddit; as Baader-Meinhof would have it, I was reading the entry about the development of intuitionistic logic on the Stanford Encyclopedia of Philosophy when it occurred to me that the different axiomatizations presented must have immediate corresponding λ-terms.

The Curry-Howard correspondence states that if intuitionistic implication is interpreted as a typed λ-abstraction, then types represent constants, polymorphic type variables represent logical variables, and each step in a logical deduction corresponds to a β-reduction step. The consequence of this is Wadler's Theorems for Free!, that basically states that given a polymorphic-typed term, its shape is so constrained by its types that it is, essentially, unique, and thus it is not necessary to actually carry out the proof, or the reduction, but just checking that the types match suffices.

Not quite. Negation in IL is a though concept to systematize, because the intuition (!) behind a proof is that it is a process of deriving the consequent from the given antecedents, and negation would seem to require showing that there is no way to "build" the thing being negated. This is codified in the usual way as ¬A ≡ A → ⊥, where the latter denotes "false", or "undefined", which is interpreted under the isomorphism as the empty type empty. This type is not usually present in Hindley-Milner languages like OCaml because it introduces more problems than it solves, so there is not really a direct way to "program" negation in OCaml. The indirect route is to use first-class continuations; these are present in Standard ML of New Jersey, but again not in OCaml. I had to fake it somehow.

Obviously, writing in continuation-passing style makes using call-with-current-continuation (or callcc, as it is affectionately called), which I could use to implement negation, trivial; the problem with that is that I had to encode all my axioms using CPS. Leroy shows how a monad can make this painless, by structuring the CPS semantics inside one:

module Cont :
 sig
  type empty
  type 'a cont = 'a -> empty
  type 'a t = 'a cont cont
  val return : 'a -> 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
  val callcc : ('a cont -> 'a t) -> 'a t
  val throw : 'a cont -> 'a -> 'b t
  val run : 'a t -> 'a
 end = (* …

The empty type I can fake it using an abstract type; this is actually an existential type that makes the type α cont of continuations mean "a continuation is a function from things of arbitrary type to some type that I know but I won't tell you what is". The type of the monad α t is a continuation of continuations; this is forced by the fact that, under the CH correspondence, the intuitionistic axiom ¬¬A → A is precisely translation to CPS. With that, return and bind have the expected types. These allow me to write callcc, that invokes a function with the current continuation, and throw, that aborts the current continuation with the one supplied to it. In order to "escape" the monad, run unpacks the computation and gives its final value, if at all possible.

The implementation follows closely Leroy's, except for run that uses a reference to achieve fully polymorphic continuations. This uses Oleg Kiselyov's insight about delimited continuations, namely that mutation is implicitly a delimited continuation, which has a recursive type:

… *)
 struct
  type empty = unit
  type 'a cont = 'a -> empty
  type 'a t = 'a cont cont
  let return x = fun k -> k x
  let bind m f = fun k -> m (fun x -> f x k)
  let callcc f = fun k -> f k k
  let throw k x = fun _ -> k x
  let run m =
    let r = ref None in
    let () = m (fun v -> r := Some v) in
    match !r with Some v -> v | None -> failwith "throw"
 end

Note that my empty is as simple as it could be short of being really the empty type. Then return and bind exactly implement the CPS-transform; I use anonymous functions in the bodies to emphasize the continuation argument. This makes callcc's working transparent: it feeds the (now explicit) continuation to its argument; in the same way, it is obvious that throw works by discarding the continuation and invoking immediately its argument.

The case of run is subtle but not especially complicated: it feeds its CPS-transformed argument a continuation that stores the result in a reference; this reference must be initialized to something not yet existing and so it has type α option. When the continuation returns, a pattern-match is used to recover the resulting value. Except that if there isn't a resulting value, because the CPS function aborted to a top-level continuation instead of running through to the end, the effect is equivalent to an unhandled exception.

The first axiomatization given in the SEP is Kolmogorov's; I won't show it here because it is the minimal set of axioms required to show an embedding of classical logic in intuitionistic logic. The second axiomatization is Glivenko's:

1. p → p
2. (p → q) → ((q → r) → (p → r))
3. (p ∧ q) → p
4. (p ∧ q) → q
5. (r → p) → ((r → q) → (r → (p ∧ q)))
6. p → (p ∨ q)
7. q → (p ∨ q)
8. (p → r) → ((q → r) → ((p ∨ q) → r))
9. (p → q) → ((p → ¬q) → ¬p)

According to the CH correspondence, the product type (that is, the type of pairs) encodes conjunction and the disjunction maps to a sum type, otherwise standard in Haskell:

type ('a, 'b) either = Left of 'a | Right of 'b

The first five axioms are straightforward; they almost write themselves, even with names that are all but forced by their shapes:

module G = struct
  let id x = x
  let seq f g x = g (f x)
  let fst (x, _) = x
  let snd (_, y) = y
  let pair f g x = (f x, g x)

The following three are no more difficult:

let left x = Left x
  let right x = Right x
  let cond f g = function Left x -> f x | Right y -> g y

The last term completes the axiomatization with a sort of rule of contradiction: if from the same antecedent it can be proved both a consequent and its negation, the antecedent is false. The problem while encoding this term is that there isn't an obvious way to magic in the particular proposition involved. The idea is to invoke the continuation of the term, hoping that it somehow provides the value required, and apply it to the first function. If it however raises an exeption, the value is fed to the second function, which functions as a kind of handler:

let catch handle raise =
    Cont.run 
      (Cont.callcc (fun k ->
        let v = Cont.run k in
        Cont.throw (raise v) (handle v)))
end

The module signature encodes the axioms:

module G :
 sig
  val id : 'a -> 'a
  val seq : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
  val fst : 'a * 'b -> 'a
  val snd : 'a * 'b -> 'b
  val pair : ('a -> 'b) -> ('a -> 'c) -> 'a -> 'b * 'c
  val left : 'a -> ('a, 'b) either
  val right : 'a -> ('b, 'a) either
  val cond : ('a -> 'b) -> ('c -> 'b) -> ('a, 'c) either -> 'b
  val catch : ('a -> 'b) -> ('a -> 'b Cont.cont) -> 'a Cont.cont
 end

where pairs must be read as conjunctions, and occurrences of the either type denote disjunctions. The third axiomatization given is Heyting's:

1. p → (p ∧ p)
2. (p ∧ q) → (q ∧ p)
3. (p → q) → ((p ∧ r)→ (q ∧ r))
4. ((p → q) ∧ (q → r)) → (p → r)
5. q → (p → q)
6. (p ∧ (p → q)) → q
7. p → (p ∨ q)
8. (p ∨ q) → (q ∨ p)
9. ((p → r) ∧ (q → r)) → ((p ∨ q) → r)
10. ¬p → (p → q)
11. ((p → q) ∧ (p → ¬q)) → ¬p

These axioms are both more basic and harder to work with; for instance, there is no axiom that directly allows proving a proposition from a conjunction:

module H = struct
  let diag x = (x, x)
  let swap (x, y) = (y, x)
  let first f (x, y) = (f x, y)
  let seq (f, g) x = g (f x)
  let const x _ = x
  let apply (x, f) = f x
  let left x = Left x
  let exch = function Left x -> Right x | Right y -> Left y
  let cond (f, g) = function Left x -> f x | Right y -> g y

Now, the axioms dealing with negation can be resolved directly with the continuation monad, as I did before. Axiom number 10 has exactly the type of throw, except for the monadic type. It corresponds to the ex falso quod libet principle (in Buenos Aires we have a saying that basically goes "if my granny had wheels, I would be a cart" which is as silly as it is true). Axiom number 11 is exactly as before:

let throw k x = Cont.run (Cont.throw k x)
  let catch (raise, handle) =
    Cont.run
      (Cont.callcc (fun k ->
        let v = Cont.run k in
        Cont.throw (handle v) (raise v)))
end

Again, the module's signature matches the axioms:

module H :
 sig
  val diag : 'a -> 'a * 'a
  val swap : 'a * 'b -> 'b * 'a
  val first : ('a -> 'b) -> 'a * 'c -> 'b * 'c
  val seq : ('a -> 'b) * ('b -> 'c) -> 'a -> 'c
  val const : 'a -> 'b -> 'a
  val apply : 'a * ('a -> 'b) -> 'b
  val left : 'a -> ('a, 'b) either
  val exch : ('a, 'b) either -> ('b, 'a) either
  val cond : ('a -> 'b) * ('c -> 'b) -> ('a, 'c) either -> 'b
  val throw : 'a Cont.cont -> 'a -> 'b
  val catch : ('a -> 'b) * ('a -> 'b Cont.cont) -> 'a Cont.cont
 end

Now strictly speaking both axiomatizations ought to be equivalent; in other words, one's axioms are theorems in the other; and so I could very well expect to find expressions for H's functions solely in terms of G's. However, things are not that easy. By the CH-correspondence, application of λ-terms corresponds to modus ponens; however, a proof is free, in order to complete a given step, to recall any axiom or prior logical derivation whatsoever; in effect, it requires binding as a metalogical operation. Should I insist with equating proofs with combinators, I must introduce one or more structural axioms that allow me to simulate abstraction and application; in effect, I'd be using SK calculus. An intermediate possibility would be to allow naming the arguments but restricting the use of composition and application of the base system's functions to construct the corresponding functions of the derived system:

module H' = struct
  let diag x = G.pair G.id G.id x
  let swap x = G.pair G.snd G.fst x
  let first f = G.pair (G.seq G.fst f) G.snd
  let seq p = G.seq (G.fst p) (G.snd p)
  let const x _ = x
  let apply p = (G.snd p) (G.fst p)
  let left = G.left
  let exch d = G.cond G.right G.left d
  let cond p = G.cond (G.fst p) (G.snd p)
  let throw k x = Cont.run (Cont.throw k x)
  let catch p = G.catch (G.fst p) (G.snd p)
end

Note that diag, swap, left and exch are combinators, and the argument is forced by OCaml's value restriction. Note also that const in Heyting's formulation is purely structural and identical to the K combinator.

With respect to seq, apply, cond and catch, they name their argument only to extract both components of the pair, in effect uncurrying the corresponding axioms in Glivenko's formulation. With an explicit metalogic axiom (a → (b → c)) → ((a ∧ b) → c):

let uncurry f (x, y) = f x y

more theorems are actually combinators:

module H'' = struct
  let diag x = G.pair G.id G.id x
  let swap x = G.pair G.snd G.fst x
  let second f = G.seq (G.seq G.snd) (G.pair G.fst) f
  let first' f = G.seq (G.seq G.fst) (G.pair G.snd) f
  let first  f = G.seq (G.seq G.fst) (fun h -> G.pair h G.snd) f
  let seq p = uncurry G.seq p
  let const x _ = x
  let apply p = G.seq swap (uncurry G.id) p
  let left = G.left
  let exch d = G.cond G.right G.left d
  let cond p = uncurry G.cond p
  let throw k x = Cont.run (Cont.throw k x)
  let catch p = uncurry G.catch p
end

The importance of theorems being implemented as combinators is that the proofs are structurally very simple, with the outermost redex the only choice point where to apply modus ponens. As it is evident, by avoiding naming the arguments the only option left for pair is to fix its first, making the point-free expression of second easy but tht of first impossible under this restriction; the best I could manage was first', where the resulting tuple is in reverse order. Also, the theorem for apply shows that it is indeed uncurry under another guise; maybe this is a heuristic argument that points to the fact that uncurry could be expressed under the axioms G.

Going the other way would need its counterpart, the axiom ((a ∧ b) → c) → (a → (b → c)), or currying:

let curry f x y = f (x, y)

In effect, this pair of functions witness the isomorphism α × β → γ ≅ α → β → γ, where I switch from the logical to the typed view to emphasize the fact that this is not just an equivalence (a fact easily proved in classical logic with the identity a ⇒ b ≡ ¬a ∨ b and de Morgan's Law).

module G' = struct
  let id x = H.seq (H.diag, uncurry H.const) x
  let seq f = curry H.seq f
  let fst p = uncurry H.const p
  let snd p = H.seq (H.swap, uncurry H.const) p
  let pair f g = H.seq (H.first f, H''.second g)
  let left = H.left
  let right x = H.seq (H.left, H.exch) x
  let cond f = curry H.cond f
  let catch f = curry H.catch f
end

I crucially needed both named capture and the auxiliary lemma H''.second in the definition of pair; I won't even try to define it in combinator form.

So as you can see, both axiomatizations are, indeed, interexpressible; a purely logical proof would simply need to simulate reduction of the corresponding terms, although this is not necessary, since as a consequence of freeness it only suffices to check that the types come out right.

As a final theorem for free, let me show you the term that proves the law of noncontradiction:

let fail x = G.catch G.fst G.snd x

(and indeed it does fail, as entering G.catch G.fst G.snd in the console shows) whose type (α × α cont) cont corresponds to the theorem ¬(a ∧ ¬a).