(* Copyright (c) 2008-2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Eqdep JMeq List.

Require Import CpdtTactics.

Set Implicit Arguments.
(* end hide *)

(** %\chapter{Reasoning About Equality Proofs}% *)

(** In traditional mathematics, the concept of equality is usually taken as a given.  On the other hand, in type theory, equality is a very contentious subject.  There are at least three different notions of equality that are important in Coq, and researchers are actively investigating new definitions of what it means for two terms to be equal.  Even once we fix a notion of equality, there are inevitably tricky issues that arise in proving properties of programs that manipulate equality proofs explicitly.  In this chapter, I will focus on design patterns for circumventing these tricky issues, and I will introduce the different notions of equality as they are germane. *)

(** * The Definitional Equality *)

(** We have seen many examples so far where proof goals follow "by computation."  That is, we apply computational reduction rules to reduce the goal to a normal form, at which point it follows trivially.  Exactly when this works and when it does not depends on the details of Coq's%\index{definitional equality}% _definitional equality_.  This is an untyped binary relation appearing in the formal metatheory of CIC.  CIC contains a typing rule allowing the conclusion [E : T] from the premise [E : T'] and a proof that [T] and [T'] are definitionally equal.

   The %\index{tactics!cbv}%[cbv] tactic will help us illustrate the rules of Coq's definitional equality.  We redefine the natural number predecessor function in a somewhat convoluted way and construct a manual proof that it returns [0] when applied to [1]. *)

Definition pred' (x : nat) :=
  match x with
    | O => O
    | S n' => let y := n' in y
  end.

Theorem reduce_me : pred' 1 = 0.

(* begin thide *)
  (** CIC follows the traditions of lambda calculus in associating reduction rules with Greek letters.  Coq can certainly be said to support the familiar alpha reduction rule, which allows capture-avoiding renaming of bound variables, but we never need to apply alpha explicitly, since Coq uses a de Bruijn representation%~\cite{DeBruijn}% that encodes terms canonically.

     The %\index{delta reduction}%delta rule is for unfolding global definitions.  We can use it here to unfold the definition of [pred'].  We do this with the [cbv] tactic, which takes a list of reduction rules and makes as many call-by-value reduction steps as possible, using only those rules.  There is an analogous tactic %\index{tactics!lazy}%[lazy] for call-by-need reduction. *)

  cbv delta.
  (** %\vspace{-.15in}%[[
  ============================
   (fun x : nat => match x with
                   | 0 => 0
                   | S n' => let y := n' in y
                   end) 1 = 0
      ]]

      At this point, we want to apply the famous %\index{beta reduction}%beta reduction of lambda calculus, to simplify the application of a known function abstraction. *)

  cbv beta.
  (** %\vspace{-.15in}%[[
  ============================
   match 1 with
   | 0 => 0
   | S n' => let y := n' in y
   end = 0
   ]]

   Next on the list is the %\index{iota reduction}%iota reduction, which simplifies a single [match] term by determining which pattern matches. *)

  cbv iota.
  (** %\vspace{-.15in}%[[
  ============================
   (fun n' : nat => let y := n' in y) 0 = 0
      ]]

   Now we need another beta reduction. *)

  cbv beta.
  (** %\vspace{-.15in}%[[
  ============================
   (let y := 0 in y) = 0
      ]]

      The final reduction rule is %\index{zeta reduction}%zeta, which replaces a [let] expression by its body with the appropriate term substituted. *)

  cbv zeta.
  (** %\vspace{-.15in}%[[
  ============================
   0 = 0
   ]]
   *)

  reflexivity.
Qed.
(* end thide *)

(** The [beta] reduction rule applies to recursive functions as well, and its behavior may be surprising in some instances.  For instance, we can run some simple tests using the reduction strategy [compute], which applies all applicable rules of the definitional equality. *)

Definition id (n : nat) := n.

Eval compute in fun x => id x.
(** %\vspace{-.15in}%[[
     = fun x : nat => x
]]
*)

Fixpoint id' (n : nat) := n.

Eval compute in fun x => id' x.
(** %\vspace{-.15in}%[[
     = fun x : nat => (fix id' (n : nat) : nat := n) x
]]

By running [compute], we ask Coq to run reduction steps until no more apply, so why do we see an application of a known function, where clearly no beta reduction has been performed?  The answer has to do with ensuring termination of all Gallina programs.  One candidate rule would say that we apply recursive definitions wherever possible.  However, this would clearly lead to nonterminating reduction sequences, since the function may appear fully applied within its own definition, and we would %\%naive%{}%ly "simplify" such applications immediately.  Instead, Coq only applies the beta rule for a recursive function when _the top-level structure of the recursive argument is known_.  For [id'] above, we have only one argument [n], so clearly it is the recursive argument, and the top-level structure of [n] is known when the function is applied to [O] or to some [S e] term.  The variable [x] is neither, so reduction is blocked.

What are recursive arguments in general?  Every recursive function is compiled by Coq to a %\index{Gallina terms!fix}%[fix] expression, for anonymous definition of recursive functions.  Further, every [fix] with multiple arguments has one designated as the recursive argument via a [struct] annotation.  The recursive argument is the one that must decrease across recursive calls, to appease Coq's termination checker.  Coq will generally infer which argument is recursive, though we may also specify it manually, if we want to tweak reduction behavior.  For instance, consider this definition of a function to add two lists of [nat]s elementwise: *)

Fixpoint addLists (ls1 ls2 : list nat) : list nat :=
  match ls1, ls2 with
    | n1 :: ls1' , n2 :: ls2' => n1 + n2 :: addLists ls1' ls2'
    | _, _ => nil
  end.

(** By default, Coq chooses [ls1] as the recursive argument.  We can see that [ls2] would have been another valid choice.  The choice has a critical effect on reduction behavior, as these two examples illustrate: *)

Eval compute in fun ls => addLists nil ls.
(** %\vspace{-.15in}%[[
     = fun _ : list nat => nil
]]
*)

Eval compute in fun ls => addLists ls nil.
(** %\vspace{-.15in}%[[
     = fun ls : list nat =>
       (fix addLists (ls1 ls2 : list nat) : list nat :=
          match ls1 with
          | nil => nil
          | n1 :: ls1' =>
              match ls2 with
              | nil => nil
              | n2 :: ls2' =>
                  (fix plus (n m : nat) : nat :=
                     match n with
                     | 0 => m
                     | S p => S (plus p m)
                     end) n1 n2 :: addLists ls1' ls2'
              end
          end) ls nil
]]

The outer application of the [fix] expression for [addLists] was only simplified in the first case, because in the second case the recursive argument is [ls], whose top-level structure is not known.

The opposite behavior pertains to a version of [addLists] with [ls2] marked as recursive. *)

Fixpoint addLists' (ls1 ls2 : list nat) {struct ls2} : list nat :=
  match ls1, ls2 with
    | n1 :: ls1' , n2 :: ls2' => n1 + n2 :: addLists' ls1' ls2'
    | _, _ => nil
  end.

(* begin hide *)
(* begin thide *)
Definition foo := (@eq, plus).
(* end thide *)
(* end hide *)

Eval compute in fun ls => addLists' ls nil.
(** %\vspace{-.15in}%[[
     = fun ls : list nat => match ls with
                            | nil => nil
                            | _ :: _ => nil
                            end
]]

We see that all use of recursive functions has been eliminated, though the term has not quite simplified to [nil].  We could get it to do so by switching the order of the [match] discriminees in the definition of [addLists'].

Recall that co-recursive definitions have a dual rule: a co-recursive call only simplifies when it is the discriminee of a [match].  This condition is built into the beta rule for %\index{Gallina terms!cofix}%[cofix], the anonymous form of [CoFixpoint].

%\medskip%

   The standard [eq] relation is critically dependent on the definitional equality.  The relation [eq] is often called a%\index{propositional equality}% _propositional equality_, because it reifies definitional equality as a proposition that may or may not hold.  Standard axiomatizations of an equality predicate in first-order logic define equality in terms of properties it has, like reflexivity, symmetry, and transitivity.  In contrast, for [eq] in Coq, those properties are implicit in the properties of the definitional equality, which are built into CIC's metatheory and the implementation of Gallina.  We could add new rules to the definitional equality, and [eq] would keep its definition and methods of use.

   This all may make it sound like the choice of [eq]'s definition is unimportant.  To the contrary, in this chapter, we will see examples where alternate definitions may simplify proofs.  Before that point, I will introduce proof methods for goals that use proofs of the standard propositional equality "as data." *)

(** * Heterogeneous Lists Revisited *)

(** One of our example dependent data structures from the last chapter (code repeated below) was the heterogeneous list and its associated "cursor" type.  The recursive version poses some special challenges related to equality proofs, since it uses such proofs in its definition of [fmember] types. *)

Section fhlist.
  Variable A : Type.
  Variable B : A -> Type.

  Fixpoint fhlist (ls : list A) : Type :=
    match ls with
      | nil => unit
      | x :: ls' => B x * fhlist ls'
    end%type.

  Variable elm : A.

  Fixpoint fmember (ls : list A) : Type :=
    match ls with
      | nil => Empty_set
      | x :: ls' => (x = elm) + fmember ls'
    end%type.

  Fixpoint fhget (ls : list A) : fhlist ls -> fmember ls -> B elm :=
    match ls return fhlist ls -> fmember ls -> B elm with
      | nil => fun _ idx => match idx with end
      | _ :: ls' => fun mls idx =>
        match idx with
          | inl pf => match pf with
                        | eq_refl => fst mls
                      end
          | inr idx' => fhget ls' (snd mls) idx'
        end
    end.
End fhlist.

Implicit Arguments fhget [A B elm ls].

(* begin hide *)
(* begin thide *)
Definition map := O.
(* end thide *)
(* end hide *)

(** We can define a [map]-like function for [fhlist]s. *)

Section fhlist_map.
  Variables A : Type.
  Variables B C : A -> Type.
  Variable f : forall x, B x -> C x.

  Fixpoint fhmap (ls : list A) : fhlist B ls -> fhlist C ls :=
    match ls return fhlist B ls -> fhlist C ls with
      | nil => fun _ => tt
      | _ :: _ => fun hls => (f (fst hls), fhmap _ (snd hls))
    end.

  Implicit Arguments fhmap [ls].

  (* begin hide *)
  (* begin thide *)
  Definition ilist := O.
  Definition get := O.
  Definition imap := O.
  (* end thide *)
  (* end hide *)

  (** For the inductive versions of the [ilist] definitions, we proved a lemma about the interaction of [get] and [imap].  It was a strategic choice not to attempt such a proof for the definitions that we just gave, which sets us on a collision course with the problems that are the subject of this chapter. *)

  Variable elm : A.

  Theorem fhget_fhmap : forall ls (mem : fmember elm ls) (hls : fhlist B ls),
    fhget (fhmap hls) mem = f (fhget hls mem).
(* begin hide *)
    induction ls; crush; case a0; reflexivity.
(* end hide *)
    (** %\vspace{-.2in}%[[
    induction ls; crush.
    ]]

    %\vspace{-.15in}%In Coq 8.2, one subgoal remains at this point.  Coq 8.3 has added some tactic improvements that enable [crush] to complete all of both inductive cases.  To introduce the basics of reasoning about equality, it will be useful to review what was necessary in Coq 8.2.

       Part of our single remaining subgoal is:
       [[
  a0 : a = elm
  ============================
   match a0 in (_ = a2) return (C a2) with
   | eq_refl => f a1
   end = f match a0 in (_ = a2) return (B a2) with
           | eq_refl => a1
           end
       ]]

   This seems like a trivial enough obligation.  The equality proof [a0] must be [eq_refl], the only constructor of [eq].  Therefore, both the [match]es reduce to the point where the conclusion follows by reflexivity.
    [[
    destruct a0.
]]

<<
User error: Cannot solve a second-order unification problem
>>

    This is one of Coq's standard error messages for informing us of a failure in its heuristics for attempting an instance of an undecidable problem about dependent typing.  We might try to nudge things in the right direction by stating the lemma that we believe makes the conclusion trivial.
    [[
    assert (a0 = eq_refl _).
]]

<<
The term "eq_refl ?98" has type "?98 = ?98"
 while it is expected to have type "a = elm"
>>

    In retrospect, the problem is not so hard to see.  Reflexivity proofs only show [x = x] for particular values of [x], whereas here we are thinking in terms of a proof of [a = elm], where the two sides of the equality are not equal syntactically.  Thus, the essential lemma we need does not even type-check!

    Is it time to throw in the towel?  Luckily, the answer is "no."  In this chapter, we will see several useful patterns for proving obligations like this.

    For this particular example, the solution is surprisingly straightforward.  The [destruct] tactic has a simpler sibling [case] which should behave identically for any inductive type with one constructor of no arguments.
    [[
    case a0.

  ============================
   f a1 = f a1
   ]]

    It seems that [destruct] was trying to be too smart for its own good.
    [[
    reflexivity.
    ]]
    %\vspace{-.2in}% *)
  Qed.
(* end thide *)

  (** It will be helpful to examine the proof terms generated by this sort of strategy.  A simpler example illustrates what is going on. *)

  Lemma lemma1 : forall x (pf : x = elm), O = match pf with eq_refl => O end.
(* begin thide *)
    simple destruct pf; reflexivity.
  Qed.
(* end thide *)

  (** The tactic %\index{tactics!simple destruct}%[simple destruct pf] is a convenient form for applying [case].  It runs [intro] to bring into scope all quantified variables up to its argument. *)

  Print lemma1.
  (** %\vspace{-.15in}% [[
lemma1 =
fun (x : A) (pf : x = elm) =>
match pf as e in (_ = y) return (0 = match e with
                                     | eq_refl => 0
                                     end) with
| eq_refl => eq_refl 0
end
     : forall (x : A) (pf : x = elm), 0 = match pf with
                                          | eq_refl => 0
                                          end

    ]]

    Using what we know about shorthands for [match] annotations, we can write this proof in shorter form manually. *)

(* begin thide *)
  Definition lemma1' (x : A) (pf : x = elm) :=
    match pf return (0 = match pf with
                           | eq_refl => 0
                         end) with
      | eq_refl => eq_refl 0
    end.
(* end thide *)

  (** Surprisingly, what seems at first like a _simpler_ lemma is harder to prove. *)

  Lemma lemma2 : forall (x : A) (pf : x = x), O = match pf with eq_refl => O end.
(* begin thide *)
    (** %\vspace{-.25in}%[[
    simple destruct pf.
]]

<<
User error: Cannot solve a second-order unification problem
>>
      *)
  Abort.

  (** Nonetheless, we can adapt the last manual proof to handle this theorem. *)

(* begin thide *)
  Definition lemma2 :=
    fun (x : A) (pf : x = x) =>
      match pf return (0 = match pf with
                             | eq_refl => 0
                           end) with
        | eq_refl => eq_refl 0
      end.
(* end thide *)

  (** We can try to prove a lemma that would simplify proofs of many facts like [lemma2]: *)

  (* begin hide *)
  (* begin thide *)
  Definition lemma3' := O.
  (* end thide *)
  (* end hide *)

  Lemma lemma3 : forall (x : A) (pf : x = x), pf = eq_refl x.
(* begin thide *)
    (** %\vspace{-.25in}%[[
    simple destruct pf.
]]

<<
User error: Cannot solve a second-order unification problem
>>
      %\vspace{-.15in}%*)

  Abort.

  (** This time, even our manual attempt fails.
     [[
  Definition lemma3' :=
    fun (x : A) (pf : x = x) =>
      match pf as pf' in (_ = x') return (pf' = eq_refl x') with
        | eq_refl => eq_refl _
      end.
]]

<<
The term "eq_refl x'" has type "x' = x'" while it is expected to have type
 "x = x'"
>>

     The type error comes from our [return] annotation.  In that annotation, the [as]-bound variable [pf'] has type [x = x'], referring to the [in]-bound variable [x'].  To do a dependent [match], we _must_ choose a fresh name for the second argument of [eq].  We are just as constrained to use the "real" value [x] for the first argument.  Thus, within the [return] clause, the proof we are matching on _must_ equate two non-matching terms, which makes it impossible to equate that proof with reflexivity.

     Nonetheless, it turns out that, with one catch, we _can_ prove this lemma. *)

  Lemma lemma3 : forall (x : A) (pf : x = x), pf = eq_refl x.
    intros; apply UIP_refl.
  Qed.

  Check UIP_refl.
  (** %\vspace{-.15in}% [[
UIP_refl
     : forall (U : Type) (x : U) (p : x = x), p = eq_refl x
     ]]

     The theorem %\index{Gallina terms!UIP\_refl}%[UIP_refl] comes from the [Eqdep] module of the standard library.  (Its name uses the acronym "UIP" for "unicity of identity proofs.")  Do the Coq authors know of some clever trick for building such proofs that we have not seen yet?  If they do, they did not use it for this proof.  Rather, the proof is based on an _axiom_, the term [eq_rect_eq] below. *)

(* begin hide *)
  Import Eq_rect_eq.
(* end hide *)
  Print eq_rect_eq.
  (** %\vspace{-.15in}% [[
*** [ eq_rect_eq :
forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p),
x = eq_rect p Q x p h ]
      ]]

      The axiom %\index{Gallina terms!eq\_rect\_eq}%[eq_rect_eq] states a "fact" that seems like common sense, once the notation is deciphered.  The term [eq_rect] is the automatically generated recursion principle for [eq].  Calling [eq_rect] is another way of [match]ing on an equality proof.  The proof we match on is the argument [h], and [x] is the body of the [match].  The statement of [eq_rect_eq] just says that [match]es on proofs of [p = p], for any [p], are superfluous and may be removed.  We can see this intuition better in code by asking Coq to simplify the theorem statement with the [compute] reduction strategy. *)

  (* begin hide *)
  (* begin thide *)
  Definition False' := False.
  (* end thide *)
  (* end hide *)

  Eval compute in (forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p),
    x = eq_rect p Q x p h).
  (** %\vspace{-.15in}%[[
     = forall (U : Type) (p : U) (Q : U -> Type) (x : Q p) (h : p = p),
       x = match h in (_ = y) return (Q y) with
           | eq_refl => x
           end
     ]]

     Perhaps surprisingly, we cannot prove [eq_rect_eq] from within Coq.  This proposition is introduced as an %\index{axioms}%axiom; that is, a proposition asserted as true without proof.  We cannot assert just any statement without proof.  Adding [False] as an axiom would allow us to prove any proposition, for instance, defeating the point of using a proof assistant.  In general, we need to be sure that we never assert _inconsistent_ sets of axioms.  A set of axioms is inconsistent if its conjunction implies [False].  For the case of [eq_rect_eq], consistency has been verified outside of Coq via "informal" metatheory%~\cite{AxiomK}%, in a study that also established unprovability of the axiom in CIC.

      This axiom is equivalent to another that is more commonly known and mentioned in type theory circles. *)

  (* begin hide *)
  (* begin thide *)
  Definition Streicher_K' := UIP_refl__Streicher_K.
  (* end thide *)
  (* end hide *)

  Check Streicher_K.
(* end thide *)
(** %\vspace{-.15in}% [[
Streicher_K
     : forall (U : Type) (x : U) (P : x = x -> Prop),
       P eq_refl -> forall p : x = x, P p
  ]]

  This is the opaquely named %\index{axiom K}%"Streicher's axiom K," which says that a predicate on properly typed equality proofs holds of all such proofs if it holds of reflexivity. *)

End fhlist_map.

(* begin hide *)
(* begin thide *)
Require Eqdep_dec.
(* end thide *)
(* end hide *)

(** It is worth remarking that it is possible to avoid axioms altogether for equalities on types with decidable equality.  The [Eqdep_dec] module of the standard library contains a parametric proof of [UIP_refl] for such cases.  To simplify presentation, we will stick with the axiom version in the rest of this chapter. *)

(** * Type-Casts in Theorem Statements *)

(** Sometimes we need to use tricks with equality just to state the theorems that we care about.  To illustrate, we start by defining a concatenation function for [fhlist]s. *)

Section fhapp.
  Variable A : Type.
  Variable B : A -> Type.

  Fixpoint fhapp (ls1 ls2 : list A)
    : fhlist B ls1 -> fhlist B ls2 -> fhlist B (ls1 ++ ls2) :=
    match ls1 with
      | nil => fun _ hls2 => hls2
      | _ :: _ => fun hls1 hls2 => (fst hls1, fhapp _ _ (snd hls1) hls2)
    end.

  Implicit Arguments fhapp [ls1 ls2].

  (* EX: Prove that fhapp is associative. *)
(* begin thide *)

  (** We might like to prove that [fhapp] is associative.
     [[
  Theorem fhapp_assoc : forall ls1 ls2 ls3
    (hls1 : fhlist B ls1) (hls2 : fhlist B ls2) (hls3 : fhlist B ls3),
    fhapp hls1 (fhapp hls2 hls3) = fhapp (fhapp hls1 hls2) hls3.
]]

<<
The term
 "fhapp (ls1:=ls1 ++ ls2) (ls2:=ls3) (fhapp (ls1:=ls1) (ls2:=ls2) hls1 hls2)
    hls3" has type "fhlist B ((ls1 ++ ls2) ++ ls3)"
 while it is expected to have type "fhlist B (ls1 ++ ls2 ++ ls3)"
>>

     This first cut at the theorem statement does not even type-check.  We know that the two [fhlist] types appearing in the error message are always equal, by associativity of normal list append, but this fact is not apparent to the type checker.  This stems from the fact that Coq's equality is%\index{intensional type theory}% _intensional_, in the sense that type equality theorems can never be applied after the fact to get a term to type-check.  Instead, we need to make use of equality explicitly in the theorem statement. *)

  Theorem fhapp_assoc : forall ls1 ls2 ls3
    (pf : (ls1 ++ ls2) ++ ls3 = ls1 ++ (ls2 ++ ls3))
    (hls1 : fhlist B ls1) (hls2 : fhlist B ls2) (hls3 : fhlist B ls3),
    fhapp hls1 (fhapp hls2 hls3)
    = match pf in (_ = ls) return fhlist _ ls with
        | eq_refl => fhapp (fhapp hls1 hls2) hls3
      end.
    induction ls1; crush.

    (** The first remaining subgoal looks trivial enough:
       [[
  ============================
   fhapp (ls1:=ls2) (ls2:=ls3) hls2 hls3 =
   match pf in (_ = ls) return (fhlist B ls) with
   | eq_refl => fhapp (ls1:=ls2) (ls2:=ls3) hls2 hls3
   end
       ]]

       We can try what worked in previous examples.
       [[
    case pf.
]]

<<
User error: Cannot solve a second-order unification problem
>>

        It seems we have reached another case where it is unclear how to use a dependent [match] to implement case analysis on our proof.  The [UIP_refl] theorem can come to our rescue again. *)

    rewrite (UIP_refl _ _ pf).
    (** [[
  ============================
   fhapp (ls1:=ls2) (ls2:=ls3) hls2 hls3 =
   fhapp (ls1:=ls2) (ls2:=ls3) hls2 hls3
        ]]
        *)

    reflexivity.

    (** Our second subgoal is trickier.
       [[
  pf : a :: (ls1 ++ ls2) ++ ls3 = a :: ls1 ++ ls2 ++ ls3
  ============================
   (a0,
   fhapp (ls1:=ls1) (ls2:=ls2 ++ ls3) b
     (fhapp (ls1:=ls2) (ls2:=ls3) hls2 hls3)) =
   match pf in (_ = ls) return (fhlist B ls) with
   | eq_refl =>
       (a0,
       fhapp (ls1:=ls1 ++ ls2) (ls2:=ls3)
         (fhapp (ls1:=ls1) (ls2:=ls2) b hls2) hls3)
   end

    rewrite (UIP_refl _ _ pf).
]]

<<
The term "pf" has type "a :: (ls1 ++ ls2) ++ ls3 = a :: ls1 ++ ls2 ++ ls3"
 while it is expected to have type "?556 = ?556"
>>

       We can only apply [UIP_refl] on proofs of equality with syntactically equal operands, which is not the case of [pf] here.  We will need to manipulate the form of this subgoal to get us to a point where we may use [UIP_refl].  A first step is obtaining a proof suitable to use in applying the induction hypothesis.  Inversion on the structure of [pf] is sufficient for that. *)

    injection pf; intro pf'.
    (** [[
  pf : a :: (ls1 ++ ls2) ++ ls3 = a :: ls1 ++ ls2 ++ ls3
  pf' : (ls1 ++ ls2) ++ ls3 = ls1 ++ ls2 ++ ls3
  ============================
   (a0,
   fhapp (ls1:=ls1) (ls2:=ls2 ++ ls3) b
     (fhapp (ls1:=ls2) (ls2:=ls3) hls2 hls3)) =
   match pf in (_ = ls) return (fhlist B ls) with
   | eq_refl =>
       (a0,
       fhapp (ls1:=ls1 ++ ls2) (ls2:=ls3)
         (fhapp (ls1:=ls1) (ls2:=ls2) b hls2) hls3)
   end
   ]]

   Now we can rewrite using the inductive hypothesis. *)

    rewrite (IHls1 _ _ pf').
    (** [[
  ============================
   (a0,
   match pf' in (_ = ls) return (fhlist B ls) with
   | eq_refl =>
       fhapp (ls1:=ls1 ++ ls2) (ls2:=ls3)
         (fhapp (ls1:=ls1) (ls2:=ls2) b hls2) hls3
   end) =
   match pf in (_ = ls) return (fhlist B ls) with
   | eq_refl =>
       (a0,
       fhapp (ls1:=ls1 ++ ls2) (ls2:=ls3)
         (fhapp (ls1:=ls1) (ls2:=ls2) b hls2) hls3)
   end
        ]]

        We have made an important bit of progress, as now only a single call to [fhapp] appears in the conclusion, repeated twice.  Trying case analysis on our proofs still will not work, but there is a move we can make to enable it.  Not only does just one call to [fhapp] matter to us now, but it also _does not matter what the result of the call is_.  In other words, the subgoal should remain true if we replace this [fhapp] call with a fresh variable.  The %\index{tactics!generalize}%[generalize] tactic helps us do exactly that. *)

    generalize (fhapp (fhapp b hls2) hls3).
    (** [[
   forall f : fhlist B ((ls1 ++ ls2) ++ ls3),
   (a0,
   match pf' in (_ = ls) return (fhlist B ls) with
   | eq_refl => f
   end) =
   match pf in (_ = ls) return (fhlist B ls) with
   | eq_refl => (a0, f)
   end
        ]]

        The conclusion has gotten markedly simpler.  It seems counterintuitive that we can have an easier time of proving a more general theorem, but such a phenomenon applies to the case here and to many other proofs that use dependent types heavily.  Speaking informally, the reason why this kind of activity helps is that [match] annotations contain some positions where only variables are allowed.  By reducing more elements of a goal to variables, built-in tactics can have more success building [match] terms under the hood.

        In this case, it is helpful to generalize over our two proofs as well. *)

    generalize pf pf'.
    (** [[
   forall (pf0 : a :: (ls1 ++ ls2) ++ ls3 = a :: ls1 ++ ls2 ++ ls3)
     (pf'0 : (ls1 ++ ls2) ++ ls3 = ls1 ++ ls2 ++ ls3)
     (f : fhlist B ((ls1 ++ ls2) ++ ls3)),
   (a0,
   match pf'0 in (_ = ls) return (fhlist B ls) with
   | eq_refl => f
   end) =
   match pf0 in (_ = ls) return (fhlist B ls) with
   | eq_refl => (a0, f)
   end
        ]]

        To an experienced dependent types hacker, the appearance of this goal term calls for a celebration.  The formula has a critical property that indicates that our problems are over.  To get our proofs into the right form to apply [UIP_refl], we need to use associativity of list append to rewrite their types.  We could not do so before because other parts of the goal require the proofs to retain their original types.  In particular, the call to [fhapp] that we generalized must have type [(ls1 ++ ls2) ++ ls3], for some values of the list variables.  If we rewrite the type of the proof used to type-cast this value to something like [ls1 ++ ls2 ++ ls3 = ls1 ++ ls2 ++ ls3], then the lefthand side of the equality would no longer match the type of the term we are trying to cast.

        However, now that we have generalized over the [fhapp] call, the type of the term being type-cast appears explicitly in the goal and _may be rewritten as well_.  In particular, the final masterstroke is rewriting everywhere in our goal using associativity of list append. *)

    rewrite app_assoc.
    (** [[
  ============================
   forall (pf0 : a :: ls1 ++ ls2 ++ ls3 = a :: ls1 ++ ls2 ++ ls3)
     (pf'0 : ls1 ++ ls2 ++ ls3 = ls1 ++ ls2 ++ ls3)
     (f : fhlist B (ls1 ++ ls2 ++ ls3)),
   (a0,
   match pf'0 in (_ = ls) return (fhlist B ls) with
   | eq_refl => f
   end) =
   match pf0 in (_ = ls) return (fhlist B ls) with
   | eq_refl => (a0, f)
   end
        ]]

        We can see that we have achieved the crucial property: the type of each generalized equality proof has syntactically equal operands.  This makes it easy to finish the proof with [UIP_refl]. *)

    intros.
    rewrite (UIP_refl _ _ pf0).
    rewrite (UIP_refl _ _ pf'0).
    reflexivity.
  Qed.
(* end thide *)
End fhapp.

Implicit Arguments fhapp [A B ls1 ls2].

(** This proof strategy was cumbersome and unorthodox, from the perspective of mainstream mathematics.  The next section explores an alternative that leads to simpler developments in some cases. *)

(** * Heterogeneous Equality *)

(** There is another equality predicate, defined in the %\index{Gallina terms!JMeq}%[JMeq] module of the standard library, implementing%\index{heterogeneous equality}% _heterogeneous equality_. *)

Print JMeq.
(** %\vspace{-.15in}% [[
Inductive JMeq (A : Type) (x : A) : forall B : Type, B -> Prop :=
    JMeq_refl : JMeq x x
    ]]

The identifier [JMeq] stands for %\index{John Major equality}%"John Major equality," a name coined by Conor McBride%~\cite{JMeq}% as an inside joke about British politics.  The definition [JMeq] starts out looking a lot like the definition of [eq].  The crucial difference is that we may use [JMeq] _on arguments of different types_.  For instance, a lemma that we failed to establish before is trivial with [JMeq].  It makes for prettier theorem statements to define some syntactic shorthand first. *)

Infix "==" := JMeq (at level 70, no associativity).

(* EX: Prove UIP_refl' : forall (A : Type) (x : A) (pf : x = x), pf == eq_refl x *)
(* begin thide *)
Definition UIP_refl' (A : Type) (x : A) (pf : x = x) : pf == eq_refl x :=
  match pf return (pf == eq_refl _) with
    | eq_refl => JMeq_refl _
  end.
(* end thide *)

(** There is no quick way to write such a proof by tactics, but the underlying proof term that we want is trivial.

   Suppose that we want to use [UIP_refl'] to establish another lemma of the kind we have run into several times so far. *)

Lemma lemma4 : forall (A : Type) (x : A) (pf : x = x),
  O = match pf with eq_refl => O end.
(* begin thide *)
  intros; rewrite (UIP_refl' pf); reflexivity.
Qed.
(* end thide *)

(** All in all, refreshingly straightforward, but there really is no such thing as a free lunch.  The use of [rewrite] is implemented in terms of an axiom: *)

Check JMeq_eq.
(** %\vspace{-.15in}% [[
JMeq_eq
     : forall (A : Type) (x y : A), x == y -> x = y
    ]]

    It may be surprising that we cannot prove that heterogeneous equality implies normal equality.  The difficulties are the same kind we have seen so far, based on limitations of [match] annotations.  The [JMeq_eq] axiom has been proved on paper to be consistent, but asserting it may still be considered to complicate the logic we work in, so there is some motivation for avoiding it.

   We can redo our [fhapp] associativity proof based around [JMeq]. *)

Section fhapp'.
  Variable A : Type.
  Variable B : A -> Type.

  (** This time, the %\%naive%{}% theorem statement type-checks. *)

  (* EX: Prove [fhapp] associativity using [JMeq]. *)

(* begin thide *)
  Theorem fhapp_assoc' : forall ls1 ls2 ls3 (hls1 : fhlist B ls1) (hls2 : fhlist B ls2)
    (hls3 : fhlist B ls3),
    fhapp hls1 (fhapp hls2 hls3) == fhapp (fhapp hls1 hls2) hls3.
    induction ls1; crush.

    (** Even better, [crush] discharges the first subgoal automatically.  The second subgoal is:
       [[
  ============================
   (a0, fhapp b (fhapp hls2 hls3)) == (a0, fhapp (fhapp b hls2) hls3)
       ]]

       It looks like one rewrite with the inductive hypothesis should be enough to make the goal trivial.  Here is what happens when we try that in Coq 8.2:
       [[
    rewrite IHls1.
]]

<<
Error: Impossible to unify "fhlist B ((ls1 ++ ?1572) ++ ?1573)" with
 "fhlist B (ls1 ++ ?1572 ++ ?1573)"
>>

       Coq 8.4 currently gives an error message about an uncaught exception.  Perhaps that will be fixed soon.  In any case, it is educational to consider a more explicit approach.

       We see that [JMeq] is not a silver bullet.  We can use it to simplify the statements of equality facts, but the Coq type-checker uses non-trivial heterogeneous equality facts no more readily than it uses standard equality facts.  Here, the problem is that the form [(e1, e2)] is syntactic sugar for an explicit application of a constructor of an inductive type.  That application mentions the type of each tuple element explicitly, and our [rewrite] tries to change one of those elements without updating the corresponding type argument.

       We can get around this problem by another multiple use of [generalize].  We want to bring into the goal the proper instance of the inductive hypothesis, and we also want to generalize the two relevant uses of [fhapp]. *)

    generalize (fhapp b (fhapp hls2 hls3))
      (fhapp (fhapp b hls2) hls3)
      (IHls1 _ _ b hls2 hls3).
    (** %\vspace{-.15in}%[[
  ============================
   forall (f : fhlist B (ls1 ++ ls2 ++ ls3))
     (f0 : fhlist B ((ls1 ++ ls2) ++ ls3)), f == f0 -> (a0, f) == (a0, f0)
        ]]

        Now we can rewrite with append associativity, as before. *)

    rewrite app_assoc.
    (** %\vspace{-.15in}%[[
  ============================
   forall f f0 : fhlist B (ls1 ++ ls2 ++ ls3), f == f0 -> (a0, f) == (a0, f0)
       ]]

       From this point, the goal is trivial. *)

    intros f f0 H; rewrite H; reflexivity.
  Qed.
(* end thide *)

End fhapp'.

(** This example illustrates a general pattern: heterogeneous equality often simplifies theorem statements, but we still need to do some work to line up some dependent pattern matches that tactics will generate for us.

   The proof we have found relies on the [JMeq_eq] axiom, which we can verify with a command%\index{Vernacular commands!Print Assumptions}% that we will discuss more in two chapters. *)

Print Assumptions fhapp_assoc'.
(** %\vspace{-.15in}%[[
Axioms:
JMeq_eq : forall (A : Type) (x y : A), x == y -> x = y
]]

It was the [rewrite H] tactic that implicitly appealed to the axiom.  By restructuring the proof, we can avoid axiom dependence.  A general lemma about pairs provides the key element.  (Our use of [generalize] above can be thought of as reducing the proof to another, more complex and specialized lemma.) *)

Lemma pair_cong : forall A1 A2 B1 B2 (x1 : A1) (x2 : A2) (y1 : B1) (y2 : B2),
  x1 == x2
  -> y1 == y2
  -> (x1, y1) == (x2, y2).
  intros until y2; intros Hx Hy; rewrite Hx; rewrite Hy; reflexivity.
Qed.

Hint Resolve pair_cong.

Section fhapp''.
  Variable A : Type.
  Variable B : A -> Type.

  Theorem fhapp_assoc'' : forall ls1 ls2 ls3 (hls1 : fhlist B ls1) (hls2 : fhlist B ls2)
    (hls3 : fhlist B ls3),
    fhapp hls1 (fhapp hls2 hls3) == fhapp (fhapp hls1 hls2) hls3.
    induction ls1; crush.
  Qed.
End fhapp''.

Print Assumptions fhapp_assoc''.
(** <<
Closed under the global context
>>

One might wonder exactly which elements of a proof involving [JMeq] imply that [JMeq_eq] must be used.  For instance, above we noticed that [rewrite] had brought [JMeq_eq] into the proof of [fhapp_assoc'], yet here we have also used [rewrite] with [JMeq] hypotheses while avoiding axioms!  One illuminating exercise is comparing the types of the lemmas that [rewrite] uses under the hood to implement the rewrites.  Here is the normal lemma for [eq] rewriting:%\index{Gallina terms!eq\_ind\_r}% *)

Check eq_ind_r.
(** %\vspace{-.15in}%[[
eq_ind_r
     : forall (A : Type) (x : A) (P : A -> Prop),
       P x -> forall y : A, y = x -> P y
]]

The corresponding lemma used for [JMeq] in the proof of [pair_cong] is %\index{Gallina terms!internal\_JMeq\_rew\_r}%[internal_JMeq_rew_r], which, confusingly, is defined by [rewrite] as needed, so it is not available for checking until after we apply it. *)

Check internal_JMeq_rew_r.
(** %\vspace{-.15in}%[[
internal_JMeq_rew_r
     : forall (A : Type) (x : A) (B : Type) (b : B)
         (P : forall B0 : Type, B0 -> Type), P B b -> x == b -> P A x
]]

The key difference is that, where the [eq] lemma is parameterized on a predicate of type [A -> Prop], the [JMeq] lemma is parameterized on a predicate of type more like [forall A : Type, A -> Prop].  To apply [eq_ind_r] with a proof of [x = y], it is only necessary to rearrange the goal into an application of a [fun] abstraction to [y].  In contrast, to apply [internal_JMeq_rew_r], it is necessary to rearrange the goal to an application of a [fun] abstraction to both [y] and _its type_.  In other words, the predicate must be _polymorphic_ in [y]'s type; any type must make sense, from a type-checking standpoint.  There may be cases where the former rearrangement is easy to do in a type-correct way, but the second rearrangement done %\%naive%{}%ly leads to a type error.

When [rewrite] cannot figure out how to apply [internal_JMeq_rew_r] for [x == y] where [x] and [y] have the same type, the tactic can instead use an alternate theorem, which is easy to prove as a composition of [eq_ind_r] and [JMeq_eq]. *)

Check JMeq_ind_r.
(** %\vspace{-.15in}%[[
JMeq_ind_r
     : forall (A : Type) (x : A) (P : A -> Prop),
       P x -> forall y : A, y == x -> P y
]]

Ironically, where in the proof of [fhapp_assoc'] we used [rewrite app_assoc] to make it clear that a use of [JMeq] was actually homogeneously typed, we created a situation where [rewrite] applied the axiom-based [JMeq_ind_r] instead of the axiom-free [internal_JMeq_rew_r]!

For another simple example, consider this theorem that applies a heterogeneous equality to prove a congruence fact. *)

Theorem out_of_luck : forall n m : nat,
  n == m
  -> S n == S m.
  intros n m H.

  (** Applying [JMeq_ind_r] is easy, as the %\index{tactics!pattern}%[pattern] tactic will transform the goal into an application of an appropriate [fun] to a term that we want to abstract.  (In general, [pattern] abstracts over a term by introducing a new anonymous function taking that term as argument.) *)

  pattern n.
  (** %\vspace{-.15in}%[[
  n : nat
  m : nat
  H : n == m
  ============================
   (fun n0 : nat => S n0 == S m) n
]]
*)
  apply JMeq_ind_r with (x := m); auto.

  (** However, we run into trouble trying to get the goal into a form compatible with [internal_JMeq_rew_r.] *)

  Undo 2.
(** %\vspace{-.15in}%[[
  pattern nat, n.
]]
<<
Error: The abstracted term "fun (P : Set) (n0 : P) => S n0 == S m"
is not well typed.
Illegal application (Type Error):
The term "S" of type "nat -> nat"
cannot be applied to the term
 "n0" : "P"
This term has type "P" which should be coercible to
"nat".
>>

In other words, the successor function [S] is insufficiently polymorphic.  If we try to generalize over the type of [n], we find that [S] is no longer legal to apply to [n]. *)

Abort.

(** Why did we not run into this problem in our proof of [fhapp_assoc'']?  The reason is that the pair constructor is polymorphic in the types of the pair components, while functions like [S] are not polymorphic at all.  Use of such non-polymorphic functions with [JMeq] tends to push toward use of axioms.  The example with [nat] here is a bit unrealistic; more likely cases would involve functions that have _some_ polymorphism, but not enough to allow abstractions of the sort we attempted above with [pattern].  For instance, we might have an equality between two lists, where the goal only type-checks when the terms involved really are lists, though everything is polymorphic in the types of list data elements.  The {{http://www.mpi-sws.org/~gil/Heq/}Heq} library builds up a slightly different foundation to help avoid such problems. *)

(** * Equivalence of Equality Axioms *)

(* EX: Show that the approaches based on K and JMeq are equivalent logically. *)

(* begin thide *)
(** Assuming axioms (like axiom K and [JMeq_eq]) is a hazardous business.  The due diligence associated with it is necessarily global in scope, since two axioms may be consistent alone but inconsistent together.  It turns out that all of the major axioms proposed for reasoning about equality in Coq are logically equivalent, so that we only need to pick one to assert without proof.  In this section, we demonstrate by showing how each of the previous two sections' approaches reduces to the other logically.

   To show that [JMeq] and its axiom let us prove [UIP_refl], we start from the lemma [UIP_refl'] from the previous section.  The rest of the proof is trivial. *)

Lemma UIP_refl'' : forall (A : Type) (x : A) (pf : x = x), pf = eq_refl x.
  intros; rewrite (UIP_refl' pf); reflexivity.
Qed.

(** The other direction is perhaps more interesting.  Assume that we only have the axiom of the [Eqdep] module available.  We can define [JMeq] in a way that satisfies the same interface as the combination of the [JMeq] module's inductive definition and axiom. *)

Definition JMeq' (A : Type) (x : A) (B : Type) (y : B) : Prop :=
  exists pf : B = A, x = match pf with eq_refl => y end.

Infix "===" := JMeq' (at level 70, no associativity).

(** remove printing exists *)

(** We say that, by definition, [x] and [y] are equal if and only if there exists a proof [pf] that their types are equal, such that [x] equals the result of casting [y] with [pf].  This statement can look strange from the standpoint of classical math, where we almost never mention proofs explicitly with quantifiers in formulas, but it is perfectly legal Coq code.

   We can easily prove a theorem with the same type as that of the [JMeq_refl] constructor of [JMeq]. *)

Theorem JMeq_refl' : forall (A : Type) (x : A), x === x.
  intros; unfold JMeq'; exists (eq_refl A); reflexivity.
Qed.

(** printing exists $\exists$ *)

(** The proof of an analogue to [JMeq_eq] is a little more interesting, but most of the action is in appealing to [UIP_refl]. *)

Theorem JMeq_eq' : forall (A : Type) (x y : A),
  x === y -> x = y.
  unfold JMeq'; intros.
  (** [[
  H : exists pf : A = A,
        x = match pf in (_ = T) return T with
            | eq_refl => y
            end
  ============================
   x = y
      ]]
      *)

  destruct H.
  (** [[
  x0 : A = A
  H : x = match x0 in (_ = T) return T with
          | eq_refl => y
          end
  ============================
   x = y
      ]]
      *)

  rewrite H.
  (** [[
  x0 : A = A
  ============================
   match x0 in (_ = T) return T with
   | eq_refl => y
   end = y
      ]]
      *)

  rewrite (UIP_refl _ _ x0); reflexivity.
Qed.

(** We see that, in a very formal sense, we are free to switch back and forth between the two styles of proofs about equality proofs.  One style may be more convenient than the other for some proofs, but we can always interconvert between our results.  The style that does not use heterogeneous equality may be preferable in cases where many results do not require the tricks of this chapter, since then the use of axioms is avoided altogether for the simple cases, and a wider audience will be able to follow those "simple" proofs.  On the other hand, heterogeneous equality often makes for shorter and more readable theorem statements. *)

(* end thide *)

(** * Equality of Functions *)

(** The following seems like a reasonable theorem to want to hold, and it does hold in set theory.
   %\vspace{-.15in}%[[
   Theorem two_funs : (fun n => n) = (fun n => n + 0).
   ]]
   %\vspace{-.15in}%Unfortunately, this theorem is not provable in CIC without additional axioms.  None of the definitional equality rules force function equality to be%\index{extensionality of function equality}% _extensional_.  That is, the fact that two functions return equal results on equal inputs does not imply that the functions are equal.  We _can_ assert function extensionality as an axiom, and indeed the standard library already contains that axiom. *)

Require Import FunctionalExtensionality.
About functional_extensionality.
(** %\vspace{-.15in}%[[
functional_extensionality :
forall (A B : Type) (f g : A -> B), (forall x : A, f x = g x) -> f = g
]]
*)

(** This axiom has been verified metatheoretically to be consistent with CIC and the two equality axioms we considered previously.  With it, the proof of [two_funs] is trivial. *)

Theorem two_funs : (fun n => n) = (fun n => n + 0).
(* begin thide *)
  apply functional_extensionality; crush.
Qed.
(* end thide *)

(** The same axiom can help us prove equality of types, where we need to "reason under quantifiers." *)

Theorem forall_eq : (forall x : nat, match x with
                                      | O => True
                                      | S _ => True
                                    end)
  = (forall _ : nat, True).

  (** There are no immediate opportunities to apply [functional_extensionality], but we can use %\index{tactics!change}%[change] to fix that problem. *)

(* begin thide *)
  change ((forall x : nat, (fun x => match x with
                                       | 0 => True
                                       | S _ => True
                                     end) x) = (nat -> True)).
  rewrite (functional_extensionality (fun x => match x with
                                                 | 0 => True
                                                 | S _ => True
                                               end) (fun _ => True)).
  (** [[
2 subgoals

  ============================
   (nat -> True) = (nat -> True)

subgoal 2 is:
 forall x : nat, match x with
                 | 0 => True
                 | S _ => True
                 end = True
      ]]
      *)

  reflexivity.

  destruct x; constructor.
Qed.
(* end thide *)

(** Unlike in the case of [eq_rect_eq], we have no way of deriving this axiom of%\index{functional extensionality}% _functional extensionality_ for types with decidable equality.  To allow equality reasoning without axioms, it may be worth rewriting a development to replace functions with alternate representations, such as finite map types for which extensionality is derivable in CIC. *)


Require Import Iron.Data.List.Base.
Require Import Iron.Data.List.Map.

Lemma match_option
 : forall {A} {B} (f: A -> B) (xs: list A) ix y
 , f (match get ix xs         with | Some x => x | None  => y   end)
 =   (match get ix (map f xs) with | Some x => x | None  => f y end).
Proof.
 intros.
 remember (get ix xs) as Get.
 destruct Get.
  symmetry in HeqGet.
  apply (get_map f) in HeqGet.
  rewrite HeqGet. auto.

  remember (get ix (map f xs)) as X.
  destruct X.
   symmetry in HeqX.   eapply get_length_more in HeqX.
   symmetry in HeqGet. eapply get_none_length in HeqGet.
   rewrite map_length in HeqX. exfalso. omega.
   auto.
Qed.


Require Import FP.Relations.Setoid.

Import ProperNotation.

Definition rel (T:Type) := T -> T -> Prop.


(**************************************************************************)
(*              Coherence of first-order Heyting arithmetic               *)
(*                                                                        *)
(*                         © 2011 Stéphane Glondu                         *)
(*                         © 2013 Pierre Letouzey                         *)
(*   modified by Alice Rixte, Farzad JafarRahmani, and Younesse Kaddar    *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*   it under the terms of the CeCILL free software license, version 2.   *)
(**************************************************************************)

Require Import List Arith Omega.

(* Tactics *)

(* First, tell the "auto" tactic to use the "omega" solver. *)

Hint Extern 8 (_ = _ :> nat) => omega.
Hint Extern 8 (_ <= _) => omega.
Hint Extern 8 (_ < _) => omega.
Hint Extern 8 (_ <> _ :> nat) => omega.
Hint Extern 8 (~ (_ <= _)) => omega.
Hint Extern 8 (~ (_ < _)) => omega.
Hint Extern 12 => exfalso; omega.

(* Destructing the <=? and ?= (in)equality tests, useful when proving facts
   about "if ... then ... else" code. *)

Ltac break := match goal with
 | |- context [ ?x <=? ?y ] => destruct (Nat.leb_spec x y)
 | |- context [ ?x ?= ?y ] => destruct (Nat.compare_spec x y)
end.

(* Terms : first-order terms over the Peano signature 0 S + *.
   The variable are represented as De Bruijn indices. *)

Inductive term :=
  | Tvar : nat -> term
  | Tzero : term
  | Tsucc : term -> term
  | Tplus : term -> term -> term
  | Tmult : term -> term -> term.

Hint Extern 10 (Tvar _ = Tvar _) => f_equal.

(* Term lifting: add n to all variables of t which are >= k *)

Fixpoint tlift n t k :=
  match t with
    | Tvar i => Tvar (if k <=? i then n+i else i)
    | Tzero => Tzero
    | Tsucc u => Tsucc (tlift n u k)
    | Tplus u v => Tplus (tlift n u k) (tlift n v k)
    | Tmult u v => Tmult (tlift n u k) (tlift n v k)
  end.

Lemma tlift_1 : forall t n n' k k', k <= k' -> k' <= k + n ->
  tlift n' (tlift n t k) k' = tlift (n' + n) t k.
Proof.
  induction t; intros; simpl; f_equal; repeat break; auto.
Qed.

Lemma tlift_2 : forall t n n' k k', k' <= k ->
  tlift n' (tlift n t k) k' = tlift n (tlift n' t k') (n' + k).
Proof.
  induction t; intros; simpl; f_equal; repeat break; auto.
Qed.

Hint Resolve tlift_1 tlift_2.

(* Term substitution: replace variable x by (tlift x t' 0) in t *)

Fixpoint tsubst x t' t :=
  match t with
    | Tvar i =>
      match x ?= i with
        | Eq => tlift x t' 0
        | Lt => Tvar (pred i)
        | Gt => Tvar i
      end
    | Tzero => Tzero
    | Tsucc u => Tsucc (tsubst x t' u)
    | Tplus u v => Tplus (tsubst x t' u) (tsubst x t' v)
    | Tmult u v => Tmult (tsubst x t' u) (tsubst x t' v)
  end.

Lemma tsubst_1 : forall t x t' n k, k <= x -> x <= k + n ->
  tsubst x t' (tlift (S n) t k) = tlift n t k.
Proof.
  induction t; intros; simpl; f_equal; auto.
  repeat (break; simpl; auto).
Qed.

Lemma tsubst_2 : forall t x t' n k, k <= x ->
  tlift n (tsubst x t' t) k = tsubst (n + x) t' (tlift n t k).
Proof.
  induction t; intros; simpl; f_equal; auto.
  repeat (break; simpl; auto).
Qed.

Hint Resolve tsubst_1 tsubst_2.

Lemma tsubst_3 : forall t x t' n k,
  tlift n (tsubst x t' t) (x + k) =
  tsubst x (tlift n t' k) (tlift n t (x + S k)).
Proof.
  induction t; intros; simpl; f_equal; auto.
  repeat (break; simpl; auto).
  symmetry. auto.
Qed.

Lemma tsubst_4 : forall t x t' y u',
  tsubst (x + y) u' (tsubst x t' t) =
  tsubst x (tsubst y u' t') (tsubst (x + S y) u' t).
Proof.
  induction t; intros; simpl; try (f_equal; auto; fail).
  repeat (break; simpl; auto);
   symmetry; rewrite <- ?plus_n_Sm; auto.
Qed.

(* Terms where all variables are < n *)

Inductive cterm n : term -> Prop :=
  | cterm_var : forall i, i < n -> cterm n (Tvar i)
  | cterm_zero : cterm n (Tzero)
  | cterm_succ : forall u, cterm n u -> cterm n (Tsucc u)
  | cterm_plus : forall u v, cterm n u -> cterm n v -> cterm n (Tplus u v)
  | cterm_mult : forall u v, cterm n u -> cterm n v -> cterm n (Tmult u v).

Hint Constructors cterm.

Lemma cterm_1 : forall n t, cterm n t -> forall n', n <= n' -> cterm n' t.
Proof.
  intros; induction t; auto; inversion H; auto.
Qed.

Lemma cterm_2 : forall n t, cterm n t -> forall k, tlift k t n = t.
Proof.
  induction t; intros; inversion H; unfold tlift; repeat break; f_equal; auto.
Qed.

Lemma cterm_3 : forall n t, cterm n t -> forall t' j, n <= j -> tsubst j t' t = t.
Proof.
  intros.
  assert (H' := H).
  apply cterm_2 with (k := j) in H.
  apply cterm_2 with (k := S j) in H'.
  rewrite <- H' at 1; rewrite <- H at 2.
  apply (@tsubst_1 _ j _ j n); auto.
Qed.

Lemma cterm_4 : forall n t, cterm (S n) t ->
  forall t', cterm 0 t' -> cterm n (tsubst n t' t).
Proof.
  induction t; induction t'; induction n; intros;
  inversion H; inversion H0; repeat (simpl; intuition);
  inversion H2; repeat (simpl; intuition);
  destruct n0; repeat (break; simpl; intuition);
  repeat (intuition; simpl);
  repeat (rewrite (@cterm_2 0 _); apply (@cterm_1 0 _)); repeat auto.
Qed.

(* Formulas of Heyting Arithmetic. *)

Inductive formula :=
  | Fequal : term -> term -> formula
  | Ffalse : formula
  | Fand : formula -> formula -> formula
  | For : formula -> formula -> formula
  | Fimplies : formula -> formula -> formula
  | Fexists : formula -> formula
  | Fforall : formula -> formula.

Delimit Scope pa_scope with pa.
Bind Scope pa_scope with term.
Bind Scope pa_scope with formula.
Arguments Tsucc _%pa.
Arguments Tplus _%pa _%pa.
Arguments Tmult _%pa _%pa.
Arguments Fequal _%pa _%pa.
Arguments Fand _%pa _%pa.
Arguments For _%pa _%pa.
Arguments Fimplies _%pa _%pa.
Arguments Fexists _%pa.
Arguments Fforall _%pa.

(* Formula lifting: add n to all variables of t which are >= k *)

Fixpoint flift n A k :=
  match A with
    | Fequal u v => Fequal (tlift n u k) (tlift n v k)
    | Ffalse => Ffalse
    | Fand B C => Fand (flift n B k) (flift n C k)
    | For B C => For (flift n B k) (flift n C k)
    | Fimplies B C => Fimplies (flift n B k) (flift n C k)
    | Fexists B => Fexists (flift n B (S k))
    | Fforall B => Fforall (flift n B (S k))
  end.

(* Add Lift *)
Lemma flift_1 : forall A n n' k k', k <= k' -> k' <= k + n ->
  flift n' (flift n A k) k' = flift (n' + n) A k.
Proof.
  induction A; intros; simpl; f_equal; auto.
Qed.

(* Commute Lift *)
Lemma flift_2 : forall A n n' k k', k' <= k ->
  flift n' (flift n A k) k' = flift n (flift n' A k') (n' + k).
Proof.
  induction A; intros; simpl; f_equal; rewrite ?plus_n_Sm; auto.
Qed.

(* Formula substitution: replace variable x by (tlift x t' 0) in A *)

Fixpoint fsubst x t' A :=
  match A with
    | Fequal u v => Fequal (tsubst x t' u) (tsubst x t' v)
    | Ffalse => Ffalse
    | Fand B C => Fand (fsubst x t' B) (fsubst x t' C)
    | For B C => For (fsubst x t' B) (fsubst x t' C)
    | Fimplies B C => Fimplies (fsubst x t' B) (fsubst x t' C)
    | Fexists B => Fexists (fsubst (S x) t' B)
    | Fforall B => Fforall (fsubst (S x) t' B)
  end.

(* Subst too low *)
Lemma fsubst_1 : forall A x t' n k, k <= x -> x <= k + n ->
  fsubst x t' (flift (S n) A k) = flift n A k.
Proof.
  induction A; intros; simpl; f_equal; auto.
Qed.

(* Lift in Subst <-> Subst in Lift *)
Lemma fsubst_2 : forall A x t' n k, k <= x ->
  flift n (fsubst x t' A) k = fsubst (n + x) t' (flift n A k).
Proof.
  induction A; intros; simpl; f_equal; rewrite ?plus_n_Sm; auto.
Qed.

(* Commute "Double Lift" and Subst *)
Lemma fsubst_3 : forall A x t' n k,
  flift n (fsubst x t' A) (x + k) =
  fsubst x (tlift n t' k) (flift n A (x + S k)).
Proof.
  induction A; intros; simpl; f_equal; auto using tsubst_3;
  apply (IHA (S x)).
Qed.

(* Add Subst *)
Lemma fsubst_4 : forall A x t' y u',
  fsubst (x + y) u' (fsubst x t' A) =
  fsubst x (tsubst y u' t') (fsubst (x + S y) u' A).
Proof.
  induction A; intros; simpl; f_equal; auto using tsubst_4;
  apply (IHA (S x)).
Qed.

(* Formulas where all variables are < n *)

Inductive cformula n : formula -> Prop :=
  | cformula_equal : forall u v,
    cterm n u -> cterm n v -> cformula n (Fequal u v)
  | cformula_false : cformula n Ffalse
  | cformula_and : forall B C,
    cformula n B -> cformula n C -> cformula n (Fand B C)
  | cformula_or : forall B C,
    cformula n B -> cformula n C -> cformula n (For B C)
  | cformula_implies : forall B C,
    cformula n B -> cformula n C -> cformula n (Fimplies B C)
  | cformula_exists : forall B,
    cformula (S n) B -> cformula n (Fexists B)
  | cformula_forall : forall B,
    cformula (S n) B -> cformula n (Fforall B).

Hint Constructors cformula.

Inductive subterm t: formula -> Prop :=
  | subterm_equal : forall t', subterm t (Fequal t t')
  | subterm_and : forall B C t',
    subterm t B -> subterm t' C -> subterm t (Fand B C)
  | subterm_or : forall B C t',
    subterm t B -> subterm t' C -> subterm t (For B C)
  | subterm_implies : forall B C t',
    subterm t B -> cformula t' C -> subterm t (Fimplies B C)
  | subterm_exists : forall B,
    subterm t B -> subterm t (Fexists B)
  | subterm_forall : forall B,
    subterm t B -> subterm t (Fforall B).

Hint Constructors subterm.

(* Monotonous cformula *)
Lemma cformula_1 : forall n A, cformula n A ->
  forall n', n <= n' -> cformula n' A.
Proof.
  intros; generalize dependent n; generalize dependent n';
  induction A; intros; eauto; inversion H; eauto.
  apply cterm_1 with (n':=n') in H3;
  apply cterm_1 with (n':=n') in H4;
  eauto.
Qed.

(* Lift above *)
Lemma cformula_2 : forall n A, cformula n A -> forall k, flift k A n = A.
Proof.
  intros; generalize dependent n; induction A;
  intros; eauto; inversion H; simpl; f_equal;
  try apply cterm_2; eauto.
Qed.

(* Subst above *)
Lemma cformula_3 : forall n A, cformula n A ->
  forall t' j, n <= j -> fsubst j t' A = A.
Proof.
  intros; generalize dependent n;
  generalize dependent j; induction A;
  intros; eauto; inversion H; simpl; f_equal;
  try apply cterm_3 with (t:=t) (n:=n);
  try apply cterm_3 with (t:=t') (n:=n);
  try apply cterm_3 with (t:=t0) (n:=n);
  eauto.
Qed.

(* Subst closed term *)
Lemma cformula_4 : forall n A, cformula (S n) A ->
  forall t', cterm 0 t' -> cformula n (fsubst n t' A).
Proof.
  intros; generalize dependent n;
  induction A; intros; eauto; inversion H;
  simpl;
  try apply cterm_4 with (t':=t') in H3;
  try apply cterm_4 with (t':=t') in H4;
  eauto.
Qed.

(* Notations *)

Reserved Notation "A ==> B" (at level 86, right associativity).
Reserved Notation "# n" (at level 2).

Notation "A /\ B" := (Fand A B) : pa_scope.
Notation "A \/ B" := (For A B) : pa_scope.
Notation "A ==> B" := (Fimplies A B) : pa_scope.
Notation "x = y" := (Fequal x y) : pa_scope.
Notation "x + y" := (Tplus x y) : pa_scope.
Notation "x * y" := (Tmult x y) : pa_scope.
Notation "# n" := (Tvar n) (at level 2) : pa_scope.

Close Scope nat_scope.
Close Scope type_scope.
Close Scope core_scope.
Open Scope pa_scope.
Open Scope core_scope.
Open Scope type_scope.
Open Scope nat_scope.

(* Contexts (or environments), represented as list of formulas. *)

Definition context := list formula.

(* Lifting an context *)

Definition clift n Γ k := map (fun A => flift n A k) Γ.

(* Rules of (intuitionistic) Natural Deduction.

   This predicate is denoted with the symbol ":-", which
   is easier to type than "⊢".
   After this symbol, Coq expect a formula, hence uses the formula
   notations, for instance /\ is Fand instead of Coq own conjunction).
*)

Reserved Notation "Γ :- A" (at level 87, no associativity).

Inductive rule : context -> formula -> Prop :=
  | Rax Γ A : In A Γ -> Γ:-A
  | Rfalse_e Γ : Γ:-Ffalse -> forall A, Γ:-A
  | Rand_i Γ B C : Γ:-B -> Γ:-C -> Γ:-B/\C
  | Rand_e1 Γ B C : Γ:-B/\C -> Γ:-B
  | Rand_e2 Γ B C : Γ:-B/\C -> Γ:-C
  | Ror_i1 Γ B C : Γ:-B -> Γ:-B\/C
  | Ror_i2 Γ B C : Γ:-C -> Γ:-B\/C
  | Ror_e Γ A B C : Γ:-B\/C -> (B::Γ):-A -> (C::Γ):-A -> Γ:-A
  | Rimpl_i Γ B C : (B::Γ):-C -> Γ:-B==>C
  | Rimpl_e Γ B C : Γ:-B==>C -> Γ:-B -> Γ:-C
  | Rforall_i Γ B : (clift 1 Γ 0):-B -> Γ:-(Fforall B)
  | Rforall_e Γ B t : Γ:-(Fforall B) -> Γ:-(fsubst 0 t B)
  | Rexists_i Γ B t : Γ:-(fsubst 0 t B) -> Γ:-(Fexists B)
  | Rexists_e Γ A B :
    Γ:-(Fexists B) -> (B::clift 1 Γ 0):-(flift 1 A 0) -> Γ:-A

where "Γ :- A" := (rule Γ A).

(* Auxiliary connectives and admissible rules *)

(* TODO: define the following formulas *)
Definition Ftrue := Ffalse ==> Ffalse.
Definition Fnot A := (A ==> Ffalse)%pa.
Definition Fiff A B := ((A ==> B) /\ (B ==> A))%pa.

(* n repeated forall *)
Fixpoint nFforall n :=
  match n with
    | 0 => (fun A => A)
    | S m => (fun A => Fforall (nFforall m A))
  end.

Notation "~ A" := (Fnot A) : pa_scope.

Lemma Rtrue_i : forall Γ, Γ:-Ftrue.
Proof.
  intros; unfold Ftrue; apply Rimpl_i;
  constructor; intuition.
Qed.

Lemma Rnot_i : forall Γ A, (A::Γ):-Ffalse -> Γ:- ~A.
Proof.
  intros; unfold Fnot; now constructor.
Qed.

Lemma Rnot_e : forall Γ A, Γ:-A -> Γ:- ~A -> Γ:-Ffalse.
Proof.
  unfold Fnot; intros; now apply Rimpl_e with (B:=A).
Qed.

Lemma Riff_i : forall Γ A B,
  (A::Γ):-B -> (B::Γ):-A -> Γ:-(Fiff A B).
Proof.
  unfold Fiff; intros; apply Rimpl_i in H;
  apply Rimpl_i in H0; now constructor.
Qed.

Lemma nFforall_1 : forall n x t A,
  fsubst x t (nFforall n A) = nFforall n (fsubst (n + x) t A).
Proof.
  induction n.
  - auto.
  - intros; simpl; f_equal.
    assert (S (n + x) = n + S x); auto.
    rewrite H; apply IHn with (x := S x) (A := A) (t := t).
Qed.

(* Peano axioms *)

Inductive PeanoAx : formula -> Prop :=
  | pa_refl : PeanoAx (nFforall 1 (#0 = #0))
  | pa_sym : PeanoAx (nFforall 2 (#1 = #0 ==> #0 = #1))
  | pa_trans : PeanoAx (nFforall 3 (#2 = #1 /\ #1 = #0 ==> #2 = #0))
  | pa_compat_s : PeanoAx (nFforall 2 (#1 = #0 ==> Tsucc #1 = Tsucc #0))
  | pa_compat_plus_l : PeanoAx (nFforall 3 (#2 = #1 ==> #2 + #0 = #1 + #0))
  | pa_compat_plus_r : PeanoAx (nFforall 3 (#1 = #0 ==> #2 + #1 = #2 + #0))
  | pa_compat_mult_l : PeanoAx (nFforall 3 (#2 = #1 ==> #2 * #0 = #1 * #0))
  | pa_compat_mult_r : PeanoAx (nFforall 3 (#1 = #0 ==> #2 * #1 = #2 * #0))
  | pa_plus_O : PeanoAx (nFforall 1 (Tzero + #0 = #0))
  | pa_plus_S : PeanoAx (nFforall 2 (Tsucc #1 + #0 = Tsucc (#1 + #0)))
  | pa_mult_O : PeanoAx (nFforall 1 (Tzero * #0 = Tzero))
  | pa_mult_S : PeanoAx (nFforall 2 (Tsucc #1 * #0 = (#1 * #0) + #0))
  | pa_inj : PeanoAx (nFforall 2 (Tsucc #1 = Tsucc #0 ==> #1 = #0))
  | pa_discr : PeanoAx (nFforall 1 (~ Tzero = Tsucc #0))
  | pa_ind : forall A n, cformula (S n) A ->
    PeanoAx (nFforall n (
      fsubst 0 Tzero A /\
      Fforall (A ==> fsubst 0 (Tsucc #0) (flift 1 A 1)) ==> Fforall A
    )).

(* Definition of theorems over Heyting Arithmetic.

   NB: we should normally restrict theorems to closed terms only,
   but this doesn't really matter here, since we'll only prove that
   False isn't a theorem. *)

Definition Thm T :=
  exists axioms, (forall A, In A axioms -> PeanoAx A) /\ (axioms:-T).

(* Example of theorem *)

Lemma HA_n_Sn : Thm (Fforall (~ #0 = Tsucc #0)).
Proof.
  Definition Gamma :=  nFforall 0 (
                      fsubst 0 Tzero (~ #0 = Tsucc #0) /\
                      Fforall ((~ #0 = Tsucc #0)
                               ==> fsubst 0 (Tsucc #0) (flift 1 (~ #0 = Tsucc #0) 1))
                               ==> Fforall (~ #0 = Tsucc #0) )
            :: nFforall 2 (Tsucc #1 = Tsucc #0 ==> #1 = #0)
            :: nFforall 1 (~ Tzero = Tsucc #0)
            :: nil.
  exists Gamma.
  split.
  (* (forall A, In A axioms -> PeanoAx A) *)
  - intros; repeat (destruct H; try apply pa_ind;
    try apply pa_inj; try apply pa_discr; try constructor; eauto).

  (* (axioms:-T) *)

  (* hyp is to make the proof terms more readable. This is just implication
  elimination in the induction principle*)
  Definition hyp := nFforall 0 (fsubst 0 Tzero (~ #0 = Tsucc #0) /\
                    Fforall ((~ #0 = Tsucc #0)
                               ==> fsubst 0 (Tsucc #0)
                               (flift 1 (~ #0 = Tsucc #0) 1))).
  - apply Rimpl_e with hyp.
    + apply Rax; simpl; auto.
    + simpl; apply Rand_i; simpl.
      assert ((Tzero = Tsucc Tzero ==> Ffalse) = (fsubst 0 Tzero (~ Tzero = Tsucc #0)));
          auto; rewrite H; apply Rforall_e; constructor; simpl; auto.
      apply Rforall_i; apply Rimpl_i; apply Rimpl_i;
      apply (@Rimpl_e _ (# 0 = Tsucc # 0) Ffalse).
      constructor; simpl; auto.
      apply (@Rimpl_e _ (Tsucc # 0 = Tsucc (Tsucc # 0)) (# 0 = Tsucc # 0)).
      assert ((Tsucc # 0 = Tsucc (Tsucc # 0) ==> # 0 = Tsucc # 0)
          = (fsubst 0 (Tsucc #0) (Tsucc #1 = Tsucc #0  ==> # 1 = # 0)));
          simpl; auto.
          rewrite H; apply Rforall_e.
      assert ( (Fforall (Tsucc # 1 = Tsucc # 0 ==> # 1 = # 0))
          = fsubst 0 #0 (Fforall (Tsucc # 1 = Tsucc # 0 ==> # 1 = # 0))).
          simpl; auto.
      rewrite H0; apply Rforall_e;
      constructor; simpl; auto.
      constructor; simpl; auto.
Qed.

(* Interpretation of terms, using a valuation for variables *)

Definition valuation := list nat.

Fixpoint tinterp (v:valuation) t :=
  match t with
    | Tvar j => nth j v O
    | Tzero => O
    | Tsucc t => S (tinterp v t)
    | Tplus t t' => tinterp v t + tinterp v t'
    | Tmult t t' => tinterp v t * tinterp v t'
  end.

Lemma tinterp_1 : forall t v0 v1 v2,
  tinterp (v0++v1++v2) (tlift (length v1) t (length v0)) =
  tinterp (v0++v2) t.
Proof.
  intros; induction t;
  simpl; try break; auto.
  repeat rewrite app_nth2;
  f_equal; auto.
  repeat rewrite app_nth1; auto.
Qed.

Lemma tinterp_2 : forall t' t v1 v2,
  tinterp (v1 ++ v2) (tsubst (length v1) t' t) =
  tinterp (v1 ++ (tinterp v2 t') :: v2) t.
Proof.
  intros; induction t;
  simpl;
  try destruct (nat_compare_spec (length v1) n); auto.
  - rewrite <- (app_nil_l v1); repeat rewrite <- app_assoc.
    assert (length (nil ++ v1) = length v1); auto; rewrite H0.
    assert (@length nat nil = 0); auto; rewrite <- H1.
    rewrite (tinterp_1 t' nil v1 v2); simpl.
    assert (n - length v1 = 0); auto.
    rewrite (app_nth2 v1 (tinterp v2 t' :: v2) 0);
    simpl. rewrite H2; auto. auto.
  - rewrite (app_nth2 v1 (tinterp v2 t' :: v2) 0); auto.
    unfold tinterp at 1.
    rewrite (app_nth2 v1 v2 0); auto.
    assert (tinterp v2 t' :: v2 = ((tinterp v2 t')::nil) ++ v2); auto.
    rewrite H0; rewrite (app_nth2 _ v2 0);
    assert (length (tinterp v2 t' :: nil) = 1); auto; rewrite H1.
    assert (Init.Nat.pred n - length v1 = n - length v1 - 1); auto;
    rewrite H2; auto.
  - simpl; repeat rewrite app_nth1; auto.
Qed.

(* Interpretation of formulas *)

Fixpoint finterp v A :=
  match A with
    | Fequal t t' => tinterp v t = tinterp v t'
    | Ffalse => False
    | Fand B C => finterp v B /\ finterp v C
    | For B C => finterp v B \/ finterp v C
    | Fimplies B C => finterp v B -> finterp v C
    | Fexists B => exists n, finterp (n::v) B
    | Fforall B => forall n, finterp (n::v) B
  end.

Lemma finterp_1 : forall A v0 v1 v2,
  finterp (v0 ++ v1 ++ v2) (flift (length v1) A (length v0)) <->
  finterp (v0 ++ v2) A.
Proof.
  intros. revert v0 v1 v2. induction A;  intros.
  - simpl. split;intros.
    + simpl in H. repeat(rewrite tinterp_1 in H). assumption.
    + repeat (rewrite tinterp_1). assumption.
  - auto. simpl. split;auto.
  - split; intro; destruct H; apply (IHA1 v0 v1 v2) in H;
    split ; try apply (IHA2 v0 v1 v2) in H0 ; assumption.
  - split ; intro; destruct H.
    +left. simpl in H. apply (IHA1 v0 v1 v2) in H. assumption.
    +right. apply (IHA2 v0 v1 v2) in H. assumption.
    +left. simpl in H. apply (IHA1 v0 v1 v2) in H. assumption.
    +right. apply (IHA2 v0 v1 v2) in H. assumption.

  - split;intro; simpl in H; simpl; intro; apply (IHA1 v0 v1 v2) in H0;
    apply H in H0; apply (IHA2 v0 v1 v2) in H0; assumption.

  - split; intro; simpl; simpl in H; destruct H; exists x; rewrite app_comm_cons;
    apply (IHA (x::v0)v1 v2); assumption.
  -split; intro; simpl;simpl in H; intro; rewrite app_comm_cons;
   apply (IHA (n::v0)v1 v2); apply H.

Qed.

Lemma finterp_2 : forall t' A v1 v2,
  finterp (v1 ++ v2) (fsubst (length v1) t' A) <->
  finterp (v1 ++ (tinterp v2 t') :: v2) A.
Proof.
  intros; revert v1 v2; induction A; intros;
  simpl; split; intuition;
  repeat rewrite <- tinterp_2; auto;
  repeat rewrite tinterp_2; auto;
  try apply (@IHA1 v1 v2) in H0; intuition;
  try apply (@IHA2 v1 v2) in H1; intuition;
  try apply (@IHA2 v1 v2) in H0; intuition;
  try (destruct H; exists x; rewrite app_comm_cons; apply (@IHA (x::v1) v2)); auto;
  try (apply (@IHA (n::v1) v2); rewrite <- app_comm_cons); intuition.
Qed.

(* Interpretation of contexts *)

Definition cinterp v Γ := forall A, In A Γ -> finterp v A.

(* Soundess of deduction rules *)

Lemma f_to_c : forall v A Γ , finterp v A ->  cinterp v Γ -> cinterp v (A :: Γ).
Proof.
  intros. unfold cinterp in *. intros.
  simpl in H1. destruct H1; try rewrite <- H1; auto.
Qed.

(*this lemma is useful for cinterp_1 and soundness_rules*)
Lemma soundness_misc : forall Γ A m n, In A (clift m Γ n) ->
                                        exists B, A = flift m B n /\ In B Γ.
Proof.
  intros. induction Γ; simpl in H; try contradiction.
  simpl in H. destruct H.
  - exists a. split; try simpl; auto.
           - assert (exists B : formula, A = flift m B n /\ In B Γ). auto.
             destruct H0 as [B H0]. exists B. destruct H0.
             split;try apply in_cons; auto.
Qed.

(*added by Alice*)
(*I hope this is true*)
Lemma cinterp_1 : forall Γ v0 v1 v2,
                    cinterp (v0 ++ v2) Γ ->
                    cinterp (v0 ++ v1 ++ v2) (clift (length v1) Γ (length v0)) .

Proof.
  intro. induction Γ.
  - intros. simpl. unfold cinterp. intros. simpl in H0. contradiction.
  -  unfold cinterp.  simpl. intros. destruct H0.
     + rewrite <- H0. apply finterp_1. apply H. auto.
     + assert (exists B, A = flift (length v1) B (length v0)/\ In B Γ).
       apply soundness_misc. auto.
       destruct H1 as [B H1]. destruct H1. rewrite H1. apply finterp_1.
       apply H. auto.
Qed.

Lemma finterp_misc_0  : forall v t B,  finterp v (fsubst 0 t B) ->
                                     (exists n, finterp (n::v) B).
Proof.
  intros.  exists (tinterp v t). assert (finterp(nil ++ (tinterp v t) :: v) B).
  apply finterp_2. simpl. auto. simpl in H0. auto.
Qed.

Lemma finterp_misc_1 : forall v t B ,  (forall n, finterp (n::v) B)
                                       -> finterp v (fsubst 0 t B).
Proof.
  intros.  assert (finterp(nil ++  v) (fsubst 0 t B));
    try apply finterp_2; simpl; auto.
Qed.

Lemma finterp_misc_2 :  forall v A,
  (exists n, (finterp (n :: v) (flift 1 A 0))) ->
  finterp v A.
Proof.
  intros.
   destruct H as [n H].
    assert (finterp ((nil : list nat) ++ (n :: nil) ++ v)
                    (flift (length (n :: nil)) A (length (nil : list nat))) <->
            finterp ((nil : list nat) ++ v) A).
  - apply finterp_1.
  - simpl in H0. apply H0. auto.
Qed.

Lemma finterp_misc_3 :  forall n v A,
                          finterp v A ->
                          (finterp (n :: v) (flift 1 A 0)).
Proof.
  intros. assert (finterp ((nil : list nat) ++ (n :: nil) ++ v)
                          (flift (length (n :: nil)) A
                                 (length (nil : list nat))) <->
                  finterp ((nil : list nat) ++ v) A).
  - apply finterp_1.
  - simpl in H0. apply H0. auto.
Qed.

(*Particular case of cinterp1*)
Lemma cinterp_forall : forall Γ n v , cinterp v Γ ->
                                      cinterp (n :: v) (clift 1 Γ 0).
Proof.

  intros. assert (cinterp ( nil ++(n::nil) ++ v)
                          (clift (length (n::nil))  Γ (length (nil:list nat)))).
  - apply (cinterp_1  Γ nil (n::nil) v). simpl. auto.
  - simpl in H0. auto.
Qed.

Lemma soundness_rules : forall Γ A, Γ:-A ->
  forall v, cinterp v Γ -> finterp v A.
Proof.
  (*intros. apply yeswecan with Γ. auto.*)
  intro;intro;intro.  induction H.
  - intros. apply H0. auto.
  - intros. cut False. auto. simpl in IHrule. apply IHrule with v. auto.
  - simpl. split; auto.
  - simpl in IHrule. apply IHrule.
  - simpl in IHrule. apply IHrule.
  - simpl. left. auto.
  - simpl. right. auto.
  - intros. simpl in IHrule1. assert (finterp v B \/ finterp v C); auto.
    destruct H3.
    + apply IHrule2. apply f_to_c; auto.
    + apply IHrule3. apply f_to_c; auto.
  - simpl. intros. apply IHrule. apply f_to_c; auto.
  - simpl in IHrule1. auto.
  - simpl. intros. apply IHrule. apply cinterp_forall. auto.
  - intros. simpl in IHrule. simpl.
    apply finterp_misc_1 .  auto.
  - intros. simpl. apply finterp_misc_0 with t . auto.
  - intros. unfold cinterp in IHrule2. simpl in *. apply finterp_misc_2.
    assert (exists n, finterp (n::v) B). auto.
    destruct H2. exists x.
    apply IHrule2 . intros. destruct H3.
    + rewrite <- H3. auto.
    + assert (exists C, A0 = flift 1 C 0 /\ In C Γ). apply soundness_misc. auto.
      destruct H4 as [C H4]. destruct H4.
      assert (finterp v C). auto. rewrite H4.
      apply finterp_misc_3. auto.
Qed.

(* n-times repeated Tsucc *)
Fixpoint nTsucc n :=
  match n with
    | 0 => (fun t => t)
    | S m => (fun t => Tsucc (nTsucc m t))
  end.

Lemma tinterp_nTsucc : forall n v, tinterp v (nTsucc n Tzero) = n.
Proof.
  induction n; simpl; auto; try apply f_equal.
Qed.

Lemma nTsucc_eq_n : forall A n v, finterp (n::v) A <->
  finterp v (fsubst 0 (nTsucc n Tzero) A).
Proof.
  intros; destruct n; split; intro; simpl;
  try apply finterp_2 with (v1 := nil);
  try apply finterp_2 with (v1 := nil) in H; auto; simpl.
  rewrite <- (@tinterp_nTsucc n v) in H; auto.
  rewrite (@tinterp_nTsucc (S n) v) in H; simpl; auto.
Qed.

Lemma destruct_list_end : forall n (v1: list nat), length v1 = S n
  -> exists n0 v0, length v0 = n /\ v1 = v0 ++ n0::nil.
Proof.
  intros.
  assert (v1 <> nil).
  intuition; rewrite <- length_zero_iff_nil in H0; auto.
  apply (@exists_last nat v1) in H0; destruct H0; destruct s.
  exists x0; exists x; split; auto.
  assert (S n = length x + 1).
  rewrite <- H; rewrite e; apply app_length.
  auto.
Qed.

Lemma finterp_nFforall : forall A n v2, finterp v2 (nFforall n A)
  <-> forall v1, length v1 = n -> finterp (v1 ++ v2) A.
Proof.
  induction n; split; intros; simpl; simpl in H.
  - apply length_zero_iff_nil in H0; try now rewrite H0.
  - now apply H with (v1 := nil).
  - apply (destruct_list_end n v1) in H0.
    destruct H0; destruct H0; destruct H0.
    rewrite H1; rewrite <- app_assoc.
    apply IHn with (v2 := (x :: nil) ++ v2); auto;
    simpl; apply H.
  - intro. apply IHn; intros.
    assert (v1 ++ n0 :: v2 = (v1 ++ (n0 :: nil)) ++ v2).
    rewrite <- app_assoc; now simpl.
    rewrite H1; apply H; rewrite app_length; simpl; auto.
Qed.

Lemma nTsucc_at_n0 : forall A n n0 v, finterp (n0::v) (nFforall n A)
  <-> finterp v (nFforall n (fsubst n (nTsucc n0 Tzero) A)).
Proof.
  split; intro;
  try rewrite -> (finterp_nFforall A n (n0::v)) in H;
  try rewrite -> (finterp_nFforall (fsubst n (nTsucc n0 Tzero) A) n v);
  try rewrite -> (finterp_nFforall A n (n0::v));
  try rewrite -> (finterp_nFforall (fsubst n (nTsucc n0 Tzero) A) n v) in H;
  intros; assert (finterp_subst := (finterp_2 (nTsucc n0 Tzero) A v1 v));
  rewrite H0 in finterp_subst; rewrite tinterp_nTsucc in finterp_subst;
  try (rewrite finterp_subst; now apply H).
  try (rewrite <- finterp_subst; now apply H).
Qed.

(*
Lemma tlift_unit: forall t n, tlift 0 t n = t.
Proof.
  induction t; intros;
  repeat (simpl; auto; break);
  simpl; try f_equal;
  try apply IHt; try apply IHt1; try apply IHt2.
Qed.
*)

Notation flift_add := flift_1.
Notation flift_commute := flift_2.
Notation subst_below := fsubst_1.
Notation flift_fsubst_commute := fsubst_2.
Notation dble_flift_fsubst_commute := fsubst_3.
Notation fsubst_add := fsubst_4.
Notation cformula_monotonous := cformula_1.
Notation lift_above := cformula_2.
Notation subst_above := cformula_3.
Notation subst_closed_term := cformula_4.
Notation finterp_lift := finterp_1.
Notation finterp_subst := finterp_2.

Lemma soundness_axioms : forall A, PeanoAx A -> forall v, finterp v A.
Proof.
  intros; induction H; simpl; auto.
  generalize dependent A; induction n.
  - simpl; intros; inversion H0.
    assert (forall n : nat,
    finterp (n :: v) A ->
    finterp ((S n) :: v) A).
    + intros; apply H2 in H3.
      apply finterp_subst with (v1 := nil) in H3.
      simpl in H3; apply finterp_lift with (v0 := S n0 :: nil) (v1 := n0 :: nil) (v2 := v) in H3.
      simpl in H3. auto.
    + apply nat_ind with (n:= n) in H3; auto.
      apply finterp_subst with (v1 := nil) in H1; now simpl in H1.
  - intros; simpl; intro.
    assert (cformula (S n) (fsubst (S n) (nTsucc n0 Tzero) A)).
    + apply subst_closed_term with (n := S n); auto.
      induction n0; auto; simpl; now constructor.
    + apply IHn in H0; rewrite nTsucc_at_n0; simpl.
      assert (fsub_add := fsubst_add A 0 Tzero n (nTsucc n0 Tzero)).
      simpl in fsub_add.
      rewrite <- fsub_add in H0.
      assert (fsub_lift := flift_fsubst_commute A (S n) (nTsucc n0 Tzero) 1 1).
      simpl in fsub_lift.
      rewrite fsub_lift in H0.
      assert (fsub_sub := fsubst_add (flift 1 A 1) 0 (Tsucc # 0) (S n) (nTsucc n0 Tzero)).
      simpl in fsub_sub.
      rewrite <- fsub_sub in H0.
      auto; destruct n. auto.
Qed.

Theorem soundness : forall A, Thm A -> forall v, finterp v A.
Proof.
  intro; intro. repeat (destruct H). intro. apply soundness_rules with x. auto.
  unfold cinterp. intros. apply soundness_axioms. auto.
Qed.

Theorem coherence : ~Thm Ffalse.
Proof.
  intro.
  assert (finterp nil  Ffalse).
  apply soundness; auto.
  simpl in H0; auto.
Qed.


Require Import JMeq FunctionalExtensionality ProofIrrelevance.
Require Export FunctorCategory SumCategory ProductCategory Functor.
Require Import Common NatCategory FEqualDep InitialTerminalCategory.
Require Import FunctorProduct ProductInducedFunctors FunctorialComposition.
Require Import SumInducedFunctors CanonicalStructureSimplification.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Hint Immediate
      TerminalCategoryFunctorUnique InitialCategoryFunctorUnique
      InitialCategoryFunctor'Unique.
Local Hint Resolve Functor_eq Functor_JMeq NaturalTransformation_eq
      NaturalTransformation_JMeq eq_JMeq.

Section Law0.
  Context `(C : @SpecializedCategory objC).

  Definition ExponentialLaw0Functor : SpecializedFunctor (C ^ 0) 1
    := FunctorTo1 _.
  Definition ExponentialLaw0Functor_Inverse : SpecializedFunctor 1 (C ^ 0)
    := FunctorFrom1 _ (FunctorFrom0 _).

  Lemma ExponentialLaw0
  : ComposeFunctors ExponentialLaw0Functor ExponentialLaw0Functor_Inverse
    = IdentityFunctor _
    /\ ComposeFunctors ExponentialLaw0Functor_Inverse ExponentialLaw0Functor
       = IdentityFunctor _.
  Proof.
    split; auto.
    apply Functor_eq; auto.
    nt_eq; auto;
    destruct_head_hnf Empty_set.
  Qed.
End Law0.

Section Law0'.
  Context `(C : @SpecializedCategory objC).
  Variable c : objC.

  Definition ExponentialLaw0'Functor : SpecializedFunctor (0 ^ C) 0
    := Build_SpecializedFunctor (0 ^ C) 0
                                (fun F => F c)
                                (fun s d m => match (s c) with end)
                                (fun x _ _ _ _ => match (x c) with end)
                                (fun x => match (x c) with end).

  Definition ExponentialLaw0'Functor_Inverse : SpecializedFunctor 0 (0 ^ C)
    := FunctorFrom0 _.

  Lemma ExponentialLaw0'
  : ComposeFunctors ExponentialLaw0'Functor ExponentialLaw0'Functor_Inverse
    = IdentityFunctor _
    /\
    ComposeFunctors ExponentialLaw0'Functor_Inverse ExponentialLaw0'Functor
    = IdentityFunctor _.
  Proof.
    split; auto;
    apply Functor_eq; simpl; intros; expand; auto.
    match goal with
        [ |- context[match ?E with end] ] => solve [ case E ]
    end.
  Qed.
End Law0'.

Section Law1.
  Context `(C : @SpecializedCategory objC).

  Definition ExponentialLaw1Functor : SpecializedFunctor (C ^ 1) C
    := Build_SpecializedFunctor (C ^ 1) C
                                (fun F => F tt)
                                (fun s d m => m tt)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).

  Definition ExponentialLaw1Functor_Inverse_MorphismOf
             s d (m : Morphism C s d)
  : Morphism (C ^ 1)
             (FunctorFrom1 _ s)
             (FunctorFrom1 _ d).
  Proof.
    hnf.
    match goal with
      | [ |- SpecializedNaturalTransformation ?F ?G ] =>
        refine (Build_SpecializedNaturalTransformation F G
                                                       (fun _ => m)
                                                       _
               )
    end;
      simpl;
      abstract (
          intros; autorewrite with morphism;
          reflexivity
        ).
  Defined.

  Global Arguments ExponentialLaw1Functor_Inverse_MorphismOf / _ _ _.

  Definition ExponentialLaw1Functor_Inverse : SpecializedFunctor C (C ^ 1).
  Proof.
    refine (Build_SpecializedFunctor
              C (C ^ 1)
              (@FunctorFrom1 _ _)
              ExponentialLaw1Functor_Inverse_MorphismOf
              _
              _
           );
    abstract nt_eq.
  Defined.

  Lemma ExponentialLaw1
  : ComposeFunctors ExponentialLaw1Functor ExponentialLaw1Functor_Inverse
    = IdentityFunctor _ /\
    ComposeFunctors ExponentialLaw1Functor_Inverse ExponentialLaw1Functor
    = IdentityFunctor _.
  Proof.
    abstract (
        split; repeat (functor_eq || nt_eq);
        destruct_head_hnf @eq;
        destruct_head_hnf unit;
        trivial;
        rewrite FIdentityOf;
        trivial
      ).
  Qed.
End Law1.

Section Law1'.
  Context `(C : @SpecializedCategory objC).

  Definition ExponentialLaw1'Functor : SpecializedFunctor (1 ^ C) 1
    := FunctorTo1 _.

  Definition ExponentialLaw1'Functor_Inverse : SpecializedFunctor 1 (1 ^ C).
  Proof.
    refine (Build_SpecializedFunctor
              1 (1 ^ C)
              (fun _ => FunctorTo1 _)
              (fun s d m => Build_SpecializedNaturalTransformation
                              (FunctorTo1 C) (FunctorTo1 C)
                              (fun _ => Identity (C := 1) tt)
                              (fun _ _ _ => eq_refl))
              _
              _
           );
    abstract nt_eq.
  Defined.

  Lemma ExponentialLaw1'
  : ComposeFunctors ExponentialLaw1'Functor ExponentialLaw1'Functor_Inverse
    = IdentityFunctor _ /\
    ComposeFunctors ExponentialLaw1'Functor_Inverse ExponentialLaw1'Functor
    = IdentityFunctor _.
  Proof.
    split; auto.
    apply Functor_eq; auto.
    nt_eq; auto.
  Qed.
End Law1'.

Section Law2.
  Context `(D : @SpecializedCategory objD).
  Context `(C1 : @SpecializedCategory objC1).
  Context `(C2 : @SpecializedCategory objC2).

  Definition ExponentialLaw2Functor
  : SpecializedFunctor (D ^ (C1 + C2)) ((D ^ C1) * (D ^ C2))
    := FunctorProduct (FunctorialComposition C1 (C1 + C2) D ⟨ - , inl_Functor _ _ ⟩)
                      (FunctorialComposition C2 (C1 + C2) D ⟨ - , inr_Functor _ _ ⟩).

  Definition ExponentialLaw2Functor_Inverse
  : SpecializedFunctor ((D ^ C1) * (D ^ C2)) (D ^ (C1 + C2)).
  Proof.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor
                  C D
                  (fun FG => sum_Functor (fst FG) (snd FG))
                  (fun _ _ m => sum_Functor_Functorial (fst m) (snd m))
                  _
                  _)
    end;
    simpl in *;
    abstract (
        nt_eq; intros;
        destruct_head_hnf @prod;
        destruct_head_hnf @sum;
        reflexivity
      ).
  Defined.

  Lemma ExponentialLaw2
  : ComposeFunctors ExponentialLaw2Functor ExponentialLaw2Functor_Inverse
    = IdentityFunctor _ /\
    ComposeFunctors ExponentialLaw2Functor_Inverse ExponentialLaw2Functor
    = IdentityFunctor _.
  Proof.
    abstract (repeat
                match goal with
                  | _ => reflexivity
                  | _ => split
                  | _ => progress (simpl in *; intros; trivial)
                  | _ => progress repeat subst
                  | _ => progress destruct_head_hnf @Empty_set
                  | _ => progress simpl_eq
                  | _ => progress apply Functor_eq
                  | _ => progress nt_eq
                  | _ => progress rsimplify_morphisms
                  | _ => progress destruct_head_hnf @sum
                  | _ => progress rewrite FIdentityOf
                end).
  Qed.
End Law2.

Section Law3.
  Context `(C1 : @SpecializedCategory objC1).
  Context `(C2 : @SpecializedCategory objC2).
  Context `(D : @SpecializedCategory objD).

  Definition ExponentialLaw3Functor
  : SpecializedFunctor ((C1 * C2) ^ D) (C1 ^ D * C2 ^ D).
    match goal with
      | [ |- SpecializedFunctor ?F ?G ] =>
        refine (Build_SpecializedFunctor
                  F G
                  (fun H => (ComposeFunctors fst_Functor H,
                             ComposeFunctors snd_Functor H))
                  (fun s d m =>
                     (MorphismOf (FunctorialComposition D (C1 * C2) C1)
                                 (s := (_, _))
                                 (d := (_, _))
                                 (Identity fst_Functor, m),
                      MorphismOf (FunctorialComposition D (C1 * C2) C2)
                                 (s := (_, _))
                                 (d := (_, _))
                                 (Identity snd_Functor, m)))
                  _
                  _
               )
    end;
    abstract (
        intros;
        simpl;
        simpl_eq;
        apply NaturalTransformation_eq;
        simpl; intros;
        rsimplify_morphisms;
        reflexivity
      ).
  Defined.

  Definition ExponentialLaw3Functor_Inverse
  : SpecializedFunctor (C1 ^ D * C2 ^ D) ((C1 * C2) ^ D).
    let FG := (match goal with
                   [ |- SpecializedFunctor ?F ?G ] => constr:(F, G)
               end) in
    refine (Build_SpecializedFunctor
              (fst FG) (snd FG)
              (fun H => FunctorProduct
                          (@fst_Functor _ (C1 ^ D) _ (C2 ^ D) H)
                          (@snd_Functor _ (C1 ^ D) _ (C2 ^ D) H))
              (fun _ _ m => FunctorProductFunctorial (fst m) (snd m))
              _
              _);
      abstract (
          simpl; intros;
          simpl_eq;
          nt_eq
        ).
  Defined.

  Lemma ExponentialLaw3
  : ComposeFunctors ExponentialLaw3Functor ExponentialLaw3Functor_Inverse
    = IdentityFunctor _ /\
    ComposeFunctors ExponentialLaw3Functor_Inverse ExponentialLaw3Functor
    = IdentityFunctor _.
  Proof.
    abstract (
        repeat
          match goal with
            | _ => reflexivity
            | _ => split
            | _ => progress (simpl; intros; trivial)
            | _ => progress repeat subst
            | _ => progress JMeq_eq
            | _ => progress simpl_eq
            | _ => progress apply Functor_eq
            | _ => progress apply NaturalTransformation_JMeq
            | _ => rsimplify_morphisms
          end
      ).
  Qed.
End Law3.

Section Law4.
  Context `(C1 : @SpecializedCategory objC1).
  Context `(C2 : @SpecializedCategory objC2).
  Context `(D : @SpecializedCategory objD).

  Section functor.
    Local Ltac do_exponential4 := intros; simpl;
      repeat (simpl;
        match goal with
          | _ => reflexivity
          | _ => rewrite FCompositionOf
          | _ => rewrite FIdentityOf
          | _ => rewrite LeftIdentity
          | _ => rewrite RightIdentity
          | _ => try_associativity ltac:(rewrite Commutes)
          | _ => repeat rewrite Associativity; apply f_equal
          | _ => repeat rewrite <- Associativity; apply f_equal2; try reflexivity; []
        end).

    Definition ExponentialLaw4Functor_ObjectOf : ((D ^ C1) ^ C2)%category -> (D ^ (C1 * C2))%category.
    Proof.
      intro F; hnf in F |- *.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
            (fun c1c2 => F (snd c1c2) (fst c1c2))
            (fun s1s2 d1d2 m1m2 => Compose ((F (snd d1d2)).(MorphismOf) (fst m1m2)) ((F.(MorphismOf) (snd m1m2)) (fst s1s2)))
            _
            _
          )
      end;
      abstract do_exponential4.
    Defined.

    Definition ExponentialLaw4Functor_MorphismOf s d (m : Morphism ((D ^ C1) ^ C2) s d) :
      Morphism (D ^ (C1 * C2)) (ExponentialLaw4Functor_ObjectOf s) (ExponentialLaw4Functor_ObjectOf d).
    Proof.
      exists (fun c => (m (snd c)) (fst c));
        abstract (
          do_exponential4;
          match goal with
            | [ |- Compose (ComponentsOf ?T ?x) (ComponentsOf ?U _) = Compose (ComponentsOf ?T' _) (ComponentsOf ?U' _) ] =>
              cut (Compose T U = Compose T' U');
                [ let H := fresh in intro H; simpl in H;
                  exact (f_equal (fun T => ComponentsOf T (fst s0)) H)
                  | rewrite Commutes; reflexivity
                ]
          end
        ).
    Defined.

    Definition ExponentialLaw4Functor : SpecializedFunctor ((D ^ C1) ^ C2) (D ^ (C1 * C2)).
    Proof.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
            ExponentialLaw4Functor_ObjectOf
            ExponentialLaw4Functor_MorphismOf
            _
            _
          )
      end;
      abstract nt_eq.
    Defined.
  End functor.

  Section inverse.
    Local Ltac do_exponential4_inverse := intros; simpl;
      repeat (simpl;
        match goal with
          | _ => reflexivity
          | _ => rewrite <- FCompositionOf
          | _ => rewrite FIdentityOf
          | _ => rewrite LeftIdentity
          | _ => rewrite RightIdentity
          | _ => try_associativity ltac:(rewrite Commutes)
          | _ => repeat rewrite Associativity; apply f_equal
          | _ => repeat rewrite <- Associativity; apply f_equal2; try reflexivity; []
        end).

    Section ObjectOf.
      Variable F : SpecializedFunctor (C1 * C2) D.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf : C2 -> (D ^ C1)%category.
      Proof.
        intro c2.
        hnf.
        match goal with
          | [ |- SpecializedFunctor ?C ?D ] =>
            refine (Build_SpecializedFunctor C D
              (fun c1 => F (c1, c2))
              (fun s1 d1 m1 => F.(MorphismOf) (s := (s1, c2)) (d := (d1, c2)) (m1, Identity c2))
              _
              _
            )
        end;
        abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf s d (m : Morphism C2 s d) :
        Morphism (D ^ C1) (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf s) (ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf d).
      Proof.
        exists (fun c => F.(MorphismOf) (s := (c, s)) (d := (c, d)) (Identity c, m));
          abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_ObjectOf : ((D ^ C1) ^ C2)%category.
      Proof.
        hnf.
        match goal with
          | [ |- SpecializedFunctor ?C ?D ] =>
            refine (Build_SpecializedFunctor C D
              ExponentialLaw4Functor_Inverse_ObjectOf_ObjectOf
              ExponentialLaw4Functor_Inverse_ObjectOf_MorphismOf
              _
              _
            )
        end;
        abstract (nt_eq; do_exponential4_inverse).
      Defined.
    End ObjectOf.

    Section MorphismOf.
      Definition ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf s d (m : Morphism (D ^ (C1 * C2)) s d) :
        forall c, Morphism (D ^ C1) ((ExponentialLaw4Functor_Inverse_ObjectOf s) c) ((ExponentialLaw4Functor_Inverse_ObjectOf d) c).
      Proof.
        intro c;
          exists (fun c' => m (c', c));
            abstract do_exponential4_inverse.
      Defined.

      Definition ExponentialLaw4Functor_Inverse_MorphismOf s d (m : Morphism (D ^ (C1 * C2)) s d) :
        Morphism ((D ^ C1) ^ C2) (ExponentialLaw4Functor_Inverse_ObjectOf s) (ExponentialLaw4Functor_Inverse_ObjectOf d).
      Proof.
        exists (ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf m);
          abstract (nt_eq; do_exponential4_inverse).
      Defined.
    End MorphismOf.

    Arguments ExponentialLaw4Functor_Inverse_MorphismOf_ComponentsOf / _ _ _ _.

    Definition ExponentialLaw4Functor_Inverse : SpecializedFunctor (D ^ (C1 * C2)) ((D ^ C1) ^ C2).
    Proof.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
            ExponentialLaw4Functor_Inverse_ObjectOf
            ExponentialLaw4Functor_Inverse_MorphismOf
            _
            _
          )
      end;
      abstract nt_eq.
    Defined.
  End inverse.

  Lemma ExponentialLaw4
  : ComposeFunctors ExponentialLaw4Functor ExponentialLaw4Functor_Inverse
    = IdentityFunctor _ /\
    ComposeFunctors ExponentialLaw4Functor_Inverse ExponentialLaw4Functor
    = IdentityFunctor _.
  Proof.
    abstract (repeat match goal with
                       | _ => reflexivity
                       | _ => split
                       | _ => progress (simpl; intros; trivial)
                       | _ => progress repeat subst
                       | _ => progress destruct_head_hnf @prod
                       | _ => progress JMeq_eq
                       | _ => progress simpl_eq
                       | _ => progress apply Functor_eq
                       | _ => progress apply NaturalTransformation_JMeq
                       | _ => progress apply f_equal
                       | _ => rewrite <- FCompositionOf
                       | _ => rewrite FIdentityOf
                       | _ => rsimplify_morphisms
                     end).
  Qed.
End Law4.


From mathcomp.ssreflect Require Import ssreflect eqtype seq ssrbool ssrnat.

Require Import Common Types.
(* Different memory regions *)
Inductive storage := | Heap | Stack | Data | Text | ReadOnlyData.

Scheme Equality for storage.
Definition storage_eqP := reflect_from_dec storage_eq_dec.
Canonical storage_eqMixin := EqMixin storage_eqP.
Canonical storage_eqType := EqType storage storage_eqMixin.

Inductive block := mk_block {
                       region: storage;
                       block_id: nat;
                       block_size: nat;
                       el_type: ctype;
                       contents: seq value;
                       (*_ : forall (v:value), v \in contents -> match v with
                                                                 | Value t v => t == el_type
                                                                 | Garbage
                                                                 | Deallocated
                                                                 | Error => true
                                                               end*)

                     }.

Definition block_beq (x y: block) :=
  (  region x == region y  )
    && (block_id x == block_id y )
    && (block_size x == block_size y)
    && (el_type x == el_type y)
    && (contents x == contents y).

Theorem block_eqP: Equality.axiom block_beq.
  move => x y.
  case (block_beq x y) eqn: H.
  destruct x, y; constructor.
  rewrite /block_beq in H.
  simpl in H.
  do 4! [ move /andP in H; destruct H].
  by rewrite (eqP H0) (eqP H1) (eqP H2) (eqP H3) (eqP H).
  constructor.
  case.
  move=> H'; subst.
  destruct y.
  rewrite /block_beq in H.
  by do 5! rewrite (eq_refl _) in H.
Defined.

Canonical block_eqMixin := EqMixin block_eqP.
Canonical block_eqType := EqType block block_eqMixin.

Definition block_mod
           mod_region
           mod_block_id
           mod_block_size
           mod_el_type
           mod_contents
           b
  :=
    match b with
      | mk_block q w e  t y => mk_block
                                  (mod_region q)
                                  (mod_block_id w)
                                  (mod_block_size e)
                                  (mod_el_type t)
                                  (mod_contents y)

    end.

Definition block_mod_cont f b := block_mod id id id id f b.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal17.

Set Printing Depth 1000.
Definition lfind_eval  y:=
rev y.

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil)))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*           [*] Affiliation Univ. Lorraine - CNRS - LORIA    *)
(*           [+] Affiliation VERIMAG - Univ. Grenoble Alpes   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*        CeCILL v2.1 FREE SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

From Coq Require Import Utf8.

(* The type of positions/indices [0,...,n-1] with small inversion *)

Inductive idx : nat → Set :=
  | idx_fst {n} : idx (S n)
  | idx_nxt {n} : idx n → idx (S n).

Notation 𝕆 := idx_fst.
Notation 𝕊 := idx_nxt.

Inductive idx_shape_O : idx 0 → Set := .

Inductive idx_shape_S n : idx (S n) → Set :=
  | idx_shape_S_fst : idx_shape_S n 𝕆
  | idx_shape_S_nxt p : idx_shape_S n (𝕊 p).

Definition idx_inv {n} p :
  match n with
  | O   => idx_shape_O
  | S n => idx_shape_S n
  end p.
Proof. destruct p; constructor. Defined.