(*! A simple demo of ghost state and lock reasoning in Iris *)

(* To compile this demo you'll just need Iris, which can be installed from opam
(follow the instructions in the README: https://gitlab.mpi-sws.org/iris/iris) *)

(* meta point: standard coqdoc syntax uses square brackets to surround Coq code,
like [forall x, x = x]. *)

From iris.base_logic Require Import lib.ghost_var.

(* we'll write this demo in HeapLang, a simple ML-like language shipped with
Iris *)
From iris.heap_lang Require Import proofmode notation adequacy.
From iris.heap_lang.lib Require Import lock spin_lock.

(* set some Coq options for basic sanity *)
Set Default Proof Using "Type".
Set Default Goal Selector "!".
Set Printing Projections.
Open Scope Z_scope.

(** The idea of this proof is to have a bank that stores user balances in
accounts which are protected by locks. We want to show that in some sense
transfers preserve the sum of balances.

First, we make some radical simplifications to focus on the essential
difficulty: we only have two accounts (but still two locks), and only transfer
from one to the other. The balances are represented as mathematical integers [Z]
and their sum will be 0. We'll also write this code in Iris using just HeapLang
rather than in Go using GooseLang.

The difficulty these simplifications leave is that the balances don't
necessarily sum to zero at any instant in time; to observe their sum is 0, we
have to acquire locks. Thus here we write a program that acquires all (both)
locks and checks that the sum is zero.

We won't prove anything else about the bank functionality or implement anything
else (like reading balances).

 *)

(* some notes on syntax for reading this code:

- ref allocates a new reference with an initial value
- # is the constructor to turn something into a value, for example #0 is an
    integer ([Z]) value, and #() is a unit
- !l dereferences a pointer l (we use "l" for "location")
- many constructs have a colon to disambiguate them from the analogous Coq
  syntax
- this language has no static type system
- [λ: <>, ...] uses <> for an anonymous binder, much like _ in Coq and other
  languages.

 *)

(** new_bank constructs a bank with two accounts that both have zero balance,
which initially satisfies the desired invariant *)
Definition new_bank: val :=
  λ: <>,
     let: "a_bal" := ref #0 in
     let: "b_bal" := ref #0 in
     let: "lk_a" := newlock #() in
     let: "lk_b" := newlock #() in
    (* the bank is represented as a pair of accounts, each of which is a pair of
    a lock and a pointer to its balance *)
     (("lk_a", "a_bal"), ("lk_b", "b_bal")).

(** transfer is what we want to prove safe, but we won't prove that it actually
modifies the bank state correctly because it requires more setup. *)
Definition transfer: val :=
  λ: "bank" "amt",
  let: "a" := Fst "bank" in
  let: "b" := Snd "bank" in
  acquire (Fst "a");;
  acquire (Fst "b");;
  Snd "a" <- !(Snd "a") - "amt";;
  Snd "b" <- !(Snd "b") + "amt";;
  release (Fst "b");;
  release (Fst "a");;
  #().

(** this is the core function of interest: we will prove that even in the
presence of [transfer]s, this function always returns true *)
Definition check_consistency: val :=
  λ: "bank",
  let: "a" := Fst "bank" in
  let: "b" := Snd "bank" in
  acquire (Fst "a");;
  acquire (Fst "b");;
  let: "a_bal" := !(Snd "a") in
  let: "b_bal" := !(Snd "b") in
  let: "ok" := "a_bal" + "b_bal" = #0 in
  release (Fst "b");;
  release (Fst "a");;
  "ok".

(** to tie everything together we'll specifically prove this function returns
true, even though the check races with a transfer. *)
Definition demo_check_consistency: val :=
  λ: <>,
  let: "bank" := new_bank #() in
  Fork (transfer "bank" #5);;
  check_consistency "bank".

(* We'll now switch over to reasoning in the logic.

The syntax for separation logic stuff here includes:
- [P ∗ Q] (note that's a unicode symbol) is separating conjunction. This binds
  weakly so that we don't need parentheses around every conjunct.
- [P -∗ Q] is separating implication (think of it as P implies Q and just
  remember that (P -∗ Q) ∗ P ⊢ Q)
- [⌜φ⌝] embeds a "pure" (Coq) proposition [φ: Prop] into separation logic
- [∃ (x:T), ...] is overloaded to also work within separation logic. This is so
  natural you can easily forget that separation logic and Coq exists aren't the
  same thing.
- [|==> P] uses a "modality" (the [|==>] part) to say that after some change in
  ghost state, it produces resources satisfying P.
*)

Section heap.

(* mostly standard boilerplate *)
Context `{!heapGS Σ}.
Context `{!lockG Σ}.
Context `{!ghost_varG Σ Z}.
Let N := nroot.@"bank".

(* We can now talk about [iProp Σ], the type of Iris propositions. This includes
ownership of ghost variables, [l ↦ v] for the usual points-to in HeapLang, and
all the separation logic connectives. You can ignore the [Σ] which is there for
technical reasons. *)

(** Verifying concurrent software generally require the use of _ghost state_,
variables that are introduced into the program only for the sake of the proof.
In some systems (like Dafny or VeriFast), ghost variables actually show up in
the source code for the program being verified. In Iris, we'll only see ghost
variables in the proof.

 We'll now start writing down the invariant for this proof, and this is where
 we'll reference the ghost variables. We do that with a proposition [ghost_var γ
 q v], which says that the ghost variable with name [γ] has value [v], and we
 own a fraction [q] (≤1) of it. Ghost variables in Iris are always a combination
 of knowledge about the variable and ownership over it. The key idea is that to
 change a ghost variable we need to assemble all the pieces of it, adding up to
 a fraction of 1; this guarantees that no other thread is claiming ownership and
 makes it sound to change its value without invalidating other threads' proofs. *)

(** account_inv is the lock invariant associated with each account. It exposes a
ghost name [γ] used to tie the account balance to a ghost variable. In the lock
invariant we'll claim half ownership, while the other half will be in a
system-wide invariant; this lets us reference the variable's value from both
places and also assert that the lock is needed to change this balance. *)
Definition account_inv γ bal_ref : iProp Σ :=
  ∃ (bal: Z), bal_ref ↦ #bal ∗ ghost_var γ (1/2) bal.

(** an account is a pair of a lock and an account protected by the lock *)
Definition is_account (acct: val) γ : iProp Σ :=
  ∃ (bal_ref: loc) lk,
    ⌜acct = (lk, #bal_ref)%V⌝ ∗
    (* The important part of [is_lock] is the lock invariant, expressed as an
    arbitrary Iris proposition [iProp Σ]. The idea of lock invariants is that
    first we associate a lock invariant [P] with the lock (we're doing that
    here). Then when we acquire the lock we get (resources satisfying) [P], and
    when we release it we have to give back (resources satisfying) [P].
    Crucially during the critical section we have access to [P] and can violate
    this proposition freely. *)
    ∃ (γl: gname), is_lock γl lk (account_inv γ bal_ref).

(** bank_inv is the invariant (the usual one that holds at all intermediate
points) that holds the authoritative fragments for the account balances and
importantly states that they are always equal. Any thread can open the invariant
to "read" the logical balances, but modifications must respect the constraint
here.

We need to say where the logical (ghost) account balances are stored so this
definition also takes two ghost names.

As mentioned above, we claim half ownership here to reference the value of both
ghost variables. This half is a bit different because it's in a regular
invariant, so any thread can open this invariant to learn the logical balances
sum to zero.
 *)
Definition bank_inv (γ: gname * gname) : iProp Σ :=
  (* the values in the accounts are arbitrary... *)
  ∃ (bal1 bal2: Z),
     ghost_var γ.1 (1/2) bal1 ∗
     ghost_var γ.2 (1/2) bal2 ∗
     (* ... except that they add up to 0 *)
     ⌜(bal1 + bal2)%Z = 0⌝.

(** finally [is_bank] ties everything together, the accounts and invariant *)
Definition is_bank (b: val): iProp Σ :=
  ∃ (acct1 acct2: val) (γ: gname*gname),
  ⌜b = (acct1, acct2)%V⌝ ∗
  is_account acct1 γ.1 ∗
  is_account acct2 γ.2 ∗
  inv N (bank_inv γ).

(* Importantly [is_bank b] is _persistent_, which means we can share it among
threads. We'll see this used in [wp_demo_check_consistency].

This proofs goes through because the components of [is_bank] are persistent.
These include the pure facts (it should be intuitive that these are persistent,
since they don't talk about resources at all), the invariant (because [inv N P]
is just knowledge of an invariant, which can and should be shared) and [is_lock
γl lk P] (similarly, this is knowledge that there is a lock at lk and is
shareable) *)
Instance is_bank_Persistent b : Persistent (is_bank b).
Proof. apply _. (* this proof is actually automatic *) Qed.

(* [new_bank] is actually interesting because we have to create all the ghost
state, lock invariants, and invariant, and of course when you create an
invariant holding [P] you have to prove [P].

These ghost operations correspond to [iMod] in these proofs, which uses theorems
with [|==>] and [==∗]. *)
Theorem wp_new_bank :
  (* This is a Hoare triple using Iris's program logic. *)
  {{{ True }}}
    new_bank #()
    (* the [b,] part is a shorthand for [∃ b, ...] in the postcondition, and RET
    b says the function returns b. *)
  {{{ b, RET b; is_bank b }}}.
Proof.
  iIntros (Φ) "_ HΦ".
  wp_rec.
  wp_alloc a_ref as "Ha".
  wp_alloc b_ref as "Hb".
  iMod (ghost_var_alloc 0) as (γ1) "(Hown1&Hγ1)".
  wp_pures.
  wp_apply (newlock_spec (account_inv γ1 a_ref) with "[Ha Hγ1]").
  { iExists _; iFrame. }
  iIntros (lk_a γlk1) "Hlk1".
  iMod (ghost_var_alloc 0) as (γ2) "(Hown2&Hγ2)".
  wp_pures.
  wp_apply (newlock_spec (account_inv γ2 b_ref) with "[Hb Hγ2]").
  { iExists _; iFrame. }
  iIntros (lk_b γlk2) "Hlk2".
  wp_pures.
  iMod (inv_alloc N _ (bank_inv (γ1,γ2)) with "[Hown1 Hown2]") as "Hinv".
  { iNext. iExists _, _; iFrame.
    iPureIntro; auto. }
  iModIntro.
  iApply "HΦ".
  iExists _, _, (γ1,γ2); iFrame.
  iSplit; first eauto.
  simpl.
  iSplitL "Hlk1".
  - iExists _; eauto with iFrame.
  - iExists _; eauto with iFrame.
Qed.

(** As mentioned above, we don't prove anything except for safety for
[transfer]. This still has to prove that we follow the lock invariants and
global invariant - after [is_bank] is created we can no longer add to a single
account, for example.

You might expect because this is separation logic that we should return [is_bank
b] here. It turns out we don't need to since the fact is persistent, so the
caller will never lose this fact. *)
Theorem wp_transfer b (amt: Z) :
  {{{ is_bank b }}}
    transfer b #amt
  {{{ RET #(); True }}}.
Proof.
  iIntros (Φ) "#Hb HΦ".
  (* breaking apart the above definitions is really quite painful - I have
  better infrastructure for this in Perennial but it isn't quite ready for this
  example and would be annoying to import here *)
  iDestruct "Hb" as (acct1 acct2 γ ->) "(Hacct1&Hacct2&Hinv)".
  iDestruct "Hacct1" as (bal_ref1 lk1 ->) "Hlk".
  iDestruct "Hlk" as (γl1) "Hlk1".
  iDestruct "Hacct2" as (bal_ref2 lk ->) "Hlk".
  iDestruct "Hlk" as (γl2) "Hlk2".
  wp_rec.
  wp_pures. wp_apply (acquire_spec with "Hlk1").
  iIntros "(Hlocked1&Haccount1)".
  wp_pures. wp_apply (acquire_spec with "Hlk2").
  iIntros "(Hlocked2&Haccount2)".
  iDestruct "Haccount1" as (bal1) "(Hbal1&Hown1)".
  iDestruct "Haccount2" as (bal2) "(Hbal2&Hown2)".

  (* If you look at the proof goal now, there are a bunch of things going on.
  The Iris Proof Mode (IPM) embeds a separation logic context within the Coq
  goal. This means we have the Coq context and the IPM context. Furthermore, it

  actually uses two contexts: a persistent context (which comes first and is
  separated by ---------□) of facts that are duplicable and thus don't go away
  when we need to split, and then a spatial context (separated by ---------∗) of
  ordinary spatial premises. The IPM view and tactics let us manipulate these in
  a way similar to how Coq hypotheses work, making proofs in separation logic as
  easy as normal Coq proofs (sort of - separation logic does add some
  difficulties to proofs that are fundamental). Learning these tactics is a lot
  like learning how to do Coq proofs all over again (that is, you need to do it
  but it's not that hard and you do get used to it). *)

  (* this steps through the critical section *)
  wp_load; wp_store; wp_pures.
  wp_load; wp_store; wp_pures.

  (* Now the physical state is updated but not the logical balances in ghost
  state. In order to restore the lock invariant, we have to do that, and this
  requires using the invariant with [iInv]. *)
  rewrite -fupd_wp. (* we need to do this for iInv to work *)
  (* iInv opens the invariant for us and also takes a pattern to destruct the
  resulting [bank_inv γ] right away. You can see that it gives us resources in
  the context but also adds [bank_inv] to the goal, since this invariant needs
  to hold at all points. *)
  iInv "Hinv" as (bal1' bal2') ">(Hγ1&Hγ2&%)".
  (* we use the agreement and update theorems above for these ghost variables *)
  iDestruct (ghost_var_agree with "Hγ1 [$]") as %->.
  iCombine "Hγ1 Hown1" as "Hγ1".
  iMod (ghost_var_update (bal1-amt) with "Hγ1") as "(Hγ1&Hown1)".

  iDestruct (ghost_var_agree with "Hγ2 [$]") as %->.
  iCombine "Hγ2 Hown2" as "Hγ2".
  iMod (ghost_var_update (bal2+amt) with "Hγ2") as "(Hγ2&Hown2)".

  iModIntro.
  (* we can't just modify ghost state however we want - to continue, [iInv]
  added [bank_inv] to our goal to prove, requiring us to restore the
  invariant *)
  iSplitL "Hγ1 Hγ2".
  { iNext. iExists _, _; iFrame.
    iPureIntro.
    lia. }
  iModIntro.

  (* We've done all the hard work of maintaining the invariant and updating the
  ghost variables to their new values.

  Now we'll be able to release both locks (in any order, actually) by
  re-proving their lock invariants, with the new values of the ghost
  variables. *)
  wp_apply (release_spec with "[$Hlk2 $Hlocked2 Hbal2 Hown2]").
  { iExists _; iFrame. }
  iIntros "_".
  wp_pures. wp_apply (release_spec with "[$Hlk1 $Hlocked1 Hbal1 Hown1]").
  { iExists _; iFrame. }
  iIntros "_".
  wp_pures.
  by iApply "HΦ".
Qed.

(** we're able to prove that [check_consistency] always returns true, using the
protocol established by [is_bank]. *)
Theorem wp_check_consistency b :
  {{{ is_bank b }}}
     check_consistency b
  {{{ RET #true; True }}}.
Proof.
  (* most of this proof is the same: open everything up and acquire the locks,
  then open the lock invariants up *)
  iIntros (Φ) "#Hb HΦ".
  iDestruct "Hb" as (acct1 acct2 γ ->) "(Hacct1&Hacct2&Hinv)".
  iDestruct "Hacct1" as (bal_ref1 lk1 ->) "Hlk".
  iDestruct "Hlk" as (γl1) "Hlk1".
  iDestruct "Hacct2" as (bal_ref2 lk ->) "Hlk".
  iDestruct "Hlk" as (γl2) "Hlk2".
  wp_rec.
  wp_pures. wp_apply (acquire_spec with "Hlk1").
  iIntros "(Hlocked1&Haccount1)".
  wp_pures. wp_apply (acquire_spec with "Hlk2").
  iIntros "(Hlocked2&Haccount2)".
  iDestruct "Haccount1" as (bal1) "(Hbal1&Hown1)".
  iDestruct "Haccount2" as (bal2) "(Hbal2&Hown2)".

  (* the critical section is easy *)
  wp_pures; wp_load.
  wp_pures; wp_load.
  wp_pures.

  (* Now we need to prove something about our return value using information
  derived from the invariant. As before we'll open the invariant, but this time
  we don't need to modify anything, just extract a pure fact. *)
  rewrite -fupd_wp.
  iInv N as (bal1' bal2') ">(Hγ1 & Hγ2 & %)". (* the [%] here is the pure fact, actually *)
  iDestruct (ghost_var_agree with "Hγ1 [$]") as %->.
  iDestruct (ghost_var_agree with "Hγ2 [$]") as %->.
  iModIntro.
  iSplitL "Hγ1 Hγ2".
  { iNext. iExists _, _; iFrame.
    iPureIntro.
    lia. }
  iModIntro.

  wp_apply (release_spec with "[$Hlk2 $Hlocked2 Hbal2 Hown2]").
  { iExists _; iFrame. }
  iIntros "_".
  wp_pures. wp_apply (release_spec with "[$Hlk1 $Hlocked1 Hbal1 Hown1]").
  { iExists _; iFrame. }
  iIntros "_".
  wp_pures.
  iModIntro.
  (* the calculation always returns true because of a fact we got from the
  invariant *)
  rewrite bool_decide_eq_true_2; last first.
  { congruence. }
  by iApply "HΦ".
Qed.

(* [demo_check_consistency] lets us tie everything together in a Hoare triple
that has no assumptions. This implies the consistency check works at least with
one concurrent transfer (and we can see that this technique doesn't depend on
the particulars, we could have any number of concurrent transfers). *)
Theorem wp_demo_check_consistency :
  {{{ True }}}
    demo_check_consistency #()
  {{{ RET #true; True }}}.
Proof using All.
  iIntros (Φ) "_ HΦ".
  wp_rec.
  wp_apply wp_new_bank; first auto.
  (* we use [#Hb] to put the newly created [is_bank] in the "persistent context"
  in the Iris Proof Mode - these are persistent facts and thus are available
  even when we need to split to prove a separating conjunction *)
  iIntros (b) "#Hb". wp_pures.
  (* the proof is easy now - the fork rule requires us to split the context and
  prove any Hoare triple for the forked thread. [transfer] only needs [Hb], but
  that's persistent and will thus be available. We've coincidentally already
  proven a triple for it with a postcondition of [True]. *)
  wp_apply wp_fork.
  - wp_apply (wp_transfer with "Hb").
    auto.
  - (* [check_consistency] always returns true, using [is_bank] *)
    wp_pures; wp_apply (wp_check_consistency with "Hb").
    iIntros "_".
    by iApply "HΦ".
Qed.

End heap.

(** To really convince ourselves that the theorem means anything, we can use the
Iris adequacy theorem (otherwise known as _soundness theorem_) to show that if
we run [demo_check_consistency], it'll always return true. This is the intuitive
meaning of the [wp_demo_check_consistency] Hoare triple above, but expressed
without Iris. *)

Definition bankΣ: gFunctors := #[heapΣ; lockΣ; ghost_varΣ Z].

Lemma demo_check_consistency_adequate σ1 :
  adequate NotStuck (demo_check_consistency #()) σ1 (λ v _, v = #true).
Proof.
  eapply (heap_adequacy bankΣ) => ?.
  iIntros "?". by iApply wp_demo_check_consistency.
Qed.

(** This is the final theorem: if we run just the thread [demo_check_consistency
#()] some number of [erased_steps] steps till it produces a value (with some
still-running forked-off threads [t2]), then that value will be [#true]. *)
Theorem demo_check_consistency_exec_true σ1 v2 t2 σ2 :
  rtc erased_step ([demo_check_consistency #()], σ1) (of_val v2 :: t2, σ2) →
  v2 = #true.
Proof.
  intros Hexec.
  apply (adequate_result _ _ _ _ (demo_check_consistency_adequate _)) in Hexec.
  auto.
Qed.


Global Set Nested Proofs Allowed.

Require Import List.
Require Import Coq.Program.Utils.

Require Import ConvBoolTac.

(* Some helpers to deal with booleans *)

Section Join.

  Definition join_andb (l : list bool) := fold_right andb true l.

  Lemma join_andb_true_iff {A : Type} :
    forall f (l : list A), (join_andb (map f l) = true) -> (forall x, List.In x l -> f x = true).
  Proof.
    intros.
    unfold join_andb in H.
    induction l; inversion H0; simpl in H; apply andb_true_iff in H; try subst; destruct H; auto.
  Qed.

  Definition join_orb (l : list bool) := fold_right orb false l.

  Lemma join_orb_true_iff {A : Type} :
    forall f (l : list A), (join_orb (map f l) = true) -> (exists x, List.In x l /\ f x = true).
  Proof.
    intros.
    unfold join_orb in H.
    induction l; simpl in H.
    - inversion H.
    - conv_bool.
      inject H.
      * exists a. simpl. eauto.
      * eapply IHl in H0. destruct H0 as [x [Hin Hf]].
        exists x. simpl. eauto.
  Qed.

End Join.

(**  option extra *)

Section Option.

Definition option_fst {A B : Type} (ab : option (A*B)) : option A :=
  match ab with
  | Some ab => Some (fst ab)
  | _ => None
  end.

Definition option_prod {A B : Type} (a : option A) (b : option B) : option (A*B) :=
  match a,b with
  | Some a, Some b => Some (a,b)
  | _,_ => None
  end.

End Option.

(*Infix "∘" := Basics.compose (at level 40).*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* Created by Bruno Barras, Jan 1998 *)
(* Made a module instance for EqdepFacts by Hugo Herbelin, Mar 2006 *)

(** We prove that there is only one proof of [x=x], i.e [eq_refl x].
    This holds if the equality upon the set of [x] is decidable.
    A corollary of this theorem is the equality of the right projections
    of two equal dependent pairs.

    Author:   Thomas Kleymann |<tms@dcs.ed.ac.uk>| in Lego
              adapted to Coq by B. Barras

    Credit:   Proofs up to [K_dec] follow an outline by Michael Hedberg

Table of contents:

1. Streicher's K and injectivity of dependent pair hold on decidable types

1.1. Definition of the functor that builds properties of dependent equalities
     from a proof of decidability of equality for a set in Type

1.2. Definition of the functor that builds properties of dependent equalities
     from a proof of decidability of equality for a set in Set

*)

(************************************************************************)
(** * Streicher's K and injectivity of dependent pair hold on decidable types *)

Set Implicit Arguments.
(* Set Universe Polymorphism. *)

Section EqdepDec.

  Variable A : Type.

  Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
    eq_ind _ (fun a => a = y') eq2 _ eq1.

  Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = eq_refl y.
  Proof.
    intros.
    case u; trivial.
  Qed.

  Variable x : A.

  Variable eq_dec : forall y:A, x = y \/ x <> y.

  Let nu (y:A) (u:x = y) : x = y :=
    match eq_dec y with
      | or_introl eqxy => eqxy
      | or_intror neqxy => False_ind _ (neqxy u)
    end.

  Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
    intros.
    unfold nu.
    destruct (eq_dec y) as [Heq|Hneq].
    reflexivity.

    case Hneq; trivial.
  Qed.

  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v.

  Remark nu_left_inv_on : forall (y:A) (u:x = y), nu_inv (nu u) = u.
  Proof.
    intros.
    case u; unfold nu_inv.
    apply trans_sym_eq.
  Qed.

  Theorem eq_proofs_unicity_on : forall (y:A) (p1 p2:x = y), p1 = p2.
  Proof.
    intros.
    elim nu_left_inv_on with (u := p1).
    elim nu_left_inv_on with (u := p2).
    elim nu_constant with y p1 p2.
    reflexivity.
  Qed.

  Theorem K_dec_on :
    forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
  Proof.
    intros.
    elim eq_proofs_unicity_on with x (eq_refl x) p.
    trivial.
  Qed.

  (** The corollary *)

  Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x :=
    match exP with
      | ex_intro _ x' prf =>
        match eq_dec x' with
          | or_introl eqprf => eq_ind x' P prf x (eq_sym eqprf)
          | _ => def
        end
    end.

  Theorem inj_right_pair_on :
    forall (P:A -> Prop) (y y':P x),
      ex_intro P x y = ex_intro P x y' -> y = y'.
  Proof.
    intros.
    cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
    simpl.
    destruct (eq_dec x) as [Heq|Hneq].
    elim Heq using K_dec_on; trivial.

    intros.
    case Hneq; trivial.

    case H.
    reflexivity.
  Qed.

End EqdepDec.

(** Now we prove the versions that require decidable equality for the entire type
    rather than just on the given element.  The rest of the file uses this total
    decidable equality.  We could do everything using decidable equality at a point
    (because the induction rule for [eq] is really an induction rule for
    [{ y : A | x = y }]), but we don't currently, because changing everything
    would break backward compatibility and no-one has yet taken the time to define
    the pointed versions, and then re-define the non-pointed versions in terms of
    those. *)

Theorem eq_proofs_unicity A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A)
: forall (y:A) (p1 p2:x = y), p1 = p2.
Proof (@eq_proofs_unicity_on A x (eq_dec x)).

Theorem K_dec A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A)
: forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
Proof (@K_dec_on A x (eq_dec x)).

Theorem inj_right_pair A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A)
: forall (P:A -> Prop) (y y':P x),
    ex_intro P x y = ex_intro P x y' -> y = y'.
Proof (@inj_right_pair_on A x (eq_dec x)).

Require Import EqdepFacts.

(** We deduce axiom [K] for (decidable) types *)
Theorem K_dec_type :
  forall A:Type,
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof.
  intros A eq_dec x P H p.
  elim p using K_dec; intros.
  case (eq_dec x0 y); [left|right]; assumption.
  trivial.
Qed.

Theorem K_dec_set :
  forall A:Set,
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof fun A => K_dec_type (A:=A).

(** We deduce the [eq_rect_eq] axiom for (decidable) types *)
Theorem eq_rect_eq_dec :
  forall A:Type,
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (p:A) (Q:A -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof.
  intros A eq_dec.
  apply (Streicher_K__eq_rect_eq A (K_dec_type eq_dec)).
Qed.

(** We deduce the injectivity of dependent equality for decidable types *)
Theorem eq_dep_eq_dec :
  forall A:Type,
    (forall x y:A, {x = y} + {x <> y}) ->
     forall (P:A->Type) (p:A) (x y:P p), eq_dep A P p x p y -> x = y.
Proof (fun A eq_dec => eq_rect_eq__eq_dep_eq A (eq_rect_eq_dec eq_dec)).

Theorem UIP_dec :
  forall (A:Type),
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (x y:A) (p1 p2:x = y), p1 = p2.
Proof (fun A eq_dec => eq_dep_eq__UIP A (eq_dep_eq_dec eq_dec)).

Unset Implicit Arguments.

(************************************************************************)
(** ** Definition of the functor that builds properties of dependent equalities on decidable sets in Type *)

(** The signature of decidable sets in [Type] *)

Module Type DecidableType.

  Monomorphic Parameter U:Type.
  Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.

End DecidableType.

(** The module [DecidableEqDep] collects equality properties for decidable
    set in [Type] *)

Module DecidableEqDep (M:DecidableType).

  Import M.

  (** Invariance by Substitution of Reflexive Equality Proofs *)

  Lemma eq_rect_eq :
    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
  Proof eq_rect_eq_dec eq_dec.

  (** Injectivity of Dependent Equality *)

  Theorem eq_dep_eq :
    forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y.
  Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).

  (** Uniqueness of Identity Proofs (UIP) *)

  Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
  Proof (eq_dep_eq__UIP U eq_dep_eq).

  (** Uniqueness of Reflexive Identity Proofs *)

  Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
  Proof (UIP__UIP_refl U UIP).

  (** Streicher's axiom K *)

  Lemma Streicher_K :
    forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
  Proof (K_dec_type eq_dec).

  (** Injectivity of equality on dependent pairs in [Type] *)

  Lemma inj_pairT2 :
    forall (P:U -> Type) (p:U) (x y:P p),
      existT P p x = existT P p y -> x = y.
  Proof eq_dep_eq__inj_pairT2 U eq_dep_eq.

  (** Proof-irrelevance on subsets of decidable sets *)

  Lemma inj_pairP2 :
    forall (P:U -> Prop) (x:U) (p q:P x),
      ex_intro P x p = ex_intro P x q -> p = q.
  Proof.
    intros.
    apply inj_right_pair with (A:=U).
    intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption.
    assumption.
  Qed.

End DecidableEqDep.

(************************************************************************)
(** ** Definition of the functor that builds properties of dependent equalities on decidable sets in Set *)

(** The signature of decidable sets in [Set] *)

Module Type DecidableSet.

  Parameter U:Set.
  Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.

End DecidableSet.

(** The module [DecidableEqDepSet] collects equality properties for decidable
    set in [Set] *)

Module DecidableEqDepSet (M:DecidableSet).

  Import M.
  Module N:=DecidableEqDep(M).

  (** Invariance by Substitution of Reflexive Equality Proofs *)

  Lemma eq_rect_eq :
    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
  Proof eq_rect_eq_dec eq_dec.

  (** Injectivity of Dependent Equality *)

  Theorem eq_dep_eq :
    forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y.
  Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).

  (** Uniqueness of Identity Proofs (UIP) *)

  Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
  Proof (eq_dep_eq__UIP U eq_dep_eq).

  (** Uniqueness of Reflexive Identity Proofs *)

  Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
  Proof (UIP__UIP_refl U UIP).

  (** Streicher's axiom K *)

  Lemma Streicher_K :
    forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
  Proof (K_dec_type eq_dec).

  (** Proof-irrelevance on subsets of decidable sets *)

  Lemma inj_pairP2 :
    forall (P:U -> Prop) (x:U) (p q:P x),
      ex_intro P x p = ex_intro P x q -> p = q.
  Proof N.inj_pairP2.

  (** Injectivity of equality on dependent pairs in [Type] *)

  Lemma inj_pair2 :
    forall (P:U -> Type) (p:U) (x y:P p),
      existT P p x = existT P p y -> x = y.
  Proof eq_dep_eq__inj_pair2 U N.eq_dep_eq.

  (** Injectivity of equality on dependent pairs with second component
      in [Type] *)

  Notation inj_pairT2 := inj_pair2.

End DecidableEqDepSet.

  (** From decidability to inj_pair2 **)
Lemma inj_pair2_eq_dec : forall A:Type, (forall x y:A, {x=y}+{x<>y}) ->
   ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ).
Proof.
  intros A eq_dec.
  apply eq_dep_eq__inj_pair2.
  apply eq_rect_eq__eq_dep_eq.
  unfold Eq_rect_eq, Eq_rect_eq_on.
  intros; apply eq_rect_eq_dec.
  apply eq_dec.
Qed.

  (** Examples of short direct proofs of unicity of reflexivity proofs
      on specific domains *)

Lemma UIP_refl_unit (x : tt = tt) : x = eq_refl tt.
Proof.
  change (match tt as b return tt = b -> Prop with
          | tt => fun x => x = eq_refl tt
          end x).
  destruct x; reflexivity.
Defined.

Lemma UIP_refl_bool (b:bool) (x : b = b) : x = eq_refl.
Proof.
  destruct b.
  - change (match true as b return true=b -> Prop with
            | true => fun x => x = eq_refl
            | _ => fun _ => True
            end x).
    destruct x; reflexivity.
  - change (match false as b return false=b -> Prop with
            | false => fun x => x = eq_refl
            | _ => fun _ => True
            end x).
    destruct x; reflexivity.
Defined.

Lemma UIP_refl_nat (n:nat) (x : n = n) : x = eq_refl.
Proof.
  induction n.
  - change (match 0 as n return 0=n -> Prop with
            | 0 => fun x => x = eq_refl
            | _ => fun _ => True
            end x).
    destruct x; reflexivity.
  - specialize IHn with (f_equal pred x).
    change eq_refl with (f_equal S (@eq_refl _ n)).
    rewrite <- IHn; clear IHn.
    change (match S n as n' return S n = n' -> Prop with
            | 0 => fun _ => True
            | S n' => fun x =>
                x = f_equal S (f_equal pred x)
            end x).
  pattern (S n) at 2 3, x.
  destruct x; reflexivity.
Defined.


Require Import Bool Arith.

Require Import List.
Import ListNotations.

(** 1.1 STLC with Booleans *)

Module STLC_with_Booleans.

Parameter V : Type.
Parameter dec : V -> V -> bool.
Parameter dec_spec :
  forall x y : V, reflect (x = y) (dec x y).

Notation "x =? y" := (dec x y) (at level 70).

Inductive type : Type :=
    | TBool : type
    | TArr : type -> type -> type.

Inductive tm : Type :=
    | TVar : V -> tm
    | TApp : tm -> tm -> tm
    | TLam : V -> tm -> tm
    | TTrue : tm
    | TFalse : tm
    | TIf : tm -> tm -> tm -> tm.

Definition Ctx : Type := V -> option type.

Inductive has_type : Ctx -> tm -> type -> Prop :=
    | ht_Var :
        forall (G : Ctx) (x : V) (A : type),
          G x = Some A -> has_type G (TVar x) A
    | ht_App :
        forall (G : Ctx) (t1 t2 : tm) (A B : type),
          has_type G t1 (TArr A B) -> has_type G t2 A ->
            has_type G (TApp t1 t2) B
    | ht_Abs :
        forall (G : Ctx) (x : V) (t : tm) (A B : type),
          has_type (fun v : V => if x =? v then Some A else G v) t B ->
            has_type G (TLam x t) (TArr A B)
    | ht_True :
        forall G : Ctx, has_type G TTrue TBool
    | ht_False :
        forall G : Ctx, has_type G TFalse TBool
    | ht_If :
        forall (G : Ctx) (t1 t2 t3 : tm) (A : type),
          has_type G t1 TBool -> has_type G t2 A -> has_type G t3 A ->
            has_type G (TIf t1 t2 t3) A.

Fixpoint type_eq_dec (t1 t2 : type) : bool :=
match t1, t2 with
    | TBool, TBool => true
    | TArr t11 t12, TArr t21 t22 =>
        type_eq_dec t11 t21 && type_eq_dec t12 t22
    | _, _ => false
end.

Fixpoint infer (G : Ctx) (t : tm) : option type :=
match t with
    | TVar x => G x
    | TApp t1 t2 =>
        match infer G t1, infer G t2 with
            | Some (TArr A B), Some A' =>
                if type_eq_dec A A' then Some B else None
            | _, _ => None
        end
    | TLam x t' => None
    | TTrue => Some TBool
    | TFalse => Some TBool
    | TIf t1 t2 t3 =>
        match infer G t1, infer G t2, infer G t3 with
            | Some TBool, Some A, Some A' =>
                if type_eq_dec A A' then Some A else None
            | _, _, _ => None
        end
end.

Lemma type_eq_dec_refl :
  forall A : type, type_eq_dec A A = true.
Proof.
  induction A; cbn.
    reflexivity.
    rewrite IHA1, IHA2. cbn. reflexivity.
Qed.

Lemma has_type_infer :
  forall (G : Ctx) (x : tm) (A : type),
    has_type G x A -> infer G x = Some A.
Proof.
  induction 1; cbn.
    assumption.
    rewrite IHhas_type1, IHhas_type2, type_eq_dec_refl. reflexivity.
    admit. (* lambda *)
    1-2: reflexivity.
    rewrite IHhas_type1, IHhas_type2, IHhas_type3, type_eq_dec_refl.
      reflexivity.
Admitted.

End STLC_with_Booleans.

(** 1.2 Bidirectional STLC with Booleans *)

Module Bidirectional_STLC_with_Booleans.

Parameter V : Type.
Parameter dec : V -> V -> bool.
Parameter dec_spec :
  forall x y : V, reflect (x = y) (dec x y).

Notation "x =? y" := (dec x y) (at level 70).

Inductive type : Type :=
    | TBool : type
    | TArr : type -> type -> type.

Inductive tm : Type :=
    | TVar : V -> tm
    | TApp : tm -> tm -> tm
    | TLam : V -> tm -> tm
    | TTrue : tm
    | TFalse : tm
    | TIf : tm -> tm -> tm -> tm
    | TAnn : tm -> type -> tm.

Definition Ctx : Type := V -> option type.

Inductive infer_type : Ctx -> tm -> type -> Prop :=
    | infer_Var :
        forall (G : Ctx) (x : V) (A : type),
          G x = Some A -> infer_type G (TVar x) A
    | infer_App :
        forall (G : Ctx) (t1 t2 : tm) (A B : type),
          infer_type G t1 (TArr A B) -> check_type G t2 A ->
            infer_type G (TApp t1 t2) B
    | infer_True :
        forall G : Ctx, infer_type G TTrue TBool
    | infer_False :
        forall G : Ctx, infer_type G TFalse TBool
    | infer_Ann :
        forall (G : Ctx) (t : tm) (A : type),
          check_type G t A -> infer_type G (TAnn t A) A

with check_type : Ctx -> tm -> type -> Prop :=
    | check_Lam :
        forall (G : Ctx) (x : V) (t : tm) (A B : type),
          check_type (fun v : V => if x =? v then Some A else G v) t B ->
            check_type G (TLam x t) (TArr A B)
    | check_If :
        forall (G : Ctx) (t1 t2 t3 : tm) (A : type),
          check_type G t1 TBool -> check_type G t2 A -> check_type G t3 A ->
            check_type G (TIf t1 t2 t3) A
    | check_infer :
        forall (G : Ctx) (t : tm) (A : type),
          infer_type G t A -> check_type G t A.

#[global] Hint Constructors infer_type : core.
#[global] Hint Constructors check_type : core.

Fixpoint type_eq_dec (t1 t2 : type) : bool :=
match t1, t2 with
    | TBool, TBool => true
    | TArr t11 t12, TArr t21 t22 =>
        type_eq_dec t11 t21 && type_eq_dec t12 t22
    | _, _ => false
end.

Fixpoint infer (G : Ctx) (t : tm) : option type :=
match t with
    | TVar x => G x
    | TApp t1 t2 =>
        match infer G t1 with
            | Some (TArr A B) => if check G t2 A then Some B else None
            | _ => None
        end
    | TTrue => Some TBool
    | TFalse => Some TBool
    | TAnn t A => if check G t A then Some A else None
    | _ => None
end

with check (G : Ctx) (t : tm) (A : type) : bool :=
match t with
    | TLam x t =>
        match A with
            | TArr X Y =>
                check (fun v : V => if x =? v then Some X else G v) t Y
            | _ => false
        end
    | TIf t1 t2 t3 =>
        check G t1 TBool && check G t2 A && check G t3 A
(* Not very pretty, but it works. *)
    | TVar x =>
        match G x with
            | Some B => type_eq_dec A B
            | _ => false
        end
    | TApp t1 t2 =>
        match infer G t1 with
            | Some (TArr X Y) => check G t2 X && type_eq_dec Y A
            | _ => false
        end
    | TTrue => type_eq_dec TBool A
    | TFalse => type_eq_dec TBool A
    | TAnn t' A' => check G t' A' && type_eq_dec A A'
end.

Lemma type_eq_dec_refl :
  forall A : type, type_eq_dec A A = true.
Proof.
  induction A; cbn.
    reflexivity.
    rewrite IHA1, IHA2. cbn. reflexivity.
Qed.

Ltac inv H := inversion H; subst; clear H.

Lemma infer_check :
  forall (G : Ctx) (t : tm) (A : type),
    infer G t = Some A -> check G t A = true.
Proof.
  destruct t; cbn; intros.
    rewrite H. apply type_eq_dec_refl.
    destruct (infer G t1) as [[] |]; inv H.
      destruct (check G t2 t); inv H1. cbn. apply type_eq_dec_refl.
    1-4: inv H; auto.
    destruct (check G t t0); inv H. cbn. apply type_eq_dec_refl.
Qed.

Lemma type_eq_dec_true :
  forall A B : type,
    type_eq_dec A B = true -> A = B.
Proof.
  induction A; destruct B; cbn; intros; try congruence.
  specialize (IHA1 B1). specialize (IHA2 B2).
  destruct (type_eq_dec A1 B1), (type_eq_dec A2 B2).
    all: firstorder; congruence.
Qed.

Lemma infer_correct :
  forall (G : Ctx) (t : tm) (A : type),
    infer G t = Some A -> infer_type G t A

with check_correct :
  forall (G : Ctx) (t : tm) (A : type),
    check G t A = true -> check_type G t A.
Proof.
  destruct t; cbn; intros.
    constructor. assumption.
    case_eq (infer G t1); intros; rewrite H0 in H.
      destruct t; inv H.
      case_eq (check G t2 t3); intro; rewrite H in H2; inv H2.
        eapply infer_App.
          eapply infer_correct. exact H0.
          apply check_correct. assumption.
    1-5: inversion H; subst; repeat constructor.
    case_eq (check G t t0); intro; rewrite H0 in H; inv H.
      constructor. apply check_correct. assumption.
  destruct t; cbn; intros.
    case_eq (G v); intros; rewrite H0 in H; inv H.
      apply type_eq_dec_true in H2; subst. do 2 constructor. assumption.
    case_eq (infer G t1); intros; rewrite H0 in H.
      destruct t; inv H.
      case_eq (check G t2 t3); intro; rewrite H in H2; inv H2.
        apply type_eq_dec_true in H3; subst.
          constructor. eapply infer_App.
            apply infer_correct. exact H0.
            apply check_correct. assumption.
      congruence.
    1-3: destruct A; inversion H.
      constructor. apply check_correct. assumption.
    do 2 constructor.
    do 2 constructor.
    constructor; apply check_correct;
      destruct (check G t1 TBool), (check G t2 A), (check G t3 A);
        cbn in H; auto.
    constructor. case_eq (check G t t0); intros; rewrite H0 in H; inv H.
      apply type_eq_dec_true in H2; subst. constructor.
        apply check_correct. assumption.
Qed.

Lemma infer_complete :
  forall (G : Ctx) (t : tm) (A : type),
    infer_type G t A -> infer G t = Some A

with check_complete :
  forall (G : Ctx) (t : tm) (A : type),
    check_type G t A -> check G t A = true.
Proof.
  destruct 1; cbn; intros.
    assumption.
    rewrite (infer_complete _ _ _ H), (check_complete _ _ _ H0). reflexivity.
    1-2: reflexivity.
    rewrite (check_complete _ _ _ H). reflexivity.
  destruct 1; cbn; intros.
    apply check_complete. assumption.
    rewrite !check_complete; cbn; auto.
    apply infer_check. apply infer_complete. apply H.
Qed.

End Bidirectional_STLC_with_Booleans.

(** 1.3 Bidirectional STLC with Booleans using mutual induction *)

Module Bidirectional_STLC_with_Booleans_using_mutual_induction.

Parameter V : Type.
Parameter dec : V -> V -> bool.
Parameter dec_spec :
  forall x y : V, reflect (x = y) (dec x y).

Notation "x =? y" := (dec x y) (at level 70).

Inductive type : Type :=
    | TBool : type
    | TArr : type -> type -> type.

Inductive tmEx : Type :=
    | TVar : V -> tmEx
    | TApp : tmEx -> tmIn -> tmEx
    | TTrue : tmEx
    | TFalse : tmEx
    | TAnn : tmIn -> type -> tmEx

with tmIn : Type :=
    | TLam : V -> tmIn -> tmIn
    | TIf : tmIn -> tmIn -> tmIn -> tmIn
    | TEx : tmEx -> tmIn.

Definition Ctx : Type := V -> option type.

Inductive infer_type : Ctx -> tmEx -> type -> Prop :=
    | infer_Var :
        forall (G : Ctx) (x : V) (A : type),
          G x = Some A -> infer_type G (TVar x) A
    | infer_App :
        forall (G : Ctx) (t1 : tmEx) (t2 : tmIn) (A B : type),
          infer_type G t1 (TArr A B) -> check_type G t2 A ->
            infer_type G (TApp t1 t2) B
    | infer_True :
        forall G : Ctx, infer_type G TTrue TBool
    | infer_False :
        forall G : Ctx, infer_type G TFalse TBool
    | infer_Ann :
        forall (G : Ctx) (t : tmIn) (A : type),
          check_type G t A -> infer_type G (TAnn t A) A

with check_type : Ctx -> tmIn -> type -> Prop :=
    | check_Lam :
        forall (G : Ctx) (x : V) (t : tmIn) (A B : type),
          check_type (fun v : V => if x =? v then Some A else G v) t B ->
            check_type G (TLam x t) (TArr A B)
    | check_If :
        forall (G : Ctx) (t1 t2 t3 : tmIn) (A : type),
          check_type G t1 TBool -> check_type G t2 A -> check_type G t3 A ->
            check_type G (TIf t1 t2 t3) A
    | check_Ex :
        forall (G : Ctx) (t : tmEx) (A : type),
          infer_type G t A -> check_type G (TEx t) A.

#[global] Hint Constructors infer_type : core.
#[global] Hint Constructors check_type : core.

Fixpoint type_eq_dec (t1 t2 : type) : bool :=
match t1, t2 with
    | TBool, TBool => true
    | TArr t11 t12, TArr t21 t22 =>
        type_eq_dec t11 t21 && type_eq_dec t12 t22
    | _, _ => false
end.

Fixpoint infer (G : Ctx) (t : tmEx) : option type :=
match t with
    | TVar x => G x
    | TApp t1 t2 =>
        match infer G t1 with
            | Some (TArr A B) => if check G t2 A then Some B else None
            | _ => None
        end
    | TTrue => Some TBool
    | TFalse => Some TBool
    | TAnn t A => if check G t A then Some A else None
end

with check (G : Ctx) (t : tmIn) (A : type) : bool :=
match t with
    | TLam x t =>
        match A with
            | TArr X Y =>
                check (fun v : V => if x =? v then Some X else G v) t Y
            | _ => false
        end
    | TIf t1 t2 t3 =>
        check G t1 TBool && check G t2 A && check G t3 A
    | TEx t' =>
        match infer G t' with
            | Some B => type_eq_dec A B
            | _ => false
        end
end.

Lemma type_eq_dec_refl :
  forall A : type, type_eq_dec A A = true.
Proof.
  induction A; cbn.
    reflexivity.
    rewrite IHA1, IHA2. cbn. reflexivity.
Qed.

Lemma type_eq_dec_true :
  forall A B : type,
    type_eq_dec A B = true -> A = B.
Proof.
  induction A; destruct B; cbn; intros; try congruence.
  specialize (IHA1 B1). specialize (IHA2 B2).
  destruct (type_eq_dec A1 B1), (type_eq_dec A2 B2).
    all: firstorder; congruence.
Qed.

Ltac inv H := inversion H; subst; clear H.

Lemma infer_correct :
  forall (G : Ctx) (t : tmEx) (A : type),
    infer G t = Some A -> infer_type G t A

with check_correct :
  forall (G : Ctx) (t : tmIn) (A : type),
    check G t A = true -> check_type G t A.
Proof.
  destruct t; cbn; intros.
    constructor. assumption.
    case_eq (infer G t); intros; rewrite H0 in H.
      destruct t1; inv H.
      case_eq (check G t0 t1_1); intro; rewrite H in H2; inv H2.
      eapply infer_App.
        eapply infer_correct. exact H0.
        apply check_correct. assumption.
      inv H.
    inv H. constructor.
    inv H. constructor.
    case_eq (check G t t0); intro; rewrite H0 in H; inv H.
      constructor. apply check_correct. assumption.
  destruct t; cbn; intros.
    destruct A.
      inv H.
      constructor. apply check_correct. assumption.
    constructor; apply check_correct;
      destruct (check G t1 TBool), (check G t2 A), (check G t3 A); cbn in H;
      congruence.
    constructor. apply infer_correct. destruct (infer G t).
      f_equal. symmetry. apply type_eq_dec_true. assumption.
      inv H.
Qed.

Lemma infer_complete :
  forall (G : Ctx) (t : tmEx) (A : type),
    infer_type G t A -> infer G t = Some A

with check_complete :
  forall (G : Ctx) (t : tmIn) (A : type),
    check_type G t A -> check G t A = true.
Proof.
  destruct 1; cbn; intros.
    assumption.
    rewrite (infer_complete _ _ _ H), (check_complete _ _ _ H0). reflexivity.
    1-2: reflexivity.
    rewrite (check_complete _ _ _ H). reflexivity.
  destruct 1; cbn; intros.
    apply check_complete. assumption.
    rewrite !check_complete; cbn; auto.
    rewrite (infer_complete _ _ _ H). apply type_eq_dec_refl.
Qed.

End Bidirectional_STLC_with_Booleans_using_mutual_induction.

(** 1.4 Bidirectional STLC with lots of other stuff *)

Module Bidirectional_STLC_with_stuff.

Parameter V : Type.
Parameter dec : V -> V -> bool.
Parameter dec_spec :
  forall x y : V, reflect (x = y) (dec x y).

Notation "x =? y" := (dec x y) (at level 70).

Inductive type : Type :=
    | TArr : type -> type -> type
    | TEmpty : type
    | TUnit : type
    | TBool : type
    | TProd : type -> type -> type
    | TSum : type -> type -> type.

Inductive tmEx : Type :=
    | TVar : V -> tmEx
    | TAnn : tmIn -> type -> tmEx

    | TApp : tmEx -> tmIn -> tmEx

    | TStar : tmEx

    | TTrue : tmEx
    | TFalse : tmEx
    | TIf : tmIn -> tmEx -> tmEx -> tmEx

    | TPair : tmEx -> tmEx -> tmEx
    | TOutl : tmEx -> tmEx
    | TOutr : tmEx -> tmEx

    | TCase : tmEx -> tmEx -> tmEx -> tmEx

with tmIn : Type :=
    | TEx : tmEx -> tmIn
    | TLam : V -> tmIn -> tmIn
    | TExfalso : tmIn -> tmIn
(*    | TExfalso : tmIn -> type -> tmIn *)

    | TInl : tmIn -> tmIn
    | TInr : tmIn -> tmIn.

(*  | TCase *)

Definition Ctx : Type := V -> option type.

Inductive infer_type : Ctx -> tmEx -> type -> Prop :=
    | infer_Var :
        forall (G : Ctx) (x : V) (A : type),
          G x = Some A -> infer_type G (TVar x) A
    | infer_Ann :
        forall (G : Ctx) (t : tmIn) (A : type),
          check_type G t A -> infer_type G (TAnn t A) A
    | infer_App :
        forall (G : Ctx) (t1 : tmEx) (t2 : tmIn) (A B : type),
          infer_type G t1 (TArr A B) -> check_type G t2 A ->
            infer_type G (TApp t1 t2) B
    | infer_Star :
        forall G : Ctx, infer_type G TStar TUnit
    | infer_True :
        forall G : Ctx, infer_type G TTrue TBool
    | infer_False :
        forall G : Ctx, infer_type G TFalse TBool
    | infer_If :
        forall (G : Ctx) (t1 : tmIn) (t2 t3 : tmEx) (A : type),
          check_type G t1 TBool ->
          infer_type G t2 A -> infer_type G t3 A ->
            infer_type G (TIf t1 t2 t3) A
    | infer_Pair :
        forall (G : Ctx) (t1 t2 : tmEx) (A B : type),
          infer_type G t1 A -> infer_type G t2 B ->
            infer_type G (TPair t1 t2) (TProd A B)
    | infer_Outl :
        forall (G : Ctx) (t : tmEx) (A B : type),
          infer_type G t (TProd A B) -> infer_type G (TOutl t) A
    | infer_Outr :
        forall (G : Ctx) (t : tmEx) (A B : type),
          infer_type G t (TProd A B) -> infer_type G (TOutr t) B
    | infer_Case :
        forall (G : Ctx) (t1 t2 t3 : tmEx) (A B C : type),
          infer_type G t1 (TSum A B) ->
          infer_type G t2 (TArr A C) ->
          infer_type G t3 (TArr B C) ->
            infer_type G (TCase t1 t2 t3) C

with check_type : Ctx -> tmIn -> type -> Prop :=
    | check_Ex :
        forall (G : Ctx) (t : tmEx) (A : type),
          infer_type G t A -> check_type G (TEx t) A
    | check_Lam :
        forall (G : Ctx) (x : V) (t : tmIn) (A B : type),
          check_type (fun v : V => if x =? v then Some A else G v) t B ->
            check_type G (TLam x t) (TArr A B)
(*    | check_Exfalso :
        forall (G : Ctx) (t : tmIn) (A : type),
          check_type G t TEmpty -> check_type G (TExfalso t A) A *)
    | check_Exfalso :
        forall (G : Ctx) (t : tmIn) (A : type),
          check_type G t TEmpty -> check_type G (TExfalso t) A
    | check_Inl :
        forall (G : Ctx) (t : tmIn) (A B : type),
          check_type G t A -> check_type G (TInl t) (TSum A B)
    | check_Inr :
        forall (G : Ctx) (t : tmIn) (A B : type),
          check_type G t B -> check_type G (TInr t) (TSum A B).

#[global] Hint Constructors infer_type : core.
#[global] Hint Constructors check_type : core.

Fixpoint type_eq_dec (t1 t2 : type) : bool :=
match t1, t2 with
    | TArr t11 t12, TArr t21 t22 =>
        type_eq_dec t11 t21 && type_eq_dec t12 t22
    | TEmpty, TEmpty => true
    | TUnit, TUnit => true
    | TBool, TBool => true
    | TProd t11 t12, TProd t21 t22 =>
        type_eq_dec t11 t21 && type_eq_dec t12 t22
    | TSum t11 t12, TSum t21 t22 =>
        type_eq_dec t11 t21 && type_eq_dec t12 t22
    | _, _ => false
end.

Lemma type_eq_dec_spec :
  forall A B : type, reflect (A = B) (type_eq_dec A B).
Proof.
  induction A; destruct B; cbn; try constructor; try inversion 1.
    destruct (IHA1 B1), (IHA2 B2); cbn; constructor; congruence.
    1-3: reflexivity.
    destruct (IHA1 B1), (IHA2 B2); cbn; constructor; congruence.
    destruct (IHA1 B1), (IHA2 B2); cbn; constructor; congruence.
Qed.

Fixpoint infer (G : Ctx) (t : tmEx) : option type :=
match t with
    | TVar x => G x
    | TAnn t A => if check G t A then Some A else None
    | TApp t1 t2 =>
        match infer G t1 with
            | Some (TArr A B) => if check G t2 A then Some B else None
            | _ => None
        end
    | TStar => Some TUnit
    | TTrue => Some TBool
    | TFalse => Some TBool
    | TIf t1 t2 t3 =>
        match infer G t2, infer G t3 with
            | Some A, Some B =>
                if check G t1 TBool && type_eq_dec A B then Some A else None
            | _, _ => None
        end
    | TPair t1 t2 =>
        match infer G t1, infer G t2 with
            | Some A, Some B => Some (TProd A B)
            | _, _ => None
        end
    | TOutl t' =>
        match infer G t' with
            | Some (TProd A B) => Some A
            | _ => None
        end
    | TOutr t' =>
        match infer G t' with
            | Some (TProd A B) => Some B
            | _ => None
        end
    | TCase t1 t2 t3 =>
        match infer G t1, infer G t2, infer G t3 with
            | Some (TSum A B), Some (TArr A' C), Some (TArr B' C') =>
                if
                  type_eq_dec A A' &&
                  type_eq_dec B B' &&
                  type_eq_dec C C'
                then
                  Some C
                else None
            | _, _, _ => None
        end
end

with check (G : Ctx) (t : tmIn) (A : type) : bool :=
match t with
    | TEx t' =>
        match infer G t' with
            | Some B => type_eq_dec A B
            | _ => false
        end
    | TLam x t =>
        match A with
            | TArr X Y =>
                check (fun v : V => if x =? v then Some X else G v) t Y
            | _ => false
        end
(*    | TExfalso t' B => check G t' TEmpty && type_eq_dec A B *)
    | TExfalso t' => check G t' TEmpty
    | TInl t' =>
        match A with
            | TSum B C => check G t' B
            | _ => false
        end
    | TInr t' =>
        match A with
            | TSum B C => check G t' C
            | _ => false
        end
end.

Ltac inv H := inversion H; subst; clear H.

Lemma infer_correct :
  forall (G : Ctx) (t : tmEx) (A : type),
    infer G t = Some A -> infer_type G t A

with check_correct :
  forall (G : Ctx) (t : tmIn) (A : type),
    check G t A = true -> check_type G t A.
Proof.
  destruct t; cbn; intros.
    constructor. assumption.
    case_eq (check G t t0); intro H'; rewrite H' in H; inv H.
      constructor. apply check_correct. assumption.
    case_eq (infer G t).
      intros C H'. rewrite H' in H. destruct C as []; inv H.
        case_eq (check G t0 C1); intro H''; rewrite H'' in H1; inv H1.
        econstructor.
          apply infer_correct. exact H'.
          apply check_correct. assumption.
      intro H'. rewrite H' in H. inv H.
    1-3: inv H; constructor.
    case_eq (infer G t2); [intros t H' | intro H']; rewrite H' in H; inv H.
      case_eq (infer G t3); [intros t' H'' | intro H''];
      rewrite H'' in H1; inv H1.
      case_eq (check G t1 TBool); intro H'''; rewrite H''' in H0; inv H0.
      destruct (type_eq_dec_spec t t'); subst; inv H1. auto.
    case_eq (infer G t1); intros; rewrite H0 in *; inv H.
      case_eq (infer G t2); intros; rewrite H in *; inv H2.
      auto.
    case_eq (infer G t); intros; rewrite H0 in *; inv H.
      destruct t0; inv H2. econstructor. apply infer_correct.
      cbn. rewrite H0. reflexivity.
    case_eq (infer G t); intros; rewrite H0 in *; inv H.
      destruct t0; inv H2. econstructor. apply infer_correct.
      cbn. rewrite H0. reflexivity.
    case_eq (infer G t1); intros; rewrite H0 in *; try destruct t; inv H.
      case_eq (infer G t2); intros; rewrite H in *; try destruct t; inv H2.
      case_eq (infer G t3); intros; rewrite H1 in *; try destruct t; inv H3.
      destruct
        (type_eq_dec_spec t4 t6),
        (type_eq_dec_spec t5 t8),
        (type_eq_dec_spec t7 t9);
      cbn in *; subst; inv H4; try congruence.
      econstructor; apply infer_correct; eassumption.
  destruct t; cbn; intros.
    constructor. apply infer_correct. destruct (infer G t).
      f_equal. destruct (type_eq_dec_spec A t0); congruence.
      inv H.
    destruct A; inv H. constructor. apply check_correct. assumption.
(*
    destruct (type_eq_dec_spec A t0); subst.
      constructor. apply check_correct. rewrite andb_true_r in H. assumption.
      rewrite andb_false_r in H. inv H.
*)
    constructor. apply check_correct. assumption.
    destruct A; inv H. constructor. apply check_correct. assumption.
    destruct A; inv H. constructor. apply check_correct. assumption.
Qed.

Lemma infer_correct'' :
  forall (G : Ctx) (t : tmEx) (A : type),
    infer G t = Some A <-> infer_type G t A

with check_correct'' :
  forall (G : Ctx) (t : tmIn) (A : type),
    reflect (check_type G t A) (check G t A).
Proof.
  split.
    destruct t; cbn; intros.
      constructor. assumption.
      destruct (check_correct'' G t t0); inv H. constructor. assumption.
      case_eq (infer G t).
        intros C H'. rewrite H' in H. destruct C as []; inv H.
          case_eq (check G t0 C1); intro H''; rewrite H'' in H1; inv H1.
          econstructor.
            apply infer_correct. exact H'.
            apply check_correct. assumption.
        intro H'. rewrite H' in H. inv H.
      1-3: inv H; constructor.
      case_eq (infer G t2); intros; rewrite H0 in H; inv H.
        case_eq (infer G t3); intros; rewrite H in H2; inv H2.
        destruct (check_correct'' G t1 TBool); inv H3.
        destruct (type_eq_dec_spec t t0); inv H2.
        constructor.
          assumption.
          1-2: apply infer_correct; assumption.
      case_eq (infer G t1); intros; rewrite H0 in *; inv H.
        case_eq (infer G t2); intros; rewrite H in *; inv H2.
        constructor; rewrite <- infer_correct''; assumption.
      case_eq (infer G t); intros; rewrite H0 in *; inv H.
        destruct t0; inv H2. econstructor. apply infer_correct.
        cbn. rewrite H0. reflexivity.
      case_eq (infer G t); intros; rewrite H0 in *; inv H.
        destruct t0; inv H2. econstructor. apply infer_correct.
        cbn. rewrite H0. reflexivity.
      case_eq (infer G t1); intros; rewrite H0 in *; try destruct t; inv H.
        case_eq (infer G t2); intros; rewrite H in *; try destruct t; inv H2.
        case_eq (infer G t3); intros; rewrite H1 in *; try destruct t; inv H3.
        destruct
          (type_eq_dec_spec t4 t6),
          (type_eq_dec_spec t5 t8),
          (type_eq_dec_spec t7 t9);
        cbn in *; subst; inv H4; try congruence.
        econstructor; apply infer_correct; eassumption.
    destruct t; cbn; intro H; inv H.
      assumption.
      destruct (check_correct'' G t A).
        reflexivity.
        contradiction.
      destruct (infer_correct'' G t (TArr A0 A)).
        rewrite (H0 H3). destruct (check_correct'' G t0 A0); subst.
          reflexivity.
          contradiction.
      1-3: reflexivity.
      destruct (infer_correct'' G t2 A), (infer_correct'' G t3 A).
        rewrite (H0 H6), (H2 H7).
        destruct (check_correct'' G t1 TBool); subst.
          cbn. destruct (type_eq_dec_spec A A); congruence.
          contradiction.
      destruct (infer_correct'' G t1 A0), (infer_correct'' G t2 B).
        rewrite (H0 H3), (H2 H5). reflexivity.
      destruct (infer_correct'' G t (TProd A B)).
        rewrite (H0 H2). reflexivity.
      destruct (infer_correct'' G t (TProd A0 A)).
        rewrite (H0 H2). reflexivity.
      destruct
            (infer_correct'' G t1 (TSum A0 B)),
            (infer_correct'' G t2 (TArr A0 A)),
            (infer_correct'' G t3 (TArr B A)).
        rewrite (H0 H4), (H2 H6), (H5 H7).
        destruct
          (type_eq_dec_spec A0 A0),
          (type_eq_dec_spec B B),
          (type_eq_dec_spec A A); subst; cbn; congruence.
  destruct t; cbn; intros.
    case_eq (infer G t); intros.
      destruct (type_eq_dec_spec A t0); constructor; subst.
        constructor. apply infer_correct. assumption.
        intro. inv H0. destruct (infer_correct'' G t A).
          specialize (H1 H3). congruence.
      constructor. intro. inv H0. destruct (infer_correct'' G t A).
        specialize (H1 H3). congruence.
    destruct A; try constructor; try inversion 1.
      destruct (check_correct''
        (fun v0 : V => if v =? v0 then Some A1 else G v0) t A2);
      constructor.
        constructor. assumption.
        intro. inv H. contradiction.
    destruct (check_correct'' G t TEmpty); subst; constructor.
      constructor. assumption.
      intro. inv H. contradiction.
    destruct A; try constructor; try inversion 1.
      destruct (check_correct'' G t A1); constructor.
        constructor. assumption.
        intro. inv H. contradiction.
    destruct A; try constructor; try inversion 1.
      destruct (check_correct'' G t A2); constructor.
        constructor. assumption.
        intro. inv H. contradiction.
Qed.

End Bidirectional_STLC_with_stuff.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. rewrite append_Nil.  reflexivity.
  - simpl. rewrite 2 append_Nil. reflexivity.
Qed.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
    f_equal. }
  { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
  induction l1.
  { induction l2.
    { simpl. rewrite append_rev_Cons.
      rewrite <- 2 append_assoc.
      f_equal. }
    { simpl. rewrite append_Nil. reflexivity. }
  }
  { intro. simpl. rewrite append_Nil. reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (rev x)) x.
Proof.
  induction x.
  { simpl. lfind.  simpl.  f_equal.
Admitted.