(** * Term definition for Simply Typed Lambda Calculus and de Bruijn manipulation . *)
(** * Usual Term syntax .*)
Require Import Arith Omega.

(** Var syntax: *)
Definition Vars := nat.

(** Type syntax:*)
Inductive Ty: Set :=
  | Base : Ty
  | Arr  : Ty -> Ty -> Ty
.

(** Term syntax:*)
Inductive Term : Set:=
 | Var : Vars -> Term
 | App : Term -> Term -> Term
 | La  : Ty -> Term -> Term
.

Notation "x · y" := (App x y) (at level 15, left associativity) : STLC_scope.
Notation "# v" := (Var v) (at level 1) : STLC_scope.
Notation "'λ' [ T ] , v " := (La T v) (at level 20, T , v at level 30) : STLC_scope.
Notation "A ⇒ B" := (Arr A B) (at level 17, right associativity): STLC_scope.

Reserved Notation " t ↑ x # n " (at level 5, x at level 0, left associativity).

Delimit Scope STLC_scope with STLC.

Open Scope STLC_scope.

(** In order to deal with variable bindings and captures, we need a lift
function to deal with free and bounded variables.

   [M ↑ n # m] recursivly add [n] to all variables that are
   above [m] in [M]. *)
Fixpoint lift_rec (n:nat) (k:nat) (T:Term) {struct T} := match T with
   | # x =>  if le_gt_dec k x then Var (n+x) else Var x
   | M · N =>  App (M ↑ n # k) (N ↑ n # k)
   | λ [ A ], M => λ [A ], (M ↑ n # (S k))
 end
   where "t ↑ n # k" := (lift_rec n k t) : STLC_scope.

Notation " t ↑ n " := (lift_rec n 0 t) (at level 5, n at level 0, left associativity) : STLC_scope.

(** Some basic properties of the lift function. That is everything we will
ever need to handle de Bruijn indexes *)

Lemma inv_lift : forall M N n m , M ↑ n # m = N ↑ n # m -> M = N.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; destruct N as [ w | G Y | T' W]; simpl in *; intros n m.
- destruct (le_gt_dec m v) as [ h | h]; destruct (le_gt_dec m w) as [ h' | h']; intro heq;
  now injection heq; clear heq; intro heq; f_equal; omega.
- destruct (le_gt_dec m v) as [ h | h]; intro heq; now discriminate.
- destruct (le_gt_dec m v) as [ h | h]; intro heq; now discriminate.
- destruct (le_gt_dec m w) as [ h | h]; intro heq; now discriminate.
- intro heq1; injection heq1; clear heq1; intros heq1 heq2.
  now rewrite (hiF _ _ _ heq2), (hiX _ _ _ heq1).
- intro heq; now discriminate.
- destruct (le_gt_dec m w) as [ h | h]; intro heq; now discriminate.
- intro heq; now discriminate.
- intro heq1; injection heq1; clear heq1; intros heq1 heq2.
  now rewrite (hiV _ _ _ heq1), heq2.
Qed.

Lemma lift_rec0 : forall M n, M ↑ 0 # n = M.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros; simpl.
- now destruct (le_gt_dec n v).
- now rewrite hiF, hiX.
- now rewrite hiV.
Qed.

Lemma lift0 : forall M, M ↑ 0 = M.
Proof.
intros; apply lift_rec0.
Qed.

Lemma liftP1 : forall M i j k, (M ↑ j # i) ↑ k # (j+i) = M ↑ (j+k) # i.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros i j k; simpl in *.
- destruct (le_gt_dec i v) as [ h | h]; simpl.
  + destruct (le_gt_dec (j+i) (j+v)) as [ h' | h']; simpl; now apply f_equal; omega.
  + destruct (le_gt_dec (j+i)) as [ h' | h']; [ | reflexivity].
    now apply f_equal; omega.
- now rewrite hiF, hiX.
- rewrite <- hiV.
  now replace (j + S i) with (S(j + i)).
Qed.

Lemma liftP2: forall M i j k n, i <= n ->
  (M ↑ j # i) ↑ k # (j+n) = (M ↑ k # n) ↑ j # i.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros i j k n hle; simpl in *.
- destruct (le_gt_dec i v) as [ h | h]; destruct (le_gt_dec n v) as [ h' | h']; simpl in *;
  destruct le_gt_dec; destruct le_gt_dec; now apply f_equal; omega.
- now rewrite hiF, hiX.
- replace (S (j + n)) with (j + S n) by intuition.
  rewrite hiV; [ reflexivity | now omega].
Qed.

Lemma liftP3 : forall M i k j n , i <= k -> k <= (i+n) ->
  (M ↑ n # i) ↑ j # k = M ↑ (j+n) # i.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros i k j n h1 h2; simpl in *.
- destruct (le_gt_dec i v) as [ h | h]; simpl in *; destruct le_gt_dec; apply f_equal; omega.
- now rewrite hiF, hiX.
- rewrite hiV; [ reflexivity | now omega | now omega].
Qed.

Lemma lift_lift : forall M n m, (M ↑ m) ↑ n  = M↑ (n+m).
Proof.
intros.
apply liftP3; intuition.
Qed.

(** We will consider the usual implicit substitution without variable capture
(this is where the lift operator comes in handy).
  [ M [ n ← N ] ] replace the variable [n] in [M] by the term [N].
  *)
Reserved Notation "t [ x ← u ]" (at level 5, x at level 0, left associativity).

Fixpoint subst_rec U T n {struct T} :=
 match T with
  | # x => match (lt_eq_lt_dec x n) with
      | inleft (left _) => # x (* v < n *)
      | inleft (right _) => U ↑ n  (* v = n *)
      | inright _ => # (x - 1) (* v > n *)
      end
  | M · N => (M [ n ← U ]) · ( N [ n ← U ])
  | λ [ A ], M => λ [ A ], (M [ S n ← U ])
end
    where " t [ n ← w ] " := (subst_rec w t n) : STLC_scope.

Notation " t [ ← w ] " := (subst_rec w t 0) (at level 5) : STLC_scope.

(** Some basic properties of the substitution function. Again, we will only need
a few functions to deal with indexes. *)

Lemma substP1: forall M N i j k ,
  ( M [ j ← N] ) ↑ k # (j+i) = (M ↑ k # (S (j+i))) [ j ← (N ↑ k # i ) ].
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros N i j k.
- simpl (#v [j ← N] ↑ k # (j+i)).
  change (#v ↑ k # (S (j+i))) with  (if le_gt_dec (S (j+i)) v then #(k+v) else #v).
  destruct (lt_eq_lt_dec v j) as [[ | ] | ].
  + destruct (le_gt_dec (S (j+i)) v); [ now omega| ].
    simpl.
    destruct (le_gt_dec (j+i) v) as [  | ]; [ now omega | ].
    destruct (lt_eq_lt_dec v j) as [[ | ] | ]; [ reflexivity | now omega| now omega].
  + destruct (le_gt_dec (S(j+i)) v) as [ | ]; [ now omega| ].
    simpl.
    destruct (lt_eq_lt_dec v j) as [[] | ]; [now omega | | now omega].
    subst; apply liftP2; now omega.
  + destruct (le_gt_dec (S (j+i)) v).
    * simpl.
      destruct (le_gt_dec (j+i) v) as [  | ].
      -- destruct (lt_eq_lt_dec) as [ [] | ].
         ++ destruct le_gt_dec;now omega.
         ++ destruct le_gt_dec; now omega.
         ++ destruct le_gt_dec; [ f_equal; now omega| now omega].
      -- destruct le_gt_dec; destruct lt_eq_lt_dec as [ [] | ]; now omega.
    * simpl.
      destruct le_gt_dec; destruct lt_eq_lt_dec as [ [] | ]; try now omega.
      reflexivity.
- simpl.
  rewrite hiF.
  replace (S(S(j+i))) with (S((S j)+i)) by intuition.
  now rewrite <- hiX.
- simpl.
  replace (S(S(j+i))) with (S((S j)+i)) by intuition.
  now rewrite <- hiV.
Qed.

Lemma substP2: forall M N i j n, i <= n ->
  (M ↑ j # i ) [ j+n ← N ] = ( M [ n ← N]) ↑ j # i .
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros N i j n hle; simpl in *.
- destruct (le_gt_dec i v); destruct (lt_eq_lt_dec v n) as [[] | ]; simpl.
  + destruct lt_eq_lt_dec as [ [] | ]; destruct le_gt_dec; try now omega.
    reflexivity.
  + destruct lt_eq_lt_dec as [ [] | ]; try now omega.
    now rewrite liftP3; [ | omega | omega].
  + destruct lt_eq_lt_dec as [ [] | ]; destruct le_gt_dec; try now omega.
    now f_equal; omega.
  + destruct lt_eq_lt_dec as [ [] | ]; destruct le_gt_dec; try now omega.
    reflexivity.
  + now omega.
  + now omega.
- now rewrite hiF, hiX.
- rewrite <- hiV; [ | now omega].
  now replace (S (j + n)) with (j + S n).
Qed.

Lemma substP3: forall M N i  k n, i <= k -> k <= i+n ->
  (M↑ (S n) # i) [ k← N] = M ↑ n # i.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros N i k n h1 h2; simpl in *.
- destruct (le_gt_dec i v).
  + unfold subst_rec.
   destruct (lt_eq_lt_dec (S(n+v)) k) as [[] | ]; [ now omega | now omega| now f_equal; omega].
  + simpl. destruct (lt_eq_lt_dec v k) as [[] | ]; [ reflexivity | now omega | now omega].
- rewrite hiF, hiX; [ reflexivity | now omega | now omega | now omega | now omega].
- rewrite hiV; [ reflexivity | now omega | now omega].
Qed.

Lemma substP4: forall M N P i j,
   (M [ i← N]) [i+j ← P] = (M [S(i+j) ← P]) [i← N[j← P]].
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros N P i j; simpl in *.
- destruct lt_eq_lt_dec as [ [] | ]; destruct lt_eq_lt_dec as [ [] | ]; simpl.
  + destruct lt_eq_lt_dec as [ [] | ]; destruct lt_eq_lt_dec as [ [] | ]; [ reflexivity | | | | | | | | ]; now omega.
  + now omega.
  + now omega.
  + destruct lt_eq_lt_dec as [ [] | ]; [ now omega | | now omega ].
    now rewrite substP2; [ reflexivity | omega ].
  + now omega.
  + now omega.
  + destruct lt_eq_lt_dec as [ [] | ]; destruct lt_eq_lt_dec as [ [] | ]; [ | | reflexivity | | | | | | ]; now omega.
  + destruct lt_eq_lt_dec as [ [] | ]; [ now omega | | now omega].
    now rewrite substP3; [ reflexivity | omega | omega ].
  + destruct lt_eq_lt_dec as [ [] | ]; destruct lt_eq_lt_dec as [ [] | ]; [ reflexivity | | | | | | | | reflexivity]; now omega.
- now rewrite hiF, hiX.
- replace (S(S(i+j))) with (S((S i)+ j)) by intuition.
  now rewrite <- hiV.
Qed.

Lemma subst_travers :
 forall  M N P n, (M [← N]) [n ← P] = (M [n+1 ← P])[← N[n← P]].
Proof.
intros.
rewrite plus_comm. change n with (O+n). apply substP4.
Qed.

(** Tool function usefull when eta-conversion is used, but this is not the case
here. *)
Lemma expand_term_with_subst : forall M n, (M ↑ 1 # (S n)) [ n ← #0 ] = M.
Proof.
induction M as [ v | F hiF X hiX | T V hiV]; intros n.
- unfold lift_rec.
  destruct le_gt_dec as [ | ].
  + unfold subst_rec.
    destruct (lt_eq_lt_dec (1+v) n) as [[] | ]; [ now omega | now omega | now f_equal; omega].
  + simpl; destruct (lt_eq_lt_dec v n) as [[] | ]; [ reflexivity |now subst; f_equal; omega| now omega].
- now simpl; rewrite hiF, hiX.
- now simpl; rewrite hiV.
Qed.

Reserved Notation " A  → B " (at level 80).

Inductive Beta : Term -> Term -> Prop :=
 | Beta_head : forall A M  N , (λ[A], M)· N  → M [← N]
 | Beta_red1 : forall M M' N , M  → M' -> M · N   → M'· N
 | Beta_red2 : forall M N  N', N  → N' -> M · N   → M · N'
 | Beta_lam  : forall A M  M', M  → M' -> λ[A],M  → λ[A ],M'
where "M  → N" := (Beta M N) : STLC_scope.

Lemma Beta_lift: forall M N, M → N -> forall n m, M ↑ n # m → N ↑ n # m.
Proof.
induction 1 as [ A M N | M M' N hM hi | M N N' hN hi | A M M' hM hi]; intros n m; simpl in *.
- change m with (0 + m).
  rewrite (substP1 M N m 0 n); simpl.
  now constructor.
- now constructor; apply hi.
- now constructor; apply hi.
- now constructor; apply hi.
Qed.

Lemma Beta_lift_inv : forall M N n m , M ↑ n # m  → N -> exists P, M  → P /\ N = P ↑ n # m .
Proof.
induction M as [ v | u hiU v hiV | A M hi]; intros N n m hred; simpl in *.
- now destruct le_gt_dec as [ h | h]; inversion hred.
- inversion hred; subst; clear hred.
  + destruct u as [ | | B N]; simpl in *; [ destruct le_gt_dec; discriminate | discriminate | ].
    injection H0; intros; subst; clear H0.
    exists (N [ ← v]); split; [ now constructor | ].
    now change m with (0 + m); rewrite <- substP1.
  + apply hiU in H2 as (u' & hu' & ->).
    now exists (u' · v); simpl; split; [ constructor | ].
  + apply hiV in H2 as (v' & hv' & ->).
    now exists (u · v'); simpl; split; [ constructor | ].
- inversion hred; subst; clear hred.
  apply hi in H2 as (Q & hQ & ->).
  now exists (λ [A], Q); split; [ constructor | ].
Qed.

Lemma Beta_subst : forall M N, M  → N -> forall n P, M [ n ← P]  → N [ n ← P].
Proof.
induction 1 as [ A M N | M M' N  hred hi| M N N' hred hi| A M M' hred hi]; intros n P; simpl in *.
- rewrite subst_travers.
  replace (n + 1) with (S n) by intuition.
  now constructor.
- now constructor; apply hi.
- now constructor; apply hi.
- now constructor; apply hi.
Qed.

Require Import List.

(** * Typing Environment for annotated terms .
  As for Terms, we define contexts of "Annotated" terms, with the very
  safe function and tools as for the usual one.*)

(** Very naive definition of environment : list of term

 be carefull, the usual written env Γ(x:A) is encoded in
  A::Γ
**)

Definition Env := list Ty.

(** Some manipulation functions (mostly from Bruno Barras' PTS contrib):
 - how to find an item in the environment
 - how to truncate an environment
 - how to insert a new element (with correct de Bruijn update)
 - how to substitute something in the environment
 *)
Set Implicit Arguments.

Inductive item (A:Type) (x:A): list A ->nat->Prop :=
| item_hd: forall Γ :list A, (item x (cons x Γ) O)
| item_tl: forall (Γ:list A)(n:nat)(y:A), item x Γ n -> item x (cons y Γ) (S n).

Hint Constructors item.

(** In the list [Γ], the [n]th item is syntacticaly [x]. *)
Notation " x ↓ n ∈ Γ " := (item x Γ n) (at level 80, no associativity) : STLC_scope.

Lemma fun_item: forall T (A B:T)(Γ:list T)(n:nat),
  A ↓ n ∈ Γ -> B ↓ n ∈ Γ -> A = B.
Proof.
intros T A B  Γ n;revert T A B Γ.
induction n as [ | n hi]; intros T A B Γ h1 h2.
- inversion h1; subst; clear h1.
  now inversion h2; subst; clear h2.
- inversion h1; subst; clear h1.
  inversion h2; subst; clear h2.
  now apply (hi _ _ _ _ H1 H0).
Qed.
Inductive trunc (A:Type) : nat->list A ->list A->Prop :=
  | trunc_O: forall (Γ:list A) , (trunc O Γ Γ)
  | trunc_S: forall (k:nat)(Γ Γ':list A)(x:A), trunc k Γ Γ'
                -> trunc (S k) (cons x Γ) Γ'.

Hint Constructors trunc.

Lemma item_trunc: forall (T:Type) (n:nat) (Γ:list T) (t:T),
  t ↓ n ∈ Γ -> exists Γ' , trunc (S n) Γ Γ'.
Proof.
intros T; induction n as [ | n hi]; intros Γ t hin.
- inversion hin; subst; clear hin.
  exists Γ0.
  now repeat constructor.
- inversion hin; subst; clear hin.
  destruct (hi Γ0 t H1) as [Γ' hΓ].
  exists Γ'.
  now repeat constructor.
Qed.

(** This type describe how do we add an element in an environment: no type
checking is done, this is just the mecanic way to do it. *)
Inductive ins_in_env (Γ:Env ) (d1:Ty): nat->Env -> Env  ->Prop :=
  | ins_O: ins_in_env Γ d1 O Γ (d1::Γ)
  | ins_S: forall (n:nat)(Δ Δ':Env )(d:Ty), (ins_in_env Γ d1 n Δ Δ')
    -> ins_in_env Γ d1 (S n) (d::Δ) ( d::Δ' ).

Hint Constructors ins_in_env.

(** Some lemmas about inserting a new element. They explain how
 terms in the environment are lifted according to their original position
 and the position of insertion. *)
Lemma ins_item_ge: forall (d':Ty) (n:nat) (Γ Δ Δ':Env),
  ins_in_env Γ d' n Δ Δ' ->
  forall (v:nat), n<=v ->
 forall (d:Ty),  d ↓ v ∈ Δ  -> d ↓ (S v) ∈ Δ'.
Proof.
intros d'; induction n as [ | n hi]; intros Γ Δ Δ' hins v hle d hd.
- inversion hd; subst; clear hd.
  + inversion hins; subst; clear hins.
    now repeat constructor.
  + inversion hins; subst; clear hins.
    now repeat constructor.
- inversion hd; subst; clear hd; [ now omega | ].
  inversion hins; subst; clear hins.
  constructor.
  eapply hi.
  + now apply H4.
  + now omega.
  + assumption.
Qed.

Lemma ins_item_lt: forall (d':Ty)(n:nat)(Γ Δ Δ':Env),
 ins_in_env Γ d' n Δ Δ' ->
 forall (v:nat), n > v ->
 forall (d:Ty), d ↓ v ∈ Δ -> d  ↓ v ∈ Δ' .
Proof.
intros d'; induction n as [ | n hi]; intros Γ Δ Δ' hins v hlt d hd; [ now omega | ].
inversion hins; subst; clear hins.
destruct v as [ | v].
- now inversion hd; subst; constructor.
- inversion hd; subst; clear hd.
  constructor.
  eapply hi.
  + now apply H0.
  + now omega.
  + now assumption.
Qed.

(** This type describe how do we do substitution inside a context.
As previously, no type checking is done at this point.*)

Inductive sub_in_env (Γ : Env) (T:Ty):
  nat -> Env -> Env -> Prop :=
    | sub_O :  sub_in_env Γ T 0 (T :: Γ) Γ
    | sub_S :
        forall Δ Δ' n  B,
        sub_in_env Γ T n Δ Δ' ->
        sub_in_env Γ T (S n) (B :: Δ) ( B :: Δ').

Hint Constructors sub_in_env.

(** Some ins / subst related facts: what happens to term when we do
 a substitution in a context.*)
Lemma nth_sub_sup :
   forall n Γ Δ Δ' T,
   sub_in_env Γ T n Δ Δ' ->
   forall v : nat, n <= v ->
   forall d , d ↓ (S v) ∈ Δ -> d ↓ v ∈ Δ'.
Proof.
induction 1 as [ | Δ  Δ' n b hΔ hi]; intros v hle d hd.
- now inversion hd; subst; clear hd.
- inversion hd; subst; clear hd.
  destruct v as [ | v]; [ now omega | ].
  constructor.
  now apply hi; [ omega |].
Qed.

Lemma nth_sub_eq :
   forall T n Γ Δ Δ',
   sub_in_env Γ T n Δ Δ' ->
  forall d , d↓ n ∈ Δ -> T = d.
Proof.
induction 1 as [ | Δ  Δ' n b hΔ hi]; intros d hd.
- now inversion hd; subst; clear hd.
- inversion hd; subst; clear hd.
  now apply hi.
Qed.

Lemma nth_sub_inf :
   forall T n Γ Δ Δ',
   sub_in_env Γ T n Δ Δ' ->
   forall v : nat,
   n > v ->
   forall d , d ↓ v ∈ Δ -> d ↓ v ∈ Δ' .
Proof.
induction 1 as [ | Δ  Δ' n b hΔ hi]; intros v hlt d hd; [ now omega | ].
inversion hd; subst; clear hd; [ now constructor | ].
constructor.
apply hi; [ now omega |assumption].
Qed.

Reserved Notation "Γ ⊢ t : T" (at level 80, t, T at level 30, no associativity) .

Inductive typ : Env -> Term -> Ty -> Prop :=
 | cVar  : forall Γ A v, A ↓ v ∈ Γ -> Γ ⊢ #v : A
 | cLa   : forall Γ A B M, A::Γ ⊢ M : B -> Γ ⊢ λ[A], M : A ⇒ B
 | cApp  : forall Γ M N A B , Γ ⊢ M : A ⇒ B -> Γ ⊢ N : A -> Γ ⊢ M · N : B
where "Γ ⊢ t : T" := (typ Γ t T) : STLC_scope.

Hint Constructors typ.

(** Weakening Property: if a judgement is valid, we can insert a well-typed term
  in the context, it will remain valid. This is where the type checking for
  inserting items in a context is done.*)
Theorem weakening: forall Δ M T, Δ ⊢ M : T -> forall Γ A n Δ', ins_in_env Γ A n Δ Δ' ->
                 Δ' ⊢ M ↑ 1 # n : T.
Proof.
induction 1 as [ Δ V v hin | Δ U V M hM hiM | Δ M N U V hM hiM hN hiN]; intros Γ A n Δ' hins; simpl in *.
- destruct le_gt_dec; constructor.
  + eapply ins_item_ge; [ now apply hins | assumption | assumption].
  + eapply ins_item_lt; [ now apply hins | | ]; assumption.
- constructor.
  eapply hiM.
  constructor.
  now apply hins.
- econstructor.
  + eapply hiM; now apply hins.
  + eapply hiN; now apply hins.
Qed.

Theorem thinning :
   forall Γ M T A, Γ ⊢ M : T -> A::Γ ⊢ M ↑ 1 : T.
Proof.
intros.
eapply weakening.
- now apply H.
- now constructor.
Qed.

Theorem thinning_n : forall n Δ Δ', trunc n Δ Δ' -> forall M T , Δ' ⊢ M : T  -> Δ ⊢ M ↑ n : T.
Proof.
induction n as [ | n hi]; intros Δ Δ' ht M T hM.
- inversion ht; subst; clear ht.
  now rewrite lift0.
- inversion ht; subst; clear ht.
  change (S n) with (1 + n).
  replace (M ↑ (1+n)) with ((M ↑ n )↑ 1) by (apply lift_lift).
  apply thinning; trivial.
  eapply hi.
  + now apply H0.
  + assumption.
Qed.

(** Substitution Property: if a judgment is valid and we replace a variable by a
  well-typed term of the same type, it will remain valid.*)
(* begin hide *)
Lemma sub_trunc : forall Δ A n Γ Γ', sub_in_env Δ A n Γ Γ' -> trunc n Γ' Δ.
Proof.
induction 1; now repeat constructor.
Qed.
(* end hide *)

Theorem substitution : forall Γ M T , Γ  ⊢ M : T  -> forall Δ P A, Δ  ⊢ P : A ->
 forall Γ' n , sub_in_env Δ A n Γ Γ' -> Γ' ⊢ M [ n ←P ]  : T.
Proof.
induction 1 as [ Γ V v hin | Γ U V M hM hiM | Γ M N U V hM hiM hN hiN]; intros Δ P A hP Γ' n hsub; simpl.
- destruct lt_eq_lt_dec as [ [] | ].
  + constructor.
    eapply nth_sub_inf; [ now apply hsub | now omega | assumption].
  + subst.
    eapply thinning_n.
    * eapply sub_trunc.
      now apply hsub.
    * replace V with A; [ assumption | ].
      eapply nth_sub_eq; [ now apply hsub | assumption].
  + constructor.
    eapply nth_sub_sup; [ now apply hsub | now omega |].
    replace (S (v - 1)) with v by now omega.
    assumption.
- econstructor.
  eapply hiM; [ now apply hP | ].
  now constructor.
- econstructor.
  + eapply hiM; [ now apply hP | assumption].
  + eapply hiN; [ now apply hP | assumption ].
Qed.

Lemma SR : forall Γ M T, Γ ⊢ M : T -> forall N, M  → N -> Γ ⊢ N : T.
Proof.
induction 1 as [ Γ A v hin | Γ A B M hM hiM | Γ M N A B hM hiM hN hiN]; intros P hred.
- now inversion hred.
- inversion hred; subst; clear hred.
  constructor.
  now apply hiM.
- inversion hred; subst; clear hred.
  + inversion hM; subst; clear hM.
    eapply substitution; [ now apply H1 | now apply hN| now constructor].
  + econstructor.
    * apply hiM; assumption.
    * assumption.
  + econstructor.
    * now apply hM.
    * apply hiN; assumption.
Qed.

Definition is_value (t: Term) : Prop :=
  match t with
  | # v => True
  | λ [ A ], M => True
  | _ => False
  end.

Lemma Progress_: forall Γ M T, Γ ⊢ M : T -> Γ = nil -> (exists N, M  → N) \/ is_value M.
Proof.
induction 1 as [ Γ A v hin | Γ A B M hM hiM | Γ M N A B hM hiM hN hiN]; intros heq; simpl; [ now right | now right | ].
left.
destruct (hiM heq) as [ [M' hM'] | hm].
- exists (M'· N); now constructor.
- destruct (hiN heq) as [ [N' hN'] | hn].
  + exists (M · N'); now constructor.
  + subst; destruct M as [ v | U V | U V].
    * inversion hM; subst; clear hM.
      now inversion H1.
    * simpl in hm; now elim hm.
    * exists (V [← N]); now constructor.
Qed.

Lemma Progress: forall M T, nil ⊢ M : T -> (exists N, M  → N) \/ is_value M.
Proof.
intros M T h; eapply Progress_.
- now apply h.
- reflexivity.
Qed.

Inductive subterm : Term -> Term -> Prop :=
  | sbtrm_abs : forall A M, subterm M (λ [A], M)
  | sbtrm_app_l : forall M N, subterm M (M · N)
  | sbtrm_app_r : forall M N, subterm N (M · N)
.

Fixpoint boccur (n:nat) (t:Term) :=
  match t with
  | # i => if eq_nat_dec n i then true else false
  | u · v => orb (boccur n u) (boccur n v)
  | λ [A], m => boccur (S n) m
  end.

Require Import Relations.

Definition normal t := forall u, ~ (t → u).

Notation SN := (Acc (transp _ Beta)).

Lemma commut_Beta_subterm : commut _ subterm (transp _ Beta).
Proof.
intros M N hsub P hP; unfold transp in *.
inversion hsub; subst; clear hsub.
- now exists (λ [A], P); constructor.
- now exists (P · N0); constructor.
- now exists (M0 · P); constructor.
Qed.

Lemma subterm_SN : forall M , SN M -> forall P, subterm P M -> SN P.
Proof.
induction 1 as [ M hM hi]; intros P hP.
constructor.
intros Q HQ.
destruct (commut_Beta_subterm hP HQ) as [R h1 h2].
now eapply hi; [ now apply h1 | ].
Qed.

Lemma SN_red_SN : forall x y, SN x -> x  → y -> SN y.
Proof.
intros x y h; revert y; induction h as [ x hx hi]; simpl in *.
exact hx.
Qed.

Lemma SN_var : forall n, SN (# n).
Proof.
intros n; constructor; intros x hx.
now inversion hx.
Qed.

Lemma SN_abs : forall M, SN M -> forall A, SN (λ [A], M).
Proof.
induction 1 as [ M hM hi]; intros A; simpl in *.
constructor; intros N hN.
inversion hN; subst; clear hN.
now apply hi.
Qed.

Lemma SN_lift : forall n t k, SN t -> SN (t ↑ n # k).
Proof.
intros n t k h; revert t h n k.
induction 1 as [N hN hi]; intros n k.
constructor; intros P hP.
apply Beta_lift_inv in hP as ( Q & hQ & ->).
now apply hi.
Qed.

Lemma SN_lift_inv : forall M', SN M' -> forall n M k, M' = M ↑ n # k -> SN M.
Proof.
induction 1 as [ M' hM hi]; intros n M k heq; subst; simpl in *.
constructor; intros N hN.
apply hi with (y := N ↑ n # k) (n := n) (k := k); [ | reflexivity].
now apply Beta_lift.
Qed.

Lemma SN_subst_inv_l u m k : SN (subst_rec u m k) -> boccur k m = true -> SN u.
Proof.
revert u k;
induction m as [ v | U hiU V hiV | A U hi]; intros u k hSN hin; simpl in *.
- destruct lt_eq_lt_dec as [ [] | ].
  + destruct Nat.eq_dec; [ now omega | discriminate].
  + destruct Nat.eq_dec; [ | subst; discriminate].
    now apply (SN_lift_inv hSN k _ 0).
  + destruct Nat.eq_dec; [ now omega | discriminate].
- apply Bool.orb_true_iff in hin as [ h | h].
  + apply hiU with (k := k); [ | assumption].
    eapply subterm_SN; [ now apply hSN | ].
    now constructor.
  + apply hiV with (k := k); [ | assumption].
    eapply subterm_SN; [ now apply hSN | ].
    now constructor.
- apply hi with (k := S k); [ | assumption].
  eapply subterm_SN; [ now apply hSN | ].
  now constructor.
Qed.

Lemma SN_subst : forall M T, SN (M [← T]) -> SN M.
Proof.
intros M T hsub.
cut (forall t,  SN t -> forall m, t = m [ ← T] -> SN m).
- intro h; now apply (h _ hsub).
- simple induction 1; intros.
  apply Acc_intro; intros; subst.
  apply H1 with (y [ ← T]); [ | reflexivity].
  now apply Beta_subst.
Qed.

Definition neutral M := match M with La _ _ => False | _ => True end.

Inductive nf : Term -> Prop :=
| Nf_var : forall n, nf (# n)
| Nf_app : forall u v, neutral u -> nf u -> nf v -> nf (u · v)
| Nf_abs : forall t, nf t -> forall A, nf (λ [A], t)
.

Lemma nf_norm : forall t, nf t -> forall u, ~ (t → u).
Proof.
induction 1 as [ v | U V hneutral hU hiU hV hiV | N hN hi A].
- now intros u hu; inversion hu.
- intros u hu; inversion hu; subst; clear hu; [ now elim hneutral | |].
  + now apply (hiU M').
  + now apply (hiV N').
- intros u hu; inversion hu; subst; clear hu.
  now apply (hi M').
Qed.

Lemma nf_sound : forall t, normal t -> nf t.
Proof.
induction t as [ v | U hiU V hiV| A M hi]; intros h; simpl in *.
- now constructor.
- destruct U as [ u | K L | B M].
  + constructor; [ now idtac | |].
    * apply hiU.
      now intros v hv; inversion hv.
    * apply hiV.
      intros W hW.
      now apply (h (#u · W)); constructor.
  + constructor; [ now idtac | |].
    * apply hiU.
      intros W hW.
      now apply (h (W · V)); constructor.
    * apply hiV.
      intros W hW.
      now apply (h (K · L · W)); constructor.
  + now elim (h (M [← V])); constructor.
- constructor.
  apply hi.
  intros W hW.
  now apply (h (λ [A], W)); constructor.
Qed.

Lemma Beta_dec : forall t, {u| t→ u}+{nf t}.
Proof.
induction t as [ u | U hiU V hiV | A M hi]; simpl in *.
- right; now constructor.
- destruct hiU as [[u hu] | hu].
  + now left; exists (u · V); constructor.
  + destruct hiV as [[v hv] | hv].
    * now left; exists (U · v); constructor.
    * destruct U as [ w | K L | A M].
      -- now right; constructor.
      -- now right; constructor.
      -- left; exists (M [← V]); now constructor.
- destruct hi as [[N hN] | h].
  + left; exists (λ [A], N); now constructor.
  + now right; constructor.
Qed.

Inductive Betas: Term -> Term -> Prop :=
  | Betas_refl : forall M, Betas M M
  | Betas_trans: forall M N P, Beta M N -> Betas N P -> Betas M P.

Lemma Betas_Beta: forall M N, Beta M N -> Betas M N.
Proof.
intros M N h; econstructor.
- now apply h.
- now constructor.
Qed.

Lemma Betas_Betas: forall M N, Betas M N -> forall P, Betas N P -> Betas M P.
Proof.
induction 1 as [ M | M N P hMN hi1 hNP hi2]; intros; [ assumption |].
econstructor; [ now apply hMN | ].
now apply hNP.
Qed.

Lemma Betas_App: forall M N, Betas M N -> forall U V, Betas U V -> Betas (M· U) (N · V).
Proof.
induction 1 as [ M | M N P hMN hNP hi]; intros U V h.
- induction h as [ U | U V P hUV hVP hi]; [ now constructor | ].
  eapply Betas_Betas.
  + apply Betas_Beta; apply Beta_red2; exact hUV.
  + assumption.
- eapply Betas_Betas.
  + apply Betas_Beta; apply Beta_red1; exact hMN.
  + now apply hi.
Qed.

Lemma Betas_Lam: forall M N, Betas M N -> forall A, Betas (λ [A], M) (λ [A], N).
Proof.
induction 1 as [ M | M N P hMN hNP hi]; intros A; [ now constructor | ].
eapply Betas_Betas.
+ apply Betas_Beta; apply Beta_lam; now apply hMN.
+ now apply hi.
Qed.

Lemma Betas_lift: forall M N, Betas M N -> forall n m, Betas (M ↑ n # m) (N ↑ n # m).
Proof.
induction 1 as [ M | M N P hMN hNP hi]; intros n m; simpl in *.
- now constructor.
- econstructor.
  + apply Beta_lift.
    now apply hMN.
  + now apply hi.
Qed.

Lemma Beta_subst_l : forall P M N, M → N -> forall n, Betas (P [ n ← M]) (P [ n ← N]).
Proof.
induction P as [ v | U hiU V hiV | A B hi]; intros M N hred n; simpl in *.
- destruct lt_eq_lt_dec as [ [] | ]; [ now constructor | | now constructor ].
  now apply Betas_lift; apply Betas_Beta.
- apply Betas_App; [ now apply hiU | now apply hiV].
- apply Betas_Lam; now apply hi.
Qed.

(* Strong -> Weak *)
Lemma norm : forall t, SN t -> { u | Betas t u /\ nf u}.
Proof.
induction 1 as [ N hN hi].
destruct (Beta_dec N) as [[ P hP] | hnf].
- destruct (hi P hP) as [Q [h1 h2]].
  exists Q; split; [ | assumption].
  now apply Betas_trans with (N := P).
- exists N; split; [ | assumption].
  now constructor.
Qed.

Fixpoint reducible (ty : Ty) (M : Term) : Prop :=
  match ty with
    | Base => SN M
    | T1 ⇒ T2 => forall N, reducible T1 N -> reducible T2 (M · N)
  end.

Lemma CR2: forall T M N,  M  → N -> reducible T M -> reducible T N.
Proof.
induction T as [ | T1 h1 T2 h2]; intros M N hred hcand; simpl in *.
- now apply hcand.
- intros Q hQ; simpl in *.
  eapply h2.
  + constructor.
    now apply hred.
  + now apply hcand.
Qed.

Lemma CR2s: forall T M N,  Betas M  N -> reducible T M -> reducible T N.
Proof.
intro T.
induction 1 as [ M | M N P hMN hNP hi]; intros h; simpl in *; [ assumption | ].
apply hi.
now apply CR2 with (M := M).
Qed.

Lemma acc_preservation_: forall A B (RA : relation A) (RB : relation B) (f : A -> B) a,
  (forall x y, RA x y -> RB (f x) (f y)) -> forall z, Acc RB z -> z = f a -> Acc RA a.
Proof.
intros A B RA RB f a h z hacc.
revert RA f a h.
induction hacc as [x hx hi]; intros RA f a h heq; subst.
constructor; intros b hb.
eapply hi.
- eapply h.
  now apply hb.
- now apply h.
- reflexivity.
Qed.

Lemma acc_preservation: forall A B (RA : relation A) (RB : relation B) (f : A -> B) a,
  (forall x y, RA x y -> RB (f x) (f y)) -> Acc RB (f a) -> Acc RA a.
Proof.
intros; eapply acc_preservation_.
now apply H.
now apply H0.
reflexivity.
Qed.

Lemma Acc_ind':forall (A : Type) (R : relation A) (P : A -> Prop),
  (forall x, (forall y, R y x -> P y) -> P x) -> forall x, Acc R x -> P x.
Proof.
intros A R P h x hacc.
eapply Acc_ind; [ | now apply hacc].
intros y hy h'.
apply h.
exact h'.
Qed.

Lemma CR1_and_CR3: forall T,
  (forall M, reducible T M -> SN M) /\
  (forall M, neutral M ->
             (forall N, M  → N -> reducible T N) -> reducible T M).
Proof.
induction T as [ | T1 [hi1 hi1'] T2 [hi2 hi2']]; simpl in *; split.
- intros M hM; assumption.
- intros M _ h; constructor; exact h.
- intros M hred.
  assert (h : SN ((fun M => M · #0) M)).
  + apply hi2, hi2'; [ now idtac | ].
    intros N h; apply (CR2 _ h).
    apply hred, hi1'; [ now idtac | ].
    now intros x hh; inversion hh.
  + apply acc_preservation with (f := fun M => M · #0) (RB := transp _ Beta); [ | assumption].
    intros x y hb; now constructor.
- intros M hn h N hred.
  assert (hSN : SN N) by now apply hi1.
  revert hred.
  elim hSN using Acc_ind'; clear N hSN.
  intros N hN hi.
  apply hi2'; [ now idtac | ].
  intros MN hMN; inversion hMN; subst; clear hMN; [ now elim hn | now apply h|].
  apply hN; [ assumption | ].
  now apply CR2 with (M := N).
Qed.

Lemma CR1 : forall T M, reducible T M -> SN M.
Proof.
intros T M; eapply CR1_and_CR3.
Qed.

Lemma CR3: forall T M, neutral M -> (forall N, M  → N -> reducible T N) -> reducible T M.
Proof.
intros T M; eapply CR1_and_CR3.
Qed.

Lemma var_reducibility: forall v T, reducible T # v.
Proof.
intros v T; apply CR3; [ now idtac | ].
now intros u h; inversion h.
Qed.

Lemma red_sat M P : boccur 0 M = true \/ SN P ->
   forall T, reducible T (M [ ← P]) -> forall A, reducible T ((λ[A], M)· P).
Proof.
intros h T hred A.
assert (hP : SN P).
- destruct h as [ h | h]; [ | exact h].
  apply CR1 in hred.
  now apply SN_subst_inv_l in hred.
- clear h; revert M hred.
  induction hP as [ P _ hiP]; unfold transp in *.
  intros M hred.
  generalize hred.
  cut (SN M).
  + simple induction 1.
    clear M hred H; intros M _ hi hred; unfold transp in *.
    apply CR3; [ now idtac | ].
    intros N hbeta.
    inversion hbeta; subst; clear hbeta; [ assumption | | ].
    * inversion H2; subst; clear H2.
      apply hi; [ assumption | ].
      apply CR2 with (M [← P]); [ now apply Beta_subst | assumption].
    * apply hiP; [ assumption | ].
      apply CR2s with (M [ ← P]); [ | assumption].
      now apply Beta_subst_l.
  + apply SN_subst with P.
    now apply CR1 with T.
Qed.

Fixpoint subst_list n l M : Term :=
  match M with
    | #v => if le_gt_dec n v then lift_rec n 0 (nth (v - n) l (# (v - n - length l)))
            else #v
    | M · N => (subst_list n l M) · (subst_list n l N)
    | λ [A], M => λ [A], (subst_list (S n) l M)
  end
.

Lemma subst_list_nil n M : subst_list n nil M = M.
Proof.
revert n; induction M as [ v | U hiU V hiV | A M hi]; intros n; simpl in *.
- destruct le_gt_dec; [ | reflexivity ].
  rewrite <- minus_n_O.
  replace (match v - n with | O | _ => #(v - n) end) with #(v - n) by now destruct (v - n).
  now simpl; f_equal; omega.
- f_equal; [ now rewrite hiU | now rewrite hiV].
- f_equal; now rewrite hi.
Qed.

Lemma subst_shift_cancel n d c l M :
  c <= n -> length l + n <= d + c ->
  subst_list n l (lift_rec d c M) = lift_rec (d - length l) c M.
Proof.
revert n d c l.
induction M as [ v | U hiU V hiV | A M hi]; intros n d c l h1 h2; simpl in *.
- destruct le_gt_dec; simpl in *.
  + destruct le_gt_dec; simpl in *; [ | now omega].
    rewrite nth_overflow; [ | now omega].
    now simpl; f_equal; omega.
  + destruct le_gt_dec; simpl in *; [ now omega | reflexivity ].
- f_equal.
  + now apply hiU.
  + now apply hiV.
- f_equal; apply hi;now omega.
Qed.

Lemma subst_list_app n k l M :
  subst_list n k (subst_list (length k + n) l M) = subst_list n (k ++ l) M.
Proof.
revert M n; induction M as [ v | U hiU V hiV | A M hi]; simpl in *; intros n.
- rewrite app_length.
  destruct (le_gt_dec n v); destruct le_gt_dec; simpl; [ | | now omega| ].
  + rewrite app_nth2; [ | now omega].
    rewrite subst_shift_cancel; [ | now omega | now omega].
    f_equal; [ now omega | ].
    f_equal; [ now omega | ].
    f_equal; now omega.
  + destruct le_gt_dec; [ | now omega].
    f_equal.
    rewrite app_nth1; [ | now omega].
    f_equal; f_equal; now omega.
  + destruct le_gt_dec; [ now omega | reflexivity ].
- f_equal; [ now apply hiU | now apply hiV].
- f_equal.
  replace (S (length k + n)) with (length k + S n) by omega.
  now apply hi.
Qed.

(* just to test it's ok with subst_rec *)
Lemma subst_list_ok: forall M n N, M [ n← N] = subst_list n (N :: nil) M.
Proof.
induction M as [ v | U hiU V hiV | A M hi]; intros n N; simpl in *.
- destruct lt_eq_lt_dec as [ [] | ].
  + destruct le_gt_dec; [ now omega | reflexivity].
  + destruct le_gt_dec; [ | now omega]; subst.
    now rewrite <- minus_n_n.
  + destruct le_gt_dec; [ | now omega ].
    case_eq (v - n); [ now omega | ].
    intros q heq; subst.
    replace (match q with | O | _ => # (S q - 1) end ) with # (S q - 1).
    * simpl; f_equal.
      rewrite <- minus_n_O.
      now omega.
    * now destruct q.
- f_equal.
  + now apply hiU.
  + now apply hiV.
- f_equal; now apply hi.
Qed.

Definition left_list (A B: Type) (l: list (A * B)) := map fst l.
Definition right_list (A B: Type) (l: list (A * B)) := map snd l.

Lemma left_list_length: forall A B (l: list (A * B)), length (left_list l) = length l.
Proof.
intros A B l.
unfold left_list; now rewrite map_length.
Qed.

Lemma reduce_lemma: forall (Δ : list (Term * Ty)) Γ M T,
  (right_list Δ) ++ Γ ⊢ M : T ->
  Forall (fun (x: Term * Ty) => let (tm, ty) := x in reducible ty tm) Δ ->
  reducible T (subst_list 0 (left_list Δ) M).
Proof.
intros Δ Γ M T; revert M T Γ Δ.
induction M as [ v | U hiU V hiV | A M hi]; intros T Γ Δ; simpl in *.
- simpl.
  rewrite <- minus_n_O in *.
  rewrite lift0, left_list_length.
  revert v.
  induction Δ as [ | hd tl hi]; simpl in *; intros v.
  + replace (reducible T match v with
            | 0 | _ => # (v - 0)
            end) with (reducible T #v) by now destruct v.
    intros _ _; now apply var_reducibility.
  + intros hty hf.
    inversion hf; subst; clear hf.
    destruct hd as [hdT hdTy]; simpl in *.
    destruct v.
    * inversion hty; subst; clear hty.
      now inversion H3; subst; clear H3.
    * apply hi; [ | assumption ].
      inversion hty; subst; clear hty.
      inversion H3; subst; clear H3.
      now constructor.
- intros hty hf.
  inversion hty; subst; clear hty.
  generalize (hiU (A ⇒ T) Γ Δ H2 hf); simpl; intros h.
  apply h.
  now apply hiV with Γ.
- intros hty hf.
  inversion hty; subst; clear hty; simpl; intros N hN.
  apply red_sat; [ right; now apply CR1 with A| ].
  rewrite subst_list_ok, subst_list_app; simpl.
  change (N :: left_list Δ) with (left_list ((N, A) :: Δ)).
  apply hi with Γ; [ simpl; assumption | ].
  now constructor.
Qed.

Lemma typ_are_SN: forall Γ M T, Γ ⊢ M : T -> SN M.
Proof.
intros Γ M T hty.
assert (h : reducible T (subst_list 0 (left_list nil) M)) by now apply reduce_lemma with Γ.
simpl in h.
rewrite subst_list_nil in h.
now apply CR1 with T.
Qed.


Require Import Frap Modeling Hoare Helpers.

Require Import Problem.

(* Look at Problem.v to see what these things mean *)

(* Helpful lemma proofs *)
Lemma is_sorted_smaller: forall (arr: heap) (startI endI endI': nat),
  is_sorted arr startI endI -> endI' <= endI -> is_sorted arr startI endI'.
Proof.
  unfold is_sorted; t.
  apply H; linear_arithmetic.
Qed.
Lemma singletone_is_sorted: forall (arr: heap) (startI: nat),
  is_sorted arr startI (startI + 1).
Proof.
  unfold is_sorted; t.
Qed.
Lemma is_sorted_extend: forall (arr: heap) (startI endI x: nat),
  is_sorted arr startI endI
  -> arr $! (endI - 1) <= x
  -> is_sorted (arr $+ (endI, x)) startI (endI + 1).
Proof.
  unfold is_sorted; t.
  cases (k2 <? endI); comparison_bool_to_prop; simplify; first_order.
  cases (k1 <? endI - 1); comparison_bool_to_prop.
  ++ assert (arr $! k1 <= arr $! (endI - 1)) by (apply H; propositional; linear_arithmetic).
     linear_arithmetic.
  ++ assert (k1 = endI - 1) by linear_arithmetic.
     rewrite H3 in *.
     assumption.
Qed.
Lemma is_sorted_remains_sorted_with_useless: forall (arr: heap) (startI endI: nat) (i x: nat),
  is_sorted arr startI endI
  -> i >= endI
  -> is_sorted (arr $+ (i, x)) startI endI.
Proof.
  unfold is_sorted; t.
Qed.

(* Define the loop invariant *)
Definition merge_invariant (len1 len2: nat): assertion :=
  fun h v =>
    (* A: we increasingly make the final array sorted as "i" increases*)
    is_sorted h (len1 + len2) (v $! "i")
    (* B: the input arrays are unchanged and remain sorted *)
    /\ is_sorted h 0 len1 /\ is_sorted h len1 (len1 + len2)
    (* lower bounds on the counters *)
    /\ (v $! "i") >= len1 + len2 /\ (v $! "i2" >= len1) /\ (v $! "i" >= (v $! "i1") + (v $! "i2") + len2)
    (* C: Very important strengthening of the invaraint:
       The bottom two terms are very similar, but not very intuitive, they are needed because they
       combine values from the current iteraion ("i", "i1", "i2"), with values from the previous iteration ("i"-1).
       These do not always apply, they only apply when "i"-1 is within range, and "i1", "i2" did not finish looping over
       their respective arrays *)
    /\ ((v $! "i" > len1 + len2) -> (v $! "i1" < len1) -> h $! (v $! "i" - 1) <= h $! (v $! "i1"))
    /\ ((v $! "i" > len1 + len2) -> (v $! "i2" < len1 + len2) -> h $! (v $! "i" - 1) <= h $! (v $! "i2"))
    (* upper bounds on the counters *)
    /\ (v $! "i1" <= len1) /\ (v $! "i2" <= len1 + len2)
    (* Z: Either: "i1" is not done yet, "i2" is not done yet, the input arrays are empty, or the loop/program is done *)
    /\ (v $! "i1" < len1 \/ v $! "i2" < len1 + len2 \/ (len1 = 0 /\ len2 = 0) \/ v $! "i" = len1 + len2 + len1 + len2).

(* Prove the basic version of correctness *)
Theorem merge_correct: forall (len1 len2: nat),
  {{ fun h v => is_sorted h 0 len1 /\ is_sorted h len1 (len1 + len2) }}
  merge_program len1 len2 merge_invariant
  {{ fun h v => (is_sorted h (len1 + len2) (len1 + len2 + len1 + len2)) }}.
Proof.
  unfold merge_invariant in *;
  (* A somewhat manual solution: go through the statements one at a time
     each time manually choose and apply the appropriate hoare logic rule *)
  simplify.
  eapply HtSeq.
  eapply HtAssign.
  eapply HtSeq.
  eapply HtAssign.
  eapply HtSeq.
  eapply HtAssign.

  eapply HtStrengthenPost.
  + eapply HtWhile.
    * unfold is_sorted. t.
    * eapply HtSeq.
      ++ ht.
      ++ t.
         eapply HtStrengthenPost.
         -- apply HtAssign.
         -- t. (* TAKES A LONG TIME  *)
            (* we get many goals (24) but they only have 3 distinct types, we only really need 3 proofs
               that we re-use (in this case copy-paste) to prove all goals of the same type. *)
            (* t already proved most of the goals (there is something near 100 of them)
               for us, and left only the things it got stuck on, if you look at t's defintion
               you will see it cannot do either case analysis (it is very hard to automatically know what to case analyse)
               or apply external lemmas. So t gets stuck on proofs that require using these features. *)
            (* The reason we have so many goals is that we have to prove that the invariant remains true after an iteration, notice
               that the invariant is made out 11 conditions combined together with ands, we need to prove every single one of the conditions.
               to top it off, the program has 3 nested if-else conditions, each combiniation produces different state (post-condition) and thus, we end
               up having to prove the same condition from the invariant from every one of them, additionally sequencing and assignments inside the loop
               body produce additional goals. t solves most of the obvious ones automatically, but gets stuck on things that depend on some conditions that
               we need to run cases on *)

            (* Type one, corresponds to A in the invariant: the first type is goals that prove that the newly extended output array is sorted *)
            (* all of these goals are very similar and have the same proof:
               1. We have two cases: either this is the first iteration, or this is some later iteration.
               2. if this is some later iteration, we can use is_sorted_extend to extend the already sorted array by one element!
               3. if this is the first iteration, that means the output array currently only has one element, and is trivially sorted *)
            ** cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop.
               +++ assert (x0 $! "i" > len1 + len2) by linear_arithmetic.
                   propositional.
                   apply is_sorted_extend; assumption.
               +++ assert (x0 $! "i" = len1 + len2) by linear_arithmetic.
                   rewrite H1 in *.
                   apply singletone_is_sorted.
            ** cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop.
               +++ assert (x0 $! "i" > len1 + len2) by linear_arithmetic.
                   propositional.
                   apply is_sorted_extend; assumption.
               +++ assert (x0 $! "i" = len1 + len2) by linear_arithmetic.
                   rewrite H1 in *.
                   apply singletone_is_sorted.
            ** cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop.
               +++ assert (x0 $! "i" > len1 + len2) by linear_arithmetic.
                   propositional.
                   apply is_sorted_extend; assumption.
               +++ assert (x0 $! "i" = len1 + len2) by linear_arithmetic.
                   rewrite H1 in *.
                   apply singletone_is_sorted.
            ** cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop.
               +++ assert (x0 $! "i" > len1 + len2) by linear_arithmetic.
                   propositional.
                   apply is_sorted_extend; assumption.
               +++ assert (x0 $! "i" = len1 + len2) by linear_arithmetic.
                   rewrite H1 in *.
                   apply singletone_is_sorted.
            ** cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop.
               +++ assert (x0 $! "i" > len1 + len2) by linear_arithmetic.
                   propositional.
                   apply is_sorted_extend; assumption.
               +++ assert (x0 $! "i" = len1 + len2) by linear_arithmetic.
                   rewrite H1 in *.
                   apply singletone_is_sorted.
            ** cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop.
               +++ assert (x0 $! "i" > len1 + len2) by linear_arithmetic.
                   propositional.
                   apply is_sorted_extend; assumption.
               +++ assert (x0 $! "i" = len1 + len2) by linear_arithmetic.
                   rewrite H1 in *.
                   apply singletone_is_sorted.

            (* Type two: goals corresponding with sortedness of input arrays, condition B in the invaraint *)
            (* we get six goals per input array, all can be solved by noticing that the input arrays are unchanged *)
            (* Notice that the proof of [is_sorted_remains_sorted_with_useless] is just [unfold is_sorted; t].
               so we could have proved these goals with just that. We use the lemma for clarity/modularity *)
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.
            ** apply is_sorted_remains_sorted_with_useless; try assumption; linear_arithmetic.

            (* Type four: almost trivial residual goals from condition C in the invariant.
               t is stuck here because it does not know how to [apply] is_sorted *)
            ** apply H2; propositional; linear_arithmetic.
            ** apply H2; propositional; linear_arithmetic.
            ** apply H2; propositional; linear_arithmetic.
            ** apply H8; propositional; linear_arithmetic.
            ** apply H8; propositional; linear_arithmetic.
            ** apply H6; propositional; linear_arithmetic.

  (* We are done with the loop, now we want to prove that the invariant after the loop
     terminates imply the final post-condition. *)
  + ht.
    (* three cases each corresponding to one of the options in Z, the case related to the third
       option is trivial and is proven automatically by ht for us. *)
    - eapply is_sorted_smaller.
      * exact H.
      * linear_arithmetic.
    - eapply is_sorted_smaller.
      * exact H.
      * linear_arithmetic.
    - eapply is_sorted_smaller.
      * exact H.
      * linear_arithmetic.

Restart.
  (* A slightly more automated verison of the proof *)
  unfold merge_invariant.

  (* We chain all these proofs to avoid copy-pasting *)
  (* will traverse all of the program and give us all the required sub goals: uses t internally *)
  ht;
  (* t does not know to unfold is_sorted, we will try to help it by unfolding is_sorted for it *)
  (* the complicated try; fail pattern is because I do not want to unfold is_sorted for goals that still need
  proving, since that will make them look more complicated on the screen *)
  try (unfold is_sorted; t; fail);

  (* The proof for type A: but written as a chain *)
  try (
    cases (len1 + len2 <? (x0 $! "i")); comparison_bool_to_prop;
      (assert (x0 $! "i" > len1 + len2) by linear_arithmetic;
      propositional;
      apply is_sorted_extend; assumption)
    ||
      (assert (x0 $! "i" = len1 + len2) by linear_arithmetic;
      rewrite H1 in *;
      apply singletone_is_sorted)
  );

  (* Proof for type C as a chain *)
  (* this is a more brute-force style of automation, we could have been smarter and pattern
     matched on the goal to see which of the assumptions we should apply. *)
  try (apply H2; propositional; linear_arithmetic);
  try (apply H8; propositional; linear_arithmetic);
  try (apply H6; propositional; linear_arithmetic);

  (* Proof for the three cases after the while loop: the invariant imply the final post-condition *)
  eapply is_sorted_smaller; try exact H; linear_arithmetic.
Qed.

(* Put any bonus parts code here *)


Require Import Psatz.

Inductive day : Type :=
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

(*
What is difference between
Proof.
Proof using.
and other constructs
 *)

Example test_next_weekday :
  (next_weekday (next_weekday saturday)) = tuesday.
Proof.
  refine (eq_refl).
Qed.

Inductive bool : Type :=
| true : bool
| false : bool.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1 b2 : bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1 b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. refine eq_refl. Qed.

Example test_orb2: (orb false false) = false.
Proof. refine eq_refl. Qed.

Example test_orb3: (orb false true) = true.
Proof. refine eq_refl. Qed.

Example test_orb4: (orb true true) = true.
Proof. refine eq_refl. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof.  refine eq_refl. Qed.

Definition nandb (b1 b2 : bool) : bool :=
  match b1, b2 with
  | true, true => false
  | _, _ => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. refine eq_refl. Qed.

Example test_nandb2: (nandb false false) = true.
Proof. refine eq_refl. Qed.

Example test_nandb3: (nandb false true) = true.
Proof. refine eq_refl. Qed.

Example test_nandb4: (nandb true true) = false.
Proof. refine eq_refl. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1, b2, b3 with
  | true, true, true => true
  | _, _, _ => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. refine eq_refl. Qed.

Example test_andb32: (andb3 false true true) = false.
Proof. refine eq_refl. Qed.

Example test_andb33: (andb3 true false true) = false.
Proof. refine eq_refl. Qed.

Example test_andb34: (andb3 true true false) = false.
Proof. refine eq_refl. Qed.

Check true.
Check (negb true).
Check negb.

Inductive rgb : Type :=
| red : rgb
| green : rgb
| blue : rgb.

Inductive color : Type :=
| black : color
| white : color
| primary : rgb -> color.

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | _ => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | primary red => true
  | _ => false
  end.

Module Natplayground.

  Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

  Inductive nat' : Type :=
  | stop : nat'
  | tick : nat' -> nat'.

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

End Natplayground.

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minustwo 4).

Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n : nat) : bool := negb (evenb n).

Example test_oddb1: oddb 1 = true.
Proof. exact eq_refl. Qed.

Example test_oddb2: oddb 4 = false.
Proof. exact eq_refl. Qed.

Module Natplayground2.

  Fixpoint plus (n m : nat) : nat :=
    match n with
    | O => m
    | S n' => S (plus n' m)
    end.

  Compute (plus 3 2).

  Fixpoint mult (n m : nat) : nat :=
    match n with
    | O => O
    | S n' => plus m (mult n' m)
    end.

  Example test_mult1: (mult 3 3) = 9.
  Proof. exact eq_refl. Qed.

  Fixpoint minus (n m : nat) : nat :=
    match n, m with
    | O, _ => O
    | S _, O => n
    | S n', S m' => minus n' m'
    end.

End Natplayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Fixpoint factorial (n : nat) : nat :=
  match n with
  | O => S O
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. exact eq_refl. Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. exact eq_refl.  Qed.

Inductive fact : nat -> nat -> Type :=
| base : fact 0 1
| step n m : fact n m -> fact (S n) (mult m (S n)).

Example fact_compute : fact 5 120.
Proof. apply step with (n := 4) (m := 24).
       apply step with (n := 3) (m := 6).
       apply step with (n := 2) (m := 2).
       apply step with (n := 1) (m := 1).
       apply step with (n := 0) (m := 1).
       apply base.
Qed.

Lemma fact_correctness : forall n m,
    fact n m -> m = factorial n.
Proof.
  induction n.
  + cbn; intros m H; inversion H; try auto.
  + cbn; intros m H; inversion H; subst; try auto.
    pose proof (IHn _ H1). rewrite H0.
    assert (forall a, a * S n = a + a * n).
    intros. lia.  rewrite H2 with (a := factorial n).
    f_equal. lia.
Qed.

Lemma fact_relation : forall n m,
    m = factorial n -> fact n m.
Proof.
  induction n.
  + cbn; intros; subst; try constructor.
  + cbn; intros.
    assert (Hm : m = mult (factorial n) (S n)). lia.
    rewrite Hm; eapply step; apply IHn; auto.
Defined.

Lemma compute_fact_rel :
  forall n, fact n (factorial n).
Proof.
  intros.
  pose proof (fact_relation n (factorial n) eq_refl); assumption.
Defined.

(* Inspect the internal details of this proof. Looks interesting *)
Eval compute in (compute_fact_rel 5).

Notation "x + y" := (plus x y)
                      (at level 50, left associativity)
                    : nat_scope.
Notation "x - y" := (minus x y)
                      (at level 50, left associativity)
                    : nat_scope.
Notation "x * y" := (mult x y)
                      (at level 40, left associativity)
                    : nat_scope.
Check ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
        | O => true
        | S m' => false
        end
  | S n' => match m with
           | O => false
           | S m' => beq_nat n' m'
           end
  end.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' => match m with
           | O => false
           | S m' => leb n' m'
           end
  end.

Example test_leb1: (leb 2 2) = true.
Proof. exact eq_refl. Qed.

Example test_leb2: (leb 2 4) = true.
Proof. exact eq_refl. Qed.

Example test_leb3: (leb 4 2) = false.
Proof. exact eq_refl. Qed.

Definition blt_nat (n m : nat) : bool :=
  negb (leb m n).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. exact eq_refl. Qed.

Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. exact eq_refl. Qed.

Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. exact eq_refl. Qed.

Theorem plus_O_n : forall n, O + n = n.
Proof.
  refine (fun n => eq_refl).
Qed.

Theorem plus_1_n : forall n, 1 + n = S n.
Proof.
  refine (fun n => eq_refl).
Qed.

Theorem mult_0_1 : forall n, O * n = O.
Proof.
  refine (fun n => eq_refl).
Qed.

Theorem plus_id_example : forall n m : nat,
    n = m ->
    n + n = m + m.
Proof.
  refine (fun n m H => eq_ind_r (fun n0 => n0 + n0 = m + m) eq_refl H).
Qed.

Check (@eq_ind_r nat O (fun n => n = O) eq_refl O eq_refl).
(* Learn more about eq_ind_r,
eq_ind_r :
forall (A : Type) (x : A) (P : A -> Prop), P x -> forall y : A, y = x -> P y
Arguments A, x, y are implicit.
If you want to supply all the arguments then use @eq_ind_r *)

Check (fun n m => @eq_ind_r _ _ (fun N => N = n + S m)  (plus_n_Sm n m) _  (plus_Sn_m n m)).

Theorem plus_id_exercise : forall n m o : nat,
    n = m -> m = o -> n + m = m + o.
Proof.
  refine (fun n m o Hnm Hmo => eq_ind_r (fun n0 => n0 + m = m + o)
                                     (eq_ind_r (fun m0 => m0 + m0 = m0 + o) eq_refl Hmo) Hnm).
Qed.

Theorem mult_O_plus : forall n m : nat,
    (O + n) * m = n * m.
Proof.
  refine (fun n m => eq_refl).
Qed.

Theorem mult_S_1 : forall n m : nat,
    m = S n ->
    m * (1 + n) = m * m.
Proof.
  refine (fun n m H => eq_ind_r (fun m0 => m0 * (1 + n) = m0 * m0) eq_refl H).
Qed.

Theorem plus_1_neq_O :
  forall (n : nat), beq_nat (n + 1) O = false.
Proof.
  refine (fix Fn n :=
            match n with
            | O => eq_refl
            | S n' => eq_refl
            end).
Qed.

Theorem negb_involutive : forall b,
    negb (negb b) = b.
Proof.
  refine (fun b => match b with
                | true => eq_refl
                | false => eq_refl
                end).
Qed.

Theorem and_commutative :
  forall a b, andb a b = andb b a.
Proof.
  refine (fun a b =>
            match a, b with
            | true, true => eq_refl
            | false, false => eq_refl
            | false, true => eq_refl
            | true, false => eq_refl
            end).
Qed.

(* plus as relation *)

Inductive plus_rel : nat -> nat -> nat -> Type :=
| pbase m : plus_rel O m m
| pstep n m r : plus_rel n m r -> plus_rel (S n) m (S r).

(* Define a division function n / k *)
Definition div (n k : nat) := 1.

Inductive log (b : nat) :  nat -> nat -> Type :=
| lbase : log b 1 0
| lstep n k : b <= n -> log b n k -> log b (div n b) (S k).

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
    (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b.
Proof.
  refine (fun f Hf =>
            fix Fn b :=
            match b with
            | true => _
            | false => _
            end);
    [repeat rewrite (Hf true) | repeat rewrite (Hf false)]; exact eq_refl.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
    (forall (x : bool), f x = negb x) -> forall (b : bool), f (f b) = b.
Proof.
  refine (fun f Hf =>
            fix Fn b :=
            match b with
            | true => _
            | false => _
            end).
  rewrite (Hf true); cbn; rewrite (Hf false); cbn; exact eq_refl.
  rewrite (Hf false); cbn; rewrite (Hf true); cbn; exact eq_refl.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
    (andb b c = orb b c) -> b = c.
Proof.
  refine (fun b c =>
            match b, c with
            | true, true => fun H => eq_refl
            | true, false => fun H => _
            | false, true => fun H => _
            | false, false => fun H => eq_refl
            end); inversion H.
Qed.

(* influenced by coq binary *)
Inductive bin : Type :=
| xZ : bin (* Zero *)
| xD : bin -> bin (* Twice *)
| xT : bin -> bin. (*Twice plus one *)

(*
 0 => xZ
 1 => xT xZ (2 * 0 + 1)
 2 => xD (xT xZ)  (2 * 1)
 3 => xT (xT xZ) (2 * 1 + 1)
 4 => xD (xD (xT xZ)) *)

Fixpoint bin_to_nat (b : bin) : nat :=
  match b with
  | xZ => O
  | xD p => 2 * bin_to_nat p
  | xT p => 1 + 2 * bin_to_nat p
  end.

Eval compute in (bin_to_nat (xD (xD (xT xZ)))).

Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n) => even n
  end.

Fixpoint div2 (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n) => S (div2 n)
  end.

Eval compute in div2 12.

Require Import FunInd.

Functional Scheme div2_ind := Induction for div2 Sort Prop.

Lemma div2t2le : forall n, div2 n <= n.
Proof.
  intros n.
  functional induction (div2 n); try lia.
Qed.

Notation "'existsT' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'") : type_scope.


Require Import List.

Definition option_bind {A B: Type} (f : A -> option B) (x : option A) :=
  match x with | None => None | Some y => f y end.

Fixpoint option_list_map {A : Type} (l : list (option A)) : option (list A) :=
match l with
| nil => Some nil
| Some h :: t => option_map (cons h) (option_list_map t)
| _ => None
end.

Lemma option_list_map_Some {A : Type} (l : list (option A)) v:
 option_list_map l = Some v ->
 forall x, In x l -> exists vx, x = Some vx.
Proof.
revert v;
induction l; intros v H x Hin;
simpl option_list_map in H.
- inversion Hin.
- destruct Hin as [Ha | Hl].
  + subst.
    destruct x.
    * eauto.
    * inversion H.
  + destruct a as [ a |]; [| inversion H].
    destruct (option_list_map l) as [ ll |].
    * eauto.
    * inversion H.
Qed.

Lemma option_list_map_map {A : Type} (l : list (option A)) f :
  (forall x, In x l -> x = Some (f x)) ->
    option_list_map l = Some (map f l).
Proof.
induction l; intros H.
- unfold option_list_map; trivial.
- assert (Ha : a = Some (f a)) by auto with *.
  rewrite Ha.
  assert (Hl : option_list_map l = Some (map f l)) by auto with *.
  unfold option_list_map, option_map in *.
  now rewrite Hl, <- Ha.
Qed.

Definition complete_option {A : Type} x0 (x : option A) : A :=
match x with
| None => x0
| Some x => x
end.

Definition option_rel {A} R (x y : option A) : Prop :=
 exists vx vy, x = Some vx /\ y = Some vy /\ R vx vy.

Definition option_choice {A B: Type} (f g: A -> option B) x :=
match f x with
| Some v => Some v
| None => g x
end.

Notation " f ;; g " := (option_choice f g) (at level 60).

Lemma option_choice_assoc {A B: Type} (f g h : A -> option B) x:
 (f;;(g;;h)) x = (f;;g;;h) x.
Proof.
unfold option_choice.
case (f x); trivial.
Qed.

Lemma option_choice_none_right {A B: Type} (f : A -> option B) x:
 (f;;fun _ => None) x = f x.
Proof.
unfold option_choice; case (f x); trivial.
Qed.

Lemma option_choice_none_left {A B: Type} (f : A -> option B) x :
 ((fun _ => None) ;; f) x = f x.
Proof.
unfold option_choice; case (f x); trivial.
Qed.

Lemma option_choice_ext_left {A B: Type} (f f' g: A -> option B) x:
  (forall x, f x = f' x) ->
  (f;;g) x = (f';; g) x.
Proof.
intro H; unfold option_choice.
case_eq (f x); simpl.
- intros v Hv; now rewrite <- H, Hv.
- intros Hnone; now rewrite <- H, Hnone.
Qed.

Lemma option_choice_ext_right {A B: Type} (f f' g: A -> option B) x:
  (forall x, f x = f' x) ->
  (g;;f) x = (g;;f') x.
Proof.
intro H; unfold option_choice; case_eq (g x); simpl; trivial.
Qed.

Lemma option_map_Some {A B : Type} (f : A -> B) x v:
  option_map f x = Some v -> exists v', x = Some v'.
Proof.
intro H.
destruct x as [v' |].
- eauto.
- inversion H.
Qed.

Lemma option_bind_Some {A B : Type} (f : A -> option B) x v:
 option_bind f x = Some v -> exists v', x = Some v' /\ f v' = Some v.
Proof.
intro H.
destruct x as [v' |].
- eauto.
- inversion H.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Examples for other tactics provided by TLC                              *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics.
From TLC Require Import LibLogic LibEqual LibList LibRelation LibWf LibList LibLN.

(* ---------------------------------------------------------------------- *)
(** ** Demo of extens tactics *)

Lemma test_extensionality_1 : forall A1 (P Q :  A1->Prop),
  (forall x1, P x1 <-> Q x1) ->
  P = Q.
Proof using.
  intros. applys extensionality. hnf.
Abort.

Lemma test_extensionality_2 : forall A1 (A2: A1->Type) (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 <-> Q x1 x2) ->
  P = Q.
  intros. applys extensionality. hnf.
Abort.

Section FuncExtDepTest.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).

Lemma test_fun_ext_3 : forall (f g : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), A4 x3),
  (forall x1 x2 x3, f x1 x2 x3 = g x1 x2 x3) ->
  f = g.
Proof using. intros. applys extensionality. hnf. Abort.

End FuncExtDepTest.

Lemma prop_ext_1_test : forall (P Q : Prop),
  (P <-> Q) ->
  P = Q.
Proof using.
  intros. applys extensionality. simpl extensionality_hyp.
Abort.

(* ---------------------------------------------------------------------- *)
(** ** Demo of LibLogic tactics *)
Lemma absurds_demo : forall (P Q : Prop),
  P /\ (~ P) /\ (Q \/ ~ P).
Proof using.
  intros. splits.
  { absurds ;=> H. admit. }
  { absurds ;=> H. admit. }
  { absurds ;=> (H1&H2). admit. }
Abort.

(* ********************************************************************** *)
(** * How to do recursion/induction on terms with list of subterms *)

Module SubtermIndDemos.

Import LibLogic LibList.

(** Definition of trees with list of subtrees *)

Inductive tree : Type :=
  | leaf : nat -> tree
  | node : list tree -> tree.

(** Example of a primitive-recursive function on trees
    using an inlined fixed point -- not recommended *)

Fixpoint tree_incr' (t:tree) :=
  match t with
  | leaf n => leaf (S n)
  | node ts =>
     node ((fix aux ts := match ts with
            | nil => nil
            | t::ts' => tree_incr' t :: aux ts'
            end) ts)
  end.

(** Same example but using the map function on lists
    -- recommended
    -- this works only because List.map has exactly
    the same form as the local [fix] used above.
    -- if you wanted to use LibList.map instead of
    List.map, it would not work; you would have to
    either use the optimal fixed point (see LibFixDemos)
    or you would have to exploit [List.map = LibList.map] *)

Fixpoint tree_incr (t:tree) :=
  match t with
  | leaf n => leaf (S n)
  | node ts => node (List.map tree_incr ts)
  end.

(** Another example -- recommended *)

Fixpoint tree_map (f:nat->nat) (t:tree) :=
  match t with
  | leaf n => leaf (f n)
  | node ts => node (List.map (tree_map f) ts)
  end.

(** Another example using List.fold -- recommended *)

Fixpoint tree_sum (t:tree) :=
  match t with
  | leaf n => n
  | node ts => List.fold_left (fun acc t => acc + tree_sum t) ts 0
  end.

(** Proof of the recursion principle *)

Section Tree_induct.
(* Note: some hypotheses are given directly by [Check tree_ind] *)
Variables
(P : tree -> Prop)
(Q : list tree -> Prop)
(P1 : forall n, P (leaf n))
(P2 : forall ts, Q ts -> P (node ts))
(Q1 : Q nil)
(Q2 : forall t ts, P t -> Q ts -> Q (t::ts)).

Fixpoint tree_induct_gen (t : tree) : P t :=
  match t as x return P x with
  | leaf n => P1 n
  | node ts => P2
      ((fix tree_list_induct (ts:list tree) : Q ts :=
      match ts as x return Q x with
      | nil   => Q1
      | t::ts' => Q2 (tree_induct_gen t) (tree_list_induct ts')
      end) ts)
  end.

End Tree_induct.

(** Example of a direct inductive proof -- not recommended *)

Lemma tree_map_pred_succ_1 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. pattern t. match goal with |- ?F _ => sets P: F end.
  eapply tree_induct_gen with (Q := Forall P); subst P; simpl; intros.
  fequals.
  fequals. induction ts; simpl.
    fequals.
    inverts H. fequals~.
  constructors.
  constructors~.
Qed.

(** Proof of the induction principle with Forall *)

Lemma tree_induct_forall : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall ts : list tree, Forall P ts -> P (node ts)) ->
  forall t : tree, P t.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := Forall P); intros.
  auto. auto. constructors~. constructors~.
Qed.

(** Example of an inductive proof with Forall
    -- recommended *)

Lemma tree_map_pred_succ_2 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. induction t using tree_induct_forall; simpl.
  fequals.
  fequals. induction ts; simpl.
    auto.
    inverts H. fequals~.
Qed.

(** Proof of the induction principle with Mem *)

Lemma tree_induct_mem : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall ts : list tree,
    (forall t, mem t ts -> P t) -> P (node ts)) ->
  forall t : tree, P t.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := fun ts =>
    forall t, mem t ts -> P t); intros.
  auto. auto. inverts H. inverts~ H1.
Qed.

Hint Constructors mem.

(** Example of an inductive proof with Mem
    -- usually not as good as the one with [Forall] *)

Lemma tree_map_pred_succ_3 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. induction t using tree_induct_mem; simpl.
  fequals.
  fequals. induction ts; simpl.
    fequals.
    fequals.
      apply H. constructor.
      apply IHts. introv M. apply H. auto.
Qed.

(** Definition of the relation "immediate subtree of" *)

Import LibRelation LibWf.

Inductive subtree : binary tree :=
  | subtree_intro : forall t ts,
     mem t ts -> subtree t (node ts).
  (* there is typically more than one case here *)

Hint Constructors subtree.

(** Proof of well-foundedness of the subtree relation *)

Lemma subtree_wf : wf subtree.
Proof using.
  intros t. induction t using tree_induct_mem;
  constructor; introv K; inversions~ K.
Qed.

(** Example of a proof on the well-founded subtree order
    -- usually a bit longer, so not recommended *)

Lemma tree_map_pred_succ_4 : forall t,
  tree_map pred (tree_map S t) = t.
Proof using.
  intros. induction_wf IH: subtree_wf t.
  destruct t as [|ts]; simpl.
  fequals.
  fequals. induction ts; simpl.
    fequals.
    fequals.
      applys IH. auto.
      applys IHts. introv M. inverts M.
       auto. (* apply IH. constructors. constructors. *)
Qed.

End SubtermIndDemos.

(* ********************************************************************** *)
(** * Tactics exported by LibVar *)

Module LibVarDemos.
Import LibList LibLN.
Section LibVarDemo.
Implicit Types x y : var.

(* ---------------------------------------------------------------------- *)
(** ** Demo for notin *)

Lemma test_notin_solve_1 : forall x E F G,
  x \notin E \u F -> x \notin G -> x \notin (E \u G).
Proof using.
  intros. dup.
  notin_simpl. notin_solve. notin_solve.
  notin_solve.
Qed.

Lemma test_notin_solve_2 : forall x y E F G,
  x \notin E \u \{y} \u F -> x \notin G ->
  x \notin \{y} /\ y \notin \{x}.
Proof using.
  split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_3 : forall x y,
  x <> y -> x \notin \{y} /\ y \notin \{x}.
Proof using.
  split. notin_solve. notin_solve.
Qed.

Lemma test_notin_solve_4 : forall x y,
  x \notin \{y} -> x <> y /\ y <> x.
Proof using.
  split. notin_solve. notin_solve.
Qed.

Lemma test_notin_false_1 : forall x y E F G,
  x \notin (E \u \{x} \u F) -> y \notin G.
Proof using.
  intros. dup 3.
    false. notin_false.
    notin_false.
    notin_false.
Qed.

Lemma test_notin_false_2 : forall x y : var,
  x <> x -> y = x.
Proof using.
  intros. notin_false.
Qed.

Lemma test_neq_solve : forall x y E F,
  x \notin (E \u \{y} \u F) -> y \notin E ->
  y <> x /\ x <> y.
Proof using.
  split. notin_solve. notin_solve.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Demo for fresh *)

Lemma test_fresh_solve_1 : forall xs L1 L2 n,
  fresh (L1 \u L2) n xs -> fresh L1 n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_2 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L2 n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_3 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh \{} n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_4 : forall xs L1 L2 n,
 fresh (L1 \u L2) n xs -> fresh L1 (length xs) xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_5 : forall xs L1 n m,
  m = n ->
  fresh L1 m xs ->
  fresh L1 n xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_6 : forall xs L1 L2 n m,
  m = n ->
  fresh (L1 \u L2) n xs ->
  fresh L1 m xs.
Proof using.
  intros. fresh_solve.
Qed.

Lemma test_fresh_solve_7 : forall xs L1 L2 n m,
  n = m ->
  fresh (L1 \u L2) n xs ->
  fresh L1 m xs.
Proof using.
  intros. fresh_solve.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Demo of automation of [notin] *)

(* LibVar exports the following hints:
     Hint Extern 1 (_ \notin _) => notin_solve.
     Hint Extern 1 (_ <> _ :> var) => notin_solve.
     Hint Extern 1 ((_ \notin _) /\ _) => splits. *)

Lemma test_notin_by_auto : forall x E F G,
  x \notin E \u F -> x \notin G -> x \notin (E \u G).
Proof using. auto. Qed.

Lemma test_neq_by_auto : forall x y E,
  x \notin E \u \{y} -> y <> x.
Proof using. auto. Qed.

Lemma test_notin_false_by_hand : forall x,
  ~ x \notin \{x}.
Proof using. intros_all. notin_false. Qed.

Hint Extern 1 (~ _ \notin _) => intros_all; notin_false.

Lemma test_notin_false_by_auto : forall x,
  ~ x \notin \{x}.
Proof using. intros_all. notin_false. Qed.

(* Comment: using the following hint is a bad idea because it will
            lead to very inefficient proof scripts.
   Hint Extern 1 (False) => notin_false. *)

(* ---------------------------------------------------------------------- *)
(** ** Demo of pick_fresh_gen *)

Parameter trm : Type.
Parameter fv : trm -> vars.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Lemma test_pick_fresh :
  forall (x y z : var) (L1 L2 L3 : vars) (t1 t2 : trm), True.
Proof using.
  intros. pick_fresh a.
Abort.

End LibVarDemo.
End LibVarDemos.

(* ---------------------------------------------------------------------- *)
(** ** Demo of LibSet tactics *)

From TLC Require Import LibSet.

Lemma inter_union_disjoint_right:
  forall A (E F G : set A),
  F \# G ->
  (E \u F) \n G = (E \n G).
Proof using.
  set_prove.
  (* intros. set_norm. set_specialize. set_norm. tauto. *)
Qed. (* demo *)

Lemma inter_union_subset_right:
  forall A (E F G : set A),
  F \c G ->
  (E \u F) \n G = (E \n G) \u F.
Proof using.
  set_prove.
Qed. (* demo *)

Lemma inter_covariant:
  forall A (E E' F F' : set A),
  E \c E' ->
  F \c F' ->
  (E \n F) \c (E' \n F').
Proof using.
  set_prove.
Qed. (* demo *)

Lemma set_decompose_inter_right :
  forall A (E F : set A),
  E = (E \n F) \u (E \- F).
Proof using.
  set_prove_classic.
Qed. (* demo *)

Lemma set_decompose_union_right :
  forall A (E F : set A),
  (E \u F) = E \u (F \- E).
Proof using.
  set_prove_classic.
Qed. (* demo *)


Require Import POrderedType.
Require Import ZArith Zbool.

(** Adapted from the infra.v library from CAD project *)
Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import Ssreflect.choice fintype finfun ssrfun bigop ssralg. (* orderedalg.*)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma eq_boolP: forall (a b:bool), (a -> b) -> (b -> a) -> a=b.
Proof.
move=> a b Ha Hb.
case Eb: b.
 by apply Hb.
apply/negP => Ea.
move/negP: Eb; apply.
by apply Ha.
Qed.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
(* Various eqtype, subtype, choice, count canonical structures          *)
(*               from the standard library                              *)
(* -------------------------------------------------------------------- *)

(* Structures on positive *)
Require Import BinPos.

Definition eqp (p q : positive) : bool :=
  match ( (Pos.compare_cont p q Eq))%positive with Eq => true | _ => false end.

Lemma eqpP : Equality.axiom eqp.
Proof.
move=> p q; apply: (iffP  idP)=>[|<-]; last by rewrite /eqp Pcompare_refl.
rewrite /eqp; case e: (Pos.compare_cont p q Eq)%positive=> // _; exact: Pcompare_Eq_eq.
Qed.

Canonical Structure eqp_Mixin := EqMixin eqpP.
Canonical Structure eqp_eqType := Eval hnf in @EqType positive eqp_Mixin.

Definition p_unpickle n := Some (Ppred (P_of_succ_nat n)).

Lemma p_pick_cancel : pcancel nat_of_P p_unpickle.
Proof.
move=> x; rewrite /p_unpickle; congr Some.
by rewrite Pnat.pred_o_P_of_succ_nat_o_nat_of_P_eq_id.
Qed.

Definition p_countMixin  := CountMixin p_pick_cancel.
Definition p_choiceMixin := CountChoiceMixin p_countMixin.

Canonical Structure p_choiceType :=
  Eval hnf in ChoiceType positive p_choiceMixin.
Canonical Structure p_countType :=
  Eval hnf in CountType positive p_countMixin.

Section ComparisonAddendum.

(** First, we equip the comparison type with the eqType structure *)
Definition eq_comparison :=
 [rel x y | match x,y with Lt,Lt | Eq,Eq | Gt,Gt => true | _,_ => false end].

Lemma eq_comparisonP :  Equality.axiom eq_comparison.
Proof.
move=> x y; apply: (iffP idP) => [|<-]; last by elim x.
case: x; case: y; by [].
Qed.

Canonical Structure comparison_eqMixin := EqMixin eq_comparisonP.
Canonical Structure comparison_eqType := Eval hnf in @EqType _ comparison_eqMixin.

Implicit Arguments eq_comparisonP [x y].
Prenex Implicits eq_comparisonP.

Lemma eq_comparisonE : eq_comparison = eq_op :> rel _ . Proof. by []. Qed.

End ComparisonAddendum.

(* Structures on Z *)

Lemma eqzP : Equality.axiom Zeq_bool.
Proof. by move=> z1 z2;  apply: (iffP idP); move/Zeq_is_eq_bool. Qed.

Canonical Structure Z_Mixin := EqMixin eqzP.
Require Import ZArith.
Canonical Structure Z_eqType := Eval hnf in EqType Z Z_Mixin.

Definition z_code (z : Z) :=
  match z with
    |0%Z => (0%nat, true)
    |Zpos p => (pickle p, true)
    |Zneg p => (pickle p, false)
  end.

Definition z_pickle z := pickle (z_code z).

Definition z_decode c :=
  match c with
    |(0%nat, true) => Some 0%Z
    |(0%nat, false) => None
    |(n, true) =>
      if (@unpickle p_countType n) is Some p then Some (Zpos p) else None
    |(n, false) =>
      if (@unpickle p_countType n) is Some p then Some (Zneg p) else None
  end.

Definition z_unpickle n :=
  match (unpickle n) with
    |None => None
    |Some u => z_decode u
  end.

Lemma z_codeK : pcancel z_code z_decode.
Proof.
rewrite /z_code /z_decode.
case=> // n; case e : (@pickle p_countType n)=>[|m]; rewrite -?e ?pickleK //;
by move/ltP: (lt_O_nat_of_P n); rewrite -e -[pickle]/nat_of_P ltnn.
Qed.

Lemma z_pick_cancel : pcancel z_pickle z_unpickle.
Proof. by move=> x; rewrite /z_pickle /z_unpickle pickleK z_codeK. Qed.

Definition z_countMixin  := CountMixin z_pick_cancel.
Definition z_choiceMixin := CountChoiceMixin z_countMixin.

Canonical Structure z_choiceType :=
  Eval hnf in ChoiceType Z z_choiceMixin.
Canonical Structure z_countType :=
  Eval hnf in CountType Z z_countMixin.

Lemma ZplusA : associative Zplus.
Proof. by exact Zplus_assoc. Qed.

Lemma ZplusC : commutative Zplus.
Proof. by exact Zplus_comm. Qed.

Lemma Zplus0 : left_id (0%Z) Zplus.
Proof. by exact Zplus_0_l. Qed.

Lemma ZplusNr : left_inverse  0%Z Zopp Zplus.
Proof. exact Zplus_opp_l. Qed.

Lemma ZplusrN : right_inverse 0%Z Zopp Zplus.
Proof. exact Zplus_opp_r. Qed.

Definition Z_zmodMixin :=
  ZmodMixin ZplusA ZplusC Zplus0 ZplusNr.

Canonical Structure Z_zmodType := ZmodType Z Z_zmodMixin.

(* Z Ring *)
Lemma ZmultA : associative Zmult.
Proof. exact: Zmult_assoc. Qed.

Lemma Zmult1q : left_id 1%Z Zmult.
Proof. exact: Zmult_1_l. Qed.

Lemma Zmultq1 : right_id 1%Z Zmult.
Proof. exact: Zmult_1_r. Qed.

Lemma Zmultq0 : forall (q : Z), Zmult q 0%Z = 0%Z.
Proof. exact: Zmult_0_r. Qed.

Lemma Zmult_addl : left_distributive Zmult Zplus.
Proof. exact: Zmult_plus_distr_l. Qed.

Lemma Zmult_addr : right_distributive Zmult Zplus.
Proof. exact: Zmult_plus_distr_r. Qed.

Lemma nonzeroZ1 : 1%Z != 0%Z.
Proof. by []. Qed.

Lemma ZmultC : commutative Zmult.
Proof. exact: Zmult_comm. Qed.

Definition Z_comRingMixin :=
  ComRingMixin ZmultA ZmultC Zmult1q Zmult_addl nonzeroZ1.
(*
Definition Z_ringMixin :=
  RingMixin ZmultA Zmult1q Zmultq1 Zmult_addl Zmult_addr nonzeroZ1.
*)
Canonical Structure Z_Ring := Eval hnf in RingType Z Z_comRingMixin.
Canonical Structure Z_comRing := Eval hnf in ComRingType Z ZmultC.

(*
Canonical Structure Z_ringType :=
  Eval hnf in RingType Z_ringMixin.

Canonical Structure Z_comRingType := ComRingType ZmultC.
*)

(* Warning : an antisymmetric an a transitive predicates are
present in loaded Relations.Relation_Definition *)
Lemma ZleP: forall x y, reflect (x <= y)%Z (Zle_bool x y).
Proof.
move=> x y; apply/(iffP idP).
 by move=> H; apply Zle_bool_imp_le in H.
by move=> H; apply Zle_imp_le_bool.
Qed.

Lemma Zle_bool_antisymb : ssrbool.antisymmetric  Zle_bool.
Proof. by move=> x y; case/andP=> h1 h2; apply: Zle_bool_antisym. Qed.

Lemma Zle_bool_transb : ssrbool.transitive Zle_bool.
Proof. move=> x y z; exact: Zle_bool_trans. Qed.

Lemma Zle_bool_totalb : ssrbool.total Zle_bool.
Proof. by move=> x y; case: (Zle_bool_total x y)=> -> //; rewrite orbT. Qed.

Lemma Zle_bool_addr : forall z x y, Zle_bool x y -> Zle_bool (x + z) (y + z).
Proof. by move=> x y z h; rewrite Zle_bool_plus_mono // Zle_bool_refl. Qed.

Lemma Zle_bool_mulr : forall x y,
  Zle_bool 0 x -> Zle_bool 0 y -> Zle_bool 0 (x * y).
Proof.
move=> x y; move/Zle_is_le_bool=> px; move/Zle_is_le_bool=> py.
by apply/Zle_is_le_bool; apply: Zmult_le_0_compat.
Qed.

Lemma ZltP: forall x y, reflect (x < y)%Z (Zlt_bool x y).
Proof. move=> x y; apply/(iffP idP); by apply Zlt_is_lt_bool. Qed.

Lemma ZgeP: forall x y, reflect (x >= y)%Z (Zge_bool x y).
Proof. move=> x y; apply/(iffP idP); rewrite Z.geb_leb.
 by move => /ZleP; auto with zarith.
by move=> H; apply/ZleP; auto with zarith.
Qed.

Lemma ZgtP: forall x y, reflect (x > y)%Z (Zgt_bool x y).
Proof. move=> x y; apply/(iffP idP); by apply Zgt_is_gt_bool. Qed.

Definition Zunit := pred2 1%Z (-1)%Z.

Definition Zinv (z : Z) := z.

Lemma ZmulV : {in Zunit, left_inverse 1%R Zinv *%R}.
Proof. by move=> x; rewrite inE; case/pred2P => ->. Qed.

(* Zmult_1_inversion_r does not exist *)
Lemma unitZPl : forall x y, y * x = 1 -> Zunit x.
Proof.
move=> y x; rewrite GRing.mulrC -[y * x]/(Zmult y x); move/Zmult_1_inversion_l.
by case=> ->.
Qed.

Lemma  Zinv_out : {in predC Zunit, Zinv =1 id}.
Proof. exact. Qed.

Definition Z_comUnitRingMixin :=  ComUnitRingMixin ZmulV unitZPl Zinv_out.

Canonical Structure Z_unitRingType :=
  Eval hnf in UnitRingType Z Z_comUnitRingMixin.

Canonical Structure Z_comUnitRing := Eval hnf in [comUnitRingType of Z].

(*
Canonical Structure Z_comUnitRing := ComUnitRingType Z_comUnitRingMixin. (*Eval hnf in [comUnitRingType of Z].*)
*)
Lemma Z_idomain_axiom : forall x y : Z,
  x * y = 0 -> (x == 0) || (y == 0).
Proof.
move=> x y; rewrite -[x * y]/(Zmult x y); move/Zmult_integral; case=> -> //=.
by rewrite eqxx orbT.
Qed.
Canonical Structure Z_iDomain := Eval hnf in IdomainType Z Z_idomain_axiom.
(*
Canonical Structure Z_iDomain := Eval hnf in IdomainType Z_idomain_axiom.
*)
(*
Definition Z_OrderedRingMixin :=
  OrderedRing.Mixin
  Zle_bool_antisymb Zle_bool_transb Zle_bool_totalb Zle_bool_addr Zle_bool_mulr.

Canonical Structure Z_oIdomainType :=
  Eval hnf in OIdomainType Z Z_OrderedRingMixin.

*)


(* Second part of the canonical structures documentation from the
   Coq reference manual.
 *)

(* .. _canonicalstructures:

Canonical Structures
======================

:Authors: Assia Mahboubi and Enrico Tassi

This chapter explains the basics of canonical structures and how they can be used
to overload notations and build a hierarchy of algebraic structures. The
examples are taken from :cite:`CSwcu`. We invite the interested reader to refer
to this paper for all the details that are omitted here for brevity. The
interested reader shall also find in :cite:`CSlessadhoc` a detailed description
of another, complementary, use of canonical structures: advanced proof search.
This latter papers also presents many techniques one can employ to tune the
inference of canonical structures.

Notation overloading
-------------------------

We build an infix notation == for a comparison predicate. Such
notation will be overloaded, and its meaning will depend on the types
of the terms that are compared.

.. coqtop:: all *)

  Module EQ.
    Record class (T : Type) := Class { cmp : T -> T -> Prop }.
    Structure type := Pack { obj : Type; class_of : class obj }.
    Definition op (e : type) : obj e -> obj e -> Prop :=
      let 'Pack _ (Class _ the_cmp) := e in the_cmp.
    Check op.
    Arguments op {e} x y : simpl never.
    Arguments Class {T} cmp.
    Module theory.
      Notation "x == y" := (op x y) (at level 70).
    End theory.
  End EQ.

(*
We use Coq modules as namespaces. This allows us to follow the same
pattern and naming convention for the rest of the chapter. The base
namespace contains the definitions of the algebraic structure. To
keep the example small, the algebraic structure ``EQ.type`` we are
defining is very simplistic, and characterizes terms on which a binary
relation is defined, without requiring such relation to validate any
property. The inner theory module contains the overloaded notation ``==``
and will eventually contain lemmas holding all the instances of the
algebraic structure (in this case there are no lemmas).

Note that in practice the user may want to declare ``EQ.obj`` as a
coercion, but we will not do that here.

The following line tests that, when we assume a type ``e`` that is in
the EQ class, we can relate two of its objects with ``==``.

.. coqtop:: all *)

  Import EQ.theory.
  Check forall (e : EQ.type) (a b : EQ.obj e), a == b.

(*
Still, no concrete type is in the ``EQ`` class.

.. coqtop:: all *)

  Fail Check 3 == 3.

(*
We amend that by equipping ``nat`` with a comparison relation.

.. coqtop:: all *)

   Definition nat_eq (x y : nat) := Nat.compare x y = Eq.
   Definition nat_EQcl : EQ.class nat := EQ.Class nat_eq.
   Canonical Structure nat_EQty : EQ.type := EQ.Pack nat nat_EQcl.
   Check 3 == 3.
   Print Canonical Projections.

   Eval compute in 3 == 4.
   Print Canonical Projections.
   Definition ThreeFour := 3 == 4.

(*
This last test shows that |Coq| is now not only able to type check ``3 == 3``,
but also that the infix relation was bound to the ``nat_eq`` relation.
This relation is selected whenever ``==`` is used on terms of type nat.
This can be read in the line declaring the canonical structure
``nat_EQty``, where the first argument to ``Pack`` is the key and its second
argument a group of canonical values associated to the key. In this
case we associate to nat only one canonical value (since its class,
``nat_EQcl`` has just one member). The use of the projection ``op`` requires
its argument to be in the class ``EQ``, and uses such a member (function)
to actually compare its arguments.

Similarly, we could equip any other type with a comparison relation,
and use the ``==`` notation on terms of this type.

Derived Canonical Structures
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We know how to use ``==`` on base types, like ``nat``, ``bool``, ``Z``. Here we show
how to deal with type constructors, i.e. how to make the following
example work:

.. coqtop:: all *)

  Fail Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b).

(*
The error message is telling that |Coq| has no idea on how to compare
pairs of objects. The following construction is telling Coq exactly
how to do that.

.. coqtop:: all *)

  Definition pair_eq (e1 e2 : EQ.type) (x y : EQ.obj e1 * EQ.obj e2) :=
    fst x == fst y /\ snd x == snd y.

  Definition pair_EQcl e1 e2 := EQ.Class (pair_eq e1 e2).

  Canonical Structure pair_EQty (e1 e2 : EQ.type) : EQ.type :=
      EQ.Pack (EQ.obj e1 * EQ.obj e2) (pair_EQcl e1 e2).

  Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b).

  Check forall n m : nat, (3, 4) == (n, m).

(*
Thanks to the ``pair_EQty`` declaration, |Coq| is able to build a comparison
relation for pairs whenever it is able to build a comparison relation
for each component of the pair. The declaration associates to the key ``*``
(the type constructor of pairs) the canonical comparison
relation ``pair_eq`` whenever the type constructor ``*`` is applied to two
types being themselves in the ``EQ`` class.

Hierarchy of structures
----------------------------

To get to an interesting example we need another base class to be
available. We choose the class of types that are equipped with an
order relation, to which we associate the infix ``<=`` notation.

.. coqtop:: all *)

  Module LE.

    Record class T := Class { cmp : T -> T -> Prop }.

    Structure type := Pack { obj : Type; class_of : class obj }.

    Definition op (e : type) : obj e -> obj e -> Prop :=
      let 'Pack _ (Class _ f) := e in f.

    Arguments op {_} x y : simpl never.

    Arguments Class {T} cmp.

    Module theory.

      Notation "x <= y" := (op x y) (at level 70).

    End theory.

  End LE.

(*
As before we register a canonical ``LE`` class for ``nat``.

.. coqtop:: all *)

  Import LE.theory.

  Definition nat_le x y := Nat.compare x y <> Gt.

  Definition nat_LEcl : LE.class nat := LE.Class nat_le.

  Canonical Structure nat_LEty : LE.type := LE.Pack nat nat_LEcl.
  Print Canonical Projections.

(*
And we enable |Coq| to relate pair of terms with ``<=``.

.. coqtop:: all *)

  Definition pair_le e1 e2 (x y : LE.obj e1 * LE.obj e2) :=
     fst x <= fst y /\ snd x <= snd y.

  Definition pair_LEcl e1 e2 := LE.Class (pair_le e1 e2).

  Canonical Structure pair_LEty (e1 e2 : LE.type) : LE.type :=
     LE.Pack (LE.obj e1 * LE.obj e2) (pair_LEcl e1 e2).
  Print Canonical Projections.

  Check (3,4,5) <= (3,4,5).

(*
At the current stage we can use ``==`` and ``<=`` on concrete types, like
tuples of natural numbers, but we can’t develop an algebraic theory
over the types that are equipped with both relations.

.. coqtop:: all *)

  Check 2 <= 3 /\ 2 == 2.

  Fail Check forall (e : EQ.type) (x y : EQ.obj e), x <= y -> y <= x -> x == y.

  Fail Check forall (e : LE.type) (x y : LE.obj e), x <= y -> y <= x -> x == y.

(*
We need to define a new class that inherits from both ``EQ`` and ``LE``.

.. coqtop:: all *)

  Module LEQ.

    Record mixin (e : EQ.type) (le : EQ.obj e -> EQ.obj e -> Prop) :=
      Mixin { compat : forall x y : EQ.obj e, le x y /\ le y x <-> x == y }.

    Record class T := Class {
                        EQ_class : EQ.class T;
                        LE_class : LE.class T;
                        extra : mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class) }.

    Structure type := _Pack { obj : Type; class_of : class obj }.

    Arguments Mixin {e le} _.

    Arguments Class {T} _ _ _.

(*
The mixin component of the ``LEQ`` class contains all the extra content we
are adding to ``EQ`` and ``LE``. In particular it contains the requirement
that the two relations we are combining are compatible.

The `class_of` projection of the `type` structure is annotated as *not canonical*;
it plays no role in the search for instances.

Unfortunately there is still an obstacle to developing the algebraic
theory of this new class.

.. coqtop:: all *)

    Module theory.

    Fail Check forall (le : type) (n m : obj le), n <= m -> n <= m -> n == m.

(*
The problem is that the two classes ``LE`` and ``LEQ`` are not yet related by
a subclass relation. In other words |Coq| does not see that an object of
the ``LEQ`` class is also an object of the ``LE`` class.

The following two constructions tell |Coq| how to canonically build the
``LE.type`` and ``EQ.type`` structure given an ``LEQ.type`` structure on the same
type.

.. coqtop:: all *)

    Definition to_EQ (e : type) : EQ.type :=
       EQ.Pack (obj e) (EQ_class _ (class_of e)).

    Canonical Structure to_EQ.
    Print Canonical Projections.

    Definition to_LE (e : type) : LE.type :=
       LE.Pack (obj e) (LE_class _ (class_of e)).

    Canonical Structure to_LE.
    Print Canonical Projections.

(*
We can now formulate out first theorem on the objects of the ``LEQ``
structure.

.. coqtop:: all *)

     Lemma lele_eq (e : type) (x y : obj e) : x <= y -> y <= x -> x == y.

     now intros; apply (compat _ _ (extra _ (class_of e)) x y); split.

     Qed.

     Arguments lele_eq {e} x y _ _.

     End theory.

  End LEQ.

  Import LEQ.theory.

  Check lele_eq.

(*
Of course one would like to apply results proved in the algebraic
setting to any concrete instate of the algebraic structure.

.. coqtop:: all *)

  Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m.

  Fail apply (lele_eq n m).

  Abort.

  Example test_algebraic2 (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) :
       n <= m -> m <= n -> n == m.

  Fail apply (lele_eq n m).

  Abort.

(*
Again one has to tell |Coq| that the type ``nat`` is in the ``LEQ`` class, and
how the type constructor ``*`` interacts with the ``LEQ`` class. In the
following proofs are omitted for brevity.

.. coqtop:: all *)

  Lemma nat_LEQ_compat (n m : nat) : n <= m /\ m <= n <-> n == m.

  Admitted.

  Definition nat_LEQmx := LEQ.Mixin nat_LEQ_compat.

  Lemma pair_LEQ_compat (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) :
     n <= m /\ m <= n <-> n == m.

  Admitted.

  Definition pair_LEQmx l1 l2 := LEQ.Mixin (pair_LEQ_compat l1 l2).

(*
The following script registers an ``LEQ`` class for ``nat`` and for the type
constructor ``*``. It also tests that they work as expected.

Unfortunately, these declarations are very verbose. In the following
subsection we show how to make them more compact.

.. coqtop:: all *)

  Module Add_instance_attempt.

    Canonical Structure nat_LEQty : LEQ.type :=
      LEQ._Pack nat (LEQ.Class nat_EQcl nat_LEcl nat_LEQmx).

    Canonical Structure pair_LEQty (l1 l2 : LEQ.type) : LEQ.type :=
      LEQ._Pack (LEQ.obj l1 * LEQ.obj l2)
        (LEQ.Class
           (EQ.class_of (pair_EQty (to_EQ l1) (to_EQ l2)))
           (LE.class_of (pair_LEty (to_LE l1) (to_LE l2)))
           (pair_LEQmx l1 l2)).

     Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m.

     now apply (lele_eq n m).

     Qed.

     Example test_algebraic2 (n m : nat * nat) : n <= m -> m <= n -> n == m.

     now apply (lele_eq n m). Qed.

  End Add_instance_attempt.

(*
Note that no direct proof of ``n <= m -> m <= n -> n == m`` is provided by
the user for ``n`` and m of type ``nat * nat``. What the user provides is a
proof of this statement for ``n`` and ``m`` of type ``nat`` and a proof that the
pair constructor preserves this property. The combination of these two
facts is a simple form of proof search that |Coq| performs automatically
while inferring canonical structures.

Compact declaration of Canonical Structures
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We need some infrastructure for that.

.. coqtop:: all *)

  Require Import Strings.String.

  Module infrastructure.

    Inductive phantom {T : Type} (t : T) : Type := Phantom.

    Definition unify {T1 T2} (t1 : T1) (t2 : T2) (s : option string) :=
      phantom t1 -> phantom t2.

    Definition id {T} {t : T} (x : phantom t) := x.

    Notation "[find v | t1 ~ t2 ] p" := (fun v (_ : unify t1 t2 None) => p)
      (at level 50, v ident, only parsing).

    Notation "[find v | t1 ~ t2 | s ] p" := (fun v (_ : unify t1 t2 (Some s)) => p)
      (at level 50, v ident, only parsing).

    Notation "'Error : t : s" := (unify _ t (Some s))
      (at level 50, format "''Error' : t : s").

    Open Scope string_scope.

  End infrastructure.

(*
To explain the notation ``[find v | t1 ~ t2]`` let us pick one of its
instances: ``[find e | EQ.obj e ~ T | "is not an EQ.type" ]``. It should be
read as: “find a class e such that its objects have type T or fail
with message "T is not an EQ.type"”.

The other utilities are used to ask |Coq| to solve a specific unification
problem, that will in turn require the inference of some canonical structures.
They are explained in more details in :cite:`CSwcu`.

We now have all we need to create a compact “packager” to declare
instances of the ``LEQ`` class.

.. coqtop:: all *)

  Import infrastructure.

  Definition packager T e0 le0 (m0 : LEQ.mixin e0 le0) :=
    [find e | EQ.obj e ~ T | "is not an EQ.type" ]
    [find o | LE.obj o ~ T | "is not an LE.type" ]
    [find ce | EQ.class_of e ~ ce ]
    [find co | LE.class_of o ~ co ]
    [find m | m ~ m0 | "is not the right mixin" ]
    LEQ._Pack T (LEQ.Class ce co m).

   Notation Pack T m := (packager T _ _ m _ id _ id _ id _ id _ id).

(*
The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers all
the other pieces of the class ``LEQ`` and declares them as canonical
values associated to the ``T`` key. All in all, the only new piece of
information we add in the ``LEQ`` class is the mixin, all the rest is
already canonical for ``T`` and hence can be inferred by |Coq|.

``Pack`` is a notation, hence it is not type checked at the time of its
declaration. It will be type checked when it is used, an in that case ``T`` is
going to be a concrete type. The odd arguments ``_`` and ``id`` we pass to the
packager represent respectively the classes to be inferred (like ``e``, ``o``,
etc) and a token (``id``) to force their inference. Again, for all the details
the reader can refer to :cite:`CSwcu`.

The declaration of canonical instances can now be way more compact:

.. coqtop:: all *)

  Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx.

  Canonical Structure pair_LEQty (l1 l2 : LEQ.type) :=
     Eval hnf in Pack (LEQ.obj l1 * LEQ.obj l2) (pair_LEQmx l1 l2).

(*
Error messages are also quite intelligible (if one skips to the end of
the message).

.. coqtop:: all *)

  Fail Canonical Structure err := Eval hnf in Pack bool nat_LEQmx.