Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e511m481_24limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Basics.
Require Import Types.
Require Import Colimits.Pushout.
Require Import Colimits.SpanPushout.
Require Import HoTT.Truncations.
Require Import Homotopy.Suspension.
Require Import Homotopy.BlakersMassey.

(** * The Freudenthal Suspension Theorem *)

(** The Freudenthal suspension theorem is a fairly trivial corollary of the Blakers-Massey theorem.  The only real work is to relate the span-pushout that we used for Blakers-Massey to the naive pushout that we used to define suspension. *)
Local Definition freudenthal' `{Univalence} (n : trunc_index)
           (X : Type) `{IsConnected n.+1 X}
  : IsConnMap (n +2+ n) (@merid X).
Proof.
  snrapply cancelR_equiv_conn_map.
  2: { refine (equiv_ap' (B:=SPushout (fun (u v : Unit) => X)) _ North South).
       exact (equiv_pushout (equiv_contr_sigma (fun _ : Unit * Unit => X))^-1
                            (equiv_idmap Unit) (equiv_idmap Unit)
                            (fun x : X => idpath) (fun x : X => idpath)). }
  refine (conn_map_homotopic _ _ _ _
                             (blakers_massey n n (fun (u v:Unit) => X) tt tt)).
  intros x.
  refine (_ @ (equiv_pushout_pglue
                 (equiv_contr_sigma (fun _ : Unit * Unit => X))^-1
                 (equiv_idmap Unit) (equiv_idmap Unit)
                 (fun x : X => idpath) (fun x : X => idpath) x)^).
  exact ((concat_p1 _ @ concat_1p _)^).
Defined.

Definition freudenthal@{u v | u < v} := Eval unfold freudenthal' in @freudenthal'@{u u u u u v u u u u u}.

Global Existing Instance freudenthal.


Require Import TypeSyntax.
Require Import Semantics.
Require Import Axioms.

Set Implicit Arguments.

Lemma lt_0_Sn : forall n, 0 < (S n).
induction n.
 constructor.
 constructor. assumption.
Defined.

Definition church_nums : forall n, type n.
intro n.
apply ty_forall.
apply ty_arr.
 apply ty_arr.
  apply ty_var. apply var with (i:=0). apply lt_0_Sn.
  apply ty_var. apply var with (i:=0). apply lt_0_Sn.
 apply ty_arr.
  apply ty_var. apply var with (i:=0). apply lt_0_Sn.
  apply ty_var. apply var with (i:=0). apply lt_0_Sn.
Defined.

Definition to_nat : forall n e, ty_sem e (church_nums n) -> nat.
intros. destruct H as [cnat _]. simpl in *.
apply (cnat nat).
 apply S.
 apply 0.
Defined.

Definition from_nat : forall n e, nat -> ty_sem e (church_nums n).
intros. unfold church_nums. unfold ty_sem. simpl.
exists (fun A succ zero => nat_rec (fun n => A) zero (fun _ a => succ a) H).
induction H.
 auto.
 intros. simpl. apply H0. apply (IHnat A1 A2 R x1 x2 H0 x0 x3). apply H1.
Defined.

Lemma nat_iso1 : forall g (e:ty_environment g) n, to_nat (from_nat e n) = n.
intros. unfold to_nat. unfold from_nat. induction n.
 simpl. reflexivity.
 simpl in *. rewrite IHn. reflexivity.
Save.

Lemma nat_iso2 : forall g (e:ty_environment g) t, from_nat e (to_nat t) = t.
unfold ty_sem. unfold to_nat. unfold from_nat. intros. simpl in *.
match goal with [ |- ?x = ?y ] => refine (sig_eq x y _) end. simpl in *. destruct t as [t P].
simpl in *.
ext A. ext succ. ext zero.
(* apply parametricity *)
apply (P nat A (fun n a => nat_rec (fun _ => A) zero (fun _ a => succ a) n = a)).
 (* S and succ are related *)
 simpl. intros. rewrite H. reflexivity.
 (* O and zero are related *)
 simpl. reflexivity.
Save.


From mathcomp Require Import all_ssreflect.
Require Import Utf8 oseq utils.

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

Section PairFoldLeft.

  Variables (T R : Type) (f : R -> T → T → R).

  Fixpoint pairfoldl z t s :=
    if s is x :: s'
    then pairfoldl (f z t x) x s'
    else z.

  Lemma pairfoldl_rcons z t s x :
    pairfoldl z t (rcons s x) =
    f (pairfoldl z t s) (last t s) x.
  Proof.
    by elim: s z t => [|hs ts IHs] /=.
  Qed.

End PairFoldLeft.

Section Prefix.

  Variable T U : eqType.
  Implicit Type s : seq T.

  Fixpoint prefix {T : eqType} (s1 s2 : seq T) :=
    if s2 is y :: s2' then
      if s1 is x :: s1' then
        if x == y then prefix s1' s2' else false
      else true
    else s1 == [::].

  Lemma prefix0seq s : prefix [::] s.
  Proof.
    by induction s.
  Qed.

  Lemma prefixseq0 s : prefix s [::] = (s == [::]).
  Proof.
    by case: s.
  Qed.

  Lemma prefixP s1 s2 :
    reflect (exists m, s2 = s1 ++ m) (prefix s1 s2).
  Proof.
    elim: s1 s2 => [|hs1 ts1 IHs1] [|hs2 ts2] //=.
    + by left; exists [::].
    + by left; exists (hs2 :: ts2).
    + right => Hm.
      by case: Hm => m.
    case Hh: (hs1 == hs2); case (IHs1 ts2) => Hm.
    + by left; move: Hm => [m] ->; rewrite (eqP Hh); exists m.
    + by right; move => [m [_ Hts2]]; apply Hm; exists m.
    + by right; move => [m [Hh' _]]; rewrite Hh' eq_refl in Hh.
    by right; move => [m [Hh' _]]; rewrite Hh' eq_refl in Hh.
  Qed.

  Lemma mask_prefix n s : prefix (mask (nseq n true) s) s.
  Proof.
    by elim: s n => [|hs ts IHs] [|n] => //=; rewrite eq_refl.
  Qed.

  Lemma prefix_trans : ssrbool.transitive (@prefix T).
  Proof.
    move => y x z /prefixP [m1 ->] /prefixP [m2 ->].
    by apply/prefixP; exists (m1 ++ m2); rewrite catA.
  Qed.

  Lemma prefix_refl s : prefix s s.
  Proof. by apply/prefixP; exists [::]; rewrite cats0. Qed.

  Hint Resolve prefix_refl : core.

  Lemma mem_prefix s1 s2 : prefix s1 s2 -> forall x , x \in s1 -> x \in s2.
  Proof. by move => /prefixP [s] ?; subst s2 => x; rewrite mem_cat => ->. Qed.

  Lemma subseq_prefix s1 s2 : prefix s1 s2 -> subseq s1 s2.
  Proof.
    move=> pl; apply/subseqP.
    case/prefixP: pl => s {s2}->.
    exists ((nseq (size s1) true) ++ (nseq (size s) false)).
    + by rewrite !size_cat !size_nseq.
    rewrite mask_cat.
    + by rewrite mask_true // mask_false cats0.
    by rewrite size_nseq.
  Qed.

  Lemma prefix_prefix s1 s2 : prefix s1 (s1 ++ s2).
  Proof.
    by apply/prefixP; exists s2.
  Qed.

  Lemma cat_prefix s1 s2 s3 :
    prefix s1 s2 → prefix s1 (s2 ++ s3).
  Proof.
    by case/prefixP => m ->; apply/prefixP; exists (m ++ s3); rewrite catA.
  Qed.

  Lemma subset_prefix s1 s2 : prefix s1 s2 -> {subset s1 <= s2}.
  Proof.
    by case/prefixP => m -> x; rewrite mem_cat => ->.
  Qed.

  Lemma prefix1 x s : prefix [:: x] s = (Some x == ohead s).
  Proof.
    apply/prefixP/eqP; first by case => m ->.
    by case: s => //= y s [->]; exists s.
  Qed.

  Lemma size_prefix s1 s2 : prefix s1 s2 → size s1 <= size s2.
  Proof.
    by case/prefixP => m ->; rewrite size_cat leq_addr.
  Qed.

  Lemma size_prefix_leqif s1 s2 :
    prefix s1 s2 → size s1 <= size s2 ?= iff (s1 == s2).
  Proof.
    move=> sub12; split; first exact: size_prefix.
    apply/idP/eqP=> [|-> //]; case/prefixP: sub12 => m ->.
    rewrite size_cat -{1}[size s1]addn0 eqn_add2l eq_sym size_eq0.
    by move/eqP => ->; rewrite cats0.
  Qed.

  Lemma prefix_rcons s x : prefix s (rcons s x).
  Proof. by elim: s => //= y s ih; rewrite eqxx. Qed.

  Lemma prefix_rcons_prefix s s' (x : T) :
    prefix (rcons s x) s' -> prefix s s'.
  Proof. by move => Hprefix; apply/(prefix_trans _ Hprefix)/prefix_rcons. Qed.

  Lemma prefix_uniq s1 s2 : prefix s1 s2 → uniq s2 → uniq s1.
  Proof.
    move => Hp.
    apply subseq_uniq.
    by apply subseq_prefix.
  Qed.

  Lemma prefixW P s :
    P [::] s ->
    (forall h t , prefix (rcons t h) s -> P t s -> P (rcons t h) s) ->
    P s s.
  Proof.
    move=> Pnil Pcons; have := prefix_refl s.
    elim/last_ind: {1 3}s => // s' x ih pr_s'x_s.
    apply: Pcons => //; apply: ih.
    by apply/(prefix_trans _ pr_s'x_s)/prefix_rcons.
  Qed.

  Lemma prefix_all s1 s2 p :
    prefix s1 s2 -> all p s2 -> all p s1.
  Proof.
    by move => /prefixP [s] ->; rewrite all_cat => /andP [].
  Qed.

  Lemma prefix_filter s1 s2 p :
    prefix s1 s2 -> prefix (filter p s1) (filter p s2).
  Proof.
    by move => /prefixP [s] ->; rewrite filter_cat; apply/prefixP; eexists.
  Qed.

End Prefix.

Section PrefixProps.

  Lemma prefix_map {T U : eqType} s1 s2 (f : T -> U) :
    prefix s1 s2 -> prefix (map f s1) (map f s2).
  Proof.
    by move => /prefixP [s] ->; rewrite map_cat; apply/prefixP; eexists.
  Qed.

End PrefixProps.

Section oPrefix.

  Variable T : eqType.
  Implicit Type s : seq T.

  Lemma prefix_onth s1 s2 i :
    prefix s1 s2 -> i < size s1 -> oseq.onth s1 i = oseq.onth s2 i.
  Proof.
    by move/prefixP => [s] ->; rewrite oseq.onth_cat => ->.
  Qed.

End oPrefix.

Section PairOnth.

  Variable T1 T2 : Type.
  Variable f : T1 -> T1 -> T2.

  Fixpoint paironth x s i : option (T1 * T1) :=
    match s with
    | [::] => None
    | y :: s' =>
      match i with
      | 0 => Some (x,y)
      | i'.+1 => paironth y s' i'
      end
    end.

  Lemma paironth_onth x s i p1 p2:
    (paironth x s i = Some (p1,p2)) <->
    match i with
    | 0 => (x = p1) /\ (oseq.onth s i = Some p2)
    | i'.+1 => (oseq.onth s i' = Some p1) /\ (oseq.onth s i = Some p2)
    end.
  Proof.
    elim: s x i => [x [|i]|hs ts IHs x [|i]] => //=.
    + by split => [|[]]; [split|].
    + by split => [|[]]; [split|].
    + by split => [[-> ->]|[-> [->]]].
    apply (iff_trans (IHs _ _)).
    case Hi: i => //=.
    apply and_iff_compat_r.
    by split => [->|[]].
  Qed.

  Lemma paironth_onth2 x s i p1 p2:
    (paironth x s i = Some (p1,p2)) ->
    (oseq.onth s i = Some p2).
  Proof.
    by move => Hpaironth; apply paironth_onth in Hpaironth;
    move: Hpaironth; case: i => [[]|i []].
  Qed.

  Lemma paironth_pairmap x s i :
    oseq.onth (pairmap f x s) i =
    match paironth x s i with
    | Some (p1,p2) => Some (f p1 p2)
    | None => None
    end.
  Proof.
    by elim: s x i => [x [|i]|hs ts IHs x [|i]] /=.
  Qed.

End PairOnth.

Section PairMapProps.

  Lemma pairmapE {T U : Type} (f : T -> T -> U) (x : T) (s : seq T) :
    pairmap f x s = map (fun xy => f xy.1 xy.2) (zip (x :: s) s).
  Proof. by elim: s x => //= y s ->. Qed.

  Lemma eq_pairmap {T U : Type} (f g : T -> T -> U) (x : T) (s : seq T) :
    f =2 g -> pairmap f x s = pairmap g x s.
  Proof. by move=> eq_fg; rewrite !pairmapE; apply/eq_map=> []. Qed.

  Lemma size_pairmap {T U : Type} (f : T -> T -> U) (x : T) (s : seq T) :
    size (pairmap f x s) = size s.
  Proof. by rewrite pairmapE size_map size2_zip /=. Qed.

End PairMapProps.

Section MapProps.

  Lemma onth_map {T1 T2 : Type} (f : T1 -> T2) s i :
    oseq.onth (map f s) i =
    match oseq.onth s i with
    | Some x => Some (f x)
    | None => None
    end.
  Proof.
    by elim: s i => [|hs ts IHs] i //; case: i => [|i] /=.
  Qed.

  Lemma map_filter (T1 T2 : Type) (a : pred T2) (b : T1 -> T2) (s : seq T1) :
    filter a (map b s) = map b (filter (fun x => a (b x)) s).
  Proof.
    by elim: s => //= hs ts ->; case: ifP.
  Qed.

End MapProps.

Section OnthProps.

  Lemma onth_rcons (T : Type) s (x : T) i :
    oseq.onth (rcons s x) i =
    if i == size s
    then Some x
    else oseq.onth s i.
  Proof.
    by elim: s i => [|hs ts IHs] i //=; case: i => //.
  Qed.

  Lemma eq_from_onth (T : Type) (s1 s2 : seq T) :
    (forall i, onth s1 i = onth s2 i) -> s1 = s2.
  Proof.
    elim: s1 s2 => [|x1 s1 IHs1] [|x2 s2] //.
    + by move => /(_ 0).
    + by move => /(_ 0).
    move => Heqonth; f_equal.
    + by move: (Heqonth 0) => /= [].
    by apply IHs1 => i; move: (Heqonth i.+1) => /=.
  Qed.

  Lemma onth_In {T : Type} (x : T) (s : seq T) i :
    onth s i = Some x →
    List.In x s.
  Proof.
    elim: s i => //= y s IHs [].
    - by case => <-; left.
    by move => i /IHs; right.
  Qed.

End OnthProps.

Lemma take_onth (T : Type) n (s : seq T) :
  take n.+1 s =
  match onth s n with
  | Some x => rcons (take n s) x
  | None   => take n s
  end.
Proof. by elim: s n => [|x s IHs] //= [|n] /=; rewrite ?take0 ?IHs //; case: (onth _ _). Qed.

Lemma drop_onth (T : Type) n (s : seq T) :
  drop n s =
  match onth s n with
  | Some x => x :: (drop n.+1 s)
  | None   => drop n.+1 s
  end.
Proof. by elim: s n => [|x s IHs] //= [|n] /=; rewrite ?drop0. Qed.

Section AllProps.

  Lemma all_if (T : Type) (a b c : pred T) (s : seq T) :
    all a (filter c s) ->
    all b (filter (negb \o c) s) ->
    all (fun x => if c x then a x else b x) s.
  Proof.
    elim: s => //= hs ts IHs.
    by case: ifP => [Hchs /= /andP [Hahs Hats] Hbts|Hchs /= Hats /andP [Hbhs Hbts]];
    apply/andP; split => //; apply: IHs.
  Qed.

  Lemma all_filtered (T : Type) (a b : pred T) (s : seq T) :
    all a s -> all a (filter b s).
  Proof.
    by elim: s => //= hs ts IHs; case: ifP => /= _ /andP;
    case => Hahs Hths; first (apply/andP; split => //); apply: IHs.
  Qed.

  Lemma all_eq_filter (T : Type) (a b c : pred T) (s : seq T) :
    (forall x, c x -> a x = b x) ->
    all a (filter c s) ->
    all b (filter c s).
  Proof.
    move => Hcab; elim: s => //= hs ts IHs; case: ifP => //= Hchs /andP [Hahs Hats].
    by apply/andP; split; first rewrite -Hcab; last apply IHs.
  Qed.

  Lemma allE (T: Type) (p: pred T) m :
    reflect (List.Forall p m) (all p m).
  Proof.
    elim: m; first by left.
    move => a m ih /=.
    case h: (p a); last first.
    - by right => /List_Forall_inv[]; rewrite h.
    case: ih => ih; constructor.
    - by constructor.
    by case/List_Forall_inv.
  Qed.

End AllProps.


(**********************************************************************************

 Total categories

 We prove that every two-sided displayed category gives rise to a span of
 categories. More specifically, every two-sided displayed category `D` over `C₁`
 and `C₂` gives rise to a total category `∫ D`, a first projection `∫ D ⟶ C₁`, and
 a second projection `∫ D ⟶ C₂`. In addition, the univalence of `∫ D` follows from
 the displayed univalence of `D` and the univalence of both `C₁` and `D₂`.

 Note that we can also construct total displayed categories from a two-sided
 displayed category. More specifically, if we have a two-sided displayed category
 `D` over `C₁` and `C₂`, then we get the left total displayed category over `C₂`
 and the right total displayed category over `C₁`. Univalence of those displayed
 categories follows from the univalence of `D`.

 Contents
 1. Total category
 1.1. Definition
 1.2. First and second projection
 1.3. Isos in the total category
 1.4. Univalence of the total category
 2. Left total displayed category
 2.1. Definition
 2.2. Isomorphisms
 2.3. The univalence
 3. Right total displayed category
 3.1. Definition
 3.2. Isomorphisms
 3.3. The univalence

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.

Local Open Scope cat.

Definition transportb_total2
           {X Y : UU}
           (Z : X → Y → UU)
           {x₁ x₂ : X}
           (p : x₁ = x₂)
           (yz : ∑ (y : Y), Z x₂ y)
  : transportb
      (λ (x : X), ∑ (y : Y), Z x y)
      p
      yz
    =
    pr1 yz
    ,,
    transportb
      (λ x, Z x (pr1 yz))
      p
      (pr2 yz).
Proof.
  induction p ; cbn.
  apply idpath.
Defined.

Section TotalOfTwoSidedDispCat.
  Context {C₁ C₂ : category}
          (D : twosided_disp_cat C₁ C₂).

  (**
   1. Total category
   *)

  (**
   1.1. Definition
   *)
 Definition total_twosided_disp_precategory_ob_mor
    : precategory_ob_mor.
  Proof.
    use make_precategory_ob_mor.
    - exact (∑ (x : C₁) (y : C₂), D x y).
    - exact (λ xy₁ xy₂,
             ∑ (f : pr1 xy₁ --> pr1 xy₂)
               (g : pr12 xy₁ --> pr12 xy₂),
             pr22 xy₁ -->[ f ][ g ] pr22 xy₂).
  Defined.

  Definition total_twosided_disp_precategory_data
    : precategory_data.
  Proof.
    use make_precategory_data.
    - exact total_twosided_disp_precategory_ob_mor.
    - exact (λ xy,
             identity (pr1 xy)
             ,,
             identity (pr12 xy)
             ,,
             id_two_disp (pr22 xy)).
    - exact (λ xy₁ xy₂ xy₃ fg₁ fg₂,
             pr1 fg₁ · pr1 fg₂
             ,,
             pr12 fg₁ · pr12 fg₂
             ,,
             pr22 fg₁ ;;2 pr22 fg₂).
  Defined.

  Definition total_twosided_disp_is_precategory
    : is_precategory total_twosided_disp_precategory_data.
  Proof.
    use make_is_precategory_one_assoc.
    - intros xy₁ xy₂ fg.
      use total2_paths_2_b.
      + apply id_left.
      + apply id_left.
      + apply id_two_disp_left.
    - intros xy₁ xy₂ fg.
      use total2_paths_2_b.
      + apply id_right.
      + apply id_right.
      + apply id_two_disp_right.
    - intros xy₁ xy₂ xy₃ xy₄ fg₁ fg₂ fg₃.
      use total2_paths_2_b.
      + apply assoc.
      + apply assoc.
      + apply assoc_two_disp.
  Qed.

  Definition total_twosided_disp_precategory
    : precategory.
  Proof.
    use make_precategory.
    - exact total_twosided_disp_precategory_data.
    - exact total_twosided_disp_is_precategory.
  Defined.

  Definition has_homsets_total_twosided_disp_category
    : has_homsets total_twosided_disp_precategory_ob_mor.
  Proof.
    intros xy₁ xy₂.
    apply isaset_total2.
    - apply homset_property.
    - intro.
      apply isaset_total2.
      + apply homset_property.
      + intro.
        apply isaset_disp_mor.
  Defined.

  Definition total_twosided_disp_category
    : category.
  Proof.
    use make_category.
    - exact total_twosided_disp_precategory.
    - exact has_homsets_total_twosided_disp_category.
  Defined.

  Definition from_eq_total
             {x₁ x₂ : total_twosided_disp_category}
             {f g : x₁ --> x₂}
             (p : f = g)
    : pr22 f
      =
      transportb
        (λ z, _ -->[ z ][ _ ] _)
        (maponpaths (λ z, pr1 z) p)
        (transportb
           (λ z, _ -->[ _ ][ z ] _)
           (maponpaths (λ z, pr12 z) p)
           (pr22 g)).
  Proof.
    induction p.
    apply idpath.
  Qed.

  (**
   1.2. First and second projection
   *)
  Definition twosided_disp_category_pr1_data
    : functor_data total_twosided_disp_category C₁.
  Proof.
    use make_functor_data.
    - exact (λ xy, pr1 xy).
    - exact (λ xy₁ xy₂ fg, pr1 fg).
  Defined.

  Definition twosided_disp_category_pr1_is_functor
    : is_functor twosided_disp_category_pr1_data.
  Proof.
    refine (_ ,, _) ; intro ; intros ; cbn.
    - apply idpath.
    - apply idpath.
  Qed.

  Definition twosided_disp_category_pr1
    : total_twosided_disp_category ⟶ C₁.
  Proof.
    use make_functor.
    - exact twosided_disp_category_pr1_data.
    - exact twosided_disp_category_pr1_is_functor.
  Defined.

  Definition twosided_disp_category_pr2_data
    : functor_data total_twosided_disp_category C₂.
  Proof.
    use make_functor_data.
    - exact (λ xy, pr12 xy).
    - exact (λ xy₁ xy₂ fg, pr12 fg).
  Defined.

  Definition twosided_disp_category_pr2_is_functor
    : is_functor twosided_disp_category_pr2_data.
  Proof.
    refine (_ ,, _) ; intro ; intros ; cbn.
    - apply idpath.
    - apply idpath.
  Qed.

  Definition twosided_disp_category_pr2
    : total_twosided_disp_category ⟶ C₂.
  Proof.
    use make_functor.
    - exact twosided_disp_category_pr2_data.
    - exact twosided_disp_category_pr2_is_functor.
  Defined.

  (**
   1.3. Isos in the total category
   *)
  Section IsoTotal.
    Context {x₁ x₂ : C₁}
            {y₁ y₂ : C₂}
            {xy₁ : D x₁ y₁}
            {xy₂ : D x₂ y₂}
            {f : x₁ --> x₂}
            {Hf : is_z_isomorphism f}
            {g : y₁ --> y₂}
            {Hg : is_z_isomorphism g}
            (fg : xy₁ -->[ f ][ g ] xy₂)
            (Hfg : is_iso_twosided_disp Hf Hg fg).

    Let total_fg : total_twosided_disp_category ⟦ (x₁ ,, y₁ ,, xy₁) , (x₂ ,, y₂ ,, xy₂) ⟧
        := f ,, g ,, fg.
    Let f_z_iso : z_iso x₁ x₂ := f ,, Hf.
    Let g_z_iso : z_iso y₁ y₂ := g ,, Hg.

    Definition is_z_iso_total_twosided_disp_cat_inv
      : total_twosided_disp_category ⟦ (x₂ ,, y₂ ,, xy₂) , (x₁ ,, y₁ ,, xy₁) ⟧
      := inv_from_z_iso f_z_iso
         ,,
         inv_from_z_iso g_z_iso
         ,,
         iso_inv_twosided_disp Hfg.

    Definition is_z_iso_total_twosided_disp_cat_inv_right
      : total_fg · is_z_iso_total_twosided_disp_cat_inv = identity _.
    Proof.
      use total2_paths_2_b ; cbn.
      - apply (z_iso_inv_after_z_iso f_z_iso).
      - apply (z_iso_inv_after_z_iso g_z_iso).
      - apply inv_after_iso_twosided_disp.
    Qed.

    Definition is_z_iso_total_twosided_disp_cat_inv_left
      : is_z_iso_total_twosided_disp_cat_inv · total_fg = identity _.
    Proof.
      use total2_paths_2_b ; cbn.
      - apply (z_iso_after_z_iso_inv f_z_iso).
      - apply (z_iso_after_z_iso_inv g_z_iso).
      - apply iso_after_inv_twosided_disp.
    Qed.

    Definition is_z_iso_total_twosided_disp_cat
      : is_z_isomorphism total_fg.
    Proof.
      simple refine (is_z_iso_total_twosided_disp_cat_inv ,, _ ,, _).
      - apply is_z_iso_total_twosided_disp_cat_inv_right.
      - apply is_z_iso_total_twosided_disp_cat_inv_left.
    Defined.
  End IsoTotal.

  Definition make_z_iso_total_twosided_disp_cat
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : z_iso x₁ x₂}
             {g : z_iso y₁ y₂}
             (fg : iso_twosided_disp f g xy₁ xy₂)
    : @z_iso
        total_twosided_disp_category
        (x₁ ,, y₁ ,, xy₁)
        (x₂ ,, y₂ ,, xy₂).
  Proof.
    simple refine (_ ,, _).
    - exact (pr1 f ,, pr1 g ,, pr1 fg).
    - use is_z_iso_total_twosided_disp_cat.
      + exact (pr2 f).
      + exact (pr2 g).
      + exact (pr2 fg).
  Defined.

  Section FromIsoTotal.
      Context {x₁ x₂ : C₁}
              {y₁ y₂ : C₂}
              {xy₁ : D x₁ y₁}
              {xy₂ : D x₂ y₂}
              (f : @z_iso
                     total_twosided_disp_category
                     (x₁ ,, y₁ ,, xy₁)
                     (x₂ ,, y₂ ,, xy₂)).

      Definition from_iso_total_twosided_disp_cat_pr1
        : z_iso x₁ x₂.
      Proof.
        use make_z_iso.
        - exact (pr11 f).
        - exact (pr1 (inv_from_z_iso f)).
        - split.
          + exact (maponpaths pr1 (z_iso_inv_after_z_iso f)).
          + exact (maponpaths pr1 (z_iso_after_z_iso_inv f)).
      Defined.

      Definition from_iso_total_twosided_disp_cat_pr12
        : z_iso y₁ y₂.
      Proof.
        use make_z_iso.
        - exact (pr121 f).
        - exact (pr12 (inv_from_z_iso f)).
        - split.
          + exact (maponpaths (λ z, pr12 z) (z_iso_inv_after_z_iso f)).
          + exact (maponpaths (λ z, pr12 z) (z_iso_after_z_iso_inv f)).
      Defined.

      Definition from_iso_total_twosided_disp_cat_pr22
        : iso_twosided_disp
            from_iso_total_twosided_disp_cat_pr1
            from_iso_total_twosided_disp_cat_pr12
            xy₁ xy₂.
      Proof.
        simple refine (_ ,, _ ,, _ ,, _).
        - exact (pr221 f).
        - exact (pr22 (inv_from_z_iso f)).
        - exact (from_eq_total (z_iso_inv_after_z_iso f)).
        - exact (from_eq_total (z_iso_after_z_iso_inv f)).
      Defined.

      Definition from_iso_total_twosided_disp_cat
        : ∑ (f : z_iso x₁ x₂)
            (g : z_iso y₁ y₂),
          iso_twosided_disp f g xy₁ xy₂.
      Proof.
        simple refine (_ ,, _ ,, _).
        - exact from_iso_total_twosided_disp_cat_pr1.
        - exact from_iso_total_twosided_disp_cat_pr12.
        - exact from_iso_total_twosided_disp_cat_pr22.
      Defined.
  End FromIsoTotal.

  Definition weq_z_iso_total_twosided_disp_cat_help_eq
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {fg₁ fg₂ : ∑ (f : z_iso x₁ x₂)
                          (g : z_iso y₁ y₂),
                        iso_twosided_disp f g xy₁ xy₂}
             (p : pr11 fg₁ = pr11 fg₂)
             (q : pr112 fg₁ = pr112 fg₂)
             (r : pr122 fg₁
                  =
                  transportb
                    (λ z, _ -->[ z ][ _ ] _)
                    p
                    (transportb
                       (λ z, _ -->[ _ ][ z ] _)
                       q
                       (pr122 fg₂)))
    : fg₁ = fg₂.
  Proof.
    induction fg₁ as [ f₁ fg₁ ].
    induction fg₁ as [ g₁ fg₁ ].
    induction f₁ as [ f₁ Hf₁ ].
    induction g₁ as [ g₁ Hg₁ ].
    induction fg₁ as [ fg₁ Hfg₁ ].
    induction fg₂ as [ f₂ fg₂ ].
    induction fg₂ as [ g₂ fg₂ ].
    induction f₂ as [ f₂ Hf₂ ].
    induction g₂ as [ g₂ Hg₂ ].
    induction fg₂ as [ fg₂ Hfg₂ ].
    cbn in *.
    induction p ; induction q ; cbn in *.
    induction r.
    assert (p : Hf₁ = Hf₂) by apply isaprop_is_z_isomorphism.
    induction p.
    apply maponpaths.
    assert (p : Hg₁ = Hg₂) by apply isaprop_is_z_isomorphism.
    induction p.
    do 2 apply maponpaths.
    apply isaprop_is_iso_twosided_disp.
  Qed.

  Definition weq_z_iso_total_twosided_disp_cat
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x₁ y₁)
             (xy₂ : D x₂ y₂)
    : (∑ (f : z_iso x₁ x₂)
         (g : z_iso y₁ y₂),
       iso_twosided_disp f g xy₁ xy₂)
      ≃
      (@z_iso
          total_twosided_disp_category
          (x₁ ,, y₁ ,, xy₁)
          (x₂ ,, y₂ ,, xy₂)).
  Proof.
    use weq_iso.
    - exact (λ fg, make_z_iso_total_twosided_disp_cat (pr22 fg)).
    - exact from_iso_total_twosided_disp_cat.
    - abstract
        (intros f ;
         use weq_z_iso_total_twosided_disp_cat_help_eq ; apply idpath).
    - abstract
        (intros f ;
         use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ;
         apply idpath).
  Defined.

  (**
   1.4. Univalence of the total category
   *)
  Definition is_univalent_total_twosided_disp_category
             (HC₁ : is_univalent C₁)
             (HC₂ : is_univalent C₂)
             (HD : is_univalent_twosided_disp_cat D)
    : is_univalent total_twosided_disp_category.
  Proof.
    intros x y.
    use weqhomot.
    - refine (weq_z_iso_total_twosided_disp_cat _ _
              ∘ weqtotal2
                  (_ ,, HC₁ _ _)
                  (λ p,
                  weqtotal2
                    (_ ,, HC₂ _ _)
                    (λ q, (_ ,, HD _ _ _ _ p q _ _))
              ∘ _
              ∘ total2_paths_equiv _ _ _)
              ∘ total2_paths_equiv _ _ _)%weq ; cbn.
      induction x, y.
      cbn in *.
      induction p.
      exact (idweq _).
    - abstract
        (intro p ;
         induction p ;
         use subtypePath ; [ intro ; apply isaprop_is_z_isomorphism | ] ;
         apply idpath).
  Qed.

  (**
   2. Left total displayed category
   *)

  (**
   2.1. Definition
   *)
  Definition left_total_of_twosided_disp_cat_ob_mor
    : disp_cat_ob_mor C₂.
  Proof.
    simple refine (_ ,, _).
    - exact (λ y, ∑ (x : C₁), D x y).
    - exact (λ y₁ y₂ xy₁ xy₂ g,
             ∑ (f : pr1 xy₁ --> pr1 xy₂),
             pr2 xy₁ -->[ f ][ g ] pr2 xy₂).
  Defined.

  Definition left_total_of_twosided_disp_cat_id_comp
    : disp_cat_id_comp C₂ left_total_of_twosided_disp_cat_ob_mor.
  Proof.
    split.
    - exact (λ y xy, identity (pr1 xy) ,, id_two_disp (pr2 xy)).
    - exact (λ y₁ y₂ y₃ g₁ g₂ xy₁ xy₂ xy₃ fg₁ fg₂,
             pr1 fg₁ · pr1 fg₂
             ,,
             (pr2 fg₁ ;;2 pr2 fg₂)).
  Defined.

  Definition left_total_of_twosided_disp_cat_data
    : disp_cat_data C₂.
  Proof.
    simple refine (_ ,, _).
    - exact left_total_of_twosided_disp_cat_ob_mor.
    - exact left_total_of_twosided_disp_cat_id_comp.
  Defined.

  Definition left_total_of_twosided_disp_cat_axioms
    : disp_cat_axioms C₂ left_total_of_twosided_disp_cat_data.
  Proof.
    repeat split.
    - intro ; intros.
      unfold mor_disp ; cbn.
      rewrite transportb_total2.
      use total2_paths_f.
      + apply id_left.
      + cbn.
        rewrite id_two_disp_left.
        rewrite transportfbinv.
        apply idpath.
    - intro ; intros.
      unfold mor_disp ; cbn.
      rewrite transportb_total2.
      use total2_paths_f.
      + apply id_right.
      + cbn.
        rewrite id_two_disp_right.
        rewrite transportfbinv.
        apply idpath.
    - intro ; intros.
      unfold mor_disp ; cbn.
      rewrite transportb_total2.
      use total2_paths_f.
      + apply assoc.
      + cbn.
        rewrite assoc_two_disp.
        rewrite transportfbinv.
        apply idpath.
    - intros.
      apply isaset_total2.
      + apply homset_property.
      + intro.
        apply isaset_disp_mor.
  Qed.

  Definition left_total_of_twosided_disp_cat
    : disp_cat C₂.
  Proof.
    simple refine (_ ,, _).
    - exact left_total_of_twosided_disp_cat_data.
    - exact left_total_of_twosided_disp_cat_axioms.
  Defined.

  (**
   2.2. Isomorphisms
   *)
  Definition make_iso_left_total_of_twosided_disp_cat
             {y : C₂}
             {xy₁ xy₂ : left_total_of_twosided_disp_cat y}
             (f : z_iso (pr1 xy₁) (pr1 xy₂))
             (fg : iso_twosided_disp f (identity_z_iso _) (pr2 xy₁) (pr2 xy₂))
    : z_iso_disp (identity_z_iso _) xy₁ xy₂.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr1 f ,, pr1 fg).
    - exact (pr12 f ,, pr12 fg).
    - abstract
        (unfold mor_disp ; cbn ;
         rewrite transportb_total2 ; cbn ;
         use total2_paths_f ; [ apply z_iso_after_z_iso_inv | ] ;
         cbn ;
         etrans ; [ apply maponpaths ; apply (iso_after_inv_twosided_disp (pr2 fg)) | ] ;
         rewrite transportfbinv ;
         apply idpath).
    - abstract
        (unfold mor_disp ; cbn ;
         rewrite transportb_total2 ; cbn ;
         use total2_paths_f ; [ apply z_iso_inv_after_z_iso | ] ;
         cbn ;
         etrans ; [ apply maponpaths ; apply (inv_after_iso_twosided_disp (pr2 fg)) | ] ;
         rewrite transportfbinv ;
         apply idpath).
  Defined.

  Definition from_iso_left_total_of_twosided_disp_cat_pr1
             {y : C₂}
             {xy₁ xy₂ : left_total_of_twosided_disp_cat y}
             (f : z_iso_disp (identity_z_iso _) xy₁ xy₂)
    : z_iso (pr1 xy₁) (pr1 xy₂).
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr11 f).
    - exact (pr112 f).
    - abstract
        (refine (maponpaths pr1 (inv_mor_after_z_iso_disp f) @ _) ;
         unfold mor_disp ; cbn ;
         rewrite transportb_total2 ;
         apply idpath).
    - abstract
        (refine (maponpaths pr1 (z_iso_disp_after_inv_mor f) @ _) ;
         unfold mor_disp ; cbn ;
         rewrite transportb_total2 ;
         apply idpath).
  Defined.

  Definition from_iso_left_total_of_twosided_disp_cat_pr2
             {y : C₂}
             {xy₁ xy₂ : left_total_of_twosided_disp_cat y}
             (f : z_iso_disp (identity_z_iso _) xy₁ xy₂)
    : iso_twosided_disp
        (from_iso_left_total_of_twosided_disp_cat_pr1 f)
        (identity_z_iso _) (pr2 xy₁) (pr2 xy₂).
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr21 f).
    - exact (pr212 f).
    - abstract
        (pose (p := inv_mor_after_z_iso_disp f) ; unfold mor_disp in p ; cbn in p ;
         rewrite transportb_total2 in p ;
         refine (!(fiber_paths (!p)) @ _) ; cbn ;
         unfold transportb ;
         rewrite !twosided_prod_transport ;
         apply maponpaths_2 ;
         apply isaset_dirprod ; apply homset_property).
    - abstract
        (pose (p := z_iso_disp_after_inv_mor f) ; unfold mor_disp in p ; cbn in p ;
         rewrite transportb_total2 in p ;
         refine (!(fiber_paths (!p)) @ _) ; cbn ;
         unfold transportb ;
         rewrite !twosided_prod_transport ;
         apply maponpaths_2 ;
         apply isaset_dirprod ; apply homset_property).
  Defined.

  Definition weq_iso_left_total_of_twosided_disp_cat_eq_help
             {y : C₂}
             {xy₁ xy₂ : left_total_of_twosided_disp_cat y}
             {fg₁ fg₂ : ∑ (f : z_iso (pr1 xy₁) (pr1 xy₂)),
                        iso_twosided_disp
                          f (identity_z_iso _)
                          (pr2 xy₁) (pr2 xy₂)}
             (p : pr11 fg₁ = pr11 fg₂)
             (q : pr12 fg₁
                  =
                  transportb
                    (λ z, _ -->[ z ][ _ ] _)
                    p
                    (pr12 fg₂))
    : fg₁ = fg₂.
  Proof.
    induction fg₁ as [ f₁ fg₁ ].
    induction f₁ as [ f₁ Hf₁ ].
    induction fg₁ as [ fg₁ Hfg₁ ].
    induction fg₂ as [ f₂ fg₂ ].
    induction f₂ as [ f₂ Hf₂ ].
    induction fg₂ as [ fg₂ Hfg₂ ].
    cbn in *.
    induction p ; cbn in *.
    induction q.
    assert (Hf₁ = Hf₂) as p by apply isaprop_is_z_isomorphism.
    induction p.
    do 2 apply maponpaths.
    apply isaprop_is_iso_twosided_disp.
  Qed.

  Definition weq_iso_left_total_of_twosided_disp_cat
             {y : C₂}
             (xy₁ xy₂ : left_total_of_twosided_disp_cat y)
    : (∑ (f : z_iso (pr1 xy₁) (pr1 xy₂)),
       iso_twosided_disp f (identity_z_iso _) (pr2 xy₁) (pr2 xy₂))
      ≃
      z_iso_disp (identity_z_iso _) xy₁ xy₂.
  Proof.
    use weq_iso.
    - exact (λ f, make_iso_left_total_of_twosided_disp_cat (pr1 f) (pr2 f)).
    - exact (λ f,
             from_iso_left_total_of_twosided_disp_cat_pr1 f
             ,,
             from_iso_left_total_of_twosided_disp_cat_pr2 f).
    - abstract
        (intro f ;
         cbn ;
         use weq_iso_left_total_of_twosided_disp_cat_eq_help ;
         apply idpath).
    - abstract
        (intro f ;
         use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ;
         apply idpath).
  Defined.

  (**
   2.3. The univalence
   *)
  Definition is_univalent_left_total_of_twosided_disp_cat
             (HC₁ : is_univalent C₁)
             (HD : is_univalent_twosided_disp_cat D)
    : is_univalent_disp left_total_of_twosided_disp_cat.
  Proof.
    intros y₁ y₂ p xy₁ xy₂.
    induction p.
    use weqhomot.
    - exact (weq_iso_left_total_of_twosided_disp_cat xy₁ xy₂
             ∘ weqtotal2
                 (_ ,, HC₁ _ _)
                 (λ p, (_ ,, HD _ _ _ _ p (idpath _) (pr2 xy₁) (pr2 xy₂)))
             ∘ total2_paths_equiv _ _ _)%weq.
    - abstract
        (intro p ;
         induction p ;
         use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ;
         cbn ;
         apply idpath).
  Defined.

  (**
   3. Right total displayed category
   *)

  (**
   3.1. Definition
   *)
  Definition right_total_of_twosided_disp_cat_ob_mor
    : disp_cat_ob_mor C₁.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x, ∑ (y : C₂), D x y).
    - exact (λ x₁ x₂ xy₁ xy₂ f,
             ∑ (g : pr1 xy₁ --> pr1 xy₂),
             pr2 xy₁ -->[ f ][ g ] pr2 xy₂).
  Defined.

  Definition right_total_of_twosided_disp_cat_id_comp
    : disp_cat_id_comp C₁ right_total_of_twosided_disp_cat_ob_mor.
  Proof.
    split.
    - exact (λ x xy, identity (pr1 xy) ,, id_two_disp (pr2 xy)).
    - exact (λ x₁ x₂ x₃ f₁ f₂ xy₁ xy₂ xy₃ fg₁ fg₂,
             pr1 fg₁ · pr1 fg₂
             ,,
             (pr2 fg₁ ;;2 pr2 fg₂)).
  Defined.

  Definition right_total_of_twosided_disp_cat_data
    : disp_cat_data C₁.
  Proof.
    simple refine (_ ,, _).
    - exact right_total_of_twosided_disp_cat_ob_mor.
    - exact right_total_of_twosided_disp_cat_id_comp.
  Defined.

  Definition right_total_of_twosided_disp_cat_axioms
    : disp_cat_axioms C₁ right_total_of_twosided_disp_cat_data.
  Proof.
    repeat split.
    - intro ; intros.
      unfold mor_disp ; cbn.
      rewrite transportb_total2.
      use total2_paths_f.
      + apply id_left.
      + cbn.
        rewrite id_two_disp_left.
        unfold transportb.
        rewrite <- twosided_swap_transport.
        apply transportfbinv.
    - intro ; intros.
      unfold mor_disp ; cbn.
      rewrite transportb_total2.
      use total2_paths_f.
      + apply id_right.
      + cbn.
        rewrite id_two_disp_right.
        unfold transportb.
        rewrite <- twosided_swap_transport.
        apply transportfbinv.
    - intro ; intros.
      unfold mor_disp ; cbn.
      rewrite transportb_total2.
      use total2_paths_f.
      + apply assoc.
      + cbn.
        rewrite assoc_two_disp.
        unfold transportb.
        rewrite <- twosided_swap_transport.
        apply transportfbinv.
    - intros.
      apply isaset_total2.
      + apply homset_property.
      + intro.
        apply isaset_disp_mor.
  Qed.

  Definition right_total_of_twosided_disp_cat
    : disp_cat C₁.
  Proof.
    simple refine (_ ,, _).
    - exact right_total_of_twosided_disp_cat_data.
    - exact right_total_of_twosided_disp_cat_axioms.
  Defined.

  (**
   3.2. Isomorphisms
   *)
  Definition make_iso_right_total_of_twosided_disp_cat
             {x : C₁}
             {xy₁ xy₂ : right_total_of_twosided_disp_cat x}
             (g : z_iso (pr1 xy₁) (pr1 xy₂))
             (fg : iso_twosided_disp (identity_z_iso _) g (pr2 xy₁) (pr2 xy₂))
    : z_iso_disp (identity_z_iso _) xy₁ xy₂.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr1 g ,, pr1 fg).
    - exact (pr12 g ,, pr12 fg).
    - abstract
        (unfold mor_disp ; cbn ;
         rewrite transportb_total2 ; cbn ;
         use total2_paths_f ; [ apply z_iso_after_z_iso_inv | ] ;
         cbn ;
         etrans ; [ apply maponpaths ; apply (iso_after_inv_twosided_disp (pr2 fg)) | ] ;
         unfold transportb ;
         rewrite <- twosided_swap_transport ;
         apply transportfbinv).
    - abstract
        (unfold mor_disp ; cbn ;
         rewrite transportb_total2 ; cbn ;
         use total2_paths_f ; [ apply z_iso_inv_after_z_iso | ] ;
         cbn ;
         etrans ; [ apply maponpaths ; apply (inv_after_iso_twosided_disp (pr2 fg)) | ] ;
         unfold transportb ;
         rewrite <- twosided_swap_transport ;
         apply transportfbinv).
  Defined.

  Definition from_iso_right_total_of_twosided_disp_cat_pr1
             {x : C₁}
             {xy₁ xy₂ : right_total_of_twosided_disp_cat x}
             (g : z_iso_disp (identity_z_iso _) xy₁ xy₂)
    : z_iso (pr1 xy₁) (pr1 xy₂).
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr11 g).
    - exact (pr112 g).
    - abstract
        (refine (maponpaths pr1 (inv_mor_after_z_iso_disp g) @ _) ;
         unfold mor_disp ; cbn ;
         rewrite transportb_total2 ;
         apply idpath).
    - abstract
        (refine (maponpaths pr1 (z_iso_disp_after_inv_mor g) @ _) ;
         unfold mor_disp ; cbn ;
         rewrite transportb_total2 ;
         apply idpath).
  Defined.

  Definition from_iso_right_total_of_twosided_disp_cat_pr2
             {x : C₁}
             {xy₁ xy₂ : right_total_of_twosided_disp_cat x}
             (g : z_iso_disp (identity_z_iso _) xy₁ xy₂)
    : iso_twosided_disp
        (identity_z_iso _)
        (from_iso_right_total_of_twosided_disp_cat_pr1 g)
        (pr2 xy₁) (pr2 xy₂).
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr21 g).
    - exact (pr212 g).
    - abstract
        (pose (p := inv_mor_after_z_iso_disp g) ; unfold mor_disp in p ; cbn in p ;
         rewrite transportb_total2 in p ;
         refine (!(fiber_paths (!p)) @ _) ; cbn ;
         unfold transportb ;
         rewrite twosided_swap_transport ;
         rewrite !twosided_prod_transport ;
         apply maponpaths_2 ;
         apply isaset_dirprod ; apply homset_property).
    - abstract
        (pose (p := z_iso_disp_after_inv_mor g) ; unfold mor_disp in p ; cbn in p ;
         rewrite transportb_total2 in p ;
         refine (!(fiber_paths (!p)) @ _) ; cbn ;
         unfold transportb ;
         rewrite twosided_swap_transport ;
         rewrite !twosided_prod_transport ;
         apply maponpaths_2 ;
         apply isaset_dirprod ; apply homset_property).
  Defined.

  Definition weq_iso_right_total_of_twosided_disp_cat_eq_help
             {x : C₁}
             {xy₁ xy₂ : right_total_of_twosided_disp_cat x}
             {fg₁ fg₂ : ∑ (g : z_iso (pr1 xy₁) (pr1 xy₂)),
                        iso_twosided_disp
                          (identity_z_iso _)
                          g
                          (pr2 xy₁) (pr2 xy₂)}
             (p : pr11 fg₁ = pr11 fg₂)
             (q : pr12 fg₁
                  =
                  transportb
                    (λ z, _ -->[ _ ][ z ] _)
                    p
                    (pr12 fg₂))
    : fg₁ = fg₂.
  Proof.
    induction fg₁ as [ f₁ fg₁ ].
    induction f₁ as [ f₁ Hf₁ ].
    induction fg₁ as [ fg₁ Hfg₁ ].
    induction fg₂ as [ f₂ fg₂ ].
    induction f₂ as [ f₂ Hf₂ ].
    induction fg₂ as [ fg₂ Hfg₂ ].
    cbn in *.
    induction p ; cbn in *.
    induction q.
    assert (Hf₁ = Hf₂) as p by apply isaprop_is_z_isomorphism.
    induction p.
    do 2 apply maponpaths.
    apply isaprop_is_iso_twosided_disp.
  Qed.

  Definition weq_iso_right_total_of_twosided_disp_cat
             {x : C₁}
             (xy₁ xy₂ : right_total_of_twosided_disp_cat x)
    : (∑ (g : z_iso (pr1 xy₁) (pr1 xy₂)),
       iso_twosided_disp (identity_z_iso _) g (pr2 xy₁) (pr2 xy₂))
      ≃
      z_iso_disp (identity_z_iso _) xy₁ xy₂.
  Proof.
    use weq_iso.
    - exact (λ f, make_iso_right_total_of_twosided_disp_cat (pr1 f) (pr2 f)).
    - exact (λ f,
             from_iso_right_total_of_twosided_disp_cat_pr1 f
             ,,
             from_iso_right_total_of_twosided_disp_cat_pr2 f).
    - abstract
        (intro f ;
         cbn ;
         use weq_iso_right_total_of_twosided_disp_cat_eq_help ;
         apply idpath).
    - abstract
        (intro f ;
         use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ;
         apply idpath).
  Defined.

  (**
   3.3. The univalence
   *)
  Definition is_univalent_right_total_of_twosided_disp_cat
             (HC₂ : is_univalent C₂)
             (HD : is_univalent_twosided_disp_cat D)
    : is_univalent_disp right_total_of_twosided_disp_cat.
  Proof.
    intros y₁ y₂ p xy₁ xy₂.
    induction p.
    use weqhomot.
    - exact (weq_iso_right_total_of_twosided_disp_cat xy₁ xy₂
             ∘ weqtotal2
                 (_ ,, HC₂ _ _)
                 (λ q, (_ ,, HD _ _ _ _ (idpath _) q (pr2 xy₁) (pr2 xy₂)))
             ∘ total2_paths_equiv _ _ _)%weq.
    - abstract
        (intro p ;
         induction p ;
         use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ;
         cbn ;
         apply idpath).
  Defined.
End TotalOfTwoSidedDispCat.


Require Import FinTypes.

(** Completeness Lemmas for lists of basic types *)

Lemma bool_enum_ok x:
  count  [true; false] x = 1.
Proof.
  simpl. dec; destruct x; congruence.
Qed.

Lemma unit_enum_ok x:
  count [tt] x = 1.
Proof.
  simpl. destruct x; dec; congruence.
Qed.

Lemma Empty_set_enum_ok (x: Empty_set):
  count nil x = 1.
Proof.
  tauto.
Qed.

Lemma True_enum_ok x:
  count [I] x = 1.
Proof.
  simpl; dec;  destruct x; congruence.
Qed.

Lemma False_enum_ok (x: False):
  count nil x = 1.
Proof.
  tauto.
Qed.

(*** Declaration of finTypeCs for base types as instances of the type class *)

Instance finTypeC_Empty_set: finTypeC (EqType Empty_set).
Proof.
  econstructor. eapply Empty_set_enum_ok.
Defined.

Instance finTypeC_bool: finTypeC (EqType bool).
Proof.
  econstructor. apply bool_enum_ok.
Defined.

Instance finTypeC_unit: finTypeC (EqType unit).
Proof. econstructor. apply unit_enum_ok.
Defined.

(* Instance finTypeC_empty : finTypeC (EqType emptu *)
(* Proof. *)
(*   econstructor. apply Empty_set_enum_ok. *)
(* Defined. *)

Instance finTypeC_True : finTypeC (EqType True).
Proof.
  econstructor. apply True_enum_ok.
Defined.

Instance  finTypeC_False : finTypeC (EqType False).
Proof.
  econstructor. apply False_enum_ok.
Defined.


From Coq.Relations Require Import Relation_Definitions.
From Coq.Classes Require Import RelationClasses Morphisms.
From Coq Require Import Setoid.
From Coq Require Import ssreflect.

Set Primitive Projections.
Set Universe Polymorphism.

Section Category.
  Reserved Notation "A ~> B" (at level 60).
  Reserved Notation "f ∼ g" (at level 65).
  Reserved Notation "f ∙ g" (at level 55).
  Reserved Notation "f × g" (at level 52).

  Record Category : Type := mkCat {
    Obj :> Type;
    Hom : Obj -> Obj -> Type
    where "A ~> B" := (Hom A B);
    Id : forall A, A ~> A;
    sim : forall {A B}, (A ~> B) -> (A ~> B) -> Prop
    where "f ∼ g" := (sim f g);
    sim_equiv : forall {A B}, Equivalence (@sim A B);
    composite : forall {A B C}, (A ~> B) -> (B ~> C) -> A ~> C
    where "g ∙ f" := (composite f g);
    composite_prop : forall {A B C}, Proper (@sim A B ==> @sim B C ==> @sim A C) composite;
    id_left : forall {A B} (f : A ~> B), Id B ∙ f ∼ f;
    id_right : forall {A B} (f : A ~> B), f ∙ Id A ∼ f;
    associativity : forall {A B C D} (f : A ~> B) (g : B ~> C) (h : C ~> D), h ∙ (g ∙ f) ∼ (h ∙ g) ∙ f
  }.

  Definition Monoid := { C : Category & { A : Obj C & forall B : Obj C, A = B } }.

  Record Monoid' := mkMonoid' {
    dom :> Type;
    Unit : dom;
    Multiplication : dom -> dom -> dom
    where "A × B" := (Multiplication A B);
    MunitL : forall x, Unit × x = x;
    MunitR : forall x, x × Unit = x;
    Massoc : forall x y z, x × (y × z) = (x × y) × z }.

  Record Equivalence A B := mkEquiv {
    f : A -> B;
    g : B -> A;
    Idfg : forall y, f (g y) = y;
    Idgf : forall x, g (f x) = x;
    Coh : forall x, Idfg (f x) = f_equal f (Idgf x)
  }.

  Lemma equiv_monoid : Equivalence Monoid Monoid'.
  Proof.
  simple refine (mkEquiv _ _ _ _ _ _ _).
  simple refine (fun m => mkMonoid' (Hom _ _ _) _ _ _ _ _).
  all: try destruct m.
  exact x.
  Abort.

  Global Existing Instance sim_equiv.
  Global Existing Instance composite_prop.
End Category.

Notation "A ~> B" := (Hom _ A B) (at level 60).
Notation "f ∼ g" := (sim _ f g) (at level 65).
Notation "f ∙ g" := (composite _ f g) (at level 55).
Arguments Id {_} _.

Section Functor.
  Context (C D : Category).

  Record Functor : Type :=
    mkFunctor
      { F :> C -> D
        ; fmap : forall {A B}, A ~> B -> F A ~> F B
        ; fmap_prop : forall {A B}, Proper (@sim C A B ==> @sim D _ _) fmap
        ; fmap_id : forall {A}, fmap (Id A) ∼ Id _
        ; fmap_composite : forall {X Y Z} (g : X ~> Y) (f: Y ~> Z),
            fmap (g ∙ f) ∼ fmap g ∙ fmap f
      }.

  Global Existing Instance fmap_prop.
End Functor.

Arguments mkFunctor {_ _} _ _ _ _ _.
Arguments fmap {_ _} _ {_ _} _.

Section FunctorComposition.
  Context {C D E : Category} (F : Functor C D) (G : Functor D E).
  Program Definition functor_composite : Functor C E :=
    mkFunctor (fun A => G (F A)) (fun A B f => fmap G (fmap F f)) _ _ _.
  Next Obligation. solve_proper. Qed.
  Next Obligation. do 2 setoid_rewrite fmap_id; reflexivity. Qed.
  Next Obligation. do 2 setoid_rewrite fmap_composite; reflexivity. Qed.
End FunctorComposition.

Notation "f ∘ g" := (functor_composite f g) (at level 55).
Reserved Notation "f × g" (at level 52).

Section NaturalIsomorphism.
  Context {C D : Category} (F G : Functor C D).

  Record NaturalIsomorphism :=
    mkNatIso
      { ni_map :> forall {A}, F A ~> G A
      ; ni_inv : forall {A}, G A ~> F A
      ; ni_natural : forall {A B} (f : A ~> B), fmap F f ∙ ni_map ∼ ni_map ∙ fmap G f
      ; ni_rightinv : forall {A}, ni_inv ∙ ni_map ∼ Id (G A)
      ; ni_leftinv : forall {A}, ni_map ∙ ni_inv ∼ Id (F A)
      }.
End NaturalIsomorphism.

Arguments ni_inv {_ _ _ _} _ _.


(** * Combi.MPoly.Cauchy : Cauchy formula for symmetric polynomials *)
(******************************************************************************)
(*      Copyright (C) 2016-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * Cauchy formula for symmetric polynomials

In this file we fix two non zero natural [m] and [n] and consider the two sets
of variables [X := (x_i)_{i < m}] and [Y := (y_j)_{j < n}]. We also consider
the variables [z_{i,j} := x_i * y_j].

We encode polynomial in [X \cup Y] as polynomials in [X] whose coefficient are
polynomials in [Y]. We denote by [mz] a monomial in the [Z].

- [monX mz]     == the monomial in [X] obtained by setting all the [y_i] to [1].
- [monsY mz]    == the [m.-tuple] of whose [i]-th element is the monomial in [Y]
                   obtained by putting [x_i] to [1] and all the others to [0].
- [Ymon ms]     == given [ms : m.-tuple 'X_{1.. n}] assemble them to get a
                   monomial in the [Z].
- [polXY m n R] == polynomial in [m] variable whose coefficients are polynomials
                   in [n] over the commutative ring [R]. This is canonically a
                   [algType] over [R].
- [polXY_scale c p] == base ring multiplication for elements of [polXY m n R]
- [p(X)]        == the image of [p] by the canonical inclusion algebra morphism
                   [polX -> polXY]
- [p(Y)]        == the image of [p] by the canonical inclusion algebra morphism
                   [polY -> polXY]
- [p(XY)]       == the polynomial in [polXY] from a polynomials in the [Z_{i,j}].
- [Cauchy_kernel d] == the Cauchy reproducing kernel in degree [d], that is
                   the sum of all monomial in [x_i*y_i] of degree [d]
                   which is defined as ['h_d(XY)]
- [co_hp la p] == if [p] is symmetric in [X], returns the coefficient of [p] on
                   ['hp[la]]
- [co_hpXY la mu p] == if [p] is symmetric both in [X] and [Y], returns the
                   coefficient of [p] on ['hp[la](X) 'hp[mu](Y)].

The main result is Theorem [homsymdotss] which asserts that Schur function are
orthonormal for the scalar product.
*)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp Require Import tuple bigop path finfun.
From mathcomp Require Import ssrint rat ssralg ssrnum algC matrix vector.

From SsrMultinomials Require Import ssrcomplements mpoly.

Require Import tools partition.
Require Import antisym Schur_mpoly Schur_altdef sympoly homogsym permcent.

Require ordtype.
Local Notation inh := ordtype.Inhabited.Exports.inh.

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

Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Local Lemma char0_rat : [char rat] =i pred0.
Proof. exact: Num.Theory.char_num. Qed.
Local Lemma char0_algC : [char algC] =i pred0.
Proof. exact: Num.Theory.char_num. Qed.
#[local] Hint Resolve char0_algC char0_rat : core.

Reserved Notation "p '(Y)'"  (at level 20, format "p '(Y)'").
Reserved Notation "p '(X)'"  (at level 20, format "p '(X)'").
Reserved Notation "p '(XY)'" (at level 20, format "p '(XY)'").

(** ** Polynomials in two sets of variables *)
Section CauchyKernel.

Variables (m0 n0 : nat).
Notation m := m0.+1.
Notation n := n0.+1.
Notation mxvec_index := (@mxvec_index m n).

Let vecmx_index : 'I_(m * n) -> 'I_m * 'I_n :=
  (enum_val \o cast_ord (esym (mxvec_cast m n))).

Lemma vecmx_indexK i : mxvec_index (vecmx_index i).1 (vecmx_index i).2 = i.
Proof.
rewrite /vecmx_index/mxvec_index/uncurry/=.
case H : (enum_val (cast_ord (esym (mxvec_cast m n)) i)) => /= [a b].
by rewrite -H enum_valK cast_ordKV.
Qed.
Lemma mxvec_indexK i j : vecmx_index (mxvec_index i j) = (i, j).
Proof.
rewrite /vecmx_index/mxvec_index/uncurry/=.
by rewrite cast_ordK enum_rankK.
Qed.

Section Big.

Variables (R : Type) (idx : R).
Variable op : Monoid.com_law idx.

Lemma big_mxvec_index P F :
  \big[op/idx]_(i : 'I_(m * n) | P i) F i =
   \big[op/idx]_(i < m)
    \big[op/idx]_(j < n | P (mxvec_index i j)) F (mxvec_index i j).
Proof.
rewrite pair_big_dep.
rewrite (reindex (uncurry mxvec_index)); first last.
  by apply: (subon_bij _ (curry_mxvec_bij m n)).
by apply eq_big => [] [i j].
Qed.

End Big.

Definition monX (mon : 'X_{1.. m*n}) : 'X_{1.. m} :=
  [multinom (\sum_(j < n) mon (mxvec_index i j))%N | i < m].

Lemma mdeg_monX mon : mdeg (monX mon) = mdeg mon.
Proof.
rewrite /mdeg /monX !big_tuple big_mxvec_index /=; apply eq_bigr => i _.
rewrite tnth_mktuple; apply eq_bigr => j _.
by rewrite mnm_tnth.
Qed.

Definition monsY (mz : 'X_{1.. m*n}) :=
  [tuple [multinom mz (mxvec_index i j) | j < n] | i < m].

Definition Ymon (ms : m.-tuple 'X_{1.. n}) :=
  [multinom (tnth ms (vecmx_index i).1) (vecmx_index i).2 | i < m*n].

Lemma monsYK : cancel monsY Ymon.
Proof.
move=> mz; apply mnmP => i.
by rewrite mnmE tnth_mktuple mnmE /= vecmx_indexK.
Qed.
Lemma YmonK : cancel Ymon monsY.
move=> ms; apply eq_from_tnth => i.
by rewrite tnth_mktuple; apply mnmP => j; rewrite !mnmE mxvec_indexK.
Qed.
Lemma monsY_bij : bijective monsY.
Proof. by exists Ymon; [exact: monsYK | exact: YmonK]. Qed.
Lemma Ymon_bij : bijective Ymon.
Proof. by exists monsY; [exact: YmonK | exact: monsYK]. Qed.

Lemma mdeg_tnth_monsY mz i :
  mdeg (tnth (monsY mz) i) = tnth (monX mz) i.
Proof.
rewrite /monsY /monX !tnth_mktuple /mdeg big_tuple.
by apply eq_bigr => j _; rewrite -mnm_tnth mnmE.
Qed.

Variable (R : comRingType).

Local Notation polZ := {mpoly R[m * n]}.
Local Notation polX := {mpoly R[m]}.
Local Notation polY := {mpoly R[n]}.
Definition polXY := {mpoly polY[m]}.
Definition polXY_scale (c : R) (p : polXY) : polXY := c%:MP *: p.
Local Notation "c *:M p" := (polXY_scale c p)
  (at level 40, left associativity).

Lemma scale_polXYA a b p : a *:M (b *:M p) = (a * b) *:M p.
Proof. by rewrite /polXY_scale scalerA rmorphM. Qed.
Lemma scale_polXY1m p : 1 *:M p = p.
Proof. by rewrite /polXY_scale rmorph1 scale1r. Qed.
Lemma scale_polXYDr c p1 p2 :
  c *:M (p1 + p2) = c *:M p1 + c *:M p2.
Proof. exact: scalerDr. Qed.
Lemma scale_polXYDl p c1 c2 :
  (c1 + c2) *:M p = c1 *:M p + c2 *:M p.
Proof. by rewrite /polXY_scale rmorphD /= scalerDl. Qed.

Definition polXY_lmodMixin :=
  LmodMixin scale_polXYA scale_polXY1m scale_polXYDr scale_polXYDl.
Canonical polXY_lmodType := Eval hnf in LmodType R polXY polXY_lmodMixin.
Lemma scale_polXYE (c : R) (p : polXY) : c *: p = c *:M p.
Proof. by []. Qed.

Lemma polXY_scaleAl (c : R) (p q : polXY) : c *: (p * q : polXY) = (c *: p) * q.
Proof. by rewrite !scale_polXYE /polXY_scale /= -!mul_mpolyC mulrA. Qed.
Canonical polXY_lalgType := Eval hnf in LalgType R polXY polXY_scaleAl.

Lemma polXY_scaleAr (c : R) (p q : polXY) : c *: (p * q : polXY) = p * (c *: q).
Proof.
rewrite !scale_polXYE /polXY_scale /= -!mul_mpolyC.
by rewrite mulrA [_ * p]mulrC mulrA.
Qed.
Canonical polXY_algType := Eval hnf in AlgType R polXY polXY_scaleAr.

Definition polX_XY : polX -> polXY := map_mpoly (mpolyC n (R := R)).
Lemma polX_XY_is_lrmorphism : lrmorphism polX_XY.
Proof.
rewrite /polX_XY; repeat split.
- exact: rmorphB.
- exact: rmorphM.
- exact: rmorph1.
- move=> p c.
  by rewrite /map_mpoly mmapZ /= scale_polXYE /polXY_scale /= -!mul_mpolyC.
Qed.
Canonical polX_XY_additive   := Additive   polX_XY_is_lrmorphism.
Canonical polX_XY_rmorphism  := RMorphism  polX_XY_is_lrmorphism.
Canonical polX_XY_linear     := AddLinear  polX_XY_is_lrmorphism.
Canonical polX_XY_lrmorphism := LRMorphism polX_XY_is_lrmorphism.

Definition polY_XY : polY -> polXY := mpolyC m (R := [ringType of mpoly n R]).
Lemma polY_XY_is_lrmorphism : lrmorphism polY_XY.
Proof.
rewrite /polY_XY; repeat split.
- exact: rmorphB.
- exact: rmorphM.
- move=> p c.
  by rewrite scale_polXYE /polXY_scale /= -!mul_mpolyC rmorphM.
Qed.
Canonical polY_XY_additive   := Additive   polY_XY_is_lrmorphism.
Canonical polY_XY_rmorphism  := RMorphism  polY_XY_is_lrmorphism.
Canonical polY_XY_linear     := AddLinear  polY_XY_is_lrmorphism.
Canonical polY_XY_lrmorphism := LRMorphism polY_XY_is_lrmorphism.

Notation "p '(Y)'" := (polY_XY p).
Notation "p '(X)'" := (polX_XY p).

Lemma polyXY_scale p q : p(X) * q(Y) = q *: p(X).
Proof. by rewrite mulrC mul_mpolyC. Qed.

Lemma symmX d (la : 'P_d) : 'hm[la](X) = 'hm[la].
Proof.
by have /(congr1 val) := map_symm [rmorphism of (mpolyC n (R:=R))] m0 la.
Qed.

Definition evalXY : polZ -> polXY :=
  mmap ((@mpolyC m _) \o (@mpolyC n R))
       (fun i => 'X_((vecmx_index i).1) (X) * 'X_((vecmx_index i).2) (Y)).
Notation "p '(XY)'" := (evalXY p).

Lemma evalXY_is_lrmorphism : lrmorphism evalXY.
Proof.
rewrite /evalXY; repeat split.
- exact: rmorphB.
- exact: rmorphM.
- exact: rmorph1.
- move=> p c.
  by rewrite  mmapZ /= scale_polXYE /polXY_scale /= -!mul_mpolyC.
Qed.
Canonical evalXY_additive   := Additive   evalXY_is_lrmorphism.
Canonical evalXY_rmorphism  := RMorphism  evalXY_is_lrmorphism.
Canonical evalXY_linear     := AddLinear  evalXY_is_lrmorphism.
Canonical evalXY_lrmorphism := LRMorphism evalXY_is_lrmorphism.

Lemma evalXY_XE mz :
  'X_[mz](XY) = 'X_[monX mz](X) * \prod_(i < m) 'X_[tnth (monsY mz) i](Y).
Proof.
rewrite -rmorph_prod polyXY_scale /monX.
transitivity (\prod_(i : 'I_(m*n))
                 (('X_(vecmx_index i).2 : polY) ^+ mz i *:
                              ('X_(vecmx_index i).1(X) ^+ mz i))).
  rewrite (multinomUE_id mz) /evalXY mmapX /mmap1.
  by apply eq_bigr => [i _]; rewrite -exprZn polyXY_scale.
rewrite big_mxvec_index /=.
rewrite mpolyXE_id rmorph_prod -scaler_prod; apply eq_bigr => i _.
rewrite scaler_prod /=; congr (_ *: _).
- rewrite /monsY tnth_mktuple mpolyXE_id; apply eq_bigr => j _.
  by rewrite mxvec_indexK /= mnmE.
- rewrite mnmE -prodrXr rmorph_prod /=; apply eq_bigr => j _.
  by rewrite mxvec_indexK /= rmorphX.
Qed.

Lemma evalXY_homog d p : p \is d.-homog -> p(XY) \is d.-homog.
Proof.
move/pihomog_dE <-; rewrite pihomogE.
rewrite rmorph_sum /=; apply rpred_sum => mon /eqP Hdeg.
rewrite linearZ /= scale_polXYE; apply rpredZ.
rewrite evalXY_XE -rmorph_prod /= polyXY_scale; apply rpredZ.
by rewrite /polX_XY map_mpolyX dhomogX /= mdeg_monX Hdeg.
Qed.

Lemma sympXY k : 'p_k(XY) = 'p_k(X) * 'p_k(Y).
Proof.
rewrite /= /symp_pol /= /evalXY /= !rmorph_sum /= big_mxvec_index /=.
rewrite mulr_suml; apply eq_bigr => i _ /=.
rewrite mulr_sumr; apply eq_bigr => j _ /=.
by rewrite !rmorphX /= mmapX mmap1U mxvec_indexK /= exprMn.
Qed.

Lemma prod_sympXY d (la : 'P_d) : 'hp[la](XY) = 'hp[la](X) * 'hp[la](Y).
Proof.
rewrite /prod_symp /prod_gen /= !rmorph_prod /=.
rewrite -big_split /=; apply eq_bigr => i _.
by rewrite [LHS]sympXY.
Qed.

(** ** The Cauchy reproducing kernel *)
Definition Cauchy_kernel d := 'h_d(XY).

Lemma Cauchy_kernel_dhomog d : Cauchy_kernel d \is d.-homog.
Proof. by rewrite /Cauchy_kernel; apply evalXY_homog; apply: symh_homog. Qed.

Section BijectionFam.

Variable d : nat.

Lemma famY_subproof (mz : 'X_{1.. (m * n) < d.+1}) i :
    (mdeg (tnth (monsY (val mz)) i) < d.+1)%N.
Proof.
apply: (leq_ltn_trans _ (bmdeg mz)).
rewrite /mdeg /monsY tnth_mktuple !big_tuple big_mxvec_index /=.
under eq_bigr do rewrite tnth_mktuple mnm_tnth.
by rewrite (bigD1 i) //= leq_addr.
Qed.
Definition famY mz := [ffun i : 'I_m => BMultinom (famY_subproof mz i)].
Let famYinv_fun (ff : {ffun 'I_m -> 'X_{1.. n < d.+1}}) :=
  let mz := [multinom (ff (vecmx_index i).1 (vecmx_index i).2) | i < m * n]
  in if (mdeg mz < d.+1)%N then mz else 0%MM.
Lemma famYinv_subproof ff : (mdeg (famYinv_fun ff) < d.+1)%N.
Proof.
rewrite /famYinv_fun /=.
case: (ssrnat.ltnP (mdeg [multinom _ | i < _]) d.+1) => //= _.
by rewrite mdeg0.
Qed.
Definition famYinv ff := BMultinom (famYinv_subproof ff).

End BijectionFam.

Variable d : nat.

(** *** Cauchy formula for complete and monomial symmetric polynomials *)
Lemma Cauchy_symm_symh :
  Cauchy_kernel d = \sum_(la : 'P_d) ('h[la] : polY) *: ('m[la] : polXY).
Proof.
apply/mpolyP => mon.
case: (altP (mdeg mon =P d)) => Hdeg; first last.
  rewrite (dhomog_nemf_coeff (Cauchy_kernel_dhomog d) Hdeg).
  rewrite linear_sum /= big1 ?mcoeff0 // => la _.
  rewrite mcoeffZ.
  case: (ssrnat.leqP (size la) m) => [Hi | /symm_oversize ->].
  - rewrite mcoeff_symm //.
    suff /negbTE -> : ~~ perm_eq (mpart (n := m) la) mon by rewrite mulr0.
    apply/negP => /perm_sumn.
    rewrite sumn_mpart // sumn_intpartn sumnE -/(mdeg _) => Hd.
    by rewrite -Hd eq_refl in Hdeg.
  - by rewrite mcoeff0 mulr0.
have Hpm : is_part_of_n d (partm mon) by rewrite /= intpartP andbT sumn_partm Hdeg.
pose pm := IntPartN Hpm.
rewrite (bigID (fun mu : 'P_d => (size mu <= m)%N)) /=.
rewrite linearD ![in RHS]linear_sum /=.
rewrite addrC big1 ?add0r; first last.
  by move=> la; rewrite -ltnNge => /symm_oversize ->; rewrite !raddf0.
rewrite (bigD1 pm) ?size_partm //= ?big1 ?addr0; first last.
  move=> la /andP [Hszla Hla].
  rewrite mcoeffZ mcoeff_symm //.
  suff /negbTE -> : ~~ perm_eq (mpart (n := m) la) mon by rewrite mulr0.
  apply/negP => /perm_partm/(congr1 val)/=.
  rewrite mpartK // => Heq.
  by move: Hla; rewrite /eq_op /= Heq eq_refl.
rewrite mcoeffZ mcoeff_symm ?size_partm // perm_sym partm_permK mulr1.
rewrite /Cauchy_kernel /prod_symh /prod_gen {1}/symh /= rmorph_prod /=.
rewrite rmorph_sum raddf_sum /= partmE; apply esym.
transitivity (\prod_(i <- mon) sympol 'h_i : polY ).
  rewrite [RHS](bigID (fun i => i == 0%N)) /=.
  rewrite [in RHS]big1 ?mul1r; first last => [i /eqP ->|].
    exact: (congr1 val (symh0 n R)).
  rewrite /= -[RHS]big_filter; apply: perm_big.
  by rewrite perm_sort.
rewrite {Hpm pm} /= big_tuple; symmetry.
rewrite (bigID (fun mZ : 'X_{1.. _ < _} => monX mZ == mon)) /=.
rewrite addrC big1 ?add0r; first last.
  move=> i /andP [_ /negbTE Hneq].
  rewrite evalXY_XE -rmorph_prod /= polyXY_scale.
  by rewrite linearZ /= /polX_XY map_mpolyX mcoeffX Hneq mulr0.
under eq_bigl=> i do [rewrite andb_idl;
  last by move=> /eqP; rewrite -{3}Hdeg => <-; rewrite mdeg_monX].
under [LHS]eq_bigr => mz Hmz.
  rewrite evalXY_XE -rmorph_prod /= polyXY_scale.
  by rewrite linearZ /= /polX_XY map_mpolyX mcoeffX Hmz mulr1 over.
under [RHS]eq_bigr => i _ do
  [rewrite (@symh_pol_any _ _ d.+1) //;
     last by rewrite ltnS -Hdeg /mdeg big_tuple (bigD1 i) // leq_addr].
rewrite bigA_distr_big_dep => /=.
rewrite (reindex (famY (d := d))) /=; first last.
  exists (famYinv (d := d)).
  + move=> mz; rewrite inE => /familyP Hff.
    apply val_inj => /=.
    rewrite [[multinom _ | i < m * n]](_ : _ = val mz) /= ?bmdeg //.
    apply mnmP => c; rewrite mnmE /famY ffunE /=.
    by rewrite tnth_mktuple mnmE //= -[in RHS](vecmx_indexK c).
  + move=> ff; rewrite inE => /familyP H /=.
    apply/ffunP => /= i; rewrite ffunE; apply val_inj => /=.
    rewrite [mdeg _](_ : _ = d) ?ltnSn; first last.
      rewrite -[RHS]Hdeg !mdegE big_mxvec_index => /=; apply eq_bigr => i' _.
      have {H} := H i'; rewrite unfold_in mnm_tnth => /eqP <-.
      rewrite mdegE; apply eq_bigr => j _.
      by rewrite mnmE mxvec_indexK /=.
    by rewrite tnth_mktuple; apply mnmP => j; rewrite !mnmE mxvec_indexK /=.
apply eq_big => [mz | mz /eqP Hmz].
- apply/eqP/familyP => [/= Hmon i | Hfam].
  + by rewrite unfold_in ffunE /= mdeg_tnth_monsY Hmon.
  + apply/mnmP => i.
    have := Hfam i; rewrite unfold_in /= !mnm_tnth => /eqP <-.
    by rewrite ffunE /= !tnth_mktuple mdegE; apply eq_bigr => j _; rewrite mnmE.
- by apply eq_bigr => i _; rewrite ffunE /= !tnth_mktuple.
Qed.

Lemma Cauchy_homsymm_homsymh :
  Cauchy_kernel d = \sum_(la : 'P_d) 'hm[la](X) * 'hh[la](Y).
Proof.
rewrite Cauchy_symm_symh.
by apply eq_bigr => i _; rewrite polyXY_scale symmX.
Qed.

(** *** Cauchy formula for Schur symmetric polynomials *)
Lemma Cauchy_homsyms_homsyms :
  Cauchy_kernel d = \sum_(la : 'P_d) 'hs[la](X) * 'hs[la](Y).
Proof.
rewrite Cauchy_homsymm_homsymh.
transitivity (\sum_(mu : 'P_d) \sum_(la : 'P_d)
               'hm[mu](X) * ('K(la, mu) *: 'hs[la])(Y)).
  apply eq_bigr => la _.
  rewrite [X in X(Y)](_ : _ = sympol 'h[la]) //.
  by rewrite symh_syms -mulr_sumr !linear_sum.
rewrite exchange_big /=; apply eq_bigr => la _.
have /= -> /= := congr1 val (syms_symm m0 R la).
rewrite 2!linear_sum /= mulr_suml; apply eq_bigr => mu _.
by rewrite !linearZ /= -scalerAr -scalerAl.
Qed.

(** Unused lemma *)
Lemma Cauchy_kernel_symmetric : Cauchy_kernel d \is symmetric.
Proof.
rewrite Cauchy_symm_symh; apply rpred_sum => la _.
by apply rpredZ; apply sympolP.
Qed.

(** Unused lemma *)
Lemma Cauchy_kernel_coeff_symmetric mon :
  (Cauchy_kernel d)@_mon \is symmetric.
Proof.
rewrite Cauchy_symm_symh linear_sum /=; apply rpred_sum => la _.
rewrite linearZ /= rpredM ?sympolP //.
case: (ssrnat.leqP (size la) m) => [/mcoeff_symm -> | /symm_oversize ->].
- by case: (perm_eq _ _) => /=; [exact: rpred1 | exact: rpred0].
- by rewrite mcoeff0 rpred0.
Qed.

(** Unused lemma *)
Lemma Cauchy_kernel_coeff_homog mon :
  (Cauchy_kernel d)@_mon \is d.-homog.
Proof.
rewrite Cauchy_symm_symh linear_sum /=; apply rpred_sum => la _.
rewrite linearZ /=.
case: (ssrnat.leqP (size la) m) => [/mcoeff_symm -> | /symm_oversize ->].
- case: (perm_eq _ _) => /=; rewrite ?mulr1 ?mulr0 ?rpred0 //.
  exact: prod_symh_homog.
- by rewrite mcoeff0 mulr0 rpred0.
Qed.

End CauchyKernel.

Notation "p '(Y)'" := (@polY_XY _ _ _ p).
Notation "p '(X)'" := (@polX_XY _ _ _ p).
Notation "p '(XY)'" := (@evalXY _ _ _ p).

Section CauchyKernelField.
Variable R : fieldType.

(** *** Cauchy formula for power sum symmetric polynomials *)
Lemma Cauchy_homsymp_zhomsymp m n d :
  [char R] =i pred0 ->
  Cauchy_kernel m n R d =
  \sum_(la : 'P_d) 'hp[la](X) * ((zcard la)%:R^-1 *: 'hp[la](Y)).
Proof.
move=> Hchar.
rewrite /Cauchy_kernel symh_to_symp // !rmorph_sum /=; apply eq_bigr => la _.
by rewrite linearZ /= -scalerAr prod_sympXY; congr (_ *: _).
Qed.

End CauchyKernelField.

(** * Cauchy kernel and scalar product of symmetric functions *)
Section Scalar.

Variable n0 d : nat.
Local Notation n := n0.+1.
Hypothesis Hd : (d <= n)%N.

Local Notation ratF := [numFieldType of rat].
Local Notation algCF := [numFieldType of algC].
Local Notation HSC := {homsym algC[n, d]}.
Local Notation HSQ := {homsym rat[n, d]}.
Local Notation polXY := (polXY n0 n0 algCF).
Local Notation pol := {mpoly algC[n]}.
Local Notation "p '(Y)'" := (@polY_XY n0 n0 _ p)
                             (at level 20, format "p '(Y)'").
Local Notation "p '(X)'" := (@polX_XY n0 n0 _ p)
                             (at level 20, format "p '(X)'").

Local Notation "''hsC[' la ]" := ('hs[la] : HSC).
Local Notation "''hsQ[' la ]" := ('hs[la] : HSQ).
Local Notation "''hpC[' la ]" := ('hp[la] : HSC).
Local Notation "''hpQ[' la ]" := ('hp[la] : HSQ).

Definition co_hp (la : 'P_d) : pol -> algC :=
  homsymdotr 'hp[la] \o in_homsym d (R := algCF).
Definition co_hpXY (la mu : 'P_d) : polXY -> algC :=
  locked (co_hp la \o map_mpoly (co_hp mu)).

Lemma co_hp_is_additive la : additive (co_hp la).
Proof. by rewrite /co_hp => p q; rewrite raddfB. Qed.
Canonical co_hp_additive la := Additive (co_hp_is_additive la).
Lemma scale_co_hp la p a : co_hp la (a *: p) = a * co_hp la p.
Proof. by rewrite /co_hp /= linearZ homsymdotZl. Qed.
Lemma co_hp_hp la mu : co_hp la 'hp[mu] = (zcard mu)%:R * (mu == la)%:R.
Proof using Hd.
by rewrite /co_hp /= -![prod_gen _ _]/(homsym 'hp[_]) in_homsymE homsymdotpp.
Qed.

Lemma co_hpXY_is_additive la mu : additive (co_hpXY la mu).
Proof. by rewrite /co_hpXY; unlock => p q; rewrite raddfB. Qed.
Canonical co_hpXY_additive la mu := Additive (co_hpXY_is_additive la mu).

Lemma co_hpYE la (p q : pol) :
  map_mpoly (co_hp la) (p(X) * q(Y)) = co_hp la q *: p.
Proof.
rewrite polyXY_scale /=; apply/mpolyP => /= m.
rewrite linearZ /= mcoeff_map_mpoly /= linearZ /= mulrC.
rewrite /polX_XY /= mcoeff_map_mpoly /= mul_mpolyC.
by rewrite mulrC -scale_co_hp.
Qed.

Lemma co_hprXYE la mu (p q : pol) :
  co_hpXY la mu (p(X) * q(Y)) = (co_hp la p) * (co_hp mu q).
Proof. by rewrite /co_hpXY; unlock; rewrite /= co_hpYE scale_co_hp mulrC. Qed.

Lemma coord_zsympsps (la mu : 'P_d) :
  (\sum_nu
    (coord 'hp (enum_rank la) 'hsC[nu]) *
    ((zcard mu)%:R * coord 'hp (enum_rank mu) 'hsC[nu]))
  = (la == mu)%:R.
Proof using Hd.
have to_p (nu : 'P_d) : ('hsC[nu] : HSC) \in span 'hp.
  by rewrite (span_basis (symbp_basis Hd _)) //= memvf.
have : \sum_(nu : 'P_d) 'hsC[nu](X) * 'hsC[nu](Y) =
       \sum_(nu : 'P_d) 'hp[nu](X) * ((zcard nu)%:R^-1 *: 'hp[nu](Y)).
  by rewrite -Cauchy_homsyms_homsyms Cauchy_homsymp_zhomsymp.
have sum_coord (p : HSC) :
  \sum_i homsym (coord 'hp i p *: ('hp)`_i : HSC) =
  \sum_px coord 'hp (enum_rank px) p *: 'hp[px] :> pol.
  rewrite (reindex _ (onW_bij _ (@enum_rank_bij _))) /=.
  rewrite !linear_sum /=; apply eq_bigr => i _.
  rewrite (nth_map inh) /= -?enum_val_nth // ?enum_rankK //.
  by rewrite -cardE ltn_ord.
rewrite (eq_bigr (fun nu : 'P_d =>
                    (\sum_px (coord 'hp (enum_rank px) 'hsC[nu]) *: 'hp[px])(X) *
                    (\sum_py (coord 'hp (enum_rank py) 'hsC[nu]) *: 'hp[py])(Y)
        )); first last.
  move=> nu _; rewrite {1 2}(coord_span (to_p nu)).
  by rewrite linear_sum; congr ((_)(X) * (_)(Y)); rewrite sum_coord.
move=> {sum_coord to_p} /(congr1 (co_hpXY la mu)).
rewrite !raddf_sum /= => /esym.
rewrite (bigD1 la) //= -[(zcard la)%:R^-1 *: 'hp[la](Y)]linearZ /=.
rewrite -![prod_gen _ _]/(homsym 'hp[_]).
rewrite co_hprXYE scale_co_hp co_hp_hp //.
rewrite eq_refl mulr1 !mulrA divff ?mul1r; last by rewrite pnatr_eq0 neq0zcard.
rewrite big1 ?addr0; first last => [nu /negbTE Hnu |].
  rewrite -![prod_gen _ _]/(homsym 'hp[_]).
  rewrite -[(zcard nu)%:R^-1 *: 'hp[nu](Y)]linearZ /=.
  rewrite -![prod_gen _ _]/(homsym 'hp[_]).
  rewrite co_hprXYE scale_co_hp co_hp_hp //.
  move: Hnu; rewrite -(inj_eq (@val_inj _ _ _)) /= => ->.
  by rewrite mulr0 !mul0r.
rewrite co_hp_hp // => /(congr1 (fun x => (zcard la)%:R^-1 * x)).
rewrite mulrA [X in X * _]mulrC divff; last by rewrite pnatr_eq0 neq0zcard.
rewrite mul1r !mulr_sumr => -> .
apply eq_bigr => nu _.
rewrite co_hprXYE.
have dot_sumhp (eta tau : 'P_d) :
  co_hp eta (\sum_px coord 'hp (enum_rank px) 'hsC[tau] *: 'hp[px]) =
  coord 'hp (enum_rank eta) 'hsC[tau] * (zcard eta)%:R.
  rewrite !raddf_sum /= (bigD1 eta) //=.
  rewrite -![prod_gen _ _]/(homsym 'hp[_]).
  rewrite scale_co_hp co_hp_hp // eq_refl mulr1.
  rewrite big1 ?addr0 // => p => /negbTE Hp.
  rewrite -![prod_gen _ _]/(homsym 'hp[_]).
  rewrite scale_co_hp co_hp_hp //.
  move: Hp; rewrite -(inj_eq (@val_inj _ _ _)) /= => ->.
  by rewrite !mulr0.
rewrite !{}dot_sumhp ![_ * (zcard _)%:R]mulrC !mulrA.
by rewrite ![_ * (zcard la)%:R]mulrC divff ?mul1r // pnatr_eq0 neq0zcard.
Qed.

Lemma coord_zsymspsp (la mu : 'P_d) :
  (\sum_nu
    (coord 'hp (enum_rank nu) 'hsC[la]) *
    ((zcard nu)%:R * coord 'hp (enum_rank nu) 'hsC[mu]))
  = (la == mu)%:R.
Proof using Hd.
pose matsp : 'M[algCF]_#|{:'P_d}| :=
  \matrix_(i, j < #|{:'P_d}|) (coord 'hp i 'hsC[enum_val j]).
pose matzsp : 'M[algCF]_#|{:'P_d}| :=
  \matrix_(i, j < #|{:'P_d}|)
   ((zcard (enum_val j))%:R * (coord 'hp j 'hsC[enum_val i])).
have: matsp *m matzsp = 1%:M.
  apply/matrixP => i j /=.
  rewrite /matsp /matzsp /= !mxE.
  rewrite (reindex _ (onW_bij _ (@enum_rank_bij _))) /=.
  rewrite -(inj_eq (@enum_val_inj _ _)) /= -coord_zsympsps //.
  apply eq_bigr => /= nu _.
  by rewrite !mxE !enum_valK !enum_rankK.
move=> /mulmx1C/matrixP/(_ (enum_rank mu) (enum_rank la)).
rewrite /matsp /matzsp /= !mxE.
rewrite (inj_eq (@enum_rank_inj _)) eq_sym => <-.
rewrite (reindex _ (onW_bij _ (@enum_rank_bij _))) /=.
apply eq_bigr => /= nu _.
by rewrite !mxE !enum_rankK mulrC.
Qed.

(** ** Schur function are orthonormal *)
Theorem homsymdotss la mu : '[ 'hsC[la] | 'hsC[mu] ] = (la == mu)%:R.
Proof using Hd.
have to_p (nu : 'P_d) : 'hsC[nu] \in span 'hp.
  by rewrite (span_basis (symbp_basis Hd _)) // memvf.
rewrite (coord_span (to_p la)) (coord_span (to_p mu)).
transitivity
  (\sum_i (coord 'hp i 'hsC[la]) *
          (zcard (enum_val i))%:R * (coord 'hp i 'hsC[mu])); first last.
  rewrite (reindex _ (onW_bij _ (@enum_rank_bij _))) /=.
  rewrite -coord_zsymspsp //; apply eq_bigr => /= nu _.
  by rewrite enum_rankK mulrA.
rewrite homsymdot_suml; apply eq_bigr => /= l _.
rewrite homsymdotZl homsymdot_sumr -mulrA; congr (_ * _).
transitivity
  (\sum_(i < #|{:'P_d}|)
    (coord 'hp i 'hsC[mu])^* * (zcard (enum_val l))%:R * (i == l)%:R).
  apply: eq_bigr => i _; rewrite homsymdotZr -mulrA; congr (_ * _).
  rewrite !(nth_map inh _ (fun l => 'hp[l])) -?cardE ?ltn_ord //.
  by rewrite -!enum_val_nth homsymdotpp // (inj_eq enum_val_inj) eq_sym.
rewrite (bigD1 l) //= big1 ?addr0; last by move=> m /negbTE ->; rewrite mulr0.
rewrite eq_refl mulr1 mulrC; congr (_ * _).
by rewrite -coord_map_homsym ?map_homsymbp ?symbp_basis // map_homsyms.
Qed.

End Scalar.


(** Uncomputablity in the definition of R function **)
(** For convenience's sake, we focus on real numbers in [0,1] **)
Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import Classes.Morphisms.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Logic.PropExtensionality.
From Coq Require Import Classes.Equivalence.
Require Import Coq.setoid_ring.Ring_theory.
Require Import Coq.Classes.RelationClasses.
Require Import Ring.
From Coq Require Import Field.
From Coq Require Import Omega.
From CReal Require Import Uncomputable.TMSet.
From CReal Require Import INQ_libs.
From CReal Require Import QArith_base_ext.
From CReal Require Import ComRealBase.
From CReal Require Import ComRealField.
From CReal Require Import ComRealBaseLemma1.
From CReal Require Import ComRealLemmas.
From CReal Require Import ComRealBase_Dec.
From Coq Require Import Psatz.
Require Import Coq.Logic.ProofIrrelevance.
Import ListNotations.
Import TM_N_Q.

Module CR_NQ (VirR: VIR_R) (VirRSingleton : VIR_R_SINGLETON VirR) (VirRComp: VIR_R_COMPLETE VirR).
  Import VirR VirRSingleton.

  Module VirRSL := VirRSingletonLemmas VirR VirRSingleton.
  Module VirRSL2 := VirRSingletonLemmas2 VirR VirRSingleton VirRComp.
  Module Dec := DEC_R VirR VirRSingleton VirRComp.
  Export VirRSL VirRSL2 Dec.
  Local Open Scope R_scope.

  Definition limit (f : nat -> Q) (r : R) : Prop :=
    forall eps : Q , (eps > 0)%Q -> exists N : nat , forall n : nat , (n >= N)%nat -> Rabs(IQR (f n) - r) < IQR eps.
  (** exists a sequence of rational number limits to r *)
  Definition CR2 (r : R) := exists f : nat -> Q, limit f r.

  Theorem limit_inject : forall (f : nat -> Q) (r1 r2 : R) , limit f r1 -> limit f r2 -> r1 == r2.
  Proof.
    intros.
    hnf in *.
    apply NNPP.
    unfold not in *.
    intros.
    apply Rdichotomy in H1.
    destruct H1 ; apply Rlt_mid in H1 ; destruct H1 ; destruct H1 ;
      specialize (H x H1) ; specialize (H0 x H1) ; destruct H , H0 ;
      specialize (H (max x0 x1) (Nat.le_max_l x0 x1) ) ; specialize (H0 (max x0 x1) (Nat.le_max_r x0 x1))
      ; apply Rabs_tri in H ; apply Rabs_tri in H0 ; destruct H , H0 ; apply (Rlt_irrefl (IQR (f (max x0 x1)))).
    - apply Rlt_trans with (r1 + IQR x) ; auto.
      apply Rlt_trans with (r2 - IQR x) ; auto.
    - apply Rlt_trans with (r2 + IQR x) ; auto.
      apply Rlt_trans with (r1 - IQR x) ; auto.
  Qed.

  Instance limit_comp : Proper (eq ==> Req ==> iff) limit.
  Proof.
    hnf ; red ; intros ; subst.
    split ; intros ; hnf in * ; intros ; specialize (H _ H1) ; destruct H;
    exists x ; intros ; specialize (H _ H2) ; rewrite H0 in * ; auto.
  Qed.

  Instance CR2_comp : Proper (Req ==> iff) CR2.
  Proof.
    hnf ; intros.
    split ; intros ; hnf in * ; destruct H0 ; exists x0 ;
    rewrite H in * ; auto.
  Qed.

  Definition CR2_r : Type := { r : R | CR2 r}.

  Definition CR2_r_eq (x y : CR2_r) : Prop .
    destruct x , y.
    apply (x == x0).
  Defined.

  Instance CR2_r_eq_equiv : Equivalence CR2_r_eq.
  Proof.
    split ; hnf ; intros.
    - destruct x. hnf. auto with real.
    - destruct x , y. simpl in *. auto with real.
    - destruct x , y , z. simpl in *. rewrite H. auto.
  Qed.

  Theorem all_Q_CR2 : forall (q : Q) , CR2 (IQR q).
  Proof.
    intros.
    unfold CR2.
    exists (fun n => q).
    unfold limit.
    intros.
    exists O.
    intros.
    rewrite Rminus_diag_eq ; try (ring).
    rewrite Rabs_pos.
    rewrite <- IQR_R0. apply IQR_lt. auto.
    apply Rle_refl.
   Qed.

  Definition NQ : Type := nat -> Q.
  Definition NQ_T_nat := NQ -> nat.

  Theorem NQ_nat : injection (eq(A:=NQ)) (eq(A:=nat)) .
  Proof.
    assert (injection (eq(A:=NQ)) TMNQ_eq).
    {
      exists Combine.
      apply Combine_comp.
      apply image_defined_Combine.
      apply partial_functional_Combine.
      apply injective_Combine.
    }
    pose proof Countable_TMNQ.
    unfold Countable in *.
    apply (injection_trans _ X X0).
  Qed.

  Definition CR2_r_NQ (r : CR2_r) (p : nat -> Q) : Prop .
    destruct r.
    apply (limit p x).
  Defined.

  Definition CR2_r_NQ' (r : CR2_r) (p : nat -> Q) : Prop :=
    CR2_r_NQ r p /\ forall q : nat -> Q , CR2_r_NQ r q ->
          (forall x y : nat , NQ_nat p x -> NQ_nat q y -> (x <= y)%nat).

  Theorem image_defined_CR2TNQ' : image_defined CR2_r_NQ'.
  Proof.
    unfold image_defined , CR2_r_NQ' , CR2_r_NQ.
    intros.
    destruct NQ_nat.
    destruct a.
    set (fun n : nat => exists nq : nat -> Q , limit nq x /\ inj_R nq n).
    assert (forall n : nat , P n \/ ~ P n).
    { intros. apply classic. }
    assert (exists n : nat , P n).
    {   destruct c.
        destruct (im_inj x0).
        exists x1. exists x0. auto.
    }
    pose proof (dec_inh_nat_subset_has_unique_least_element P H H0).
    repeat destruct H1.
    exists x1. split ; auto.
    intros.
    hnf in H6 , H7.
    assert (x2 = x0). { apply (pf_inj x1) ;  auto. }
    subst.
    apply H3.
    exists q ; auto.
  Qed.

  Theorem partial_functional_CR2TNQ' : partial_functional eq CR2_r_NQ'.
  Proof.
    unfold partial_functional in *.
    intros.
    destruct a.
    destruct H , H0.
    pose proof (H1 b2 H0).
    pose proof (H2 b1 H).
    clear H H0 H1 H2.
    destruct NQ_nat.
    destruct (im_inj b1).
    destruct (im_inj b2).
    pose proof (H3 x0 x1 H H0).
    pose proof (H4 x1 x0 H0 H).
    assert ((x1 = x0)%nat). { omega. }
    subst.
    apply  (in_inj b1 b2 x0) ; auto.
  Qed.

  Theorem injective_CR2TNQ' : injective CR2_r_eq CR2_r_NQ'.
  Proof.
    unfold injective , CR2_r_NQ in *.
    intros.
    destruct a1 , a2.
    repeat destruct H , H0.
    unfold CR2_r_NQ in H , H0.
    assert (x == x0). { apply (limit_inject b) ; auto. }
    simpl. auto.
  Qed.

  Theorem Countable_CR2 : Countable CR2_r CR2_r_eq.
  Proof.
    pose proof NQ_nat.
    unfold Countable.
    assert (injection CR2_r_eq (eq(A:=NQ))).
    {
      exists CR2_r_NQ'.
      - split;  intros ; subst ; destruct x , y ; hnf in * ; simpl in *.
        + destruct H1 ; split ; rewrite H in *; auto.
          intros. apply (H1 q) ; auto. rewrite H in * ; auto.
        + destruct H1 ; split ; rewrite <- H in *; auto.
          intros. apply (H1 q) ; auto. rewrite H in * ; auto.
      - apply image_defined_CR2TNQ'.
      - apply partial_functional_CR2TNQ'.
      - apply injective_CR2TNQ'.
    }
    apply (injection_trans _ X0 X).
  Qed.

  Definition P_for_DecR (D : Dec) : Prop := forall r : R , Dec_r D r -> CR2 r.
  Definition DecR_to_CR2 (D : Dec)(r : CR2_r) : Prop.
    destruct r.
    apply (Dec_r D x).
  Defined.
  Definition R_CR2_CR2r (r : R) (H: CR2 r) : CR2_r.
    exists r ; auto.
  Defined.

  Instance DecR_to_CR2_comp : Proper (eq ==> CR2_r_eq ==> iff) DecR_to_CR2.
  Proof.
    hnf ; red; intros ; split ; intros ;  subst ; destruct x0 , y0; hnf in * ; simpl in *.
    - split ; intros ;  rewrite <- H0 in * ; apply H1.
    - split ; intros ; rewrite H0 in * ; apply H1.
  Qed.

  Theorem image_defined_DRTCR2 : (forall D : Dec , P_for_DecR D) -> image_defined DecR_to_CR2.
  Proof.
    unfold image_defined , P_for_DecR , CR2_r , DecR_to_CR2.
    intros.
    pose proof H a.
    destruct (image_defined_Dec_r a).
    pose proof H0 x H1.
    exists (R_CR2_CR2r x H2).
    auto.
  Qed.

  Theorem partial_functional_DRTCR2 : (forall D : Dec , P_for_DecR D) -> partial_functional CR2_r_eq DecR_to_CR2.
  Proof.
    pose proof partial_functional_Dec_r.
    unfold partial_functional , P_for_DecR , CR2_r , DecR_to_CR2 in *.
    intros.
    destruct b1 , b2.
    pose proof (H a x x0 H1 H2).
    simpl. auto.
  Qed.

  Theorem injective_DRTCR2 : (forall D : Dec , P_for_DecR D) -> injective eq DecR_to_CR2.
  Proof.
    pose proof injective_Dec_r.
    unfold injective , P_for_DecR , CR2_r , DecR_to_CR2 in *.
    intros.
    destruct b.
    apply (H _ _ x) ; auto.
  Qed.

  Theorem exists_DecR_not_CR2 : exists D : Dec , ~ P_for_DecR D.
  Proof.
    apply not_all_ex_not .
    unfold not.
    intros.
    apply UnCountable_DecR.
    pose proof Countable_CR2.
    destruct X.
    pose proof partial_functional_DRTCR2 H.
    pose proof image_defined_DRTCR2 H.
    pose proof injective_DRTCR2 H.
    set (fun (d : Dec)(n : nat) => forall r : CR2_r , DecR_to_CR2 d r -> inj_R r n).
    exists P ; subst P; hnf ; intros.
    - hnf ; intros. subst. reflexivity.
    - destruct (H1 a).
      destruct (im_inj x).
      exists x0.
      intros.
      pose proof (H0 a _ _ H3 H5).
      rewrite <- H6 ; auto.
    - destruct (H1 a).
      pose proof (H3 _ H5).
      pose proof (H4 _ H5).
      apply (pf_inj x b1 b2) ; auto.
    - destruct (H1 a1).
      destruct (H1 a2).
      pose proof H3 x H5.
      pose proof H4 x0 H6.
      pose proof in_inj x x0 b H7 H8.
      apply (H2 a1 a2 x0) ; auto.
      rewrite H9 in H5. auto.
  Qed.

  Theorem limit_CN2'_NCN : (forall (Un:nat -> R->Prop) (l1:R), Un_cv Un l1 ->
          (forall (n : nat)(r : R) , Un n r -> CR2 r) -> CR2 l1) -> False.
  Proof.
    destruct exists_DecR_not_CR2.
    intros.
    apply H.
    unfold P_for_DecR in *.
    intros.
    destruct x.
    set (NQP_T_NRP (NNP_T_NQP x)).
    assert (Un_cv P r). {
     assert (mono_up P).
     {
        pose proof Dec_mono_up (NNP_Dec x i).
        subst P. apply H2.
     }
     assert (exists r : R , upper_bound P r).
     {
        pose proof Dec_upper_bound (NNP_Dec x i).
        destruct H3. exists x0.
        subst.
        auto.
     }
     pose proof mono_up_upper_bound_seq_has_limit P H2 H3.
     destruct H4.
     apply Uncv_eqb_Uncv' in H4.
     pose proof Un_cv'_Dec x x0 i H4.
     assert (x0 == r).
     {
        pose proof Dec_R2_bound x i.
        apply Uncv_eqb_Uncv' in H4.
        apply Dec_R_eq.
        - pose proof mono_up_limit_sup _ H2 H3 _ H4.
          destruct H7.
          subst P.
          split.
          + destruct H2 , H2.
            destruct (H2 O).
            specialize (H8 O x1 H11).
            apply Rle_ge. apply Rle_trans with x1 ; auto.
            destruct H11.
            destruct H11 ; subst.
            destruct H12. rewrite <- H11. destruct H13.
            auto with real.
          + apply Rle_lt_trans with 2.
            * auto with real.
            * apply R2_Rlt_R10.
        - destruct H1.
          apply H7.
        - intros. rewrite H5. destruct H1.
          rewrite H1. reflexivity.
        - apply is_function_NNP_T_NQP. auto.
     }
     subst. apply Uncv_eqb_Uncv' ; auto.
     apply is_function_NNP_T_NQP ; auto.
     rewrite <- H6. auto.
     apply is_function_NNP_T_NQP ; auto.
    }
    assert (forall (n : nat)(r' : R), P n r' -> CR2 r').
    { intros.
      subst P.
      destruct H3 , H3.
      rewrite <- H3.
      apply all_Q_CR2.
    }
    pose proof (H0 P r H2 H3).
    auto.
  Qed.
End CR_NQ.


Require Import List Arith Omega.
Require Import STLC_Ref.term STLC_Ref.ty STLC_Ref.env STLC_Ref.red.

(** So far memories where not typed. We are going to use a second storage
    in our typing judgement to keep track of the type of terms associated
    to any addresses.

   This map is used as truth source to type memories: each address in the
   the map is associated with a type. The idea is that memories should be
   typed in the empty context, so we get something like:

   forall address a in a memory m typed by a type store D,
     nil, D ⊢ Addr a : D(a)
*)
Definition TStore := list (Addrs * Ty).

(* begin hide *)
(* Type store inclusion *)
Definition InclTStore {T: Type} D1 D2 := forall u (t: T),
    readAddr u D1 = Some t -> readAddr u D2 = Some t.

Lemma InclTStore_refl: forall T (D: list (Addrs * T)), InclTStore D D.
Proof.
now intros.
Qed.

Lemma app_InclTStore_left: forall {T: Type} (D D1 D2 : list (Addrs * T)),
    InclTStore D D1 -> InclTStore D (D1 ++ D2).
Proof.
intros T D D1 D2 hin x M hx.
apply readAddr_app.
now apply hin.
Qed.
(* end hide *)

(** * Typing judgement for terms.

It is STLC extended with references as
described in https://www-apr.lip6.fr/~demangeon/Recherche/impfun2.pdf
with minor tweaks to be able to mechanism the proofs:
- Addition of the type store D instead of having typed variables,
  which break the hard mutual dependency between reduction and typing
- Subject Reduction is proved in the empty context (as usual for call
  by value reductions). This removes the need for memories to be only
  values.
*)
Inductive typ : Env -> TStore -> Term -> Ty -> Prop :=
 | cVar  : forall Γ D A v, A ↓ v ∈ Γ -> typ Γ D (#v) A
 | cLa   : forall Γ D A B M, typ (A::Γ) D M B -> typ Γ D (λ[A], M) (A ⇒ B)
 | cApp  : forall Γ D M N A B, typ Γ D M (A ⇒ B) -> typ Γ D N A ->
         typ Γ D (M • N) B
 | cRef  : forall Γ D M A, typ Γ D M A -> typ Γ D (ref M) (Ref A)
 | cUnit : forall Γ D, typ Γ D unit Unit
 | cAddr : forall Γ D T u, readAddr u D = Some T -> typ Γ D (Addr u) (Ref T)
 | cAsg  : forall Γ D M N A, typ Γ D M (Ref A) -> typ Γ D N A ->
         typ Γ D (M :=: N) Unit
 | cDrf  : forall Γ D M A, typ Γ D M (Ref A) -> typ Γ D (deref M)  A
.

(* begin hide *)
Hint Constructors typ.

Lemma InclTStore_typ: forall Γ D1 M T, typ Γ D1 M T -> forall D2,
    InclTStore D1 D2 -> typ Γ D2 M T.
Proof.
induction 1 as [ ? ? ? v hin | ? ? ? ? ? h hi | ? ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi | ? ? | ? ? ? ? h | ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi ]; intros  D2 hincl; try solve [
            constructor; now apply hi | now constructor
            | econstructor; [now apply hi1 | now apply hi2 ] ].
constructor.
now apply hincl.
Qed.
(* end hide *)

(** A type store D types a memory m if they map the same set of addresses
 and types in D type the corresponding term in m in the empty context *)
Definition WfTStore D mem :=
    (forall u, InAddr u D <-> InAddr u mem) /\
    (* (length D = length mem) /\ *)
    (forall u V, readAddr u mem = Some V ->
        (match readAddr u D with Some T => typ nil D V T | None => False end)).

(** Weakening Property: if a judgement is valid, we can insert a well-typed term
  in the context, it will remain valid. This is where the type checking for
  inserting items in a context is done.*)
Theorem weakening: forall Δ D M T, typ Δ D M T ->
    forall Γ A n Δ', ins_in_env Γ A n Δ Δ' -> typ Δ' D (M ↑ 1 # n) T.
Proof.
induction 1 as [ Δ D ? ? hin | Δ D ? ? ? h hi | Δ D ? ? ? ? h1 hi1 h2 hi2 |
        Δ D ? ? h hi | Δ D | Δ D ? ? ? | Δ D ? ? ? h1 hi1 h2 hi2 | Δ D ? ? h hi ];
        intros Γ ? n Δ' hins; simpl in *; try solve [
            constructor; eapply hi; constructor; now apply hins |
            constructor; eapply hi; now apply hins |
            econstructor; [now eapply hi1; apply hins |
                           now eapply hi2; apply hins ] ].
- destruct le_gt_dec; constructor.
  + eapply ins_item_ge; [ now apply hins | assumption | assumption].
  + eapply ins_item_lt; [ now apply hins | | ]; assumption.
- now constructor.
Qed.

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

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

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

Theorem substitution : forall Γ D M T , typ Γ D M T  ->
    forall Δ P A,  typ Δ D P A ->
 forall Γ' n , sub_in_env Δ A n Γ Γ' -> typ Γ' D (M [ n ←P ])  T.
Proof.
induction 1 as [ ? ? ? v hin | ? ? ? ? ? h hi | ? ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi | ? ? | ? ? ? ? | ? ? ? ? ? h1 hi1 h2 hi2 | ? ? ? ? h hi ];
    intros Δ P X hP Γ' n hsub; simpl; try solve [
        now econstructor; [eapply hi1; [apply hP | ] |
                eapply hi2; [apply hP | ]]
        | constructor; now  eapply hi; [ now apply hP | ]].
- destruct lt_eq_lt_dec as [ [] | ].
  + constructor.
    eapply nth_sub_inf; [ now apply hsub | now omega | assumption].
  + subst.
    eapply thinning_n.
    * eapply sub_trunc.
      now apply hsub.
    * replace A with X; [ assumption | ].
      eapply nth_sub_eq; [ now apply hsub | assumption].
  + constructor.
    eapply nth_sub_sup; [ now apply hsub | now omega |].
    replace (S (v - 1)) with v by now omega.
    assumption.
- econstructor.
  eapply hi; [ now apply hP | ].
  now constructor.
- now constructor.
Qed.

(* begin hide *)
(* Adding a fresh variable to a type store doesn't change existing typing
 * judgements
 *)
Lemma bindAddr_thinning: forall Γ D M T, typ Γ D M T -> forall u S,
    ~ InAddr u D -> typ Γ (bindAddr u S D) M T.
Proof.
induction 1 as [ ? ? ? v ? | ? ? ? ? ? h hi | ? ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi | ? ? | ? ? ? ? | ? ? ? ? ? h1 hi1 h2 hi2 | ? ? ? ? h hi ];
        intros w S hnotin; try solve [
            now constructor |
            now constructor; apply hi |
            now econstructor; [ apply hi1 | apply hi2 ]].
constructor; simpl.
destruct Nat.eq_dec; [subst | assumption].
elim hnotin.
now apply read2In with T.
Qed.

(* Adding a duplicate address with the same type that is already bound in
 * the store doesn't change existing typing judgements
 *)
Lemma bindAddr_thinning_same: forall Γ D M T, typ Γ D M T -> forall u S,
    readAddr u D = Some S -> typ Γ (bindAddr u S D) M T.
Proof.
induction 1 as [ ? ? ? v ? | ? ? ? ? ? h hi | ? ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi | ? ? | ? ? ? ? | ? ? ? ? ? h1 hi1 h2 hi2 | ? ? ? ? h hi ];
        intros w S hr; try solve [
            now constructor |
            now constructor; apply hi |
            now econstructor; [ apply hi1 | apply hi2 ]].
constructor; simpl.
destruct Nat.eq_dec; [subst | assumption].
now elim hr.
Qed.

Lemma bindWfTStore: forall D mem u V A,
    WfTStore D mem -> typ nil D V A -> ~ InAddr u mem ->
    WfTStore (bindAddr u A D) (bindAddr u V mem).
Proof.
intros D mem u V A [h1 h2] htyp hin; split.
- intros w; split; intro h; simpl in *.
  + destruct Nat.eq_dec; try now idtac.
    now apply h1.
  + destruct Nat.eq_dec; try now idtac.
    now apply h1.
- intros w W hr; simpl in *.
  destruct Nat.eq_dec.
  + injection hr; intros; subst; clear hr.
    apply bindAddr_thinning; [ assumption | ].
    intro h; apply hin; now apply h1.
  + generalize (h2 w W hr).
    destruct (readAddr w D); [ | now idtac ].
    intro h; apply bindAddr_thinning; [ assumption | ].
    intro hh; apply hin; now apply h1.
Qed.
(* end hide *)

(** Subject Reduction *)
(* TODO: clean a bit the script *)
Lemma SR: forall Γ D M T, typ Γ D M T -> forall m1 m2 N,
    Γ = nil -> red M m1 N m2 -> WfTStore D m1 ->
    exists D', (InclTStore D D' /\ WfTStore D' m2 /\ typ Γ D' N T).
Proof.
induction 1 as [ ? ? ? v hin | ? ? ? ? ? h hi | ? ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi | ? ? | ? ? ? ? h | ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi ];
          intros m1 m2 Q hgamma hred hst; try solve [
            inversion hred; subst; clear hred; constructor; now apply hi
            ].
- inversion hred; subst; clear hred.
  + exists D; split; [ now apply InclTStore_refl |].
    split; [assumption |].
    inversion h1; subst; clear h1.
    eapply substitution; [ now apply H2 | now apply h2 | now constructor ].
  + destruct (hi1 m1 m2 M'  (refl_equal _) H4 hst) as [Q [hQ1 [hQ2 hQ3]]].
    exists Q; split; [assumption | ].
    split; [assumption |].
    econstructor; [ now apply hQ3 | ].
    eapply InclTStore_typ; [ now apply h2 | now apply hQ1 ].
  + destruct (hi2 m1 m2 N' (refl_equal _) H5 hst) as [Q [hQ1 [hQ2 hQ3]]].
    exists Q; split; [assumption | ].
    split; [assumption |].
    econstructor; [ | now apply hQ3 ].
    eapply InclTStore_typ; [ now apply h1 | now apply hQ1 ].
- inversion hred; subst; clear hred.
  + exists (bindAddr u A D); repeat split; try assumption.
    * intros x X hx; simpl.
      destruct Nat.eq_dec as [ heq | hne ]; [ | now assumption].
      subst.
      apply read2In in hx.
      apply hst in hx.
      now elim H0.
    * simpl.
      destruct Nat.eq_dec as [heq | hne]; [now idtac | intro hh].
      now apply hst.
    * simpl.
      destruct Nat.eq_dec as [heq | hne]; [now idtac | intro hh].
      now apply hst.
    * intros w V; simpl.
      destruct Nat.eq_dec as [heq | hne]; intro hh.
      -- injection hh; intros; subst; clear hh.
         apply bindAddr_thinning; [assumption | ].
         intro hin; apply H0; now apply hst.
      -- destruct hst as [h1 h2].
         generalize (h2 w V hh).
         destruct (readAddr w D); [ | now idtac].
         intro hty.
         apply bindAddr_thinning; [assumption | ].
         intro hin; apply H0; now apply h1.
    * constructor; simpl.
      now destruct Nat.eq_dec.
  + destruct (hi m1 m2 M' (refl_equal _) H0 hst) as [Q [h1 [h2 h3]]].
    exists Q; split; [assumption | ].
    split; [assumption |].
    now constructor.
- inversion hred; subst; clear hred.
  + inversion h1; subst; clear h1.
    exists (bindAddr u A D); repeat split; try assumption.
    * intros x X h; simpl; rewrite h.
      destruct Nat.eq_dec; [ | now idtac].
      now subst; rewrite H3 in h.
    * simpl.
      destruct Nat.eq_dec as [heq | hne]; [now idtac | intro hh].
      now apply hst.
    * simpl.
      destruct Nat.eq_dec as [heq | hne]; [now idtac | intro hh].
      now apply hst.
    * intros w V; simpl.
      destruct Nat.eq_dec as [heq | hne]; intro hh.
      -- injection hh; intros; subst; clear hh.
         now apply bindAddr_thinning_same.
      -- destruct hst as [hst1 hst2].
         generalize (hst2 w V hh).
         destruct (readAddr w D); [ | now idtac].
         intro hty.
         now apply bindAddr_thinning_same.
    * now constructor; simpl.
  + destruct (hi1 m1 m2 M' (refl_equal _) H4 hst) as [Q [hQ1 [hQ2 hQ3]]].
    exists Q; split; [assumption | ].
    split; [assumption |].
    econstructor; [ now apply hQ3 | ].
    now apply InclTStore_typ with D.
  + destruct (hi2 m1 m2 N' (refl_equal _) H5 hst) as [Q [hQ1 [hQ2 hQ3]]].
    exists Q; split; [assumption | ].
    split; [assumption |].
    econstructor; [ | now apply hQ3 ].
    now apply InclTStore_typ with D.
- inversion hred; subst; clear hred.
  + inversion h; subst; clear h.
    exists D; repeat split; [ now apply InclTStore_refl | | | | ].
    * now intro hh; apply hst.
    * now intro hh; apply hst.
    * intros w V hw.
      destruct hst as [h1 h2].
      apply h2 in hw.
      revert hw.
      now destruct (readAddr w D).
    * destruct hst as [h1 h2].
      apply h2 in H0.
      now rewrite H4 in H0.
  + destruct (hi m1 m2 M' (refl_equal _) H0 hst) as [Q [h1 [h2 h3]]].
    exists Q; repeat split; try assumption.
    * now intro hh; apply h2.
    * now intro hh; apply h2.
    * intros w V hw.
      now apply h2 in hw.
    * now constructor.
Qed.

(** Progress *)
(* begin hide *)
Lemma Progress_: forall Γ D M T, typ Γ D M T -> Γ = nil ->
    forall m1, WfTStore D m1 ->
    (exists N, exists m2, red M m1 N m2) \/ is_value M.
Proof.
induction 1 as [ ? ? ? v hin | ? ? ? ? ? h hi | ? ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi | ? ? | ? ? ? ? h | ? ? ? ? ? h1 hi1 h2 hi2 |
        ? ? ? ? h hi ]; intros hgamma m1 hst; try (now right).
- left.
  destruct (hi1 hgamma m1 hst) as [[M' [m2 hred]] | hV].
  + exists (M' • N); exists m2; now constructor.
  + destruct (hi2 hgamma m1 hst) as [[N' [m2 hred]] | hW].
    * exists (M • N'); exists m2; now constructor.
    * inversion h1; subst; clear h1; try now elim hV.
      now exists (M0 [← N]); exists m1; constructor.
- left.
  destruct (hi hgamma m1 hst) as [[M' [m2 hred]] | hV].
  + exists (ref M'); exists m2; now constructor.
  + exists (Addr (fresh m1)); exists (bindAddr (fresh m1) M m1);
     constructor; [ | assumption ].
    now apply fresh_is_fresh.
- left.
  destruct (hi1 hgamma m1 hst) as [[M' [m2 hred]] | hV].
  + exists (M' :=: N); exists m2; now constructor.
  + destruct (hi2 hgamma m1 hst) as [[N' [m2 hred]] | hW].
    * exists (M :=: N'); exists m2; now constructor.
    * inversion h1; subst; clear h1; try now elim hV.
      now exists unit; exists (bindAddr u N m1); constructor.
- left.
  destruct (hi hgamma m1 hst) as [[M' [m2 hred]] | hV].
  + exists (deref M'); exists m2; now constructor.
  + inversion h; subst; clear hi; try now elim hV.
    case_eq (readAddr u m1).
    * now intros V heq; exists V; exists m1; constructor.
    * intro hr; apply read2In in H3.
      apply hst in H3.
      apply In2read in H3 as [ ? hh].
      now rewrite hh in hr; discriminate.
Qed.
(* end hide *)

Lemma Progress: forall D M T, typ nil D M T ->
    forall m1, WfTStore D m1 ->
    (exists N, exists m2, red M m1 N m2) \/ is_value M.
Proof.
intros D M T htyp m1 h.
eapply Progress_.
- now apply htyp.
- reflexivity.
- assumption.
Qed.