(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.SemEquiv.
Require Import FCF.DetSem.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
          | 0 =>
            fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
          | S n' =>
            fun (v : Vector.t A (S n' + m)) =>
              let (v1, v2) := splitVector _ _ (Vector.tl v) in
                (Vector.cons _ (Vector.hd v) _ v1, v2)
    end.

Theorem splitVector_append :
  forall (A : Set) n1 (v1 : Vector.t A n1) n2 (v2 : Vector.t A n2),
    splitVector n1 n2 (Vector.append v1 v2) = (v1, v2).

  induction v1; intuition; simpl in *.
  remember ( splitVector n n2 (Vector.append v1 v2)) as z.
  destruct z.
  rewrite IHv1 in Heqz.
  inversion Heqz; subst.
  trivial.
Qed.

Theorem append_splitVector_h :
  forall (A : Set) n1 n2 (x : Vector.t A (n1 + n2)),
   (Vector.append (fst (splitVector n1 n2 x)) (snd (splitVector n1 n2 x))) = x.

  induction n1; intuition; simpl in *.
  destruct (vector_S x).
  destruct H.
  subst.
  simpl.
  remember (splitVector n1 n2 x1) as z.
  destruct z.
  simpl.
  f_equal.
  specialize (IHn1 n2 x1).
  rewrite <- Heqz in IHn1.
  simpl in *.
  trivial.

Qed.

Theorem append_splitVector:
  forall (A : Set) n1 n2 (x : Vector.t A (n1 + n2)) x1 x2,
    (x1, x2) = (splitVector n1 n2 x) ->
   (Vector.append x1 x2) = x.

  intuition.
  specialize (append_splitVector_h _ _ x); intuition.
  rewrite <- H in H0.
  simpl in *.
  trivial.

Qed.

Theorem shiftOut_plus :
  forall (n1 n2 : nat) s b s',
    shiftOut s (n1 + n2) = Some (b, s') ->
    exists b1 b2 s'',
      shiftOut s n1 = Some (b1, s'') /\
      shiftOut s'' n2 = Some (b2, s') /\
      splitVector n1 n2 b = (b1, b2).

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0.
  econstructor.
  econstructor.
  econstructor.
  intuition.
  trivial.

  destruct s; simpl in *.
  discriminate.
  case_eq (shiftOut s (n1 + n2)); intuition.
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  edestruct IHn1.
  eauto.
  destruct H.
  destruct H.
  intuition.
  rewrite H1.
  econstructor.
  econstructor.
  econstructor.
  intuition.
  eauto.
  simpl.
  rewrite H3.
  trivial.

  rewrite H0 in H.
  discriminate.

Qed.

Theorem shiftOut_plus_None :
  forall n1 n2 s,
    shiftOut s (n1 + n2) = None ->
    shiftOut s n1 = None \/
    (exists x s', shiftOut s n1 = Some (x, s') /\
      shiftOut s' n2 = None).

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0.
  right.
  econstructor.
  econstructor.
  intuition.

  destruct s; simpl in *.
  intuition.

  case_eq (shiftOut s (n1 + n2)); intuition.
  rewrite H0 in H.
  destruct p.
  discriminate.
  edestruct IHn1.
  eauto.
  rewrite H1.
  intuition.

  destruct H1.
  destruct H1.
  intuition.

  rewrite H2.
  right.

  econstructor.
  econstructor.
  intuition.
Qed.

Theorem Vector_cons_app_assoc :
  forall (A : Type)(a : A)(n1 n2 : nat)(v1 : Vector.t A n1)(v2 : Vector.t A n2),
    Vector.cons _ a _ (Vector.append v1 v2) =
    Vector.append (Vector.cons _ a _ v1) v2.

  induction n1; intuition; simpl in *.

Qed.

Theorem shiftOut_plus_if :
  forall n1 n2 s s' s'' b1 b2,
    shiftOut s n1 = Some (b1, s') ->
    shiftOut s' n2 = Some (b2, s'') ->
    shiftOut s (n1 + n2) = Some (Vector.append b1 b2, s'').

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0 in H.
  inversion H; clear H; subst.
  simpl in *.
  trivial.

  destruct s; simpl in *.
  discriminate.
  case_eq (shiftOut s n1); intuition.
  rewrite H1 in H.
  destruct p.
  inversion H; clear H; subst.
  erewrite IHn1; eauto.

  rewrite Vector_cons_app_assoc.
  trivial.

  rewrite H1 in H.
  discriminate.
Qed.

Theorem shiftOut_plus_None_if :
  forall n1 n2 s,
    (shiftOut s n1 = None \/
      (exists b s', shiftOut s n1 = Some (b, s') /\
        shiftOut s' n2 = None)) ->
    shiftOut s (n1 + n2) = None.

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0 in H0.
  discriminate.
  destruct H0.
  destruct H.
  intuition.
  rewrite shiftOut_0 in H0.
  inversion H0; clear H0; subst.
  trivial.

  destruct s; simpl in *.
  trivial.

  case_eq (shiftOut s n1); intuition.
  rewrite H in H0.
  destruct p.
  discriminate.

  rewrite H in H0.
  erewrite IHn1.
  trivial.
  intuition.

  destruct H0.
  destruct H.
  intuition.
  destruct s; simpl in *.
  discriminate.

  case_eq (shiftOut s n1); intuition.
  rewrite H in H0.
  destruct p.
  inversion H0; clear H0; subst.
  erewrite IHn1.
  trivial.
  right.
  econstructor.
  econstructor.
  intuition.
  eauto.
  trivial.

  rewrite H in H0.
  discriminate.

Qed.

Theorem Rnd_split_equiv :
  forall n1 n2 z ,
    evalDist
    (x <-$ {0, 1}^(n1 + n2);
      ret (splitVector n1 n2 x)) z ==
    evalDist
    (x1 <-$ {0, 1}^n1;
      x2 <-$ {0, 1}^n2;
      ret (x1, x2)) z.

  intuition.

  eapply det_eq_impl_dist_sem_eq; wftac.
  unfold evalDet_equiv.
  intuition.
  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s (plus n1 n2)); intuition.
  destruct p.
  specialize (shiftOut_plus _ _ _ H); intuition.
  destruct H0.
  destruct H0.
  destruct H0.
  intuition.

  rewrite H in H4.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H8; clear H8; subst.
  simpl in *.
  inversion H7; clear H7; subst.
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  simpl.
  rewrite H0.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  rewrite H3.
  econstructor.

  rewrite H in H4.
  inversion H4; clear H4; subst.

  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s (n1 + n2)); intuition.
  rewrite H in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H5; clear H5; subst.
  simpl in *.
  inversion H4.

  specialize (shiftOut_plus_None _ _ _ H); intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  destruct H1.
  destruct H0.
  intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  simpl.
  rewrite H2.
  econstructor.

  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s n1); intuition.
  rewrite H in H4.
  destruct p.
  inversion H4; clear H4; subst.
  inversion H5; clear H5; subst.
  simpl in *.
  case_eq (shiftOut b1 n2); intuition.
  rewrite H0 in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H6; clear H6; subst.
  simpl in *.
  inversion H5; clear H5; subst.
  econstructor.
  econstructor.
  eauto.
  simpl.

  erewrite shiftOut_plus_if; eauto.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  simpl.

  rewrite splitVector_append.
  econstructor.

  rewrite H0 in H4.
  inversion H4; clear H4; subst.
  rewrite H in H4.
  inversion H4.

  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s n1); intuition.
  rewrite H in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H5; clear H5; subst.
  simpl in *.
  case_eq (shiftOut b1 n2); intuition.
  rewrite H0 in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H6; clear H6; subst.
  simpl in *.
  inversion H5.

  econstructor.
  econstructor.
  eauto.
  simpl.

  erewrite shiftOut_plus_None_if.
  econstructor.
  right.
  econstructor.
  econstructor.
  intuition.
  eauto.
  trivial.

  rewrite H in H4.
  econstructor.
  econstructor.
  eauto.
  simpl.
  erewrite shiftOut_plus_None_if.
  econstructor.

  intuition.
Qed.


Require Import Coq.Program.Basics.
Import EqNotations.

(** A chain (elsewhere called a type-aligned list) is like a list, but with
    dependent types that must link between consequetive pairs. If a list is a
    free monoid, maybe this is a free category? Anyway, it's a useful way to
    represent a typed context since it's composable on both the inside and the
    outside. *)
Inductive chain {X} {P : X -> X -> Type} : X -> X -> Type :=
| chain_nil {A : X} : chain A A
| chain_cons {A B C : X} :
    P A B -> chain B C -> chain A C
.

(** Most definitions and lemmas in this file will mirror that of [list] *)
Arguments chain {X} P _ _.
Infix ":::" := chain_cons (at level 60, right associativity).

Fixpoint chain_app {X} {P : X -> X -> Type} {A B C}
         (c : chain P A B) (c' : chain P B C) : chain P A C :=
  match c in (chain _ A' B') return (B = B' -> chain P A' C) with
  | chain_nil => fun HB => rew [fun B => chain P B C] HB in c'
  | x ::: xs =>
    fun HB =>
      x ::: chain_app xs (rew [fun B => chain P B C] HB in c')
  end eq_refl.
Infix "+++" := chain_app (right associativity, at level 60).

Theorem chain_app_nil_r {X} {P : X -> X -> Type} {A B}
      (c : chain P A B) :
  c +++ chain_nil = c.
Proof.
  induction c; auto.
  cbn.
  rewrite IHc.
  auto.
Qed.

Theorem chain_app_assoc {X} {P : X -> X -> Type} {A B C D : X}
      (c0 : chain P A B) (c1 : chain P B C) (c2 : chain P C D) :
  c0 +++ (c1 +++ c2) = (c0 +++ c1) +++ c2.
Proof.
  induction c0; auto.
  cbn.
  rewrite IHc0.
  auto.
Qed.

Definition chain_snoc {X} {P : X -> X -> Type} {A B C : X} :
  chain P A B -> P B C -> chain P A C :=
  fun c x => c +++ x ::: chain_nil.

Definition chain_fold_right {X} {P : X -> X -> Type}
         {F : X -> Type}
         (f : forall {A B : X}, P A B -> F B -> F A)
         {B : X}
         (b : F B)
  : forall {A : X}, chain P A B -> F A :=
  fix chain_fold_right {A} c :=
    match c in (chain _ A' B') return (B = B' -> F A') with
    | chain_nil => fun HB => rew [F] HB in b
    | x ::: c' =>
      fun HB =>
        f x (chain_fold_right (rew <- [chain P _] HB in c'))
    end eq_refl.

Definition chain_fold_left {X} {P : X -> X -> Type}
           {F : X -> Type}
           (f : forall {A B : X}, F A -> P A B -> F B)
  : forall {A B : X}, F A -> chain P A B -> F B :=
  fix chain_fold_left {A B} a c :=
    match c in (chain _ A' B') return (A = A' -> F B') with
    | chain_nil => fun HA => rew [F] HA in a
    | x ::: c' =>
      fun HA =>
        chain_fold_left (f a (rew <-[fun a => P a _] HA in x)) c'
    end eq_refl.

(** this could be expressed in terms of fold_right, but intermediate steps in
    computation look nicer if it's spelled out as a fixpoint. *)
Definition chain_to_list {X} {P : X -> X -> Type}
           {L : Type}
           (f : forall {A B : X}, P A B -> L)
  : forall {A B : X}, chain P A B -> list L :=
  fix chain_to_list {A B} c :=
    match c with
    | chain_nil => nil
    | x ::: c' =>
      cons (f x) (chain_to_list c')
    end.

(** A bichain is just a chain on a product, but it makes a lot of things easier
   to spell it out. *)

Definition bicurry {A B C D E} (f : A -> B -> C -> D -> E)
  : (A * B) -> (C * D) -> E :=
  fun ab cd => f (fst ab) (snd ab) (fst cd) (snd cd).

Definition bichain {X Y} (P : X -> Y -> X -> Y -> Type)
           (xA : X) (yA : Y) (xB : X) (yB : Y)
  : Type := @chain (X * Y) (bicurry P) (xA, yA) (xB, yB).

Definition bichain_cons {X Y} {P : X -> Y -> X -> Y -> Type} {xA yA xB yB xC yC} :
  P xA yA xB yB -> bichain P xB yB xC yC -> bichain P xA yA xC yC
  := @chain_cons (X * Y) (bicurry P) (xA, yA) (xB, yB) (xC, yC).
(* Note to self: get more creative with notation *)
Infix "::::" := bichain_cons (at level 60, right associativity).

Definition bichain_fold_right {X Y} {P : X -> Y -> X -> Y -> Type}
           {F : X -> Y -> Type}
           (f : forall {xA yA xB yB}, P xA yA xB yB -> F xB yB -> F xA yA)
           {xB yB}
           (b : F xB yB)
           {xA : X} {yA : Y}
           (c : bichain P xA yA xB yB)
  : F xA yA.
Proof.
  refine
    (@chain_fold_right
       (X * Y)
       (bicurry P)
       (prod_curry F)
       _
       (xB, yB)
       b
       (xA, yA)
       c).
  intros [? ?] [? ?] ? ?.
  exact (f _ _ _ _ X0 X1).
Defined.

Definition bichain_to_list {X Y} {P : X -> Y -> X -> Y -> Type}
         {L : Type}
         (f : forall {xA yA xB yB}, P xA yA xB yB -> L)
         {xA yA xB yB} (c : bichain P xA yA xB yB) : list L.
Proof.
  refine (chain_to_list _ c).
  intros [? ?] [? ?] ?.
  eapply f; eauto.
Defined.

Lemma bichain_rect X Y (P : X -> Y -> X -> Y -> Type)
      (motive : forall {xA xB yA yB}, bichain P xA xB yA yB -> Type)
      (case_nil : forall {x y}, @motive x y x y chain_nil)
      (case_cons : forall {xA yA xB yB xC yC}
                          (x : P xA yA xB yB)
                          (xs : bichain P xB yB xC yC),
          motive xs -> motive (x :::: xs)) :
  forall {xA yA xB yB} (c : bichain P xA yA xB yB), motive c.
Proof.
  intros.

  (* "transparent assert" from https://sympa.inria.fr/sympa/arc/coq-club/2015-10/msg00047.html *)
  simple refine (let motive' : forall A B : X * Y, chain (bicurry P) A B -> Type := _ in _). {
    intros [? ?] [? ?].
    apply motive.
  }

  change (motive' _ _ c).
  apply (chain_rect (X * Y) (bicurry P));
    subst motive';
    repeat intros [? ?];
    eauto.
Qed.


(* -------------------------------------------------------------------- *)
(* ------- *) Require Import ClassicalFacts Setoid Morphisms.
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import boolp classical_sets reals distr.

Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.
Set   Printing Projections.

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Parameter (R : realType).

(* -------------------------------------------------------------------- *)
Lemma funext : forall {T U : Type} (f g : T -> U),
  (forall x, f x = g x) -> f = g.
Proof. by move=> T U f g; apply: functional_extensionality_dep. Qed.

Lemma funext2 : forall {T U V : Type} (f g : T -> U -> V),
  (forall x y, f x y = g x y) -> f = g.
Proof. by move=> T U V f g eq; apply/funext=> x; apply/funext. Qed.

(* -------------------------------------------------------------------- *)
Lemma distr_eqP {T : choiceType} (f1 f2 : {distr T / R}) :
  f1 =1 f2 <-> f1 = f2.
Proof.
split=> [|->] //; case: f1 f2 => [mu1 ge0_1 s1 le1_1] [mu2 ge0_2 s2 le1_2].
move/funext => /= eq_mu; have PI (A : Prop): A \/ ~ A by case: (asboolP A); auto.
by subst; congr Distr; apply Prop_irrelevance.
Qed.

(* -------------------------------------------------------------------- *)
Definition Choice T := (ChoiceType (EqType T gen_eqMixin) gen_choiceMixin).

(* -------------------------------------------------------------------- *)
Record premonad := mkPreMonad {
  M    :> Type -> Type;
  unit :  forall {T : Type}, T -> M T;
  bind :  forall {T U : Type}, M T -> (T -> M U) -> M U;
}.

Arguments unit p {T} _.
Arguments bind p {T U} _ _.

(* -------------------------------------------------------------------- *)
Variant ismonad (M : premonad) :=
| IsMonad of
       (forall {T U} (x : T) (f : T -> M U),
          M.(bind) (M.(unit) x) f = f x)
     & (forall {T} (m : M T),
          M.(bind) m M.(unit) = m)
     & (forall {T U V} (m : M T) (f : T -> M U) (g : U -> M V),
          M.(bind) (M.(bind) m f) g = M.(bind) m (fun x => M.(bind) (f x) g)).

(* -------------------------------------------------------------------- *)
Definition dpremonad :=
  {| M    := fun T => {distr (Choice T) / R}
   ; unit := fun T => @dunit R (Choice T)
   ; bind := fun T U m f => @dlet R (Choice T) (Choice U) f m |}.

(* -------------------------------------------------------------------- *)
Lemma ismonad_dpremonad : ismonad dpremonad.
Proof. constructor => [T U x f|T m|T U V m f g] /=.
+ by apply/distr_eqP/dlet_unit.
+ by apply/distr_eqP/dlet_dunit_id.
+ by apply/distr_eqP/dlet_dlet.
Qed.


(** * Typing Environment Definition and Function Manipulation.*)
Require Import base ut_term.
Require Import List.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Le Gt.

Module Type ut_env_mod (X: term_sig) (TM: ut_term_mod X).
 Import TM.

(** Since we use de Bruijn indexes, Environment (or Context) are
simply lists of terms:  Γ(x:A) is encoded as  [A::Γ]. *)

Definition Env := list Term.

(** 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) : UT_scope.

Lemma fun_item: forall T (A B:T)(Γ:list T)(n:nat),
  A ↓ n ∈ Γ -> B ↓ n ∈ Γ -> A = B.
intros T A B  Γ n;revert T A B Γ.
induction n; intros.
inversion H; inversion H0.
rewrite <- H2 in H1; injection H1; trivial.
inversion H; inversion H0; subst.
injection H5; intros; subst.
apply IHn with (Γ:=Γ0); trivial.
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) Γ Γ'.
intros T n; induction n; intros.
inversion H.
exists Γ0.
apply trunc_S; apply trunc_O.
inversion H; subst.
destruct (IHn Γ0 t H2).
exists x.
apply trunc_S.
apply H0.
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:Term): nat->Env -> Env  ->Prop :=
  | ins_O: ins_in_env Γ d1 O Γ (d1::Γ)
  | ins_S: forall (n:nat)(Δ Δ':Env )(d:Term), (ins_in_env Γ d1 n Δ Δ')
    -> ins_in_env Γ d1 (S n) (d::Δ) ( (d ↑ 1 # n)::Δ' ).

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':Term) (n:nat) (Γ Δ Δ':Env),
  ins_in_env Γ d' n Δ Δ' ->
  forall (v:nat), n<=v ->
 forall (d:Term),  d ↓ v ∈ Δ  -> d ↓ (S v) ∈ Δ'.
induction n; intros.
inversion H; subst.
apply item_tl. exact H1.
inversion H; subst.
apply item_tl.
destruct v.
elim (le_Sn_O n H0).
apply IHn with (Γ:=Γ) (Δ:=Δ0).
trivial.
apply le_S_n ; trivial.
inversion H1.
exact H4.
Qed.

(* begin hide *)
Lemma gt_O: forall v, ~ 0 > v.
intros; intro.
unfold gt in H. apply lt_n_O in H; trivial.
Qed.
(* end hide *)

Lemma ins_item_lt: forall (d':Term)(n:nat)(Γ Δ Δ':Env),
 ins_in_env Γ d' n Δ Δ' ->
 forall (v:nat), n > v ->
 forall (d:Term), d ↓ v ∈ Δ -> (d ↑ 1 # (n-S v)) ↓ v ∈ Δ' .
induction n; intros.
elim (gt_O H0).
inversion H; subst.
destruct v.
inversion H1; subst.
replace (S n -1) with n by intuition.
apply item_hd.
apply item_tl.
replace (S n - S (S v)) with (n -S v) by intuition.
apply IHn with (Γ:=Γ) (Δ:=Δ0).
exact H3.
intuition.
inversion H1.
exact H4.
Qed.

(** In the list [Γ], [t] is  [n]th element correctly lifted according to [Γ]:
e.g.: if t ↓ n ⊂ Γ and we insert something in Γ, then
we can still speak about t without think of the lift hidden by the insertion. *)

Definition item_lift (t:Term) (Γ:Env) (n:nat) :=
     exists u ,  t= u ↑ (S n) /\  u ↓ n ∈ Γ .

Hint Unfold item_lift.
Notation " t ↓ n ⊂ Γ " := (item_lift t Γ n) (at level 80, no associativity): UT_scope.

(** Properties of the item_lift notation.*)
Lemma ins_item_lift_lt: forall  (d':Term)(n:nat)(Γ Δ Δ':Env ),
 ins_in_env Γ d' n Δ Δ' ->
 forall (v:nat),  n>v ->
 forall (t:Term), t ↓ v ⊂ Δ  -> (t ↑ 1 # n) ↓ v ⊂ Δ'.
intros.
destruct H1 as [u [ P Q]].
rewrite P.
exists (u ↑ 1 # (n - S v) ); split.
replace n with ( S v + (n -  S v))  by intuition .
rewrite liftP2.
replace (S v+(n-S v)-S v) with (n-S v) by intuition.
reflexivity.
intuition.
clear t P.
inversion H; subst.
elim (gt_O H0).
inversion Q; subst.
replace (S n0 -1) with n0 by intuition.
apply item_hd.
apply item_tl.
replace (S n0 - S (S n)) with (n0 -S n) by intuition.
apply ins_item_lt with d' Γ Δ0; trivial.
intuition.
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 T:Term):
  nat -> Env -> Env -> Prop :=
    | sub_O :  sub_in_env Γ t T 0 (T :: Γ) Γ
    | sub_S :
        forall Δ Δ' n  B,
        sub_in_env Γ t T n Δ Δ' ->
        sub_in_env Γ t T (S n) (B :: Δ) ( B [n← t]  :: Δ').

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 T,
   sub_in_env Γ t T n Δ Δ' ->
   forall v : nat, n <= v ->
   forall d , d ↓ (S v) ∈ Δ -> d ↓ v ∈ Δ'.
intros n Γ Δ Δ' t T H; induction H; intros.
inversion H0; subst. trivial.
inversion H1; subst.
destruct v.
elim (le_Sn_O n H0).
apply item_tl.
apply le_S_n in H0.
apply IHsub_in_env; trivial.
Qed.

Lemma nth_sub_eq :
   forall t T n Γ Δ Δ',
   sub_in_env Γ t T n Δ Δ' ->
  forall d , d↓ n ∈ Δ -> T = d.
intros  t T n Γ Δ Δ' H; induction H; intros.
inversion H; trivial.
inversion H0; subst.
apply IHsub_in_env; trivial.
Qed.

Lemma nth_sub_inf :
   forall t T n Γ Δ Δ',
   sub_in_env Γ t T n Δ Δ' ->
   forall v : nat,
   n > v ->
   forall d , d ↓ v ∈ Δ ->  ( d [n - S v ← t] )↓ v ∈ Δ' .
intros t T n Γ Δ Δ' H; induction H; intros.
elim (gt_O  H).
destruct v.
inversion H1; subst.
replace (S n -1) with n by intuition.
apply item_hd.
replace (S n - S (S v)) with (n - S v) by intuition.
inversion H1; subst.
apply item_tl.
apply gt_S_n in H0.
apply IHsub_in_env; trivial.
Qed.

Lemma nth_sub_item_inf :
   forall t T n g e f , sub_in_env g t T n e f ->
   forall v : nat, n > v ->
   forall u , item_lift u e v -> item_lift (subst_rec t u n) f v.
intros.
destruct H1 as [y [K L]].
exists (subst_rec t y (n-S v)); split.
rewrite K; clear u K.
pattern n at 1 .
replace n with (S v + ( n - S v)) by intuition.
apply substP2; intuition.
apply nth_sub_inf with T g  e; trivial.
Qed.

End ut_env_mod.


(** * Unscoped syntax example *)

Require Export unscoped.

Section type.
Inductive type  : Type :=
  | var_type : ( fin ) -> type
  | all : ( type   ) -> ( type   ) -> type .

Lemma congr_all  { s0 : type   } { s1 : type   } { t0 : type   } { t1 : type   } (H1 : s0 = t0) (H2 : s1 = t1) : all  s0 s1 = all  t0 t1 .
Proof. congruence. Qed.

Definition upRen_type_type   (xi : ( fin ) -> fin) : ( fin ) -> fin :=
  (up_ren) xi.

Fixpoint ren_type   (xitype : ( fin ) -> fin) (s : type ) : type  :=
    match s return type  with
    | var_type  s => (var_type ) (xitype s)
    | all  s0 s1 => all  ((ren_type xitype) s0) ((ren_type (upRen_type_type xitype)) s1)
    end.

Definition up_type_type   (sigma : ( fin ) -> type ) : ( fin ) -> type  :=
  (scons) ((var_type ) (var_zero)) ((funcomp) (ren_type (shift)) sigma).

Fixpoint subst_type   (sigmatype : ( fin ) -> type ) (s : type ) : type  :=
    match s return type  with
    | var_type  s => sigmatype s
    | all  s0 s1 => all  ((subst_type sigmatype) s0) ((subst_type (up_type_type sigmatype)) s1)
    end.

Definition upId_type_type  (sigma : ( fin ) -> type ) (Eq : forall x, sigma x = (var_type ) x) : forall x, (up_type_type sigma) x = (var_type ) x :=
  fun n => match n with
  | S fin_n => (ap) (ren_type (shift)) (Eq fin_n)
  | 0  => eq_refl
  end.

Fixpoint idSubst_type  (sigmatype : ( fin ) -> type ) (Eqtype : forall x, sigmatype x = (var_type ) x) (s : type ) : subst_type sigmatype s = s :=
    match s return subst_type sigmatype s = s with
    | var_type  s => Eqtype s
    | all  s0 s1 => congr_all ((idSubst_type sigmatype Eqtype) s0) ((idSubst_type (up_type_type sigmatype) (upId_type_type (_) Eqtype)) s1)
    end.

Definition upExtRen_type_type   (xi : ( fin ) -> fin) (zeta : ( fin ) -> fin) (Eq : forall x, xi x = zeta x) : forall x, (upRen_type_type xi) x = (upRen_type_type zeta) x :=
  fun n => match n with
  | S fin_n => (ap) (shift) (Eq fin_n)
  | 0  => eq_refl
  end.

Fixpoint extRen_type   (xitype : ( fin ) -> fin) (zetatype : ( fin ) -> fin) (Eqtype : forall x, xitype x = zetatype x) (s : type ) : ren_type xitype s = ren_type zetatype s :=
    match s return ren_type xitype s = ren_type zetatype s with
    | var_type  s => (ap) (var_type ) (Eqtype s)
    | all  s0 s1 => congr_all ((extRen_type xitype zetatype Eqtype) s0) ((extRen_type (upRen_type_type xitype) (upRen_type_type zetatype) (upExtRen_type_type (_) (_) Eqtype)) s1)
    end.

Definition upExt_type_type   (sigma : ( fin ) -> type ) (tau : ( fin ) -> type ) (Eq : forall x, sigma x = tau x) : forall x, (up_type_type sigma) x = (up_type_type tau) x :=
  fun n => match n with
  | S fin_n => (ap) (ren_type (shift)) (Eq fin_n)
  | 0  => eq_refl
  end.

Fixpoint ext_type   (sigmatype : ( fin ) -> type ) (tautype : ( fin ) -> type ) (Eqtype : forall x, sigmatype x = tautype x) (s : type ) : subst_type sigmatype s = subst_type tautype s :=
    match s return subst_type sigmatype s = subst_type tautype s with
    | var_type  s => Eqtype s
    | all  s0 s1 => congr_all ((ext_type sigmatype tautype Eqtype) s0) ((ext_type (up_type_type sigmatype) (up_type_type tautype) (upExt_type_type (_) (_) Eqtype)) s1)
    end.

Definition up_ren_ren_type_type    (xi : ( fin ) -> fin) (tau : ( fin ) -> fin) (theta : ( fin ) -> fin) (Eq : forall x, ((funcomp) tau xi) x = theta x) : forall x, ((funcomp) (upRen_type_type tau) (upRen_type_type xi)) x = (upRen_type_type theta) x :=
  up_ren_ren xi tau theta Eq.

Fixpoint compRenRen_type    (xitype : ( fin ) -> fin) (zetatype : ( fin ) -> fin) (rhotype : ( fin ) -> fin) (Eqtype : forall x, ((funcomp) zetatype xitype) x = rhotype x) (s : type ) : ren_type zetatype (ren_type xitype s) = ren_type rhotype s :=
    match s return ren_type zetatype (ren_type xitype s) = ren_type rhotype s with
    | var_type  s => (ap) (var_type ) (Eqtype s)
    | all  s0 s1 => congr_all ((compRenRen_type xitype zetatype rhotype Eqtype) s0) ((compRenRen_type (upRen_type_type xitype) (upRen_type_type zetatype) (upRen_type_type rhotype) (up_ren_ren (_) (_) (_) Eqtype)) s1)
    end.

Definition up_ren_subst_type_type    (xi : ( fin ) -> fin) (tau : ( fin ) -> type ) (theta : ( fin ) -> type ) (Eq : forall x, ((funcomp) tau xi) x = theta x) : forall x, ((funcomp) (up_type_type tau) (upRen_type_type xi)) x = (up_type_type theta) x :=
  fun n => match n with
  | S fin_n => (ap) (ren_type (shift)) (Eq fin_n)
  | 0  => eq_refl
  end.

Fixpoint compRenSubst_type    (xitype : ( fin ) -> fin) (tautype : ( fin ) -> type ) (thetatype : ( fin ) -> type ) (Eqtype : forall x, ((funcomp) tautype xitype) x = thetatype x) (s : type ) : subst_type tautype (ren_type xitype s) = subst_type thetatype s :=
    match s return subst_type tautype (ren_type xitype s) = subst_type thetatype s with
    | var_type  s => Eqtype s
    | all  s0 s1 => congr_all ((compRenSubst_type xitype tautype thetatype Eqtype) s0) ((compRenSubst_type (upRen_type_type xitype) (up_type_type tautype) (up_type_type thetatype) (up_ren_subst_type_type (_) (_) (_) Eqtype)) s1)
    end.

Definition up_subst_ren_type_type    (sigma : ( fin ) -> type ) (zetatype : ( fin ) -> fin) (theta : ( fin ) -> type ) (Eq : forall x, ((funcomp) (ren_type zetatype) sigma) x = theta x) : forall x, ((funcomp) (ren_type (upRen_type_type zetatype)) (up_type_type sigma)) x = (up_type_type theta) x :=
  fun n => match n with
  | S fin_n => (eq_trans) (compRenRen_type (shift) (upRen_type_type zetatype) ((funcomp) (shift) zetatype) (fun x => eq_refl) (sigma fin_n)) ((eq_trans) ((eq_sym) (compRenRen_type zetatype (shift) ((funcomp) (shift) zetatype) (fun x => eq_refl) (sigma fin_n))) ((ap) (ren_type (shift)) (Eq fin_n)))
  | 0  => eq_refl
  end.

Fixpoint compSubstRen_type    (sigmatype : ( fin ) -> type ) (zetatype : ( fin ) -> fin) (thetatype : ( fin ) -> type ) (Eqtype : forall x, ((funcomp) (ren_type zetatype) sigmatype) x = thetatype x) (s : type ) : ren_type zetatype (subst_type sigmatype s) = subst_type thetatype s :=
    match s return ren_type zetatype (subst_type sigmatype s) = subst_type thetatype s with
    | var_type  s => Eqtype s
    | all  s0 s1 => congr_all ((compSubstRen_type sigmatype zetatype thetatype Eqtype) s0) ((compSubstRen_type (up_type_type sigmatype) (upRen_type_type zetatype) (up_type_type thetatype) (up_subst_ren_type_type (_) (_) (_) Eqtype)) s1)
    end.

Definition up_subst_subst_type_type    (sigma : ( fin ) -> type ) (tautype : ( fin ) -> type ) (theta : ( fin ) -> type ) (Eq : forall x, ((funcomp) (subst_type tautype) sigma) x = theta x) : forall x, ((funcomp) (subst_type (up_type_type tautype)) (up_type_type sigma)) x = (up_type_type theta) x :=
  fun n => match n with
  | S fin_n => (eq_trans) (compRenSubst_type (shift) (up_type_type tautype) ((funcomp) (up_type_type tautype) (shift)) (fun x => eq_refl) (sigma fin_n)) ((eq_trans) ((eq_sym) (compSubstRen_type tautype (shift) ((funcomp) (ren_type (shift)) tautype) (fun x => eq_refl) (sigma fin_n))) ((ap) (ren_type (shift)) (Eq fin_n)))
  | 0  => eq_refl
  end.

Fixpoint compSubstSubst_type    (sigmatype : ( fin ) -> type ) (tautype : ( fin ) -> type ) (thetatype : ( fin ) -> type ) (Eqtype : forall x, ((funcomp) (subst_type tautype) sigmatype) x = thetatype x) (s : type ) : subst_type tautype (subst_type sigmatype s) = subst_type thetatype s :=
    match s return subst_type tautype (subst_type sigmatype s) = subst_type thetatype s with
    | var_type  s => Eqtype s
    | all  s0 s1 => congr_all ((compSubstSubst_type sigmatype tautype thetatype Eqtype) s0) ((compSubstSubst_type (up_type_type sigmatype) (up_type_type tautype) (up_type_type thetatype) (up_subst_subst_type_type (_) (_) (_) Eqtype)) s1)
    end.

Definition rinstInst_up_type_type   (xi : ( fin ) -> fin) (sigma : ( fin ) -> type ) (Eq : forall x, ((funcomp) (var_type ) xi) x = sigma x) : forall x, ((funcomp) (var_type ) (upRen_type_type xi)) x = (up_type_type sigma) x :=
  fun n => match n with
  | S fin_n => (ap) (ren_type (shift)) (Eq fin_n)
  | 0  => eq_refl
  end.

Fixpoint rinst_inst_type   (xitype : ( fin ) -> fin) (sigmatype : ( fin ) -> type ) (Eqtype : forall x, ((funcomp) (var_type ) xitype) x = sigmatype x) (s : type ) : ren_type xitype s = subst_type sigmatype s :=
    match s return ren_type xitype s = subst_type sigmatype s with
    | var_type  s => Eqtype s
    | all  s0 s1 => congr_all ((rinst_inst_type xitype sigmatype Eqtype) s0) ((rinst_inst_type (upRen_type_type xitype) (up_type_type sigmatype) (rinstInst_up_type_type (_) (_) Eqtype)) s1)
    end.

Lemma rinstInst_type   (xitype : ( fin ) -> fin) : ren_type xitype = subst_type ((funcomp) (var_type ) xitype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => rinst_inst_type xitype (_) (fun n => eq_refl) x)). Qed.

Lemma instId_type  : subst_type (var_type ) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_type (var_type ) (fun n => eq_refl) ((id) x))). Qed.

Lemma rinstId_type  : @ren_type   (id) = id .
Proof. exact ((eq_trans) (rinstInst_type ((id) (_))) instId_type). Qed.

Lemma varL_type   (sigmatype : ( fin ) -> type ) : (funcomp) (subst_type sigmatype) (var_type ) = sigmatype .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma varLRen_type   (xitype : ( fin ) -> fin) : (funcomp) (ren_type xitype) (var_type ) = (funcomp) (var_type ) xitype .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma compComp_type    (sigmatype : ( fin ) -> type ) (tautype : ( fin ) -> type ) (s : type ) : subst_type tautype (subst_type sigmatype s) = subst_type ((funcomp) (subst_type tautype) sigmatype) s .
Proof. exact (compSubstSubst_type sigmatype tautype (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_type    (sigmatype : ( fin ) -> type ) (tautype : ( fin ) -> type ) : (funcomp) (subst_type tautype) (subst_type sigmatype) = subst_type ((funcomp) (subst_type tautype) sigmatype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_type sigmatype tautype n)). Qed.

Lemma compRen_type    (sigmatype : ( fin ) -> type ) (zetatype : ( fin ) -> fin) (s : type ) : ren_type zetatype (subst_type sigmatype s) = subst_type ((funcomp) (ren_type zetatype) sigmatype) s .
Proof. exact (compSubstRen_type sigmatype zetatype (_) (fun n => eq_refl) s). Qed.

Lemma compRen'_type    (sigmatype : ( fin ) -> type ) (zetatype : ( fin ) -> fin) : (funcomp) (ren_type zetatype) (subst_type sigmatype) = subst_type ((funcomp) (ren_type zetatype) sigmatype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compRen_type sigmatype zetatype n)). Qed.

Lemma renComp_type    (xitype : ( fin ) -> fin) (tautype : ( fin ) -> type ) (s : type ) : subst_type tautype (ren_type xitype s) = subst_type ((funcomp) tautype xitype) s .
Proof. exact (compRenSubst_type xitype tautype (_) (fun n => eq_refl) s). Qed.

Lemma renComp'_type    (xitype : ( fin ) -> fin) (tautype : ( fin ) -> type ) : (funcomp) (subst_type tautype) (ren_type xitype) = subst_type ((funcomp) tautype xitype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renComp_type xitype tautype n)). Qed.

Lemma renRen_type    (xitype : ( fin ) -> fin) (zetatype : ( fin ) -> fin) (s : type ) : ren_type zetatype (ren_type xitype s) = ren_type ((funcomp) zetatype xitype) s .
Proof. exact (compRenRen_type xitype zetatype (_) (fun n => eq_refl) s). Qed.

Lemma renRen'_type    (xitype : ( fin ) -> fin) (zetatype : ( fin ) -> fin) : (funcomp) (ren_type zetatype) (ren_type xitype) = ren_type ((funcomp) zetatype xitype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renRen_type xitype zetatype n)). Qed.

End type.

Global Instance Subst_type   : Subst1 (( fin ) -> type ) (type ) (type ) := @subst_type   .

Global Instance Ren_type   : Ren1 (( fin ) -> fin) (type ) (type ) := @ren_type   .

Global Instance VarInstance_type  : Var (fin) (type ) := @var_type  .

Notation "x '__type'" := (var_type x) (at level 5, format "x __type") : subst_scope.

Notation "x '__type'" := (@ids (_) (_) VarInstance_type x) (at level 5, only printing, format "x __type") : subst_scope.

Notation "'var'" := (var_type) (only printing, at level 1) : subst_scope.

Class Up_type X Y := up_type : ( X ) -> Y.

Notation "↑__type" := (up_type) (only printing) : subst_scope.

Notation "↑__type" := (up_type_type) (only printing) : subst_scope.

Global Instance Up_type_type   : Up_type (_) (_) := @up_type_type   .

(* Notation "s [ sigmatype ]" := (subst_type sigmatype s) (at level 7, left associativity, only printing) : subst_scope. *)

Notation "[ sigmatype ]" := (subst_type sigmatype) (at level 1, left associativity, only printing) : fscope.

(* Notation "s ⟨ xitype ⟩" := (ren_type xitype s) (at level 7, left associativity, only printing) : subst_scope. *)

(* Notation "⟨ xitype ⟩" := (ren_type xitype) (at level 1, left associativity, only printing) : fscope. *)

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_type,  Ren_type,  VarInstance_type.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_type,  Ren_type,  VarInstance_type in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_type| progress rewrite ?compComp_type| progress rewrite ?compComp'_type| progress rewrite ?rinstId_type| progress rewrite ?compRen_type| progress rewrite ?compRen'_type| progress rewrite ?renComp_type| progress rewrite ?renComp'_type| progress rewrite ?renRen_type| progress rewrite ?renRen'_type| progress rewrite ?varL_type| progress rewrite ?varLRen_type| progress (unfold up_ren, upRen_type_type, up_type_type)| progress (cbn [subst_type ren_type])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_type in *| progress rewrite ?compComp_type in *| progress rewrite ?compComp'_type in *| progress rewrite ?rinstId_type in *| progress rewrite ?compRen_type in *| progress rewrite ?compRen'_type in *| progress rewrite ?renComp_type in *| progress rewrite ?renComp'_type in *| progress rewrite ?renRen_type in *| progress rewrite ?renRen'_type in *| progress rewrite ?varL_type in *| progress rewrite ?varLRen_type in *| progress (unfold up_ren, upRen_type_type, up_type_type in *)| progress (cbn [subst_type ren_type] in *)| fsimpl in *].

Ltac substify := auto_unfold; try repeat (erewrite rinstInst_type).

Ltac renamify := auto_unfold; try repeat (erewrite <- rinstInst_type).


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Import CoRN.algebra.CSetoids.
Set Automatic Introduction.

(**
** Setoids of the first [n] natural numbers
*)

Record F (n:nat):Set:=
{F_crr:> nat ;
F_prf: F_crr<n
}.

Definition Feq (n : nat) : F n -> F n -> Prop.
Proof.
 intros a b.
 case a.
 case b.
 intros x H x0 H0.
 exact (x = x0).
Defined.

Definition Fap (n : nat) : F n -> F n -> CProp.
Proof.
 intros a b.
 case a.
 case b.
 intros x H x0 H0.
 exact (x <> x0).
Defined.

Lemma Fap_irreflexive : forall n : nat, irreflexive (Fap n).
Proof.
 unfold irreflexive in |- *.
 unfold Fap in |- *.
 intros n x.
 case x.
 intuition.
 red in |- *.
 intuition.
Qed.

Lemma Fap_symmetric : forall n : nat, Csymmetric (Fap n).
Proof.
 intro n.
 unfold Csymmetric in |- *.
 unfold Fap in |- *.
 intros x y.
 case x.
 case y.
 intuition.
Qed.

Lemma Fap_cotransitive : forall n : nat, cotransitive (Fap n).
Proof.
 intro n.
 unfold cotransitive in |- *.
 unfold Fap in |- *.
 intros x y.
 case x.
 case y.
 intros x0 H0 x1 H1 H2 z.
 case z.
 intros x2 H.
 set (H5 := eq_nat_dec x2 x1) in *.
 elim H5.
  clear H5.
  intro H5.
  right.
  rewrite H5.
  exact H2.
 clear H5.
 intro H5.
 left.
 exact H5.
Qed.

Lemma Fap_tight : forall n : nat, tight_apart (Feq n) (Fap n).
Proof.
 unfold tight_apart in |- *.
 unfold Fap in |- *.
 unfold Feq in |- *.
 intros n x y.
 case x.
 case y.
 intros x0 H0 x1 H1.
 red in |- *.
 unfold not in |- *.
 unfold Not in |- *.
 intuition.
Qed.

Definition less (n : nat) :=
  Build_is_CSetoid (F n) (Feq n) (Fap n) (Fap_irreflexive n)
    (Fap_symmetric n) (Fap_cotransitive n) (Fap_tight n).

Definition CSetoid_of_less (n : nat) : CSetoid :=
  Build_CSetoid (F n) (Feq n) (Fap n) (less n).


(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import Lqa.
Require Import QArith.

Lemma plus_minus : forall x y,
  0 == x + y -> 0 ==  x -y -> 0 == x /\ 0 == y.
Proof.
  intros.
  lra.
Qed.

(* Other (simple) examples *)
Open Scope Q_scope.

Lemma binomial : forall x y:Q, ((x+y)^2 == x^2 + (2 # 1) *x*y + y^2).
Proof.
  intros.
  lra.
Qed.

Lemma hol_light19 : forall m n, (2 # 1) * m + n == (n + m) + m.
Proof.
  intros ; lra.
Qed.
Open Scope Z_scope.
Open Scope Q_scope.

Lemma vcgen_25 : forall
  (n : Q)
  (m : Q)
  (jt : Q)
  (j : Q)
  (it : Q)
  (i : Q)
  (H0 : 1 * it + (-2 # 1) * i + (-1 # 1) == 0)
  (H :  1 * jt + (-2 # 1) * j + (-1 # 1) == 0)
  (H1 : 1 * n + (-10 # 1) = 0)
  (H2 : 0 <= (-4028 # 1)  * i + (6222 # 1) * j + (705 # 1)  * m + (-16674 # 1))
  (H3 : 0 <= (-418 # 1) * i + (651 # 1) * j + (94 # 1) * m + (-1866 # 1))
  (H4 : 0 <= (-209 # 1) * i + (302 # 1) * j + (47 # 1) * m + (-839 # 1))
  (H5 : 0 <= (-1 # 1) * i + 1 * j + (-1 # 1))
  (H6 : 0 <= (-1 # 1) * j + 1 * m + (0 # 1))
  (H7 : 0 <= (1 # 1) * j + (5 # 1) * m + (-27 # 1))
  (H8 : 0 <= (2 # 1) * j + (-1 # 1) * m + (2 # 1))
  (H9 : 0 <= (7 # 1) * j + (10 # 1) * m + (-74 # 1))
  (H10 : 0 <= (18 # 1) * j + (-139 # 1) * m + (1188 # 1))
  (H11 : 0 <= 1  * i + (0 # 1))
  (H13 : 0 <= (121 # 1)  * i + (810 # 1)  * j + (-7465 # 1) * m + (64350 # 1)),
  (( 1# 1) == (-2 # 1) * i + it).
Proof.
  intros.
  lra.
Qed.

Goal forall x : Q, x * x >= 0.
  intro; nra.
Qed.

Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False.
Proof.
  intros.
  psatz Q 3.
Qed.

Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 # 1) *x^2*y^2) >= 0.
Proof.
  intros ; psatz Q 3.
Qed.


(** ** Variadic Preservation *)

Require Export ARS Program.Equality.
Require Import core core_axioms fintype fintype_axioms.
Import ScopedNotations.
From Chapter6 Require Export variadic_fin.
Set Implicit Arguments.
Unset Strict Implicit.

Ltac inv H := dependent destruction H.
Hint Constructors star.

(** *** Single-step reduction *)
Inductive step {n} : tm n -> tm n -> Prop :=
| step_beta p b (t: fin p -> tm n) : step (app _ (lam p b) t) (b[scons_p p t ids])
| step_abs  p b1 b2 : @step (p + n) b1 b2 -> step (lam p b1) (lam p b2)
| step_appL p s1 s2 t : step s1 s2 -> step (app p s1 t) (app _ s2 t).

Hint Constructors step.

Lemma step_beta' n p b (t: fin p -> tm n) t':
  t' = b[scons_p p t ids] -> step (app _ (lam p b) t) t'.
Proof. intros ->. now constructor. Qed.

(** *** Substitutivity *)

Lemma step_inst {m n} (f : fin m -> tm n) (s t : tm m) :
  step s t -> step (subst_tm f s) (subst_tm f t).
Proof.
  intros st. revert n f.  induction st; intros; cbn.
  - apply step_beta'. now asimpl.
  - apply step_abs. eapply IHst.
  - apply step_appL, IHst.
Qed.

Lemma mstep_inst m n (f : fin m -> tm n) (s t : tm m) :
  star step s t -> star step (s[f]) (t[f]).
Proof. induction 1; eauto using step_inst. Qed.

(** *** Variadic typing *)

Inductive ty  : Type :=
  | Base : ty
  | arr p : (fin p -> ty)  -> ty  -> ty .

Definition ctx n := fin n -> ty.

Inductive has_type {n} (Gamma : ctx n) : tm n -> ty -> Prop :=
| ty_var (x : fin n) :
    has_type Gamma (var_tm x) (Gamma x)
| ty_abs p (S1 : fin p -> ty) ( S2 : ty) (M : tm (p + n)) :
    @has_type (p + n) (scons_p p S1 Gamma) M S2 ->
    has_type Gamma (lam p M) (arr S1 S2)
| ty_app p (T : fin p -> ty) ( S : ty) (M  : tm n) N :
    has_type Gamma M (arr T S) ->
    (forall x, has_type Gamma (N x) (T x)) ->
    has_type Gamma (app p M N) S.
Notation "Gamma |- M : T" := (has_type Gamma M T) (at level 20, M at level 99).

Lemma ty_var' n  (x : fin n) A Gamma:
  A = Gamma x ->  has_type Gamma (var_tm x) A.
Proof. intros. subst. constructor. Qed.

Definition ltc {k k'} (Gamma: ctx k) (Delta: ctx k') rho := forall x, Delta (rho x) = Gamma x.

Lemma typing_ren n k (Gamma: ctx n) (Delta: ctx k) (rho: fin n -> fin k) (M: tm n) T :
  ltc Gamma Delta rho  -> Gamma |- M : T ->  Delta |- (M⟨rho⟩) : T.
Proof.
  intros C H. revert k Delta rho C. induction H; intros; asimpl; eauto using has_type.
  - unfold ltc in C. rewrite <- C. constructor.
  - constructor. apply IHhas_type. intros x.
    destruct (destruct_fin x) as [(?&->)|(?&->)]; eauto; asimpl; unfold upRen_p; asimpl. cbn. eauto.
    + now asimpl.
  - econstructor; eauto.
Qed.

Lemma typing_inst n k (Gamma: ctx n) (Delta: ctx k) (sigma: fin n -> tm k) (M: tm n) T :
  (forall x, Delta |- sigma x : Gamma x) -> Gamma |- M : T ->  Delta |- (M[sigma]) : T.
Proof.
Proof.
  intros C H. revert k Delta sigma C. induction H; intros; asimpl; eauto using has_type.
  - unfold ltc in C. apply C.
  - constructor. apply IHhas_type. intros x.
    destruct (destruct_fin x) as [(?&->)|(?&->)]; asimpl.
    + apply ty_var'. now asimpl.
    + eapply typing_ren; eauto. intros x. now asimpl.
 - econstructor; eauto.
Qed.

(** *** Preservation *)

Lemma step_typing k (Gamma: ctx k) M T :
  Gamma |- M : T -> forall M', step M M' -> Gamma |- M' : T.
Proof.
  induction 1; intros; cbn.
  - inv H.
  - inv H0. econstructor. now apply IHhas_type.
  - inv H2.
    + inv H. eapply typing_inst; try eassumption.
      intros x. destruct (destruct_fin x) as [(?&->)|(?&->)]; asimpl; eauto.
      * apply ty_var'; eauto.
    + eapply ty_app; eauto.
Qed.


Module Accum.

Require Import Finite. Import FiniteTypes.
Require Import Le. Require Import Lt. Require Import Plus.
Require Import Omega.
Require Import Classical. Require Import ClassicalDescription.
Require Import Description.

Definition exchange (T : Type) (x y : T) (k : T) :=
  If k = x then y else If k = y then x else k.
Lemma and_idem (A : Prop) :
  A -> A /\ A.
Proof.
  tauto.
Qed.
Lemma exchange_bijective (T : Type) (x y : T) :
  bijection (exchange T x y).
Proof.
  apply bijection_inversible.
  exists (exchange T x y). apply and_idem.
  intro k. unfold exchange.
  destruct (excluded_middle_informative (k = x)).
  rewrite If_l with (P := y = y). case_if.
  congruence. auto. auto.
  destruct (excluded_middle_informative (k = y)).
  rewrite If_l. auto. auto.
  rewrite If_r. rewrite If_r. auto. auto. auto.
Qed.
Lemma exchange_1 (T : Type) (x y : T) :
  exchange T x y x = y.
Proof.
  unfold exchange. apply If_l. auto.
Qed.
Lemma exchange_2 (T : Type) (x y : T) :
  exchange T x y y = x.
Proof.
  unfold exchange. case_if. auto. apply If_l. auto.
Qed.
Lemma lt_not_eq :
  forall n m : nat, n < m -> n <> m.
Proof.
  intros n m H. apply lt_not_le in H. contradict H. destruct H. auto.
Qed.
Theorem induction_double (P : nat -> Prop) :
  P O -> P (S O) -> (forall n, P n -> P (S n) -> P (S (S n))) -> forall n, P n.
Proof.
  intros H0 H1 Hnext.
  assert (forall n, P n /\ P (S n)).
  simple induction n.
  auto. intros n0 H. destruct H. auto.
  intro n. apply H.
Qed.

Section Acc.
Variable T : Type.
Variable mult : T -> T -> T.
Infix "*" := mult.
Hypothesis mult_com :
  forall x y : T, x * y = y * x.
Hypothesis mult_assoc :
  forall x y z : T, x * (y * z) = (x * y) * z.
Variable e : T.
Hypothesis e_idemp : e * e = e.
Hypothesis e_img_neutral :
  forall x y : T, e * (x * y) = (x * y).

Lemma pr_ex (n : nat) (n' : nat) (k : Fints n') (Heq : n = S n') :
  `k < n.
Proof.
  rewrite Heq.
  apply (lt_S `k n' (proj2_sig k)).
Qed.
Lemma pr_ex2 (n : nat) (n' : nat) (Heq : n = S n') :
  n' < n.
Proof.
  rewrite Heq. apply lt_n_Sn.
Qed.
Fixpoint pr (n : nat) (f : Fints n -> T) :=
  match n as n' return n = n' -> T with
    | O => fun _ => e
    | S n' =>
      fun Heq =>
        (pr n' (fun (k : Fints n') =>
           f (exist (fun p => p < n) `k (pr_ex n n' k Heq))))
      * (f (exist (fun p => p < n) n' (pr_ex2 n n' Heq)))
  end (eq_refl n).
Lemma pr_ext :
  forall (n : nat) (f f' : Fints n -> T),
    (forall k : Fints n, f k = f' k) -> pr n f = pr n f'.
Proof.
  simple induction n.
  intros. simpl. auto.
  intros n0 H f f' Heq. simpl.
  f_equal. apply H. intro k.
  apply Heq. apply Heq.
Qed.

Definition prod (n : nat) (I : Type)
    (b : Fints n -> I) (Hb : bijection b) (f : I -> T) :=
  pr n (fun x => f (b x)).
Lemma prod_elim_last (n : nat) (I : Type)
    (b : Fints (S n) -> I) (Hb : bijection b) (f : I -> T) :
  prod (S n) I b Hb f =
  prod n _ _ (bijection_restriction2 Hb) (fun x => f `x) *
    (f (b (Fints_last n))).
Proof.
  unfold prod. simpl. f_equal.
  apply pr_ext. intro k. f_equal. f_equal. unfold Fints_coerce.
  apply proj1_inj. auto.
  f_equal. f_equal. unfold Fints_last. apply proj1_inj. auto.
Qed.

Theorem prod_unique_n :
  forall (n  : nat) (I : Type) (f : I -> T)
     (b  : Fints n -> I) (Hb  : bijection b )
     (b' : Fints n -> I) (Hb' : bijection b'),
  prod n I b Hb f = prod n I b' Hb' f.
Proof.
  apply (induction_double (fun n => forall (I : Type) (f : I -> T)
     (b  : Fints n -> I) (Hb  : bijection b )
     (b' : Fints n -> I) (Hb' : bijection b'),
  prod n I b Hb f = prod n I b' Hb' f)).
  intros. unfold prod. auto.
  intros. unfold prod. unfold pr. f_equal. f_equal.
  assert (exists x, b x = b' (exist (fun p : nat => p < 1) 0 (pr_ex2 1 0 eq_refl))).
  apply Hb. destruct H as [x H]. rewrite <- H. f_equal.
  destruct x as [x' Hx']. apply proj1_inj. simpl. clear H. apply le_S_n in Hx'. apply le_n_0_eq. auto.
  intros n1 H' H I f b Hb b' Hb'.
  remember (S n1) as n0.
  do 2 (rewrite prod_elim_last).
  remember (bijection_restriction2 Hb) as Hc. clear HeqHc.
  remember (fun k : Fints n0 =>
   exist (fun p : I => p <> b (Fints_last n0))
     (b (Fints_coerce (le_n_Sn n0) k)) (bijection_restriction1 Hb k)) as c.
  clear Heqc.
  remember (bijection_restriction2 Hb') as Hc'. clear HeqHc'.
  remember (fun k : Fints n0 =>
   exist (fun p : I => p <> b' (Fints_last n0))
     (b' (Fints_coerce (le_n_Sn n0) k)) (bijection_restriction1 Hb' k)) as c'.
  clear Heqc'.
  destruct (classic (b (Fints_last n0) = b' (Fints_last n0))).
  f_equal. destruct H0. auto. destruct H0. auto.
  assert (Hbijc : bijection c). auto.
  destruct Hbijc as [Hinjc Hsurjc].
  assert (Hbijc' : bijection c'). auto.
  destruct Hbijc' as [Hinjc' Hsurjc'].
  remember (exist (fun p => p <> b (Fints_last n0)) (b' (Fints_last n0)) (not_eq_sym H0)) as y.
  remember (exist (fun p => p <> b' (Fints_last n0)) (b (Fints_last n0)) H0) as y'.
  destruct (Hsurjc y) as [x Hx].
  destruct (Hsurjc' y') as [x' Hx'].
  destruct n0 as [ | n1'].
  discriminate.
  assert (n1 = n1'). injection Heqn0. auto. destruct H1.
  remember (compose c (exchange _ x (Fints_last n1))) as d.
  assert (Hd : bijection d).
  rewrite Heqd.
  apply bij_compose. auto. apply exchange_bijective.
  assert (prod (S n1) {p : I | p <> b (Fints_last (S n1))} c Hc
  (fun x0 : {p : I | p <> b (Fints_last (S n1))} => f `x0) =
         prod (S n1) {p : I | p <> b (Fints_last (S n1))} d Hd
  (fun x0 : {p : I | p <> b (Fints_last (S n1))} => f `x0)).
  apply H. rewrite H1.
  remember (compose c' (exchange _ x' (Fints_last n1))) as d'.
  assert (Hd' : bijection d').
  rewrite Heqd'.
  apply bij_compose. auto. apply exchange_bijective.
  assert (prod (S n1) {p : I | p <> b' (Fints_last (S n1))} c' Hc'
  (fun x0 : {p : I | p <> b' (Fints_last (S n1))} => f `x0) =
         prod (S n1) {p : I | p <> b' (Fints_last (S n1))} d' Hd'
  (fun x0 : {p : I | p <> b' (Fints_last (S n1))} => f `x0)).
  apply H. rewrite H2.
  rewrite prod_elim_last. rewrite prod_elim_last.
  rewrite <- mult_assoc. rewrite mult_com with (y := f (b (Fints_last (S n1)))).
  rewrite mult_assoc. f_equal. f_equal.
  assert (ex_d''1 : forall k : Fints n1, proj1_sig (d' (Fints_coerce (le_n_Sn n1) k)) <> b (Fints_last (S n1))).
  intro k. assert (b (Fints_last (S n1)) = proj1_sig (d' (Fints_last n1))).
  rewrite Heqd'. unfold compose. rewrite exchange_2. rewrite Hx'.
  rewrite Heqy'. auto.
  rewrite H3. apply proj1_inj_neg. apply injection_iff_neg. apply Hd'.
  apply proj1_inj_neg. simpl. destruct k as [k' Hk'].
  simpl. apply lt_not_eq. auto.
  assert (ex_d''2 : forall k : Fints n1,
    (exist (fun p : I => p <> b (Fints_last (S n1)))
                  (proj1_sig (d' (Fints_coerce (le_n_Sn n1) k)))
                  (ex_d''1 k)) <> (d (Fints_last n1))).
  intro k. apply proj1_inj_neg. simpl. rewrite Heqd. unfold compose.
  rewrite exchange_2. rewrite Hx. rewrite Heqy. simpl.
  remember (d' (Fints_coerce (le_n_Sn n1) k)) as l.
  destruct l as [l' Hl']. auto.
  remember (fun k : Fints n1 =>
    exist (fun p : {p : I | p <> b (Fints_last (S n1))} => p <> d (Fints_last n1))
      (exist (fun p : I => p <> b (Fints_last (S n1)))
                  (proj1_sig (d' (Fints_coerce (le_n_Sn n1) k)))
                  (ex_d''1 k))
      (ex_d''2 k)) as d''.
  assert (Hd'' : bijection d'').
  split. intros x1 x2 He. rewrite Heqd'' in He.
  apply proj1_inj in He. simpl in He. apply proj1_inj in He. simpl in He.
  apply proj1_inj in He. apply Hd' in He. unfold Fints_coerce in He.
  apply proj1_inj in He. simpl in He. apply proj1_inj in He. auto.
  intro y0.
  assert (``y0 <> (b' (Fints_last (S n1)))).
  destruct y0 as [y0' Hy0']. simpl. rewrite Heqd in Hy0'.
  unfold compose in Hy0'.  rewrite exchange_2 in Hy0'. rewrite Hx in Hy0'.
  rewrite Heqy in Hy0'. apply proj1_inj_neg in Hy0'. auto.
  assert (exists x0, d' x0 = exist (fun p => p <> b' (Fints_last (S n1))) ``y0 H3).
  apply Hd'. destruct H4 as [x0 H4].
  destruct x0 as [x0' Hx0'].
  assert (x0' <= n1). apply le_S_n. auto.
  apply le_lt_or_eq in H5. destruct H5.
  exists (exist (fun p => p < n1) x0' H5).
  rewrite Heqd''. apply proj1_inj. simpl. apply proj1_inj. simpl.
  apply proj1_inj in H4. simpl in H4. rewrite <- H4.
  apply proj1_inj. f_equal. unfold Fints_coerce. apply proj1_inj. auto.
  destruct y0 as [y0' Hy0']. destruct y0' as [y0'' Hy0''].
  simpl in *. apply proj1_inj in H4. simpl in H4. exfalso.
  clear Hy0'. rewrite <- H4 in Hy0''. clear H4. clear H3.
  rewrite Heqd' in Hy0''. unfold compose in Hy0''.
  assert ((Fints_last n1) = (exist (fun p : nat => p < S n1) x0' Hx0')).
  unfold Fints_last. apply proj1_inj. auto.
  clear H5. rewrite H3 in Hy0''. rewrite exchange_2 in Hy0''.
  rewrite Hx' in Hy0''. rewrite Heqy' in Hy0''. auto.
  rewrite H' with (b' := d'') (Hb' := Hd'').
  repeat (unfold prod). apply pr_ext.
  intro k. f_equal. simpl. rewrite Heqd''. auto.
  rewrite Heqd'. unfold compose. unfold exchange.
  assert ((If Fints_last n1 = x' then Fints_last n1
     else (If Fints_last n1 = Fints_last n1 then x' else Fints_last n1)) = x').
  case_if. auto. apply If_l. auto. rewrite H3. rewrite Hx'.
  rewrite Heqy'. simpl. auto.
  f_equal. rewrite Heqd. unfold compose. unfold exchange.
  assert ((If Fints_last n1 = x then Fints_last n1
     else (If Fints_last n1 = Fints_last n1 then x else Fints_last n1)) = x).
  case_if. auto. apply If_l. auto. rewrite H3. rewrite Hx.
  rewrite Heqy. simpl. auto.
Qed.

Theorem prod_unique :
  forall (I : Type) (f : I -> T)
         (n  : nat) (b  : Fints n  -> I) (Hb  : bijection b )
         (n' : nat) (b' : Fints n' -> I) (Hb' : bijection b'),
  prod n I b Hb f = prod n' I b' Hb' f.
Proof.
  intros.
  assert (n = n').
  apply cardinality_unique with (T := I).
  unfold cardinality. apply inv_bijection. exists b. auto.
  unfold cardinality. apply inv_bijection. exists b'. auto.
  destruct H. apply prod_unique_n.
Qed.

Lemma product_exists (I : Type) (H : finite I) (f : I -> T) :
  exists ! p : T,
    (forall (n : nat) (b : Fints n -> I) (Hb : bijection b), p = prod n I b Hb f).
Proof.
  apply unique_existence with (P := fun p =>
    forall (n : nat) (b : Fints n -> I) (Hb : bijection b), p = prod n I b Hb f).
  destruct H as [n H]. apply inv_bijection in H. destruct H as [b Hb].
  split.
  exists (prod n I b Hb f). apply prod_unique.
  intros p1 p2 H1 H2.
  transitivity (prod n I b Hb f). auto. auto.
Qed.

Definition product (I : Type) (H : finite I) (f : I -> T) :=
  proj1_sig (constructive_definite_description (fun p =>
    forall (n : nat) (b : Fints n -> I) (Hb : bijection b), p = prod n I b Hb f)
  (product_exists I H f)).

Lemma product_any (I : Type) (H : finite I) (f : I -> T)
    (n : nat) (b : Fints n -> I) (Hb : bijection b) :
  product I H f = prod n I b Hb f.
Proof.
  unfold product.
  remember (constructive_definite_description
    (fun p : T =>
     forall (n0 : nat) (b0 : Fints n0 -> I) (Hb0 : bijection b0),
     p = prod n0 I b0 Hb0 f) (product_exists I H f)) as p.
  destruct p. simpl. apply e0.
Qed.

Lemma product_ext (I : Type) (H : finite I) (f g : I -> T) :
  (forall i: I, f i = g i) -> product I H f = product I H g.
Proof.
  assert (finite I). auto.
  destruct H0 as [n H0]. apply inv_bijection in H0. destruct H0 as [b Hb].
  intro He. repeat (rewrite (product_any I H _ n b Hb)). unfold prod.
  apply pr_ext. auto.
Qed.

Lemma product_n (n : nat) (f : Fints (S n) -> T) :
  product _ (Fints_finite (S n)) f = product _ (Fints_finite n)
    (fun k => f (Fints_coerce (le_n_Sn n) k)) * f (Fints_last n).
Proof.
  rewrite (product_any (Fints (S n)) (Fints_finite (S n)) f
           (S n) (fun x => x) (id_bijection (Fints (S n)))).
  rewrite (product_any (Fints n) (Fints_finite n)
          (fun k => f (Fints_coerce (le_n_Sn n) k))
           n (fun x => x) (id_bijection (Fints n))).
  unfold prod. simpl. f_equal.
  apply pr_ext. intro k. f_equal. unfold Fints_coerce.
  apply proj1_inj. auto.
  f_equal. unfold Fints_last. apply proj1_inj. auto.
Qed.

Lemma product_bij (I : Type) (HI : finite I) (f : I -> T)
                  (J : Type) (HJ : finite J) (b : J -> I) (Hb : bijection b) :
  product I HI f = product J HJ (compose f b).
Proof.
  assert (exists n, exists a : Fints n -> J, bijection a).
  destruct HJ as [n HJ]. exists n. apply inv_bijection in HJ.
  destruct HJ as [a Ha]. exists a. auto.
  destruct H as [n H]. destruct H as [a Ha].
  rewrite (product_any I HI f n (compose b a) (bij_compose Hb Ha)).
  rewrite (product_any J HJ (compose f b) n a Ha).
  unfold prod. unfold compose. auto.
Qed.

Lemma empty_product (f : Fints 0 -> T) :
  product _ (Fints_finite 0) f = e.
Proof.
  rewrite (product_any _ _ _ _ (fun x => x) (id_bijection _)).
  unfold prod. auto.
Qed.

Lemma product_e_neutral_n (n : nat) (f : Fints n -> T) :
  e * (product _ (Fints_finite n) f) = product _ (Fints_finite n) f.
Proof.
  destruct n as [ | n'].
  rewrite empty_product. apply e_idemp.
  rewrite product_n. apply e_img_neutral.
Qed.

Lemma product_e_neutral (I : Type) (HI : finite I) (f : I -> T) :
  e * (product I HI f) = product I HI f.
Proof.
  assert (finite I). auto.
  destruct H as [n H]. apply inv_bijection in H. destruct H as [b Hb].
  repeat (rewrite (product_bij I HI _ (Fints n) (Fints_finite n) b Hb)).
  apply product_e_neutral_n.
Qed.

Lemma product_mul_n :
  forall (n : nat) (f g : (Fints n) -> T),
    product _ (Fints_finite n) (fun k => f k * g k) =
    product _ (Fints_finite n) f * product _ (Fints_finite n) g.
Proof.
  simple induction n.
  intros f g.
  repeat (rewrite empty_product).
  symmetry. apply e_idemp.
  intros n0 H f g.
  repeat (rewrite product_n). rewrite H.
  repeat (rewrite mult_assoc). f_equal. repeat (rewrite <- mult_assoc). f_equal.
  apply mult_com.
Qed.

Lemma product_mul (I : Type) (HI : finite I) (f g : I -> T) :
  product I HI (fun x => f x * g x) =
  product I HI f * product I HI g.
Proof.
  assert (finite I). auto.
  destruct H as [n H]. apply inv_bijection in H. destruct H as [b Hb].
  repeat (rewrite (product_bij I HI _ (Fints n) (Fints_finite n) b Hb)).
  rewrite <- product_mul_n. unfold compose. auto.
Qed.

Lemma product_property_conservation_n (P : T -> Prop)
    (Hc : forall x y : T, P x -> P y -> P (x * y)) (He : P e) :
  forall (n : nat) (f : (Fints n) -> T),
    (forall k : Fints n, P (f k)) -> P (product _ (Fints_finite n) f).
Proof.
  simple induction n. intros. rewrite empty_product. apply He.
  intros n0 H f HP.
  rewrite product_n. apply Hc. apply H. auto. auto.
Qed.
Lemma product_property_conservation (P : T -> Prop)
    (Hc : forall x y : T, P x -> P y -> P (x * y)) (He : P e)
    (I : Type) (HI : finite I) (f : I -> T) :
  (forall x, P (f x)) -> P (product I HI f).
Proof.
  assert (finite I). auto.
  destruct H as [n H]. apply inv_bijection in H. destruct H as [b Hb].
  repeat (rewrite (product_bij I HI _ (Fints n) (Fints_finite n) b Hb)).
  intro H. apply product_property_conservation_n. auto. auto.
  unfold compose. auto.
Qed.

Lemma product_eq_n (R : T -> T -> Prop)
    (Hc : forall x1 x2 y1 y2 : T, R x1 x2 -> R y1 y2 -> R (x1 * y1) (x2 * y2))
    (He : R e e) :
  forall (n : nat) (f g : (Fints n) -> T),
    (forall k : (Fints n), R (f k) (g k)) ->
      R (product _ (Fints_finite n) f) (product _ (Fints_finite n) g).
Proof.
  simple induction n.
  intros. repeat (rewrite empty_product). auto.
  intros n0 H f g Heq.
  repeat (rewrite product_n). apply Hc. apply H. auto. auto.
Qed.
Lemma product_eq (R : T -> T -> Prop)
    (Hc : forall x1 x2 y1 y2 : T, R x1 x2 -> R y1 y2 -> R (x1 * y1) (x2 * y2))
    (He : R e e)
    (I : Type) (HI : finite I) (f g : I -> T) :
  (forall x, R (f x) (g x)) -> R (product I HI f) (product I HI g).
Proof.
  assert (finite I). auto.
  destruct H as [n H]. apply inv_bijection in H. destruct H as [b Hb].
  repeat (rewrite (product_bij I HI _ (Fints n) (Fints_finite n) b Hb)).
  intro H. apply product_eq_n. auto. auto. unfold compose. auto.
Qed.

Lemma product_split_ex1 (n m : nat) (k : Fints n) :
  `k < n + m.
Proof.
  destruct k as [k' Hk']. simpl. omega.
Qed.
Lemma product_split_ex2 (n m : nat) (k : Fints m) :
  `k + n < n + m.
Proof.
  destruct k as [k' Hk']. simpl. omega.
Qed.

Lemma product_split_n :
  forall (n : nat) (m : nat) (f : (Fints (n + m)) -> T),
    product _ (Fints_finite (n + m)) f =
  (product _ (Fints_finite n) (fun k => f (exist _ `k (product_split_ex1 n m k)))) *
  (product _ (Fints_finite m) (fun k => f (exist _ (`k + n) (product_split_ex2 n m k)))).
Proof.
  simple induction m.
  intro f. rewrite empty_product.
  rewrite mult_com. rewrite product_e_neutral.
  remember (product_split_ex1 n 0) as H.
  clear HeqH.
  generalize f. generalize H. rewrite <- plus_n_O.
  intros. apply product_ext. intro. f_equal. apply proj1_inj. auto.
  intros m0 H. remember (product_split_ex1 n (S m0)) as H1.
  remember (product_split_ex2 n (S m0)) as H2.
  clear HeqH1. clear HeqH2. generalize H1 H2.
  rewrite <- plus_n_Sm. intros.
  repeat (rewrite product_n). rewrite mult_assoc. f_equal.
  rewrite H. f_equal.
  apply product_ext. intro. f_equal. unfold Fints_coerce.
  apply proj1_inj. auto.
  apply product_ext. intro. f_equal. unfold Fints_coerce.
  apply proj1_inj. auto.
  f_equal. unfold Fints_last. apply proj1_inj. simpl. apply plus_comm.
Qed.

Lemma product_split (I : Type) (HI : finite I) (f : I -> T) (P : I -> Prop) :
  product I HI f =
   (product {x : I | P x} (subtype_finite HI _) (fun x => f `x)) *
   (product {x : I | ~ P x} (subtype_finite HI _) (fun x => f `x)).
Proof.
  assert (Hn : finite {x : I | P x}). apply subtype_finite. auto.
  destruct Hn as [n Hn]. apply inv_bijection in Hn. destruct Hn as [b Hb].
  assert (Hm : finite {x : I | ~ P x}). apply subtype_finite. auto.
  destruct Hm as [m Hm]. apply inv_bijection in Hm. destruct Hm as [c Hc].
  remember (choose_bijection P Hb Hc) as a.
  assert (Ha : bijection a). rewrite Heqa. apply choose_bij.
  rewrite (product_bij _ _ _ _ (Fints_finite (n + m)) a Ha).
  rewrite (product_bij _ _ _ _ (Fints_finite n) b Hb).
  rewrite (product_bij _ _ _ _ (Fints_finite m) c Hc).
  rewrite product_split_n.
  f_equal.
  apply product_ext. intro k. unfold compose.
  f_equal. rewrite Heqa. unfold choose_bijection. simpl.
  destruct k as [k' Hk']. simpl.
  destruct (excluded_middle_informative (k' < n)).
  f_equal. f_equal. apply proj1_inj. auto.
  contradiction.
  apply product_ext. intro k. unfold compose.
  f_equal. rewrite Heqa. unfold choose_bijection. simpl.
  destruct k as [k' Hk']. simpl.
  destruct (excluded_middle_informative (k' + n < n)).
  omega.
  f_equal. f_equal. apply proj1_inj. simpl. omega.
Qed.

Variable a : T.
Hypothesis integral : forall x y : T, x <> a -> y <> a -> x * y <> a.
Hypothesis e_not_a : e <> a.

Lemma product_integral (I : Type) (HI : finite I) (f : I -> T) :
  (forall x, f x <> a) -> product I HI f <> a.
Proof.
  intro H.
  apply product_property_conservation. auto. auto. auto.
Qed.

End Acc.

Section Acc_morph.
Variable T : Type.
Variable multT : T -> T -> T.
Infix "*" := multT.
Hypothesis multT_com :
  forall x y : T, x * y = y * x.
Hypothesis multT_assoc :
  forall x y z : T, x * (y * z) = (x * y) * z.
Variable eT : T.
Variable S : Type.
Variable multS : S -> S -> S.
Infix "×" := multS (at level 40).
Hypothesis multS_com :
  forall x y : S, x × y = y × x.
Hypothesis multS_assoc :
  forall x y z : S, x × (y × z) = (x × y) × z.
Variable eS : S.
Variable morph : T -> S.
Hypothesis morphism :
  forall x y : T, morph (x * y) = morph x × morph y.
Hypothesis morph_e :
  morph eT = eS.

Lemma product_morph_n :
  forall (n : nat) (f : (Fints n) -> T),
    morph (product T multT multT_com multT_assoc eT _ (Fints_finite n) f) =
    product S multS multS_com multS_assoc eS _ (Fints_finite n) (compose morph f).
Proof.
  simple induction n.
  intro f.
  repeat (rewrite empty_product). apply morph_e.
  intros n0 H f.
  repeat (rewrite product_n). rewrite morphism.
  unfold compose. f_equal. rewrite H. unfold compose. auto.
Qed.

Lemma product_morph (I : Type) (HI : finite I) (f : I -> T) :
    morph (product T multT multT_com multT_assoc eT I HI f) =
    product S multS multS_com multS_assoc eS I HI (compose morph f).
Proof.
  assert (finite I). auto.
  destruct H as [n H]. apply inv_bijection in H. destruct H as [b Hb].
  repeat (rewrite (product_bij _ _ _ _ _ I HI _ (Fints n) (Fints_finite n) b Hb)).
  apply product_morph_n.
Qed.

End Acc_morph.

Lemma disjoint_union_cardinality_sum_n :
  forall (n : nat) (T : Type) (f : T -> Fints n) (c : Fints n -> nat),
    (forall k : Fints n, cardinality {x : T | f x = k} (c k)) ->
       cardinality T (product nat plus plus_comm plus_assoc 0 _ (Fints_finite n) c).
Proof.
  simple induction n.
  intros. rewrite empty_product. exists f. split.
  intro x. destruct (f x). exfalso. omega.
  intro y. destruct y. exfalso. omega.
  intros n0 H T f c Hc.
  rewrite product_n.
  assert (cardinality {x : T | f x = Fints_last n0} (c (Fints_last n0))). auto.
  assert (cardinality {x : T | ~ (f x = Fints_last n0)} (product nat plus plus_comm plus_assoc 0 (Fints n0) (Fints_finite n0)
     (fun k : Fints n0 => c (Fints_coerce (le_n_Sn n0) k)))).
  assert (forall x : {x : T | f x <> Fints_last n0}, proj1_sig (f `x) < n0).
  intro x. destruct x as [x' Hx']. simpl.
  assert (proj1_sig (f x') < S n0). destruct (f x'). auto.
  assert (proj1_sig (f x') <> n0). apply proj1_inj_neg in Hx'.
  unfold Fints_last in Hx'. simpl in Hx'. auto. omega.
  apply H with (f := fun x => exist _ (proj1_sig (f `x)) (H1 x)).
  intro k.
  destruct (Hc (Fints_coerce (le_n_Sn n0) k)) as [b Hb].
  assert (forall x : {x : {x : T | f x <> Fints_last n0} |
    exist (fun p : nat => p < n0) (proj1_sig (f `x)) (H1 x) = k}, f ``x = Fints_coerce (le_n_Sn n0) k).
  intro x. destruct x as [x' Hx']. destruct x' as [x'' Hx''].
  simpl in *. unfold Fints_coerce. apply proj1_inj. simpl.
  rewrite <- Hx'. simpl. auto.
  exists (fun x => b (exist _ ``x (H2 x))).
  destruct Hb as [Hbinj Hbsurj].
  split.
  intros x1 x2 He. apply Hbinj in He. apply proj1_inj in He. simpl in He.
  apply proj1_inj in He. apply proj1_inj. auto.
  intro y. destruct (Hbsurj y) as [x Hx]. destruct x as [x' Hx'].
  assert (f x' <> Fints_last n0). unfold Fints_last. rewrite Hx'.
  unfold Fints_coerce. apply proj1_inj_neg. simpl. destruct k. simpl. omega.
  assert (exist _ (proj1_sig (f (proj1_sig (exist _ x' H3)))) (H1 (exist _ x' H3)) = k).
  apply proj1_inj. simpl. rewrite Hx'. unfold Fints_coerce. auto.
  exists (exist _ (exist _ x' H3) H4).
  simpl. rewrite <- Hx. f_equal. apply proj1_inj. auto.
  rewrite (plus_comm _ (c (Fints_last n0))).
  apply disjoint_union_cardinality with (P := fun x => f x = Fints_last n0).
  auto. auto.
Qed.

Lemma disjoint_union_cardinality_sum (I T : Type) (HI : finite I) (f : T -> I) (c : I -> nat) :
    (forall i : I, cardinality {x : T | f x = i} (c i)) ->
       cardinality T (product nat plus plus_comm plus_assoc 0 I HI c).
Proof.
  intro H.
  assert (finite I). auto.
  destruct H0 as [n H0]. destruct H0 as [b Hb].
  assert (Hb' : inversible b). apply bijection_inversible. auto.
  destruct Hb' as [b' Hb']. destruct Hb' as [Hb'id Hbid].
  assert (Hb' : bijection b'). apply bijection_inversible. exists b. auto.
  rewrite (product_bij _ _ _ _ _ I HI _ (Fints n) (Fints_finite n) b' Hb').
  apply disjoint_union_cardinality_sum_n with (f := fun x => b (f x)).
  intro k.
  apply (card_subtype (fun x => b (f x) = k) (fun x => f x = b' k)).
  intro x. split. intro He. rewrite <- (Hb'id (f x)). f_equal. auto.
  intro He. rewrite <- (Hbid k). f_equal. auto.
  unfold compose. auto.
Qed.

End Accum.


Add LoadPath "../metatheory".
Require Export STLC_soundness.

Lemma eq_typ_dec : forall (τ₁ τ₂: typ), {τ₁ = τ₂} + {τ₁ ≠ τ₂}.
Proof.
decide equality.
Qed.

Lemma in_dom_dec : forall x (Γ: typing_env), {x ∈ dom Γ} + {~x ∈ dom Γ}.
Proof.
intros x Γ. induction Γ; simpl.
auto.
destruct a; destruct IHΓ; auto.
destruct (x == a); subst; auto.
Qed.

Lemma uniq_dec : forall (Γ: typing_env), {uniq Γ} + {~uniq Γ}.
Proof.
intro Γ; induction Γ.
auto.
destruct IHΓ.
  destruct a as [x τ]; destruct (in_dom_dec x Γ); [right | left]; auto.
    intro; solve_uniq.
  right; intro; inversion H; subst; auto.
Qed.

Lemma lc_term_dec : forall t, {lc_term t} + {~lc_term t}.
Proof.
assert (forall n t, size_term t ≤ n -> {lc_term t} + {~lc_term t}) as Th.
intro n; induction n; intros t Hsize; destruct t; simpl in *; try solve [absurdity with omega]; auto.
Case "bound var". right; intro H; inversion H.
Case "abs".
  assert (forall x, {lc_term (t0 ^ x)} + {⌉lc_term (t0 ^ x)}) as H.
    intro x; apply IHn; autorewrite with lngen; omega.
  pick fresh x; destruct (H x); [left | right]; eauto using lc_term_abs_exists.
Case "app".
  destruct (IHn t1).
    omega. destruct (IHn t2). omega. auto.
    right; intro H; inversion H; auto.
    right; intro H; inversion H; auto.

intro t; apply (Th (size_term t)); auto.
Qed.

Lemma wfterm_abs_exists : forall x τ Γ e τ',
  x ∉ fv_term e →
  wfterm (x ~ τ ++ Γ) (e ^ x) τ' → wfterm Γ (term_abs τ e) (typ_arrow τ τ').
Proof.
intros x τ Γ e τ' Hx H.
assert (uniq Γ). assert (uniq ([(x, τ)] ++ Γ)) as H1 by eauto. inversion H1; auto.
apply wfterm_abs with (L := {{x}} ∪ dom Γ); intros y Hy. assert (y ≠ x) by auto.
replace (e ^ y) with (subst_term (term_var_f y) x (e ^ x)).
apply wfterm_subst with (τ₂ := τ) (Γ₁ := nil); simpl; simpl_env.
apply wfterm_weakening; simpl_env; eauto.
constructor; eauto.
rewrite subst_term_open_term_wrt_term; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfterm_abs_exists_inv : forall x τ Γ e τ',
  x ∉ fv_term e ∪ dom Γ →
  wfterm Γ (term_abs τ e) (typ_arrow τ τ') →
  wfterm (x ~ τ ++ Γ) (e ^ x) τ'.
Proof.
intros x τ Γ e τ' Hx H.
inversion H; subst. pick fresh y.
assert (wfterm ([(y, τ)] ++ Γ) (e ^ y) τ') by auto.
replace (e ^ x) with (subst_term (term_var_f x) y (e ^ y)).
apply wfterm_subst with (τ₂ := τ) (Γ₁ := nil); simpl; simpl_env.
eauto using wfterm_weakening. constructor; auto.
assert (uniq ([(y, τ)] ++ Γ)) as H1 by eauto; inversion H1; subst; auto.
rewrite subst_term_open_term_wrt_term; auto.
autorewrite with lngen. reflexivity.
Qed.

Lemma wfterm_dec : forall Γ e,
  {τ | wfterm Γ e τ} + {forall τ, ~wfterm Γ e τ}.
Proof.
intros Γ e.
destruct (uniq_dec Γ); eauto.
destruct (lc_term_dec e) as [H | H]; eauto.
assert (lc_set_term e) as H' by auto with lngen; clear H.
generalize dependent Γ. induction H'; intros.
Case "var". destruct (binds_lookup _ x1 Γ) as [[τ H] | H]; eauto.
  right; intros τ H0; inversion H0; subst; eapply H; eauto.
Case "abs". pick fresh x.
edestruct (H x (x ~ t1 ++ Γ)) as [[τ H1] | H1]; auto.
left; eauto using wfterm_abs_exists.
right; intros τ H0; inversion H0; subst; eapply H1; eauto using wfterm_abs_exists_inv.
Case "app".
edestruct (IHH'1 Γ) as [[τ₁ H1] | H1]; auto.
SCase "wfterm e1".
destruct τ₁.
SSCase "typ_base".
right; intros τ H; inversion H; subst;
  assert (typ_base = typ_arrow t2 τ) by eauto using wfterm_uniqueness;
    congruence.
SSCase "typ_arrow".
edestruct (IHH'2 Γ) as [[τ₂ H2] | H2]; auto.
SSSCase "wfterm e2".
destruct (eq_typ_dec τ₁1 τ₂); subst.
SSSSCase "τ₁1 = τ₂". eauto.
SSSSCase "τ₁1 ≠ τ₂". right. intros τ H. inversion H; subst.
assert (typ_arrow τ₁1 τ₁2 = typ_arrow t2 τ) by eauto using wfterm_uniqueness.
assert (τ₂ = t2) by eauto using wfterm_uniqueness.
congruence.
SSSCase "~ wfterm e2".
right; intros τ H; inversion H; subst; eapply H2; eauto.
SCase "~ wfterm e1".
right; intros τ H; inversion H; subst; eapply H1; eauto.
Qed.


Require Import syntax.
Require Import substitution.
Require Import statics.
From stdpp Require Import gmap.
(* From stdpp Require Import set. *)

(* pg. 142 *)

Inductive val :=
  | VarV (x : var)
  | LamV (x : var) (tau : type) (e : expr)
  | Lam2V (t : var) (e : expr)
  .

Fixpoint to_val (e : expr) :=
  match e with
  | Var x => Some (VarV x)
  | Lam x t e => Some (LamV x t e)
  | Lam2 t e => Some (Lam2V t e)
  | _ => None
  end.

Fixpoint of_val (v : val) :=
  match v with
  | VarV x => Var x
  | LamV x t e => Lam x t e
  | Lam2V t e => Lam2 t e
  end.

Inductive step_cbv : expr -> expr -> Prop :=
  | AppSV x tau e1 e2 v : to_val e2 = Some v -> step_cbv (App (Lam x tau e1) e2) (subst_e_e e1 e2 x)
  | AppLSV e1 e1' e2 : step_cbv e1 e1' -> step_cbv (App e1 e2) (App e1' e2)
  | AppRSV e1 e2 e2' v : to_val e1 = Some v -> step_cbv e2 e2' -> step_cbv (App e1 e2) (App e1 e2')
  | App2SV e t tau : step_cbv (App2 (Lam2 t e) tau) (subst_e_t e tau t)
  | App2MSV e e' tau : step_cbv e e' -> step_cbv (App2 e tau) (App2 e' tau)
  .

Inductive step_cbn : expr -> expr -> Prop :=
  | AppSN x tau e1 e2 v : to_val e2 = Some v -> step_cbn (App (Lam x tau e1) e2) (subst_e_e e1 e2 x)
  | AppLSN e1 e1' e2 : step_cbn e1 e1' -> step_cbn (App e1 e2) (App e1' e2)
  | App2SN e t tau : step_cbn (App2 (Lam2 t e) tau) (subst_e_t e tau t)
  | App2MSN e e' tau : step_cbn e e' -> step_cbn (App2 e tau) (App2 e' tau)
  .


From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Lists.List.
Require Import Coq.btauto.Btauto.

Require Import KA.Finite.
Require Import KA.Scope.
Local Open Scope ka_scope.

Section TermSyntax.
  Context {A: Type}.

  Inductive term :=
  | zero: term
  | one: term
  | letter: A -> term
  | plus: term -> term -> term
  | times: term -> term -> term
  | star: term -> term
  .

  Derive NoConfusion for term.
End TermSyntax.

Arguments term A : clear implicits.

Notation "0" := zero : ka_scope.
Notation "1" := one : ka_scope.
Notation "$ a" :=
  (letter a)
  (at level 30)
  : ka_scope
.
Notation "t1 + t2" :=
  (plus t1 t2)
  (at level 50, left associativity)
  : ka_scope
.
Notation "t1 ;; t2" :=
  (times t1 t2)
  (at level 40, left associativity)
  : ka_scope
.
Notation "t *" :=
  (star t)
  (at level 30)
  : ka_scope
.

Section TermEquivalence.
  Context {A: Type}.
  Notation term := (term A).

  Reserved Notation "t1 == t2" (at level 70).
  Reserved Notation "t1 <= t2" (at level 70).

  Inductive term_equiv: term -> term -> Prop :=
  | ERefl: forall t, t == t
  | ESym: forall t1 t2, t1 == t2 -> t2 == t1
  | ETrans: forall t1 t2 t3, t1 == t2 -> t2 == t3 -> t1 == t3
  | ECongPlus: forall t1 t2 t3 t4, t1 == t2 -> t3 == t4 -> t1 + t3 == t2 + t4
  | ECongTimes: forall t1 t2 t3 t4, t1 == t2 -> t3 == t4 -> t1 ;; t3 == t2 ;; t4
  | ECongStar: forall t1 t2, t1 == t2 -> t1 * == t2 *
  | EPlusIdemp: forall t, t + t == t
  | EPlusComm: forall t1 t2, t1 + t2 == t2 + t1
  | EPlusAssoc: forall t1 t2 t3, t1 + (t2 + t3) == (t1 + t2) + t3
  | EPlusUnit: forall t, t + 0 == t
  | ETimesAssoc: forall t1 t2 t3, t1 ;; (t2 ;; t3) == (t1 ;; t2) ;; t3
  | ETimesUnitRight: forall t, t ;; 1 == t
  | ETimesUnitLeft: forall t, 1 ;; t == t
  | ETimesZeroLeft: forall t, t ;; 0 == 0
  | ETimesZeroRight: forall t, 0 ;; t == 0
  | EDistributeLeft: forall t1 t2 t3, t1 ;; (t2 + t3) == t1 ;; t2 + t1 ;; t3
  | EDistributeRight: forall t1 t2 t3, (t1 + t2) ;; t3 == t1 ;; t3 + t2 ;; t3
  | EStarLeft: forall t, t* == t ;; t* + 1
  | EFixLeft: forall t1 t2 t3, t2 ;; t1 + t3 <= t1 -> t2* ;; t3 <= t1
  where "t1 == t2" := (term_equiv t1 t2) : ka_scope
    and "t1 <= t2" := (t1 + t2 == t2) : ka_scope.

  Global Add Relation term term_equiv
    reflexivity proved by ERefl
    symmetry proved by ESym
    transitivity proved by ETrans
    as equiv_eq
  .

  Global Add Morphism plus
    with signature term_equiv ==> term_equiv ==> term_equiv
    as plus_mor
  .
  Proof.
    intros.
    now apply ECongPlus.
  Qed.

  Global Add Morphism times
    with signature term_equiv ==> term_equiv ==> term_equiv
    as times_mor
  .
  Proof.
    intros.
    now apply ECongTimes.
  Qed.

  Global Add Morphism star
    with signature term_equiv ==> term_equiv
    as star_mor
  .
  Proof.
    intros.
    now apply ECongStar.
  Qed.

  Definition term_lequiv (t1 t2: term) := t1 <= t2.
  (* Hint Unfold term_lequiv : core. *)

  Lemma term_lequiv_refl (t: term):
    t <= t
  .
  Proof.
    now rewrite EPlusIdemp.
  Qed.

  Lemma term_lequiv_trans (t1 t2 t3: term):
    t1 <= t2 -> t2 <= t3 -> t1 <= t3
  .
  Proof.
    intros.
    rewrite <- H0.
    rewrite <- H.
    repeat rewrite EPlusAssoc.
    rewrite EPlusIdemp.
    reflexivity.
  Qed.

  Lemma term_lequiv_zero (t: term):
    0 <= t
  .
  Proof.
    now rewrite EPlusComm, EPlusUnit.
  Qed.

  Global Add Relation term term_lequiv
    reflexivity proved by term_lequiv_refl
    transitivity proved by term_lequiv_trans
    as term_lequiv_po
  .

  Global Instance term_equiv_implies_lequiv: subrelation term_equiv term_lequiv.
  Proof.
    unfold subrelation, term_lequiv; intros.
    rewrite H.
    now rewrite EPlusIdemp.
  Qed.
End TermEquivalence.

Notation "t1 == t2" := (term_equiv t1 t2) (at level 70) : ka_scope.
Notation "t1 <= t2" := (t1 + t2 == t2) (at level 70) : ka_scope.

Ltac fold_term_lequiv :=
  match goal with
  | |- ?lhs <= ?rhs => fold (term_lequiv lhs rhs)
  end
.

Section TermProperties.
  Context {A: Type}.
  Notation term := (term A).

  Lemma term_lequiv_split_left
    (t1 t2 t3: term)
  :
    t1 <= t2 -> t1 <= t2 + t3
  .
  Proof.
    intros.
    rewrite <- H.
    repeat rewrite EPlusAssoc.
    now rewrite EPlusIdemp.
  Qed.

  Lemma term_lequiv_split_right
    (t1 t2 t3: term)
  :
    t1 <= t3 -> t1 <= t2 + t3
  .
  Proof.
    intros.
    rewrite <- H.
    rewrite EPlusAssoc with (t1 := t2).
    rewrite EPlusComm with (t1 := t2).
    repeat rewrite EPlusAssoc.
    now rewrite EPlusIdemp.
  Qed.

  Lemma term_lequiv_split
    (t1 t2 t3: term)
  :
    t1 <= t3 -> t2 <= t3 -> t1 + t2 <= t3
  .
  Proof.
    intros.
    rewrite <- H, <- H0.
    rewrite EPlusAssoc with (t1 := t1).
    rewrite EPlusAssoc with (t1 := (t1 + t2)).
    now rewrite EPlusIdemp.
  Qed.

  Global Add Morphism plus
    with signature term_lequiv ==> term_lequiv ==> (@term_lequiv A)
    as plus_mor_mono
  .
  Proof.
    unfold term_lequiv; intros.
    apply term_lequiv_split.
    - rewrite <- H.
      repeat apply term_lequiv_split_left.
      apply term_lequiv_refl.
    - rewrite <- H0.
      apply term_lequiv_split_right.
      apply term_lequiv_split_left.
      apply term_lequiv_refl.
  Qed.

  Global Add Morphism times
    with signature term_lequiv ==> term_lequiv ==> (@term_lequiv A)
    as times_mor_mono
  .
  Proof.
    unfold term_lequiv; intros.
    rewrite <- H, <- H0.
    rewrite EDistributeLeft.
    repeat rewrite EDistributeRight.
    repeat apply term_lequiv_split_left.
    apply term_lequiv_refl.
  Qed.

  Lemma term_lequiv_squeeze
    (t1 t2: term)
  :
    t1 <= t2 ->
    t2 <= t1 ->
    t1 == t2
  .
  Proof.
    intros.
    rewrite <- H.
    rewrite <- H0 at 1.
    rewrite EPlusComm.
    reflexivity.
  Qed.
End TermProperties.

Section TermSum.
  Context {A: Type}.
  Notation term := (term A).

  Equations sum (l: list term): term := {
    sum nil := 0;
    sum (t :: l) := t + sum l;
  }.

  Lemma sum_split (l1 l2: list term):
    sum (l1 ++ l2) == sum l1 + sum l2
  .
  Proof.
    revert l2; induction l1; intros.
    - autorewrite with sum.
      now rewrite EPlusComm, EPlusUnit, app_nil_l.
    - rewrite <- app_comm_cons.
      autorewrite with sum.
      rewrite <- EPlusAssoc.
      now rewrite IHl1.
  Qed.

  Lemma sum_distribute_right (l: list term) (t: term):
    sum (map (fun x => x ;; t) l) == sum l ;; t
  .
  Proof.
    induction l; simpl; autorewrite with sum.
    - now rewrite ETimesZeroRight.
    - rewrite IHl.
      now rewrite EDistributeRight.
  Qed.

  Lemma sum_distribute_left (l: list term) (t: term):
    sum (map (fun x => t ;; x) l) == t ;; sum l
  .
  Proof.
    induction l; simpl; autorewrite with sum.
    - now rewrite ETimesZeroLeft.
    - rewrite IHl.
      now rewrite EDistributeLeft.
  Qed.

  Lemma sum_lequiv_member
    (t: term)
    (l: list term)
  :
    In t l ->
    t <= sum l
  .
  Proof.
    intros; induction l; destruct H.
    - subst.
      autorewrite with sum.
      apply term_lequiv_split_left.
      apply term_lequiv_refl.
    - autorewrite with sum.
      apply term_lequiv_split_right.
      now apply IHl.
  Qed.

  Lemma sum_lequiv_all
    (l: list term)
    (t: term)
  :
    (forall (t': term), In t' l -> t' <= t) ->
    sum l <= t
  .
  Proof.
    intros.
    induction l.
    - autorewrite with sum.
      apply term_lequiv_zero.
    - autorewrite with sum.
      apply term_lequiv_split.
      + apply H.
        now left.
      + apply IHl; intros.
        apply H.
        now right.
  Qed.

  Lemma sum_lequiv_containment
    (l1 l2: list term)
  :
    incl l1 l2 ->
    sum l1 <= sum l2
  .
  Proof.
    intros.
    apply sum_lequiv_all; intros.
    apply sum_lequiv_member.
    now apply H.
  Qed.

  Lemma sum_equiv_containment
    (l1 l2: list term)
  :
    incl l1 l2 ->
    incl l2 l1 ->
    sum l1 == sum l2
  .
  Proof.
    intros.
    apply term_lequiv_squeeze;
    now apply sum_lequiv_containment.
  Qed.
End TermSum.

Section TermMatches.
  Context {A: Type}.
  Notation term := (term A).

  Inductive term_matches: term -> list A -> Prop :=
  | MatchOne:
      term_matches 1 nil
  | MatchLetter:
      forall (a: A),
      term_matches ($ a) (a :: nil)
  | MatchPlusLeft:
      forall (w: list A) (t1 t2: term),
      term_matches t1 w ->
      term_matches (t1 + t2) w
  | MatchPlusRight:
      forall (w: list A) (t1 t2: term),
      term_matches t2 w ->
      term_matches (t1 + t2) w
  | MatchTimes:
      forall (w1 w2: list A) (t1 t2: term),
      term_matches t1 w1 ->
      term_matches t2 w2 ->
      term_matches (t1 ;; t2) (w1 ++ w2)
  | MatchStarBase:
      forall (t: term),
      term_matches (t*) nil
  | MatchStarStep:
      forall (t: term) (w1 w2: list A),
      term_matches t w1 ->
      term_matches (t*) w2 ->
      term_matches (t*) (w1 ++ w2)
  .

  Lemma term_matches_star_split (t: term) (w: list A):
    term_matches (t*) w <->
    exists (l: list (list A)),
      w = concat l /\
      forall (w': list A), In w' l -> term_matches t w'
  .
  Proof.
    split; intros.
    - dependent induction H.
      + now exists nil.
      + specialize (IHterm_matches2 t eq_refl).
        destruct IHterm_matches2 as [l [? ?]]; subst.
        exists (w1 :: l).
        intuition.
        destruct H1.
        * now subst.
        * now apply H2.
    - destruct H as [l [? ?]]; subst.
      induction l; simpl.
      + apply MatchStarBase.
      + apply MatchStarStep.
        * apply H0.
          now left.
        * apply IHl; intros.
          apply H0.
          now right.
  Qed.

  Lemma term_equiv_sound (t1 t2: term) (w: list A):
    t1 == t2 ->
    term_matches t1 w <-> term_matches t2 w
  .
  Proof.
    intros.
    revert w; dependent induction H; intros.
    - reflexivity.
    - now symmetry.
    - now transitivity (term_matches t2 w).
    - split; intros.
      + dependent destruction H1.
        * apply MatchPlusLeft; intuition.
        * apply MatchPlusRight; intuition.
      + dependent destruction H1.
        * apply MatchPlusLeft; intuition.
        * apply MatchPlusRight; intuition.
    - split; intros.
      + dependent destruction H1.
        apply MatchTimes; intuition.
      + dependent destruction H1.
        apply MatchTimes; intuition.
    - split; intros.
      + dependent induction H0.
        * apply MatchStarBase.
        * apply MatchStarStep; intuition.
      + dependent induction H0.
        * apply MatchStarBase.
        * apply MatchStarStep; intuition.
    - split; intros.
      + now dependent destruction H.
      + now apply MatchPlusLeft.
    - split; intros.
      + dependent destruction H.
        * now apply MatchPlusRight.
        * now apply MatchPlusLeft.
      + dependent destruction H.
        * now apply MatchPlusRight.
        * now apply MatchPlusLeft.
    - split; intros.
      + dependent destruction H; [| dependent destruction H].
        * now apply MatchPlusLeft, MatchPlusLeft.
        * now apply MatchPlusLeft, MatchPlusRight.
        * now apply MatchPlusRight.
      + dependent destruction H; [dependent destruction H|].
        * now apply MatchPlusLeft.
        * now apply MatchPlusRight, MatchPlusLeft.
        * now apply MatchPlusRight, MatchPlusRight.
    - split; intros.
      + now dependent destruction H.
      + now apply MatchPlusLeft.
    - split; intros.
      + dependent destruction H.
        dependent destruction H0.
        rewrite app_assoc.
        apply MatchTimes; auto.
        now apply MatchTimes.
      + dependent destruction H.
        dependent destruction H.
        rewrite <- app_assoc.
        apply MatchTimes; auto.
        now apply MatchTimes.
    - split; intros.
      + dependent destruction H.
        dependent destruction H0.
        now rewrite app_nil_r.
      + rewrite <- app_nil_r.
        apply MatchTimes; auto.
        apply MatchOne.
    - split; intros.
      + dependent destruction H.
        dependent destruction H.
        now rewrite app_nil_l.
      + rewrite <- app_nil_l.
        apply MatchTimes; auto.
        apply MatchOne.
    - split; intros.
      + dependent destruction H.
        dependent destruction H0.
      + dependent destruction H.
    - split; intros.
      + dependent destruction H.
        dependent destruction H.
      + dependent destruction H.
    - split; intros.
      + dependent destruction H.
        dependent destruction H0.
        * apply MatchPlusLeft.
          now apply MatchTimes.
        * apply MatchPlusRight.
          now apply MatchTimes.
      + dependent destruction H.
        * dependent destruction H.
          apply MatchTimes; auto.
          now apply MatchPlusLeft.
        * dependent destruction H.
          apply MatchTimes; auto.
          now apply MatchPlusRight.
    - split; intros.
      + dependent destruction H.
        dependent destruction H.
        * apply MatchPlusLeft.
          now apply MatchTimes.
        * apply MatchPlusRight.
          now apply MatchTimes.
      + dependent destruction H.
        * dependent destruction H.
          apply MatchTimes; auto.
          now apply MatchPlusLeft.
        * dependent destruction H.
          apply MatchTimes; auto.
          now apply MatchPlusRight.
    - split; intros.
      + dependent destruction H.
        * now apply MatchPlusRight, MatchOne.
        * now apply MatchPlusLeft, MatchTimes.
      + dependent destruction H.
        * dependent destruction H.
          now apply MatchStarStep.
        * dependent destruction H.
          apply MatchStarBase.
    - split; intros.
      + dependent destruction H0; auto.
        dependent destruction H0.
        apply term_matches_star_split in H0_.
        destruct H0_ as [l [? ?]].
        subst; induction l; simpl.
        * apply IHterm_equiv.
          now apply MatchPlusLeft, MatchPlusRight.
        * apply IHterm_equiv.
          apply MatchPlusLeft, MatchPlusLeft.
          rewrite <- app_assoc.
          apply MatchTimes; intuition.
      + now apply MatchPlusRight.
  Qed.

  Lemma term_matches_sum (l: list term) (w: list A):
    term_matches (sum l) w <->
    exists (t: term),
      In t l /\ term_matches t w
  .
  Proof.
    induction l; autorewrite with sum.
    - split; intros.
      + dependent destruction H.
      + now destruct H as [t [? ?]].
    - split; intros.
      + dependent destruction H.
        * exists a; intuition.
        * apply IHl in H.
          destruct H as [t [? ?]].
          exists t; intuition.
      + destruct H as [t [[? | ?] ?]].
        * subst.
          now apply MatchPlusLeft.
        * apply MatchPlusRight.
          apply IHl.
          now exists t.
  Qed.

  Lemma term_matches_prepend_letter (t: term) (a: A):
    ~ term_matches ($a ;; t) nil
  .
  Proof.
    intro.
    dependent destruction H.
    dependent destruction H.
    rewrite <- app_comm_cons in x.
    inversion x.
  Qed.
End TermMatches.

Section TermEmpty.
  Context {A: Type}.
  Context `{Finite A}.
  Notation term := (term A).

  Equations term_empty (t: term): bool := {
    term_empty 0 := true;
    term_empty 1 := false;
    term_empty ($ a) := false;
    term_empty (t1 + t2) := term_empty t1 && term_empty t2;
    term_empty (t1 ;; t2) := term_empty t1 || term_empty t2;
    term_empty (t*) := false
  }.

  Lemma term_empty_dec (t: term):
    term_empty t = false <-> exists w, term_matches t w
  .
  Proof.
    induction t;
    autorewrite with term_empty.
    - intuition.
      destruct H0 as [w ?].
      dependent destruction H0.
    - intuition.
      exists nil.
      apply MatchOne.
    - intuition.
      exists (a :: nil).
      apply MatchLetter.
    - rewrite Bool.andb_false_iff.
      rewrite IHt1, IHt2.
      split; intros.
      + destruct H0.
        * destruct H0 as [w ?].
          exists w.
          now apply MatchPlusLeft.
        * destruct H0 as [w ?].
          exists w.
          now apply MatchPlusRight.
      + destruct H0 as [w ?].
        dependent destruction H0.
        * left; now exists w.
        * right; now exists w.
    - rewrite Bool.orb_false_iff.
      rewrite IHt1, IHt2.
      split; intros.
      + destruct H0.
        destruct H0 as [w1 ?], H1 as [w2 ?].
        exists (w1 ++ w2).
        now apply MatchTimes.
      + destruct H0 as [w ?].
        dependent destruction H0.
        split.
        * now exists w1.
        * now exists w2.
    - intuition.
      exists nil.
      apply MatchStarBase.
  Qed.

  Lemma term_empty_zero (t: term):
    term_empty t = true ->
    t == 0
  .
  Proof.
    induction t;
    autorewrite with term_empty;
    intros.
    - reflexivity.
    - discriminate.
    - discriminate.
    - rewrite Bool.andb_true_iff in H0.
      destruct H0.
      rewrite IHt1, IHt2; auto.
      apply term_lequiv_refl.
    - rewrite Bool.orb_true_iff in H0.
      destruct H0.
      + rewrite IHt1 by auto.
        now rewrite ETimesZeroRight.
      + rewrite IHt2 by auto.
        now rewrite ETimesZeroLeft.
    - discriminate.
  Qed.

  Lemma term_empty_invariant (t1 t2: term):
    t1 == t2 ->
    term_empty t1 = term_empty t2
  .
  Proof.
    intros.
    dependent induction H0;
    autorewrite with term_empty in *;
    try congruence;
    try rewrite <- IHterm_equiv;
    btauto.
  Qed.

  Lemma term_zero_empty (t: term):
    t == 0 ->
    term_empty t = true
  .
  Proof.
    intros.
    now apply term_empty_invariant in H0.
  Qed.

  Equations term_repeat
    (n: nat)
    (t: term)
  :
    term
  := {
    term_repeat 0%nat t := 1;
    term_repeat (S n) t := t ;; term_repeat n t;
  }.

  Lemma term_matches_star_repeat
    (t: term)
    (w: list A)
  :
    term_matches (t*) w <->
    exists n, term_matches (term_repeat n t) w
  .
  Proof.
    split; intros.
    - dependent induction H0.
      + exists 0%nat.
        autorewrite with term_repeat.
        apply MatchOne.
      + destruct (IHterm_matches2 H t eq_refl) as [n ?].
        exists (S n).
        autorewrite with term_repeat.
        now apply MatchTimes.
    - destruct H0 as [n ?].
      revert w H0; induction n; intros;
      autorewrite with term_repeat in H0.
      + dependent destruction H0.
        apply MatchStarBase.
      + dependent destruction H0.
        apply MatchStarStep; auto.
  Qed.

  Lemma term_lequiv_sound
    (t1 t2: term)
    (w: list A)
  :
    t1 <= t2 ->
    term_matches t1 w ->
    term_matches t2 w
  .
  Proof.
    intros.
    apply term_equiv_sound with (t2 := t1 + t2).
    + now symmetry.
    + now apply MatchPlusLeft.
  Qed.
End TermEmpty.

Section TermSubst.
  Context {A: Type}.
  Notation term := (term A).

  Equations term_subst (f: A -> term) (t: term) : term := {
    term_subst f 0 := 0;
    term_subst f 1 := 1;
    term_subst f ($ a) := f a;
    term_subst f (t1 + t2) := term_subst f t1 + term_subst f t2;
    term_subst f (t1 ;; t2) := term_subst f t1 ;; term_subst f t2;
    term_subst f (t*) := (term_subst f t)*
  }.

  Lemma term_subst_preserve (f: A -> term) (t1 t2: term):
    t1 == t2 ->
    term_subst f t1 == term_subst f t2
  .
  Proof.
    intros.
    dependent induction H;
    autorewrite with term_subst.
    - reflexivity.
    - now symmetry.
    - now transitivity (term_subst f t2).
    - now rewrite IHterm_equiv1, IHterm_equiv2.
    - now rewrite IHterm_equiv1, IHterm_equiv2.
    - now rewrite IHterm_equiv.
    - apply EPlusIdemp.
    - apply EPlusComm.
    - apply EPlusAssoc.
    - apply EPlusUnit.
    - apply ETimesAssoc.
    - apply ETimesUnitRight.
    - apply ETimesUnitLeft.
    - apply ETimesZeroLeft.
    - apply ETimesZeroRight.
    - apply EDistributeLeft.
    - apply EDistributeRight.
    - apply EStarLeft.
    - autorewrite with term_subst in IHterm_equiv.
      now apply EFixLeft.
  Qed.
End TermSubst.