Require Import ssreflect ssrfun.
Set Automatic Coercions Import.
Require Import FunctionalExtensionality.
Require Import relations.

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

Section Functional.
Variables A B : Type.

Definition FuncType : Type
  := forall (T : monadType), A -> T B.
End Functional.

Module AcceptableFO.
Section axiom.
Variable T T' : monadType.

Definition TRtypeFO
  := forall X X', Rel X X' -> Rel (T X) (T' X').

Definition acceptableTRFO (TR : TRtypeFO) : Prop :=
  forall X X' (R : Rel X X') (x : X) (x' : X'),
    R x x' -> TR X X' R (tval T x) (tval T' x').
End axiom.

Record TRaccFO (T T' : monadType) := mkTRacc {
  TR :> TRtypeFO T T';
  axiomAcc :> acceptableTRFO TR
}.

End AcceptableFO.

Notation TRtypeFO := AcceptableFO.TRtypeFO.
Notation TRaccTypeFO := AcceptableFO.TRaccFO.
Notation TRFO := AcceptableFO.TR.
Notation AccFO :=  AcceptableFO.axiomAcc.

Section Purity.
Variables A B : Type.

Definition isPure (f : FuncType A B) : Prop
  := forall (T T' : monadType) (TRacc : TRaccTypeFO T T'),
    (@IdR A =R=> (TRFO TRacc) _ _ (@IdR B)) (f T) (f T').
End Purity.

Section RepresentationTheorems.
Variables A B : Type.

Lemma lem_pure (g : A -> B) : isPure (fun T => (@tval T _) \o g).
Proof.
rewrite /isPure.
move => T T' TR a a'; elim => {a'}.
now apply: AccFO.
Qed.

Section TopTopMonadicRelation.
Variable T : monadType.

Definition RelTop X X' (R : Rel X X') : Rel (X -> T B) (X' -> B)
  := fun h h' =>
       forall x x', R x x' -> h x = tval _ (h' x').

Definition RelTopTop X X' (R : Rel X X') : Rel (T X) X'
  := fun t t' =>
       forall h h', RelTop R h h' -> tbind t h = tval _ (h' t').

Definition TRacc1 : TRaccTypeFO T Id.
exists RelTopTop.
rewrite /RelTopTop /RelTop /=.
move => X X' R /=.
by intuition; rewrite taxiom0; auto.
Defined.

End TopTopMonadicRelation.

Theorem pure_is_pure (f : FuncType A B) (Hpure : isPure f) T :
  exists g : A -> B, @f T = (@tval _ _) \o g.
Proof.
exists (@f Id).
extensionality a => /=.
have H := Hpure _ _ (@TRacc1 T).
rewrite -[X in X = _]taxiom1.
apply : (H _ _ eq_refl (@tval _ _) id).
rewrite /RelTop /=.
by move => ? ?; elim.
Qed.

End RepresentationTheorems.


From LF Require Import Maps.
From LF Require Import Imp.
From Coq Require Import Classical.

Reserved Notation
         "st '=[' c ']=>inf'"
         (at level 40, c custom com at level 99).

CoInductive evalinf : com -> state -> Prop :=
  | I_Seq1 : forall c1 c2 st,
      st  =[ c1 ]=>inf  ->
      st  =[ c1 ; c2 ]=>inf
  | I_Seq2 : forall c1 c2 st st',
      st  =[ c1 ]=> st'  ->
      st' =[ c2 ]=>inf ->
      st  =[ c1 ; c2 ]=>inf
  | I_IfTrue : forall st b c1 c2,
      beval st b = true ->
      st =[ c1 ]=>inf ->
      st =[ if b then c1 else c2 end]=>inf
  | I_IfFalse : forall st b c1 c2,
      beval st b = false ->
      st =[ c2 ]=>inf ->
      st =[ if b then c1 else c2 end]=>inf
  | I_WhileBody : forall st b c,
      beval st b = true ->
      st  =[ c ]=>inf ->
      st  =[ while b do c end ]=>inf
  | I_WhileLoop : forall st st' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ while b do c end ]=>inf ->
      st  =[ while b do c end ]=>inf
  where "st =[ c ]=>inf" := (evalinf c st ).

Lemma loop_diverges: forall st,
  st =[ loop ]=>inf.
Proof.
  cofix COINDHYP; intros.
  unfold loop.
  eapply I_WhileLoop.
  - reflexivity.
  - constructor.
  - fold loop. apply COINDHYP.
Qed.

Lemma state_unchaning_loop_converges: forall b c st,
  beval st b = true ->
  st =[ c ]=> st ->
  st =[ while b do c end ]=>inf.
Proof.
  cofix COINDHYP. intros.
  eapply I_WhileLoop.
  - auto.
  - eauto.
  - eapply COINDHYP; auto.
Qed.

Lemma loop_diverges': forall st,
  st =[ loop ]=>inf.
Proof.
  intros.
  apply state_unchaning_loop_converges; auto; constructor.
Qed.

Definition loop' : com :=
  <{ while 1 <= X do
       X := X + 1
     end }>.

Lemma loop'_converges: forall st,
  st X = 0 -> st =[ loop' ]=> st /\ ~st =[ loop']=>inf.
Proof.
  intros st Hx; inversion Hx; split.
  - econstructor; simpl; rewrite H0; reflexivity.
  - intros H; inversion H; subst;
    simpl in H3; rewrite H0 in H3; discriminate.
Qed.

Theorem eval_evalinf_exclusive: forall c st st',
    st =[ c ]=> st' -> ~(st =[ c ]=>inf).
Proof.
    intros c st st' H.
    induction H; intros contra; inversion contra;
    subst; try congruence; auto.
    - apply IHeval2. remember (eval_deterministic _ _ _ _ H H3); subst; auto.
    - generalize (eval_deterministic _ _ _ _ H0 H5); intros. subst st'0; auto.
Qed.

Reserved Notation
         "st '=[' c ']=>>' st'"
         (at level 40, c custom com at level 99).

CoInductive coeval : com -> state -> state -> Prop :=
| C_Skip : forall (st : state),
    st =[ skip ]=>> st
| C_Ass  : forall st a n x,
    aeval st a = n ->
    st =[ x := a ]=>> (x !-> n; st)
| C_Seq : forall c1 c2 st st' st'',
    st  =[ c1 ]=>> st'  ->
    st' =[ c2 ]=>> st'' ->
    st  =[ c1 ; c2 ]=>> st''
| C_IfTrue : forall st st' b c1 c2,
    beval st b = true ->
    st =[ c1 ]=>> st' ->
    st =[ if b then c1 else c2 end]=>> st'
| C_IfFalse : forall st st' b c1 c2,
    beval st b = false ->
    st =[ c2 ]=>> st' ->
    st =[ if b then c1 else c2 end]=>> st'
| C_WhileFalse : forall b st c,
    beval st b = false ->
    st =[ while b do c end ]=>> st
| C_WhileTrue : forall st st' st'' b c,
    beval st b = true ->
    st  =[ c ]=>> st' ->
    st' =[ while b do c end ]=>> st'' ->
    st  =[ while b do c end ]=>> st''
where "st =[ c ]=>> st'" := (coeval c st st').

Theorem eval_coeval: forall c st st',
    st =[ c ]=> st' ->
    st =[ c ]=>> st'.
Proof.
  induction 1; econstructor; eauto; assumption.
Qed.

Lemma coeval_loop: forall st,
  st =[ loop ]=>> st.
Proof.
    cofix COINDHYP.
    intros; unfold loop.
    eapply C_WhileTrue.
    - auto.
    - constructor.
    - apply COINDHYP.
Qed.

Lemma coeval_loop': forall st,
  st X = 0 -> st =[ loop ]=>> st.
Proof.
    cofix COINDHYP.
    intros; unfold loop.
    eapply C_WhileTrue.
    - auto.
    - constructor.
    - apply COINDHYP; auto.
Qed.

Lemma coeval_noteval_evalinf: forall c st st',
  st =[ c ]=>> st' -> ~(st =[ c ]=> st') -> st =[ c ]=>inf.
Proof.
    cofix COINDHYP. intros.
    inversion H; subst.
    - (* skip *) elim H0; constructor.
    - (* x := a *) elim H0; constructor; auto.
    - (* c1; c2 *) elim (classic (st =[ c1 ]=> st'0)); intro.
      + (* st =[ c1 ]=> st'0 *)
        elim (classic (st'0 =[ c2 ]=> st')); intro.
        * (* st'0 =[ c2 ]=> st' *)
          elim H0. econstructor; try apply H3;  apply H4.
        * (* ~ st'0 =[ c2 ]=> st' *)
          eapply I_Seq2; try apply H3. eapply COINDHYP; eauto; auto.
      + (* ~ st =[ c1 ]=> st'0 *)
        eapply I_Seq1; eapply COINDHYP; eauto.
    - (* if true then c1 else c2 end *)
      elim (classic (st =[ c1 ]=> st')); intro.
      + (* st =[ c1 ]=> st' *)
        elim H0; econstructor; try apply H1; apply H3.
      + (* ~st =[ c1 ]=> st' *)
        eapply I_IfTrue; try apply H1; eauto.
    - (* if false then c1 else c2 end *)
      elim (classic (st =[ c2 ]=> st')); intro.
        + (* st =[ c2 ]=> st' *)
          elim H0. eapply E_IfFalse; try apply H1; apply H3.
        + (* ~st =[ c2 ]=> st' *)
          eapply I_IfFalse; try apply H1; eauto.
    - (* while false do c end *)
      elim H0. eapply E_WhileFalse; auto.
    - (* while true do c end *)
      elim (classic ( st =[ c0 ]=> st'0 )); intro.
      (* st =[ c0 ]=> st'0 *)
      + elim (classic ( st'0 =[ while b do c0 end ]=> st')); intro.
        (* ~ st'0 =[ while b do c0 end ]=> st' *)
        * elim H0; eauto using E_WhileTrue.
        (* ~ st'0 =[ while b do c0 end ]=> st' *)
        * eapply I_WhileLoop; eauto.
      (* ~ st =[ c0 ]=> st'0 *)
      + eapply I_WhileBody; eauto.
Qed.

Theorem coeval_eval_or_evalinf: forall c st st',
    st =[ c ]=>> st' ->
    st =[ c ]=> st' \/ st =[ c ]=>inf.
Proof.
  intros. elim (classic (st =[ c ]=> st')); intros.
  left; auto.
  right. eapply coeval_noteval_evalinf; eauto.
Qed.

Theorem eval_coeval_deterministic: forall c st st',
    st =[ c ]=> st' ->
    forall st'', st =[ c ]=>> st''-> st' = st''.
Proof.
  intros c st st' H. induction H; intros st''' H';
   inversion H'; subst; try congruence; auto.
   - (* st =[c1; c2]=>>st''' *)
      remember (IHeval1 _ H3); subst; auto.
   - (* st =[ while true do c end ]=>> st''' *)
      remember (IHeval1 _ H5); subst; auto.
Qed.


Require Import
  Coq.Bool.Sumbool Ssreflect.ssreflect Ssreflect.seq
  FormalPS.stdlib_ext FormalPS.Core.

Set Implicit Arguments.

(*
instfalse_spec, insttrue_spec, instbool_spec:
  ブール値の仕様。
  false は何もしない命令である。
  true は swap と同様の振舞いをする命令である。
*)
Definition instbool_spec (b : bool) (i1 : inst) : Prop :=
  forall i2 i3 vs cs,
    (i3 :: i2 :: vs, i1 :: cs) |=>*
    ((if b then [:: i2; i3] else [:: i3; i2]) ++ vs, cs).

(*
exists_false, exists_true:
  ブール値の仕様を満たす命令。
*)
Lemma exists_bool b : {instbool : inst | instbool_spec b instbool }.
Proof.
  case: b; eexists => i1 i2 vs cs /=.
  - evalpartial evalswap; evalauto.
  - evalpartial evalnop; evalauto.
Defined.

Notation instbool b := (proj1_sig (exists_bool b)).
Notation evalbool b := (proj2_sig (exists_bool b)).

Hint Resolve ((fun b => evalbool b) :
  forall b, instbool_spec b (instbool b)).

(*
instbool_eqmap:
*)
Lemma instbool_eqmap :
  forall b1 b2 i, instbool_spec b1 i -> instbool_spec b2 i -> b1 = b2.
Proof.
  move => b1 b2 i H H0.
  have: let f b := if b then [:: instpop; instcopy]
                        else [:: instcopy; instpop] in
        let s1 := (f b1, [::]) in
        let s2 := (f b2, [::]) in s1 |=>* s2 \/ s2 |=>* s1
    by apply (@eval_semi_uniqueness ([:: instcopy; instpop], [:: i]));
      [evalpartial H | evalpartial H0]; rewrite cats0; evalauto.
  by move: b1 b2 {H H0} => [] [] [] //= H; inversion H; inversion H0.
Qed.

(*
exists_not:
  not 命令。
*)
Lemma exists_not :
  { instnot : inst |
    forall (b : bool) i1 vs cs, instbool_spec b i1 ->
    exists i2 : inst, instbool_spec (negb b) i2 /\
    (i1 :: vs, instnot :: cs) |=>* (i2 :: vs, cs) }.
Proof.
  eexists => b i1 vs cs H.
  evalpartial' (evalpush instswap).
  evalpartial evalcons.
  evalauto.
  case: b H => H i2 i3 vs' cs'; evalauto; evalpartial H; evalauto.
Defined.

Notation instnot := (proj1_sig exists_not).
Notation evalnot := (proj2_sig exists_not).

(*
exists_if, exists_execif:
  ブール値による条件分岐の命令。
  exists_if は、ブール値によってスタックの先頭にある2つの値のうちどちらを残すか
  を切り替える。後者(exists_execif)は、exists_if によって選択される命令を実行す
  る。
*)
Lemma exists_if :
  { instif : inst |
    forall (b : bool) i1 i2 i3 vs cs, instbool_spec b i1 ->
    (i3 :: i2 :: i1 :: vs, instif :: cs) |=>*
    ((if b then i2 else i3) :: vs, cs) }.
Proof.
  eexists => b i1 i2 i3 vs cs H.
  evalpartial' evalquote.
  evalpartial' evalswap.
  evalpartial' evalquote.
  evalpartial' evalcons.
  evalpartial' evalsnoc.
  evalpartial' evalexec.
  evalauto.
  case: b H => H; evalpartial H => /=; evalpartial evalpop; evalauto.
Defined.

Notation instif := (proj1_sig exists_if).
Notation evalif := (proj2_sig exists_if).

Lemma exists_execif :
  { instexecif : inst |
    forall (b : bool) i1 i2 i3 vs cs, instbool_spec b i1 ->
    (i3 :: i2 :: i1 :: vs, instexecif :: cs) |=>*
    (vs, (if b then i2 else i3) :: cs) }.
Proof.
  eexists => b i1 i2 i3 vs cs H.
  evalpartial' (evalif b).
  evalpartial evalexec.
  evalauto.
Defined.

Notation instexecif := (proj1_sig exists_execif).
Notation evalexecif := (proj2_sig exists_execif).

(*
instxor:
  xor 命令。
*)
Definition instxor : inst := instcons.

Lemma evalxor :
  forall (b1 b2 : bool) i1 i2 vs cs,
  instbool_spec b1 i1 -> instbool_spec b2 i2 ->
  exists i3 : inst, instbool_spec (xorb b1 b2) i3 /\
  (i2 :: i1 :: vs, instxor :: cs) |=>* (i3 :: vs, cs).
Proof.
  (do 2 case) => i1 i2 vs cs H H0; evalauto => i3 i4 vs' cs';
    evalauto; evalpartial H; evalpartial H0; evalauto.
Qed.

(*
exists_and:
  and 命令。
*)
Lemma exists_and :
  { instand : inst |
    forall (b1 b2 : bool) i1 i2 vs cs,
    instbool_spec b1 i1 -> instbool_spec b2 i2 ->
    exists i3 : inst, instbool_spec (andb b1 b2) i3 /\
    (i2 :: i1 :: vs, instand :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => b1 b2 i1 i2 vs cs H H0.
  evalpartial' evalswap.
  do 2 evalpartial' evalpush.
  evalpartial (evalexecif b1).
  case b1 => /=.
  - evalpartial evalnop.
    by evalauto.
  - evalpartial' evalpop.
    evalpartial evalpush.
    by evalauto.
Defined.

Notation instand := (proj1_sig exists_and).
Notation evaland := (proj2_sig exists_and).

(*
exists_or:
  or 命令。
*)
Lemma exists_or :
  { instand : inst |
    forall (b1 b2 : bool) i1 i2 vs cs,
    instbool_spec b1 i1 -> instbool_spec b2 i2 ->
    exists i3 : inst, instbool_spec (orb b1 b2) i3 /\
    (i2 :: i1 :: vs, instand :: cs) |=>* (i3 :: vs, cs) }.
Proof.
  eexists => b1 b2 i1 i2 vs cs H H0.
  evalpartial' evalswap.
  do 2 evalpartial' evalpush.
  evalpartial (evalexecif b1).
  case b1 => /=.
  - evalpartial' evalpop.
    evalpartial evalpush.
    by evalauto.
  - evalpartial evalnop.
    by evalauto.
Defined.

Notation instor := (proj1_sig exists_or).
Notation evalor := (proj2_sig exists_or).


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra complex.
Require Import forms.
From mathcomp.analysis Require Import reals.
From mathcomp.real_closed Require Import complex.

Require Import mcextra prodvect mxpred hermitian.

(* -------------------------------------------------------------------- *)
Import Order.TTheory GRing.Theory Num.Theory ComplexField Num.Def complex.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

(* -------------------------------------------------------------------- *)
Local Open Scope complex_scope.
Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Import Vector.InternalTheory.

Local Notation C := hermitian.C.

(* --------------------------------------------------------------------- *)
Declare Scope ffun_scope.
Delimit Scope ffun_scope with F.
Bind Scope ffun_scope with finfun_of.

Notation "0"     := (@ffun_zero _ _) : ffun_scope.
Notation "1"     := (@ffun_one  _ _) : ffun_scope.
Notation "+%F"   := (@ffun_add  _ _) : ffun_scope.
Notation "*%F"   := (@ffun_mul  _ _) : ffun_scope.
Notation "f + g" := (ffun_add f g)   : ffun_scope.
Notation "f * g" := (ffun_mul f g)   : ffun_scope.
Local Open Scope ffun_scope.

Program Canonical ffun_add_monoid (I : finType) (G : zmodType) :=
  @Monoid.Law {ffun I -> G} 0 +%F _ _ _.

Next Obligation. by move=> I G; apply: ffun_addA. Qed.
Next Obligation. by move=> I G; apply: ffun_add0. Qed.
Next Obligation. by move=> I G x; rewrite ffun_addC ffun_add0. Qed.

Program Canonical ffun_add_comoid (I : finType) (G : zmodType) :=
  @Monoid.ComLaw {ffun I -> G} 0 (ffun_add_monoid I G) _.

Next Obligation. by move=> I G; apply: ffun_addC. Qed.

Program Canonical ffun_mul_monoid (I : finType) (R : ringType) :=
  @Monoid.Law {ffun I -> R} 1 *%F _ _ _.

Next Obligation. by move=> I G; apply: ffun_mulA. Qed.
Next Obligation. by move=> I G; apply: ffun_mul_1l. Qed.
Next Obligation. by move=> I G; apply: ffun_mul_1r. Qed.

Program Canonical ffun_mul_comoid (I : finType) (R : comRingType) :=
  @Monoid.ComLaw {ffun I -> R} 1 (ffun_mul_monoid I R) _.

Next Obligation. by move=> I G; apply: ffun_mulC. Qed.

Program Canonical ffun_muloid (I : finType) (R : ringType) :=
  @Monoid.MulLaw {ffun I -> R} 0 (ffun_mul_monoid I R) _ _.

Next Obligation.
by move=> I R f; apply/ffunP=> i; rewrite !ffunE mul0r.
Qed.

Next Obligation.
by move=> I R f; apply/ffunP=> i; rewrite !ffunE mulr0.
Qed.

Program Canonical ffun_addoid (I : finType) (R : comRingType) :=
  @Monoid.AddLaw {ffun I -> R} 0 *%F (ffun_add_comoid I R) _ _.

Next Obligation. by move=> I G; apply: ffun_mul_addl. Qed.
Next Obligation. by move=> I G; apply: ffun_mul_addr. Qed.

(* -------------------------------------------------------------------- *)
Notation "\sum_ ( i <- r | P ) F" :=
  (\big[+%F/0%F]_(i <- r | P%B) F%F) : ffun_scope.
Notation "\sum_ ( i <- r ) F" :=
  (\big[+%F/0%F]_(i <- r) F%F) : ffun_scope.
Notation "\sum_ ( m <= i < n | P ) F" :=
  (\big[+%F/0%F]_(m <= i < n | P%B) F%F) : ffun_scope.
Notation "\sum_ ( m <= i < n ) F" :=
  (\big[+%F/0%F]_(m <= i < n) F%F) : ffun_scope.
Notation "\sum_ ( i | P ) F" :=
  (\big[+%F/0%F]_(i | P%B) F%F) : ffun_scope.
Notation "\sum_ i F" :=
  (\big[+%F/0%F]_i F%F) : ffun_scope.
Notation "\sum_ ( i : t | P ) F" :=
  (\big[+%F/0%F]_(i : t | P%B) F%F) (only parsing) : ffun_scope.
Notation "\sum_ ( i : t ) F" :=
  (\big[+%F/0%F]_(i : t) F%F) (only parsing) : ffun_scope.
Notation "\sum_ ( i < n | P ) F" :=
  (\big[+%F/0%F]_(i < n | P%B) F%F) : ffun_scope.
Notation "\sum_ ( i < n ) F" :=
  (\big[+%F/0%F]_(i < n) F%F) : ffun_scope.
Notation "\sum_ ( i 'in' A | P ) F" :=
  (\big[+%F/0%F]_(i in A | P%B) F%F) : ffun_scope.
Notation "\sum_ ( i 'in' A ) F" :=
  (\big[+%F/0%F]_(i in A) F%F) : ffun_scope.

Notation "\prod_ ( i <- r | P ) F" :=
  (\big[*%F/1%F]_(i <- r | P%B) F%F) : ffun_scope.
Notation "\prod_ ( i <- r ) F" :=
  (\big[*%F/1%F]_(i <- r) F%F) : ffun_scope.
Notation "\prod_ ( m <= i < n | P ) F" :=
  (\big[*%F/1%F]_(m <= i < n | P%B) F%F) : ffun_scope.
Notation "\prod_ ( m <= i < n ) F" :=
  (\big[*%F/1%F]_(m <= i < n) F%F) : ffun_scope.
Notation "\prod_ ( i | P ) F" :=
  (\big[*%F/1%F]_(i | P%B) F%F) : ffun_scope.
Notation "\prod_ i F" :=
  (\big[*%F/1%F]_i F%F) : ffun_scope.
Notation "\prod_ ( i : t | P ) F" :=
  (\big[*%F/1%F]_(i : t | P%B) F%F) (only parsing) : ffun_scope.
Notation "\prod_ ( i : t ) F" :=
  (\big[*%F/1%F]_(i : t) F%F) (only parsing) : ffun_scope.
Notation "\prod_ ( i < n | P ) F" :=
  (\big[*%F/1%F]_(i < n | P%B) F%F) : ffun_scope.
Notation "\prod_ ( i < n ) F" :=
  (\big[*%F/1%F]_(i < n) F%F) : ffun_scope.
Notation "\prod_ ( i 'in' A | P ) F" :=
  (\big[*%F/1%F]_(i in A | P%B) F%F) : ffun_scope.
Notation "\prod_ ( i 'in' A ) F" :=
  (\big[*%F/1%F]_(i in A) F%F) : ffun_scope.

Local Close Scope ffun_scope.

(* -------------------------------------------------------------------- *)
Section FfunBig.
Context  {I J : finType}.

Lemma ffun_sumE
    (G : zmodType) (r : seq I) (P : pred I) (F : I -> {ffun J -> G}) j
  : (\sum_(i <- r | P i) (F i))%F j = \sum_(i <- r | P i) F i j.
Proof.
apply: (big_morph (fun f : {ffun J -> G} => f j)).
- by move=> f g; rewrite ffunE. - by rewrite ffunE.
Qed.

Lemma ffun_prodE
    (R : ringType) (r : seq I) (P : pred I) (F : I -> {ffun J -> R}) j
  : (\prod_(i <- r | P i) (F i))%F j = \prod_(i <- r | P i) F i j.
Proof.
apply: (big_morph (fun f : {ffun J -> R} => f j)).
- by move=> f g; rewrite ffunE. - by rewrite ffunE.
Qed.
End FfunBig.

Section FFunSet.
Context {I : finType} (E : I -> Type).

Implicit Types (f : {ffun forall i : I, E i}).

Definition ffun_set (i0 : I) (v : E i0) f :=
  [ffun i => if i0 =P i is ReflectT eq then ecast k (E k) eq v else f i].

Lemma ffset_eq (i : I) (v : E i) f : @ffun_set i v f i = v.
Proof. by rewrite ffunE; case: eqP => // p; rewrite eq_axiomK. Qed.

Lemma ffset_neq (i j : I) (v : E i) f : i != j -> @ffun_set i v f j = f j.
Proof. by move=> /eqP ne_ij; rewrite ffunE; case: (i =P j). Qed.
End FFunSet.

Notation "f .[ i0 <- v ]" := (@ffun_set _ _ i0 v f)
  (at level 2, i0 at level 200, v at level 200, format "f .[ i0  <-  v ]")
   : fun_scope.

Definition ffunE := (@ffset_eq, ffunE, @ffun_sumE, @ffun_prodE).

Lemma mv_neqP (I : finType) (E : I -> eqType) (f g : mvector E) :
  reflect (exists i, f i != g i) (f != g).
Proof. exact: dffun_neqP. Qed.

(* ==================================================================== *)
Section TensorProducts.
Context {I : finType} {k : fieldType} (E : I -> vectType k).

Implicit Types (G : vectType k).

Let B := mvector (fun i => 'I_(Vector.dim (E i))).
Let T := {ffun B -> k^o}.

Lemma dim_ffunr : Vector.dim [vectType k of T] = #|[finType of B]|.
Proof. by rewrite /Vector.dim /= /Vector.dim /= muln1. Qed.

Definition i2n (i : B) : 'I_(Vector.dim [vectType k of T])
  := (cast_ord (esym dim_ffunr) (enum_rank i)).
Definition n2i i : B := enum_val (cast_ord (dim_ffunr) i).
Lemma i2nK : cancel i2n n2i.
Proof. by move=>i; rewrite /i2n /n2i cast_ordKV enum_rankK. Qed.
Lemma n2iK : cancel n2i i2n.
Proof. by move=>i; rewrite /i2n /n2i enum_valK cast_ordK. Qed.
Lemma i2n_inj : injective i2n.
Proof. exact (can_inj i2nK). Qed.
Lemma n2i_inj : injective n2i.
Proof. exact (can_inj n2iK). Qed.

Definition inject (x : mvector E) : T :=
  r2v (\row_i (\prod_j v2r (x j) 0 (n2i i j))).

Notation "'⊗' x" := (inject x) (at level 2, format "⊗ x").

Lemma inject_cpnt (x : mvector E) (b : B) :
  (v2r ⊗x 0 (i2n b)) = \prod_i v2r (x i) 0 (b i).
Proof. by rewrite /inject r2vK mxE i2nK. Qed.

Lemma idx_neq (i j: B) : i == j = false -> exists k, i k == j k = false.
Proof.
move/eqP; rewrite boolp.not_existsP; apply contra_not => P.
by apply/mvectorP=> i'; move:(P i'); rewrite Bool.not_false_iff_true =>/eqP ->.
Qed.

Lemma inject_base (b : B) : ⊗(\mvector_(i : I) r2v (delta_mx 0 (b i)))
  = r2v (delta_mx 0 (i2n b)).
Proof.
rewrite /inject; apply f_equal; apply/matrixP=>i j; rewrite !mxE !ord1 eqxx /=.
rewrite -(can2_eq n2iK i2nK); case P: (n2i j == b).
by move/eqP: P=> ->; rewrite big1 //= => m _; rewrite mvE r2vK mxE !eqxx.
by move: (idx_neq P)=> H; destruct H; rewrite (bigD1 x) //= mvE r2vK mxE H mul0r.
Qed.

Lemma inject_baseV b : r2v (delta_mx 0 b) =
  ⊗(\mvector_(i : I) r2v (delta_mx 0 (n2i b i))).
Proof. by rewrite inject_base n2iK. Qed.

Definition scalei (i : I) (a : k) (x : mvector E) : mvector E :=
  \mvector_(j : I) ((if i == j then a else 1) *: x j).

Notation "a *:_ i x" := (scalei i a x)
  (at level 50, i at level 2, format "a  *:_ i  x").

Lemma scale1i (i : I) (x : mvector E) : 1 *:_i x = x.
Proof. by apply/mvectorP=> j; rewrite mvE if_same scale1r. Qed.

Definition scalem (a : I -> k) (x : mvector E) : mvector E :=
  \mvector_(i : I) (a i *: x i).

Notation "a *:_m x" := (scalem a x)
  (at level 50, format "a  *:_m  x").

Lemma scalem1E (i : I) (a : k) (x : mvector E) :
  [ffun j => if i == j then a else 1] *:_m x = a *:_i x.
Proof. by apply/mvectorP=> j; rewrite !(mvE, ffunE). Qed.

Lemma scalem_eq (a b : I -> k) x : a =1 b -> a *:_m x = b *:_m x.
Proof. by move=> eq_ab; apply/mvectorP => i; rewrite !mvE eq_ab. Qed.

Lemma scale1m (x : mvector E) : 1%F *:_m x = x.
Proof. by apply/mvectorP=> i; rewrite !(mvE, ffunE) scale1r. Qed.

Lemma scalemA (a b : {ffun I -> k}) (x : mvector E) :
  a *:_m (b *:_m x) = (a * b)%F *:_m x.
Proof. by apply/mvectorP=> i; rewrite !(mvE, ffunE); rewrite scalerA. Qed.

Definition mset (i : I) (x : mvector E) (v : E i) : mvector E :=
  \mvector_(j : I)
    if i =P j is ReflectT eq return E j then
      ecast k (E k) eq v
    else x j.

Notation "x [< i ← v >]" := (@mset i x v)
  (at level 2, left associativity, format "x [< i  ←  v >]").

Lemma msetii (i : I) (x : mvector E) (v : E i) :
  x[< i ← v >] i = v.
Proof. by rewrite mvE; case: eqP => // p; rewrite eq_axiomK. Qed.

Lemma mset_same (i : I) (x : mvector E) v :
  x i = v -> x[< i ← v >] = x.
Proof.
move=> {v}<-; apply/mvectorP=> j; rewrite mvE.
by case: eqP => //; case: j /.
Qed.

Lemma mset_eq (i j : I) (x : mvector E) (v : E i) (p : i = j) :
  x[< i ← v >] j = ecast z (E z) p v.
Proof.
rewrite mvE; case: eqP => //; case: _ / p => p.
by rewrite eq_axiomK.
Qed.

Lemma mset_ne (i j : I) (x : mvector E) (v : E i) :
  i != j -> x[< i ← v >] j = x j.
Proof.
move=> ne_ij; rewrite mvE; case: eqP=> // p.
by apply/contraNeq: ne_ij => _; apply/eqP.
Qed.

Notation "x +_ i v" := (x + 0[< i ← v >])
  (at level 60, i at level 2, format "x  +_ i  v").

Lemma addi0 x i : x +_i 0 = x.
Proof. by rewrite mset_same ?mvE // addr0. Qed.

Lemma addiE_ne (x : mvector E) i (v : E i) j : i <> j -> (x +_i v) j = x j.
Proof.
by move=> ne_ij; rewrite !mvE; case: eqP ne_ij => // _ _; rewrite addr0.
Qed.

Lemma addiE_eq (x : mvector E) i (v : E i) : (x +_i v) i = x i + v.
Proof. by rewrite !mvE; case: eqP => // p; rewrite eq_axiomK. Qed.

Definition mxlinear {G} (c : {rmorphism k -> k}) (f : mvector E -> G) :=
  forall i a x v, f (a *:_i x +_i v) = (c a) *: f x + f (x[<i ← v>]).

Definition mlinear {G} (f : mvector E -> G) :=
  @mxlinear G [rmorphism of idfun] f.

Lemma eq_mxlinear {G} (c : {rmorphism k -> k}) (f g : mvector E -> G) :
  f =1 g -> mxlinear c f -> mxlinear c g.
Proof. by move=> eq_fg lin_f i a x v; rewrite -!eq_fg; apply: lin_f. Qed.

Lemma mxlinear0 {G} c (f : _ -> G) (x : mvector E) :
  mxlinear c f -> (exists i, x i = 0) -> f x = 0.
Proof.
move=> + [i xi_eq0] => /(_ i 1 x 0); rewrite rmorph1 scale1r.
rewrite addi0 mset_same // scale1i => /eqP.
by rewrite -subr_eq subrr => /eqP <-.
Qed.

Lemma mlinear0 {G} (f : _ -> G) (x : mvector E) :
  mlinear f -> (exists i, x i = 0) -> f x = 0.
Proof. by apply: mxlinear0. Qed.

Lemma mxlinearZ {G} c (f : _ -> G) i a (x : mvector E) :
  mxlinear c f -> f (a *:_i x) = c a *: f x.
Proof.
move=> /[dup] lin_f /(_ i a x 0); rewrite addi0.
rewrite [X in _+X](mxlinear0 lin_f) ?addr0 //.
by exists i; rewrite msetii.
Qed.

Lemma mlinearZ {G} (f : _ -> G) i a (x : mvector E) :
  mlinear f -> f (a *:_i x) = a *: f x.
Proof. by apply: mxlinearZ. Qed.

Lemma mxlinearD {G} c (f : _ -> G) i (x : mvector E) (v : E i) :
  mxlinear c f -> f (x +_i v) = f x + f x[<i ← v>].
Proof. by move=> /(_ i 1 x v); rewrite rmorph1 scale1i scale1r. Qed.

Lemma mlinearD {G} (f : _ -> G) i (x : mvector E) (v : E i) :
  mlinear f -> f (x +_i v) = f x + f x[<i ← v>].
Proof. apply: mxlinearD. Qed.

Lemma mxlinear_sum
    {G} c a (x : forall {i : I}, 'I_(a i) -> E i) (f : _ -> G)
  : mxlinear c f -> f (\mvector_(i : I) \sum_(j < a i) x j) =
      \sum_(b : mvector (fun i : I => 'I_(a i))) f (\mvector_(i : I) x (b i)).
Proof.
move=> lin_f; pose w (a : I -> nat) := (\sum_i a i)%N.
have h0 (a' : I -> nat) (x' : forall i : I, 'I_(a' i) -> E i) :
     (forall i, (a' i <= 1)%N)
  -> f (\mvector_(i : I) \sum_(j < a' i) x' _ j) =
       \sum_(b : mvector (fun i : I => 'I_(a' i))) f (\mvector_(i : I) x' _ (b i)).
- move=> le1; case/boolP: [forall i, a' i == 1%N]; last first.
  - rewrite negb_forall => /existsP[] i neq1_a'i; move: (le1 i).
    rewrite leq_eqVlt (negbTE neq1_a'i) /= ltnS leqn0 => /eqP z_a'i.
    rewrite (mxlinear0 lin_f); first exists i.
    - by rewrite mvE big_pred0 //; case=> ?; rewrite z_a'i.
    rewrite big1 //= => b _; absurd false => //.
    by case: (b i)=> ?; rewrite z_a'i.
  - move/forallP=> eq1_a'; have gt0_a' i: (0 < a' i)%N.
    - by rewrite (eqP (eq1_a' _)).
    rewrite [X in f X = _](_ : _ = \mvector_(i : I) x' i (Ordinal (gt0_a' i))).
    - apply/mvectorP=> i; rewrite !mvE (big_pred1 (Ordinal (gt0_a' i))) //.
      case=> m lt; apply/esym/eqP/val_inj => /=.
      by move: lt; rewrite (eqP (eq1_a' _)); rewrite ltnS leqn0 => /eqP.
    pose b0 := \mvector_(i : I) (Ordinal (gt0_a' i)).
    rewrite (big_pred1 b0); last first.
    - by congr (f _); apply/mvectorP=> i; rewrite !mvE.
    case=> b; apply/esym/eqP/mvectorP=> i; apply/val_inj => /=.
    rewrite /b0 mvE /= /fun_of_mvector /=; case: (b i) => m /=.
    by rewrite (eqP (eq1_a' _)) ltnS leqn0 => /eqP.
move: {2}(w a) (leqnn (w a)) x => n; elim: n a => [|n ih] a.
- rewrite leqn0 => /eqP z_wa m; apply: h0.
  move=> i; move/eqP: z_wa; rewrite /w sum_nat_eq0.
  by move/'forall_implyP => /(_ i (erefl true)) /eqP ->.
case/boolP: [forall i, (a i <= 1)%N].
- by move/forallP=> ? _ ?; apply: h0.
rewrite negb_forall => /existsP[] i0; rewrite -ltnNge => gt1_ai0.
have gt0_ai0: (0 < a i0)%N by apply: (@leq_ltn_trans 1%N).
pose a' (i : I) := if i == i0 then (a i0).-1 else a i.
move=> bd_wa; have bd_wa': (w a' <= n)%N.
- rewrite /w (bigD1 i0) //= (eq_bigr a).
  - by move=> i ne_i_i0; rewrite /a' (negbTE ne_i_i0).
  rewrite /a' eqxx; rewrite -(leq_add2r 1%N) !addn1 -addSn.
  rewrite (ltn_predK gt0_ai0) -(bigD1 _ (P := predT)) //=.
move=> m; set v := (X in f X).
have le_a'_a i : (a' i <= a i)%N.
- by rewrite /a'; case: eqP => // <-; rewrite leq_pred.
have [mx mxval]: exists mx : 'I_(a i0), val mx = (a i0).-1.
- by case: (a i0) gt0_ai0 => //= i0' _; exists ord_max.
have ->: v =
  \mvector_ (i : I) (\sum_(j < a' i) m i (widen_ord (le_a'_a i) j))
    +_i0 m i0 mx.
- apply/mvectorP => i; case: (i =P i0) => [->|]; last first.
  - move=> ne_i_i0; rewrite addiE_ne; first by move/esym.
    rewrite !mvE -(big_ord_narrow_cond (P := predT)) /=.
    rewrite [RHS]big_mkcond /=; apply: eq_bigr.
    move=> i' _; rewrite /a'; case: eqP=> // _.
    by rewrite ltn_ord.
  - rewrite addiE_eq !mvE; have hle: ((a' i0).+1 <= a i0)%N.
    - by rewrite /a' eqxx prednK.
    transitivity (\sum_(j < (a' i0).+1) m i0 (widen_ord hle j)).
    - rewrite -(big_ord_narrow_cond (P := predT)) /=.
      rewrite [RHS]big_mkcond /=; apply: eq_bigr.
      by move=> i' _; rewrite /a' eqxx prednK // ltn_ord.
    rewrite big_ord_recr /=; congr (_ + _).
    - by apply: eq_bigr=> i' _; congr (m _ _); apply: val_inj.
    - by congr (m _ _); apply: val_inj => /=; rewrite mxval /a' eqxx.
rewrite (mxlinearD _ _ lin_f) ih //; apply/esym.
pose P (b : mvector (fun i : I => 'I_(a i))) := b i0 == mx.
rewrite (bigID P) /= addrC; congr (_ + _).
- pose h (b : mvector (fun i => 'I_(a' i))) : mvector (fun i => 'I_(a i)) :=
    \mvector_(i : I) (widen_ord (le_a'_a i) (b i)).
  rewrite (reindex h) /=; last first.
  - apply: congr_big => //.
    - move=> b; apply/negP; rewrite /P /h mvE => /eqP /(congr1 val) /=.
      rewrite mxval; case: (b i0) => /= ?.
      by rewrite /a' eqxx => /[swap] ->; rewrite ltnn.
    - by move=> b PNhi; congr (f _); apply/mvectorP=> i; rewrite !mvE.
  have eq: forall i, i0 <> i -> a i = a' i.
  - by move=> i /eqP ne; rewrite /a' eq_sym (negbTE ne).
  have hsplit: (a i0 = a' i0 + 1)%N.
  - by rewrite /a' eqxx addn1 (ltn_predK gt0_ai0).
  have gt0_a'i0: (0 < a' i0)%N.
  - by rewrite /a' eqxx -ltnS (ltn_predK gt0_ai0).
  pose hI (b : mvector (fun i => 'I_(a i))) : mvector (fun i => 'I_(a' i)) :=
    \mvector_(i : I) (
      match i0 =P i with
      | ReflectT heq =>
          match split (cast_ord hsplit (b i0)) with
          | inl v => cast_ord (f_equal a' heq) v : 'I_(a' i)
          | inr _ => cast_ord (f_equal a' heq) (Ordinal gt0_a'i0) : 'I_(a' i)
          end
      | ReflectF hne =>
          cast_ord (eq _ hne) (b i) : 'I_(a' i)
      end
    ).
  exists hI=> b; rewrite !inE.
  - move=> PNhb; apply/mvectorP=> i; move: PNhb.
    rewrite !mvE /P /h /hI; case: eqP=> //; last first.
    - by move=> ? _; apply/val_inj.
    move=> p; rewrite mvE -val_eqE /= => ne_bi0_mx.
    case: splitP; last first.
    - move=> k0 /= bi0E; apply/val_inj => /=.
      absurd false => //; apply/contra_neqT: ne_bi0_mx => _.
      by rewrite bi0E ord1 addn0 /a' eqxx -mxval.
    - move=> j /esym /= jE; apply/val_inj => /=.
      by rewrite jE; case: _ / p.
  - move=> PNb; apply/mvectorP=> i; move: PNb.
    rewrite !mvE /P /h /hI; case: eqP=> //; last first.
    - by move=> ? _; apply/val_inj.
    move=> p ne_bi0_mx; case: splitP; last first.
    - move=> k0 /= bi0E; apply/val_inj => /=.
      absurd false => //; apply/contra_neqT: ne_bi0_mx => _.
      apply/val_inj=> /=; rewrite bi0E ord1 addn0.
      by rewrite /a' eqxx -mxval.
    move=> j /= jE; apply/val_inj => /=.
    by rewrite -jE; case: _ / p.
- pose a1 (i : I) := if i == i0 then 1%N else a i.
  have le_a1_a i : (a1 i <= a i)%N.
  - by rewrite /a1; case: eqP => // ->.
  pose F (i : I) (j : 'I_(a1 i)) :=
    if i0 =P i is ReflectT heq then
      ecast z (E z) heq (m i0 mx)
    else m i (widen_ord (le_a1_a i) j).
  rewrite [X in f X](_ : _ = \mvector_(i : I) \sum_(j < a1 i) (F i j)).
  - apply/mvectorP=> i; rewrite [RHS]mvE /F.
    case: eqP=> // [eq_i0_i|/eqP ne_i0_i].
    - rewrite mset_eq; have lt: (0 < a1 i)%N by rewrite /a1 eq_i0_i eqxx.
      rewrite (big_pred1 (Ordinal lt)) //; case=> l /= lt'.
      apply/esym/eqP/val_inj=> /=; move: lt'.
      by rewrite /a1 eq_i0_i eqxx ltnS leqn0 => /eqP.
    - rewrite mset_ne ?mvE //.
      rewrite -[LHS](big_ord_narrow_cond (P := predT)) /=.
      rewrite -[RHS](big_ord_narrow_cond (P := predT)) /=.
      rewrite [LHS]big_mkcond [RHS]big_mkcond //=.
      apply: eq_bigr=> i1 _; rewrite /a' /a1.
      by rewrite [i == _]eq_sym (negbTE ne_i0_i).
  rewrite ih; first apply: (leq_trans _ bd_wa').
  - rewrite /w; apply: leq_sum => i _; rewrite /a1 /a'.
    case: eqP => // _; rewrite -ltnS (ltn_predK gt0_ai0) //.
  have eq: forall i, i0 <> i -> a1 i = a i.
  - by move=> i /eqP ne; rewrite /a1 eq_sym (negbTE ne).
  pose h (b : mvector (fun i => 'I_(a1 i))) : mvector (fun i => 'I_(a i)) :=
    \mvector_(i : I) (
        match i0 =P i with
        | ReflectT heq => cast_ord (f_equal a heq) mx : 'I_(a i)
        | ReflectF hne => cast_ord (eq i hne) (b i)
        end
    ).
  rewrite (reindex h) /=; last first.
  - apply/congr_big => //.
    - move=> b; rewrite /P /h mvE ; case: eqP=> // p.
      by rewrite cast_ord_id eqxx.
    - move=> b Phb; congr (f _); apply/mvectorP => i.
      rewrite !mvE /F; case: eqP=> // p.
      - by case: _  / p; rewrite cast_ord_id.
      - by congr (m _ _); apply/val_inj => /=.
  have gt0: (0 < a1 i0)%N by rewrite /a1 eqxx.
  pose hI (b : mvector (fun i => 'I_(a i))) : mvector (fun i => 'I_(a1 i)) :=
    \mvector_(i : I) (
        match i0 =P i with
        | ReflectT heq => cast_ord (f_equal a1 heq) (Ordinal gt0) : 'I_(a1 i)
        | ReflectF hne => cast_ord (esym (eq i hne)) (b i)
        end
    ).
  exists hI=> b; rewrite !inE.
  - move=> Phb; apply/mvectorP=> i; move: Phb.
    rewrite /P /h /hI; rewrite !mvE. case: eqP => // _ _.
    case: eqP => p; apply/val_inj => //=; rewrite -p.
    by case: (b i0)=> /= ?; rewrite /a1 eqxx ltnS leqn0 => /eqP.
  - move=> Pb; apply/mvectorP=> i; move: Pb.
    rewrite /P /h /hI; rewrite !mvE; case: eqP => // p.
    - by move/eqP=> <-; apply/val_inj => /=; rewrite p.
    - by move=> _; apply/val_inj.
Qed.

Lemma mlinear_sum
    {G} a (x : forall {i : I}, 'I_(a i) -> E i) (f : _ -> G)
  : mlinear f -> f (\mvector_(i : I) \sum_(j < a i) x j) =
      \sum_(b : mvector (fun i : I => 'I_(a i))) f (\mvector_(i : I) x (b i)).
Proof. by apply: mxlinear_sum. Qed.

Lemma injectZi (i : I) (a : k) (x : mvector E) : ⊗(a *:_i x) = a *: ⊗x.
Proof.
rewrite /inject -linearZ /=; apply f_equal; apply/matrixP=>m n.
rewrite !mxE !(bigD1 i (P := predT)) //= mulrA. congr (_ * _).
by rewrite mvE eqxx linearZ mxE.
by apply: eq_bigr=> j ne_ji; rewrite mvE eq_sym (negbTE ne_ji) scale1r.
Qed.

Lemma injectDi (i : I) (x : mvector E) (v : E i) :
  ⊗ (x +_i v) = ⊗ x + ⊗ (x[<i ← v>]).
Proof.
rewrite /inject -linearD /=; apply f_equal; apply/matrixP=>m n.
rewrite !mxE !(bigD1 i (P := predT)) //=.
rewrite !(msetii, mvE) linearD /= mxE mulrDl; congr (_ * _ + _ * _);
  by apply/eq_bigr=> j ne_ji; rewrite !(mset_ne, mvE) 1?eq_sym // addr0.
Qed.

Lemma inject_is_mlinear : mlinear inject.
Proof.
move=> i a x v /=; rewrite injectDi injectZi; congr (_ + ⊗_).
by apply/mvectorP=> j; rewrite !mvE; case: eqP => //; rewrite scale1r.
Qed.

Lemma inject_eq0P (x : mvector E) :
  reflect (exists i, x i = 0) (⊗x == 0).
Proof.
apply: (iffP eqP) => eq0; last first.
- by apply: mlinear0 => //; apply/inject_is_mlinear.
apply/'exists_eqP; apply/contra_eqT: eq0 => eq0.
have {}eq0: forall i, exists j, v2r (x i) 0 j != 0.
- move=> i; apply/existsP; rewrite -negb_forall.
  apply/contra: eq0 => /forallP /= eq0; apply/existsP.
  exists i; apply/eqP/v2r_inj; rewrite linear0.
  by apply/rowP=> j; rewrite mxE; apply/eqP/eq0.
pose e := \mvector_(i : I) (xchoose (eq0 i)).
rewrite /inject (can2_eq r2vK v2rK) linear0.
apply/eqP => /matrixP /(_ 0 (i2n e)) => /eqP; apply/negP.
rewrite !mxE i2nK; apply/prodf_neq0 => i _.
by rewrite mvE; apply/(xchooseP (eq0 i)).
Qed.

Lemma mxlinearZm {G} c (f : _ -> G) a x :
  mxlinear c f -> f (a *:_m x) = c (\prod_i a i) *: (f x).
Proof.
have: a =1 (\prod_(i : I) [ffun j => (if i == j then a i else 1)%R])%F.
- move=> i; rewrite ffunE (bigD1 i) //= !ffunE eqxx big1 ?mulr1 //=.
  by move=> j ne_ji; rewrite ffunE (negbTE ne_ji).
move=> eqa lin_f; rewrite (scalem_eq _ eqa).
elim/big_rec2: _ => [|i d b _ ih].
- by rewrite rmorph1 scale1r scale1m.
- by rewrite rmorphM -scalemA scalem1E (mxlinearZ _ _ _ lin_f) // ih scalerA.
Qed.

Lemma mlinearZm {G} (f : _ -> G) a x :
  mlinear f -> f (a *:_m x) = (\prod_i a i) *: (f x).
Proof. by apply: mxlinearZm. Qed.
End TensorProducts.

(* -------------------------------------------------------------------- *)
Local Notation "'⊗' x" := (inject x) (at level 2, format "⊗ x").

Notation "a *:_ i x" := (scalei i a x)
  (at level 50, i at level 2, format "a  *:_ i  x").

Notation "a *:_m x" := (scalem a x)
  (at level 50, format "a  *:_m  x").

Notation "x [< i ← v >]" := (mset (i := i) x v)
  (at level 2, left associativity, format "x [< i  ←  v >]").

Notation "x +_ i v" := (x + 0[< i ← v >])
  (at level 60, i at level 2, format "x  +_ i  v").

Section Lift.
Context {I : finType} {J : I -> finType} {k : fieldType}.
Context
  (c : {ffun I -> {rmorphism k -> k}}) (* twist on i-th argument *)
  (E : forall i : I, J i -> vectType k)(* tensor product for i-th argument *)
  (F : vectType k).                    (* codomain *)

Let B i := mvector (fun j : J i => 'I_(Vector.dim (@E i j))).
Let T i := {ffun (B i) -> k^o}.

Context (f : {ffun forall i : I, mvector (@E i)} -> F).

Hypothesis lin_f :
  forall (i : I) (m : {ffun forall i : I, mvector (@E i)}),
    mxlinear (c i) (fun x => f m.[i <- x]).

Definition lift_r (x : forall (i : I), T i) (b : forall (i : I), B i) :=
  (\prod_(i : I) c i (v2r (x i) 0 (i2n (b i))))
    *: (f [ffun i => \mvector_(j : J i) r2v (delta_mx 0 (b i j))]).

Definition lift (x : forall (i : I), T i) : F :=
  \sum_(b : {dffun forall i : I, B i}) lift_r x b.

Lemma setW (K : finType) (P : {set K} -> Prop) :
     P set0
  -> (forall (s : {set K}) (k : K), k \notin s -> P s -> P (k |: s))
  -> forall s, P s.
Proof.
move=> P0 PS s; move: {2} #|s| (erefl #|s|) => n; elim: n s.
- by move=> s; rewrite (rwP eqP) cards_eq0 => /eqP->.
move=> n ih s cds; have: (0 < #|s|)%N by rewrite cds.
case/card_gt0P=> x /[dup] x_in_s /setD1K <-; apply: PS.
- by rewrite in_setD1 eqxx.
apply: ih; move: cds; rewrite (cardsD1 x).
by rewrite x_in_s /= add1n => -[].
Qed.

Lemma mlinearZms a (x : {ffun forall i : I, mvector (@E i)}) :
  f [ffun i => a i *:_m x i] =
    \prod_(i : I) c i (\prod_(j : J i) a i j) *: f x.
Proof.
pose b (S : {set I}) i := if i \in S then a i else [ffun=> 1].
rewrite [X in f X = _](_ : _ = [ffun i => b [set: I] i *:_m x i]).
- by apply/ffunP=> i; rewrite !ffunE /b in_setT.
rewrite (eq_bigl (fun x => x \in [set: I])) /= => [i|].
- by rewrite in_setT.
elim/setW: [set: I] => [|s i i_notin_s ih].
- rewrite big_set0 scale1r; congr (f _); apply/ffunP.
  by move=> i; rewrite !ffunE /b in_set0 scale1m.
rewrite big_setU1 //= -scalerA -ih; set y := (X in f X = _).
have {y}->: y = [ffun j => b s j *:_m x j].[i <- a i *:_m x i].
- apply/ffunP=> j; case: (i =P j) => [ <-|/eqP ne_ij].
  - by rewrite !ffunE /b in_setU1 eqxx.
  by rewrite ffset_neq // !ffunE /b in_setU1 eq_sym (negbTE ne_ij).
rewrite (mxlinearZm _ _ (@lin_f i _)); congr (_ *: f _).
apply/ffunP=> j; case: (i =P j) => [ <-|/eqP ne_ij].
- by rewrite !ffunE /b (negbTE i_notin_s) scale1m.
- by rewrite ffset_neq.
Qed.

Lemma xliftE (x : {ffun forall i : I, mvector (@E i)}) :
  lift [ffun i => ⊗(x i)] = f x.
Proof.
pose a (b : forall i, B i) i j := v2r (x i j) 0 (b i j).
have fE b: lift_r [ffun i => ⊗(x i)] b =
  f [ffun i => \mvector_(j : J i) (a b i j *: r2v (delta_mx 0 (b i j)))].
- rewrite /lift_r (eq_bigr (fun i => c i (\prod_(j : J i) (v2r (x i j) 0 (b i j))))).
  - by move=> i _; rewrite ffunE inject_cpnt.
  rewrite -mlinearZms; congr (f _); apply/ffunP=> i.
  by rewrite !ffunE; apply/mvectorP=> j; rewrite !mvE.
rewrite /lift {fE}(eq_bigr _ (fun (b : {ffun forall i, B i}) _ => fE b)).
pose P (m : forall i, option (B i)) (b : {ffun forall i, B i}) :=
  [forall i : I, if m i is Some v then b i == v else true].
pose y (m : forall i, option (B i)) :=
  [ffun i : I => if m i is Some b then
       \mvector_(j : J i) (v2r (x i j) 0 (b j) *: r2v (delta_mx 0 (b j)))
     else x i].
pose supp (p : {ffun forall i : I, option (B i)}) := [set i | p i != None].
pose p0 := [ffun i : I => (None : option (B i))].
rewrite (eq_bigl (P p0)).
- by move=> b; apply/esym/forallP => i; rewrite ffunE.
rewrite [in RHS](_ : x = y p0).
- by apply/ffunP=> i; rewrite !ffunE.
have: supp p0 = setT :\: setT.
- by apply/setP=> i; rewrite !(inE, ffunE).
elim/setW: {2}[set: I] p0 => [|s i i_notin_s ih] p0.
- rewrite setD0 => /setP supp_p0.
   have h i: exists v : B i, p0 i == Some v.
  - move/(_ i): supp_p0; rewrite !inE; case: (p0 i) => //.
    by move=> v _; exists v.
  pose b : {dffun forall i : I, B i} := [ffun i => xchoose (h i)].
  have p0iE i: p0 i = Some (b i).
  - case p0iE: (p0 i) => [v|].
    - by rewrite /b ffunE -(eqP (xchooseP (h i))) p0iE.
    - by move/(_ i): supp_p0; rewrite !inE p0iE.
  rewrite (big_pred1 b) => /= [zc|].
  - rewrite /P -(@eq_forallb _ (fun i => zc i == b i)).
    - by move=> i /=; rewrite p0iE.
    by rewrite inE; apply/'forall_eqP/eqP=> [/ffunP|->].
  congr (f _); apply/ffunP=> i; rewrite !ffunE.
  rewrite [in RHS]p0iE; apply/mvectorP=> j; rewrite !mvE.
  by congr (_ *: _); rewrite !ffunE.
move=> p0E; pose R (b : {dffun forall i, B i}) := b i.
rewrite (partition_big R predT) {}/R //=.
pose q0 j := p0.[i <- Some j].
have q0s j: supp (q0 j) = [set: I] :\: s.
- apply/setP=> i'; rewrite [in LHS]inE.
  case: (i =P i') => [ <-|/eqP ne_ii'].
  - by rewrite ffset_eq !inE i_notin_s.
  rewrite ffset_neq //; move/setP/(_ i'): p0E.
  by rewrite !inE [i' == i]eq_sym (negbTE ne_ii') andbT.
have ->: f (y p0) = \sum_j f (y (q0 j)).
- have h (b : B i): y (q0 b) = (y p0).[i <-
    \mvector_ (j : J i) (v2r (x i j) 0 (b j) *: r2v (delta_mx 0 (b j)))].
  - apply/ffunP=> i'; case: (i =P i') => [ <-|/eqP ne_ii'].
    - by rewrite !ffunE.
    - by rewrite ffset_neq // ffunE ffset_neq // !ffunE.
  rewrite (eq_bigr _ (fun (b : B i) _ => congr1 f (h b))).
  pose z j b := v2r (x i j) 0 b *: r2v (delta_mx 0 b).
  rewrite -(mxlinear_sum z (@lin_f i (y p0))); congr (f _).
  apply/ffunP=> i'; case: (i =P i') => [ <-|/eqP ne_ii'];
    last by rewrite ffset_neq.
  rewrite ffset_eq; move/setP/(_ i): p0E.
  rewrite ffunE !inE eqxx /= => /negbFE /eqP ->.
  apply/mvectorP=> j; rewrite mvE; apply/v2r_inj.
  apply/rowP=> /= b; rewrite linear_sum summxE (bigD1 b) //= big1.
  - move=> l ne_lj; rewrite linearZ mxE /= r2vK mxE.
  by rewrite [b == l]eq_sym (negbTE ne_lj) andbF mulr0.
  - by rewrite linearZ mxE /= r2vK mxE !eqxx andbT mulr1 addr0.
apply: eq_bigr=> j _; rewrite -ih //; apply: eq_bigl.
- move=> b; apply/idP/idP.
  - case/andP=> h /eqP biE; apply/forallP => i'.
    case: (i =P i') => [ <-|/eqP ne_ii'].
    - by rewrite ffset_eq biE.
    by rewrite ffset_neq //; move/forallP/(_ i'): h.
move/forallP=> /[dup] /(_ i); rewrite ffset_eq andbC => -> /=.
move=> h; apply/forallP => i'; case: (i =P i') => [ <-|/eqP ne_ii'].
- by move/setP/(_ i): p0E; rewrite !inE eqxx andbT /= => /negbFE /eqP->.
- by move/(_ i'): h; rewrite ffset_neq.
Qed.

Lemma xlinear_lift  i a m (x y : {ffun B i -> k^o}) :
  lift m.[i <- a *: x + y] = (c i a) *: lift m.[i <- x] + lift m.[i <- y].
Proof.
rewrite /lift; rewrite scaler_sumr -big_split /=.
apply: eq_bigr=> /= b _; rewrite /lift_r /=.
set m' := (X in f X); have lf := @lin_f i m'.
rewrite scalerA -scalerDl !(bigD1 (P := predT) i) //=.
pose X := \prod_(i' | i' != i) c i' (v2r (m i') 0 (i2n (b i'))).
have h z: \prod_(i' | i' != i) c i' (v2r (m.[i <- z] i') 0 (i2n (b i'))) = X.
- by apply: eq_bigr=> i' ne_i'i; rewrite ffset_neq // eq_sym.
rewrite !{}h ![_ * X]mulrC mulrCA -mulrDr -!scalerA; congr (_ *: _).
by rewrite !ffset_eq linearP /= !mxE rmorphD rmorphM.
Qed.
End Lift.

(* -------------------------------------------------------------------- *)
Section BiSemiLinear.
Context {I : finType} {k : fieldType}.
Context (c1 c2 : {rmorphism k -> k}) (E : I -> vectType k).
Context (F : vectType k).

Let B := mvector (fun i : I => 'I_(Vector.dim (E i))).
Let T := {ffun B -> k^o}.

Context (f : mvector E -> mvector E -> F).

Hypothesis (lin1_f : forall y, mxlinear c1 (f^~ y)).
Hypothesis (lin2_f : forall x, mxlinear c2 (f   x)).

Let cT : {ffun bool -> {rmorphism k -> k}} :=
  [ffun b => if b then c1 else c2].

Let aT {T : Type} (x y : T) : {ffun bool -> T} :=
  [ffun b => if b then x else y].

Let fT (x : {ffun bool -> mvector E}) :=
  f (x true) (x false).

Definition lift2 (x y : T) : F := lift cT fT (aT x y).

Lemma mxlinear2 b m : mxlinear (cT b) (fun v => fT m.[b <- v]).
Proof.
case: b => /=; rewrite !ffunE => i.
- apply/(eq_mxlinear (f := f^~ (m false)))/lin1_f.
  by move=> b; rewrite /fT ffset_eq ffset_neq.
- apply/(eq_mxlinear (f := f (m true)))/lin2_f.
  by move=> b; rewrite /fT ffset_eq ffset_neq.
Qed.

Lemma xlift2E (x y : mvector E) : lift2 ⊗x ⊗y = f x y.
Proof.
rewrite /lift2; have ->: aT ⊗x ⊗y = [ffun b => ⊗(aT x y b)].
- by apply/ffunP; case; rewrite !ffunE.
by rewrite xliftE /=; [apply: mxlinear2 | rewrite /fT !ffunE].
Qed.

Lemma xlift2_mxlinear1 a (x1 x2 y : T) :
  lift2 (a *: x1 + x2) y = c1 a *: lift2 x1 y + lift2 x2 y.
Proof.
have h x: lift2 x y = lift cT fT [ffun=> y].[true <- x].
- congr (lift _ _ (fun_of_fin _)); apply/ffunP=> /=.
  move=> b; rewrite ffunE; case: b.
  - by rewrite ffset_eq. - by rewrite ffset_neq // ffunE.
by rewrite h xlinear_lift /=; [apply: mxlinear2 | rewrite -!h ffunE].
Qed.

Lemma xlift2_mxlinear2 a (x y1 y2 : T) :
  lift2 x (a *: y1 + y2) = c2 a *: lift2 x y1 + lift2 x y2.
Proof.
have h y: lift2 x y = lift cT fT [ffun=> x].[false <- y].
- congr (lift _ _ (fun_of_fin _)); apply/ffunP=> /=.
  move=> b; rewrite ffunE; case: b.
  - by rewrite ffset_neq // ffunE. - by rewrite ffset_eq.
by rewrite h xlinear_lift /=; [apply: mxlinear2 | rewrite -!h ffunE].
Qed.
End BiSemiLinear.

(* -------------------------------------------------------------------- *)
Section SesqLinear.
Context {I : finType} (E : I -> vectType C) (F : vectType C).

Context (f : mvector E -> mvector E -> F).

Let B := mvector (fun i : I => 'I_(Vector.dim (E i))).
Let T := {ffun B -> C^o}.

Hypothesis (lin1_f : forall y, mxlinear conjC (f^~ y)).
Hypothesis (lin2_f : forall x, mlinear (f x)).

Definition lifts (x y : T) : F :=
  lift2 conjC [rmorphism of idfun] f x y.

Lemma xliftsE (x y : mvector E) : lifts ⊗x ⊗y = f x y.
Proof. by apply: xlift2E. Qed.

Lemma xlifts_alinear a (x1 x2 y : T) :
  lifts (a *: x1 + x2) y = a^* *: (lifts x1 y) + lifts x2 y.
Proof. by apply: xlift2_mxlinear1. Qed.

Lemma xlifts_linear (x : T) : linear (lifts x).
Proof. by move=> a y1 y2; apply: xlift2_mxlinear2. Qed.
End SesqLinear.

(* -------------------------------------------------------------------- *)
Section Linear.
Context {I : finType} {k : fieldType}.
Context (E : I -> vectType k) (F : vectType k).

Context (f : mvector E -> F).

Let B := mvector (fun i : I => 'I_(Vector.dim (E i))).
Let T := {ffun B -> k^o}.

Hypothesis (lin_f : mlinear f).

Let cT : {ffun unit -> {rmorphism k -> k}} :=
  [ffun=> [rmorphism of idfun]].

Let aT {T : Type} (x : T) : {ffun unit -> T} :=
  [ffun=> x].

Let fT (x : {ffun unit -> mvector E}) :=
  f (x tt).

Definition lift1 (x : T) : F :=
  lift cT fT (aT x).

Lemma mxlinear1 b m : mxlinear (cT b) (fun v => fT m.[b <- v]).
Proof.
case: b; rewrite !ffunE /=.
apply/(eq_mxlinear (f := f))/lin_f.
by move=> b; rewrite /fT ffset_eq.
Qed.

Lemma xlift1E (x : mvector E) : lift1 ⊗x = f x.
Proof.
rewrite /lift1; have ->: aT ⊗x = [ffun b=> ⊗(aT x b)].
- by apply/ffunP; case; rewrite !ffunE.
by rewrite xliftE /=; [apply: mxlinear1 | rewrite /fT !ffunE].
Qed.

Lemma xlift1_linear : linear lift1.
Proof.
move=> /= a u v; have h x: lift1 x = lift cT fT [ffun=> 0].[tt <- x].
- by congr (lift _ _ (fun_of_fin _)); apply/ffunP=> /= -[]; rewrite !ffunE.
by rewrite h xlinear_lift /=; [apply: mxlinear1 | rewrite -!h ffunE].
Qed.
End Linear.

(* -------------------------------------------------------------------- *)
Section HermitianTensorProducts.
Context {I : finType} (E : I -> hermitianType).

Let B := mvector (fun i => 'I_(Vector.dim (E i))).
Let T := {ffun B -> C^o}.

Definition hdotp (x y : mvector E) : C^o :=
  \prod_(i : I) [< x i; y i >].

Definition tdotp (x y : T) : C :=
  lifts hdotp x y.

Lemma ge0_hdotp (x : mvector E) : 0 <= hdotp x x.
Proof. by apply: prodr_ge0 => i _; apply/ge0_dotp. Qed.

Lemma hdotp_eq0 (x : mvector E) : (hdotp x x == 0) = (⊗x == 0).
Proof.
apply/prodf_eq0/inject_eq0P.
- by case=> i _; rewrite dotp_eq0 => /eqP eq0_xi; exists i.
- by case=> i eq0_xi; exists i => //; rewrite dotp_eq0 -(rwP eqP).
Qed.

Lemma conj_hdotp x y : (hdotp x y)^* = hdotp y x.
Proof. by rewrite rmorph_prod; apply/eq_bigr=> i _; rewrite conj_dotp. Qed.

Lemma linear_hdotp x : mlinear (G := [vectType C of C^o]) (hdotp x).
Proof.
move=> /= i a y z; rewrite {1}/hdotp (bigD1 i) //= !(msetii, mvE).
rewrite eqxx dotpDr dotpZr mulrDl -mulrA; congr (_ *: _ + _).
- rewrite /hdotp [in RHS](bigD1 i) //=; congr (_ * _).
  apply: eq_bigr=> j ne_ji; rewrite mvE mset_ne 1?eq_sym //.
  by rewrite !mvE eq_sym (negbTE ne_ji) scale1r addr0.
- rewrite /hdotp [in RHS](bigD1 i) //= msetii; congr (_ * _).
  apply: eq_bigr=> j ne_ji; rewrite mvE !mset_ne 1?eq_sym //.
  by rewrite !mvE eq_sym (negbTE ne_ji) scale1r addr0.
Qed.

Lemma alinear_hdotp y :
  mxlinear (G := [vectType C of C^o]) conjC (hdotp^~ y).
Proof.
move=> /= i a x1 x2; rewrite -conj_hdotp linear_hdotp /=.
by rewrite linearD /= rmorphM /= !conj_hdotp.
Qed.

Lemma tdotpE (x y : mvector E) :
  tdotp ⊗x ⊗ y = \prod_(i : I) [< x i; y i >].
Proof.
rewrite /tdotp xliftsE //;
  [by apply: alinear_hdotp | by apply: linear_hdotp].
Qed.

Lemma linear_tdotp x : linear_for *%R (tdotp x).
Proof.
by move=>a b c; rewrite /tdotp (xlifts_linear
  alinear_hdotp linear_hdotp) /GRing.scale.
Qed.
Local Canonical tdotp_linear x := Linear (@linear_tdotp x).
Definition tdotpr x := (@tdotp)^~ x.
Lemma linear_tdotpr x : linear_for (conjC \; *%R) (tdotpr x).
Proof.
by move=>a b c; rewrite /tdotpr /tdotp (xlifts_alinear
  alinear_hdotp linear_hdotp) /GRing.scale.
Qed.
Local Canonical tdotpr_linear x := Linear (@linear_tdotpr x).
Local Canonical tdotp_rev := [revop (@tdotpr) of (@tdotp)].
Local Canonical tdotp_is_bilinear := [bilinear of (@tdotp)].

Definition fbasis (b : B) := ⊗ (\mvector_(i : I) (vonbasis {:(E i)})~_
  (cast_ord (esym (dimvf (E i))) (b i))).

Lemma fbasis_ortho (b c : B) :
  tdotp (fbasis b) (fbasis c) = (b == c)%:R.
Proof.
rewrite /fbasis tdotpE. rewrite (eq_bigr (fun i => (b i == c i)%:R)).
move=>i _. rewrite !mvE.
move: (vonbasisP {:(E i)})=>/andP [_ /'forall_'forall_eqP].
rewrite size_tuple=>P. by rewrite !(tnth_nth 0) P (inj_eq (@cast_ord_inj _ _ _)).
case E1: (b == c). move/eqP: E1=>->. rewrite big1// => i _. by rewrite eqxx.
move: (idx_neq E1)=> P2. apply/eqP/prodf_eq0.
destruct P2. exists x=>//. by rewrite H.
Qed.

Definition fbasis_seq :=
    [seq fbasis (n2i i) | i: 'I_(Vector.dim [vectType C of T])].
Lemma fbasis_size : size fbasis_seq == Vector.dim [vectType C of T].
Proof. by rewrite size_map size_enum_ord. Qed.
Definition fbase := nosimpl (Tuple fbasis_size).
Lemma fbasis_seqE (i: 'I_(Vector.dim [vectType C of T])) :
  fbase~_ i = fbasis (n2i i).
Proof.
  rewrite /fbase (tnth_nth 0)/= (nth_map i) ?size_enum_ord //. do 2 f_equal.
  apply ord_inj. destruct i=>/=. by apply nth_enum_ord.
Qed.

Lemma fbasis_basis : basis_of {: [vectType C of T]} fbase.
Proof.
rewrite basisEfree. do 2 ? [apply/andP; split].
apply/freeP=> k H i.
have: tdotp (fbasis (n2i i)) 0 = 0 by rewrite linear0.
rewrite -H linear_sum (bigD1 i)// big1 =>[j /negPf nji|];
rewrite linearZ -tnth_nth/= fbasis_seqE fbasis_ortho (inj_eq (@n2i_inj _ _ E)).
by rewrite eq_sym nji mulr0. by rewrite eqxx addr0 mulr1.
by apply subvf. by rewrite size_tuple dimvf leqnn.
Qed.

Lemma fbasis_dec (x : T) :
  x = \sum_(b:B) coord fbase (i2n b) x *: fbasis b.
Proof.
rewrite (reindex (fun i => n2i i)).
exists (@i2n _ _ E)=> [a _ | a _]; by rewrite ?n2iK ?i2nK.
rewrite [LHS](coord_basis fbasis_basis (memvf x)).
by apply eq_bigr=>i _; rewrite n2iK -tnth_nth fbasis_seqE.
Qed.

Lemma tdotp_sumlr (f g : B -> C) :
  tdotp (\sum_b f b *: fbasis b) (\sum_b g b *: fbasis b)
  = \sum_b (f b)^* * g b.
Proof.
rewrite linear_suml/=. apply eq_bigr=>b _.
rewrite linear_sum/= (bigD1 b)// big1/= =>[j /negPf nji |];
rewrite linearZl linearZr/= fbasis_ortho 1 ?eq_sym ?nji ?mulr0//.
by rewrite eqxx mulr1 addr0.
Qed.

Lemma ge0_tdotp (x : T) : 0 <= tdotp x x.
Proof.
rewrite (fbasis_dec x) tdotp_sumlr. apply sumr_ge0=>i _.
by rewrite mulrC mul_conjC_ge0.
(* by elim/tensorW: x => x; rewrite tdotpE ge0_hdotp.  *)
Qed.

Lemma tdotp_eq0 (x : T) : (tdotp x x == 0) = (x == 0).
Proof.
apply Bool.eq_true_iff_eq; split=>[/eqP | /eqP ->].
rewrite (fbasis_dec x) tdotp_sumlr=> P1.
have P2: forall (b: B), true -> 0 <= (coord fbase (i2n b) x)^*
  * coord fbase (i2n b) x by move=>b _; rewrite mulrC mul_conjC_ge0.
move: (psumr_eq0P P2 P1) =>/=P3; rewrite big1/= ?eqxx// =>i _.
have t : true by []; move/eqP: (P3 i t).
by rewrite mulrC mul_conjC_eq0=>/eqP->; rewrite scale0r.
by rewrite linear0 eqxx.
(* by elim/tensorW: x => x; rewrite tdotpE hdotp_eq0. *)
Qed.

Lemma conj_tdotp (x y : T) : (tdotp x y)^* = tdotp y x.
Proof.
rewrite (fbasis_dec x) (fbasis_dec y) !tdotp_sumlr rmorph_sum.
by under eq_bigr do rewrite rmorphM conjCK mulrC.
(* elim/tensorW: y; elim/tensorW: x => x y.
by rewrite !tdotpE conj_hdotp. *)
Qed.

(* Lemma linear_tdotp x : linear_for *%R (tdotp x).
Proof.
move=> /= a; elim/tensorW=> u; elim/tensorW=> v.
rewrite /tdotp xlifts_linear //;
  [by apply: alinear_hdotp | by apply: linear_hdotp].
Qed. *)

Definition tensor_hermitianMixin :=
  HermitianMixin ge0_tdotp tdotp_eq0 conj_tdotp linear_tdotp.
Canonical tensor_hermitianType := HermitianType tensor_hermitianMixin.

End HermitianTensorProducts.

(* -------------------------------------------------------------------- *)
Section chsTensorProducts.
Context {I : finType} (E : I -> chsType).

Let B := mvector (fun i => 'I_(Vector.dim (E i))).
Let T := {ffun B -> C^o}.

Lemma tensor_chs_is_chs :
  forall i j, [< r2v (delta_mx 0 i) : T; r2v (delta_mx 0 j) : T>] = (i == j)%:R.
Proof.
move=> i j; rewrite -(n2iK i) -(n2iK j) (inj_eq).
apply: i2n_inj. rewrite -!inject_base.
set x := (\mvector_ (k : I) r2v (delta_mx 0 (n2i i k))).
set y := (\mvector_ (k : I) r2v (delta_mx 0 (n2i j k))).
have ->: [< ⊗x; ⊗y >] = \prod_k [< x k; y k>]. by rewrite -tdotpE.
rewrite (eq_bigr (fun k=> (n2i i k == n2i j k)%:R)).
by move=>k _; rewrite !mvE chsE.
case eqij: (n2i i == n2i j).
by move/eqP: eqij=>->; rewrite big1 // => k; rewrite eqxx.
by move: (idx_neq eqij)=>P; destruct P; rewrite (bigD1 x0) //= H mul0r.
Qed.

Lemma tensor_chs_dim_proper : (1 <= (Vector.dim [vectType C of T]))%N.
Proof.
rewrite {1}/Vector.dim /= /Vector.dim /=.
rewrite muln1 card_mv card_dep_ffun foldrE big_map big_enum /=.
apply prodn_gt0=> i. move: (dim_proper (E i)).
by rewrite /Vector.dim /= card_ord.
Qed.

Definition tensor_chsMixin := ChsMixin tensor_chs_is_chs tensor_chs_dim_proper.
Canonical tensor_chsType := ChsType tensor_chsMixin.

End chsTensorProducts.

Section TensorSpaceDim.
Context {I : finType} (E : I -> chsType).

Lemma dim_tensor : (Vector.dim (tensor_chsType E) = \prod_i Vector.dim (E i))%N.
Proof.
rewrite {1}/Vector.dim /= /Vector.dim /=.
rewrite muln1 card_mv card_dep_ffun foldrE big_map big_enum /=.
apply eq_bigr; by move=> i _; rewrite card_ord.
Qed.

End TensorSpaceDim.

Lemma big_sig_cond (T : Type) (idm : T) (op : Monoid.com_law idm)
  (I : finType) (P Q : pred I) (f : I -> T) :
  \big[op/idm]_(i : {x : I | P x} | Q (val i)) f (val i) = \big[op/idm]_(i | P i && Q i) f i.
Proof.
case E: (pred0b P); [move: E=>/pred0P P1 | move: E=>/pred0Pn[x Px]].
rewrite big_seq_cond !big_pred0//= =>x; last by move: (P1 x)=>->.
by destruct x; move: (P1 x); rewrite !inE/=/in_mem/= i.
rewrite (reindex (fun x: {x : I | P x}=> projT1 x));
  last by apply eq_big =>[y|y P2]; destruct y=>//=; rewrite i.
exists (fun t=> match P t =P true with | ReflectT px => exist _ t px
  | ReflectF _ => exist _ x Px end)=>y Py; case: eqP=>P1//.
by destruct y=>/=; move: P1=>/= P1; rewrite (eq_irrelevance i P1).
all: by move: Py; rewrite inE=>/andP[].
Qed.

Lemma big_sig (T : Type) (idm : T) (op : Monoid.com_law idm)
  (I : finType) (P : pred I) (f : I -> T) :
  \big[op/idm]_(i : {x : I | P x}) f (val i) = \big[op/idm]_(i | P i) f i.
Proof.
move: (@big_sig_cond T idm op I P (fun=>true) f)=>->.
by apply eq_bigl=>i; rewrite andbT.
Qed.

Lemma big_sig_set_cond (R : Type) (idm : R) (op : Monoid.com_law idm) (L: finType)
  (P: pred L) (W: {set L}) (F: L -> R) :
  \big[op/idm]_(i : {i:L|i \in W} | P (val i)) F (val i) = \big[op/idm]_(i in W | P i) F i.
Proof. exact: big_sig_cond. Qed.

Lemma big_sig_set (T : Type) (idm : T) (op : Monoid.com_law idm) (L: finType)
  (W: {set L}) (F: L -> T) :
  \big[op/idm]_(i : {i:L|i \in W}) F (val i) = \big[op/idm]_(i in W ) F i.
Proof. exact: big_sig. Qed.

(* -------------------------------------------------------------------- *)
Section FsetTensorSpace.

Local Open Scope lfun_scope.

Context {I : finType} (E : I -> chsType).
Implicit Type (S T : {set I}).
(* idx : index of S   Hs: tensor hermitianType of S *)
(* Let idx S := mvector (fun i : S => 'I_(Vector.dim (E (val i)))). *)
Definition idx S := mvector (fun i : {i : I | i \in S } => 'I_(Vector.dim (E (val i)))).
Definition Hf S  := (fun i : {i : I | i \in S } => E (val i)).
Definition Hs S  := tensor_chsType (@Hf S).

Lemma eb_mv S i : eb i = ⊗ \mvector_(j : {i : I | i \in S }) eb ((n2i i : idx S) j).
Proof. by rewrite /eb inject_baseV /n2i. Qed.

(* instead of using ordinal number as index, following allows to use idx directly *)
Definition deltav S (i : idx S) := eb (i2n i).
Lemma tcbase S (i j : idx S) : [< deltav i ; deltav j >] = (i == j)%:R.
Proof. by rewrite /deltav cbase; rewrite inj_eq //; apply: i2n_inj. Qed.

Lemma normdv1 S (i : idx S) : `|deltav i| = 1.
Proof. by rewrite hnormE tcbase eqxx sqrtC1. Qed.

Lemma decdv S (u: Hs S) : u = \sum_i [< deltav i ; u >] *: deltav i.
Proof.
rewrite -intro_ebl =>i; rewrite dotp_sumr (bigD1 (n2i i)) //= big1.
move=> j /negPf nji; rewrite dotpZr /deltav cbase eq_sym.
by rewrite (can2_eq (@i2nK _ _ _) (@n2iK _ _ _)) nji mulr0.
by rewrite dotpZr /deltav !n2iK cbase eqxx mulr1 addr0.
Qed.

Lemma conjvdv S (i : idx S) : (deltav i)^*v = deltav i.
Proof. by rewrite /deltav conjveb. Qed.

Definition cdv S (i: idx S) (u: Hs S) := [< deltav i; u >].
Lemma cdvE S (i: idx S) (u: Hs S) : cdv i u = [< deltav i; u >].
Proof. by []. Qed.

Lemma cdv_is_linear S (i: idx S) : scalar (cdv i).
Proof. by move=>a u v; rewrite /cdv linearP. Qed.
Canonical cdv_linear S (i: idx S) := Linear (cdv_is_linear i).

Definition cdvdelta S (i j: idx S) : cdv i (deltav j) = (i == j)%:R.
Proof. by rewrite /cdv tcbase. Qed.

Definition cdvdeltaC S (i j: idx S) : cdv i (deltav j) = cdv j (deltav i).
Proof. by rewrite !cdvdelta eq_sym. Qed.

Lemma deccdv S (u: Hs S) : u = \sum_i cdv i u *: deltav i.
Proof. by rewrite /cdv -decdv. Qed.

Lemma conjvcdv S (u: Hs S) i : cdv i u^*v = (cdv i u)^*.
Proof. by rewrite /cdv conjv_dotr conjvdv conj_dotp. Qed.

Lemma adjcdv S T (f: 'Hom(Hs S, Hs T)) i j :
  cdv i (f^A (deltav j)) = (cdv j (f (deltav i)))^*.
Proof. by rewrite /cdv adj_dotEV conj_dotp. Qed.

Lemma dot_cdv S (u v: Hs S) : [< u; v>] = \sum_i (cdv i u)^* * (cdv i v).
Proof.
rewrite {1}(deccdv u) {1}(deccdv v).
rewrite dotp_suml; apply eq_bigr=> i _; rewrite dotp_sumr (bigD1 i) //= big1.
by move=>j /negPf nji; rewrite dotpZl dotpZr tcbase eq_sym nji !mulr0.
by rewrite dotpZl dotpZr tcbase eqxx mulr1 addr0.
Qed.

Lemma cdvP S (u v: Hs S) :
  ((@cdv _ )^~ u) =1 ((@cdv _ )^~ v) <-> u = v.
Proof.
split; last by move=>->. move=> P; rewrite -intro_ebl => t.
by move: (P (n2i t)); rewrite /cdv /deltav !n2iK.
Qed.

Lemma intro_dvl S (u v: Hs S) :
  (forall i, cdv i u = cdv i v) <-> u = v.
Proof.
split; last by move=>->. move=> P; rewrite -intro_ebl => t.
by move: (P (n2i t)); rewrite /cdv /deltav !n2iK.
Qed.

Lemma intro_dvr S (u v: Hs S) :
  (forall i, [< u ; deltav i >] = [< v ; deltav i >]) <-> u = v.
Proof.
split; [| move=>-> //]; rewrite -intro_dvl=> P t.
by apply (can_inj conjCK); rewrite !conj_dotp.
Qed.

Lemma dotmvT S (x y: mvector (@Hf S)) :
  [< ⊗ x ; ⊗ y >] = \prod_i [< x i; y i>].
Proof. by rewrite -tdotpE. Qed.

Lemma dim_setten S : (Vector.dim (Hs S) = \prod_(i in S ) Vector.dim (E i))%N.
Proof. by rewrite dim_tensor /Hf -big_sig_set. Qed.

(* Cast Index and State *)
Definition castidx S T (eqAB : S = T) (eA : idx S)  : idx T :=
  let: erefl in _ = T := eqAB return (idx T) in eA.

Lemma castidx_id S erefl_S (eA : idx S) : castidx erefl_S eA = eA.
Proof. by rewrite eq_axiomK. Qed.

Lemma castidx_comp S1 S2 S3 (eq_S1 : S1 = S2) (eq_S2 : S2 = S3) A :
  castidx eq_S2 (castidx eq_S1 A) = castidx (etrans eq_S1 eq_S2) A.
Proof. by case: S2 / eq_S1 eq_S2; case: S3 /. Qed.

Lemma castidxK S1 S2 (eq_S : S1 = S2) :
  cancel (castidx eq_S) (castidx (esym eq_S)).
Proof. by case: S2 / eq_S. Qed.

Lemma castidxKV S1 S2 (eq_S : S1 = S2) :
  cancel (castidx (esym eq_S)) (castidx eq_S).
Proof. by case: S2 / eq_S. Qed.

(* This can be use to reverse an equation that involves a cast. *)
Lemma castidx_sym S1 S2 (eq_S : S1 = S2) A1 A2 :
  A1 = castidx eq_S A2 -> A2 = castidx (esym eq_S) A1.
Proof. by move/(canLR (castidxK _)). Qed.

Definition casths S T (eqAB : S = T) (v : Hs S) : Hs T :=
  let: erefl in _ = T := eqAB return (Hs T) in v.

Lemma casthsE S T (eq_ST : S = T) (v : Hs S) i:
  casths eq_ST v i = v (castidx (esym eq_ST) i).
Proof. by case: T / eq_ST i => //=. Qed.

Lemma casths_id S erefl_S (v : Hs S) : casths erefl_S v = v.
Proof. by rewrite eq_axiomK. Qed.

Lemma casths_comp S1 S2 S3 (eq_S1 : S1 = S2) (eq_S2 : S2 = S3) v :
  casths eq_S2 (casths eq_S1 v) = casths (etrans eq_S1 eq_S2) v.
Proof. by case: S2 / eq_S1 eq_S2; case: S3 /. Qed.

Lemma casthsK S1 S2 (eq_S : S1 = S2) :
  cancel (casths eq_S) (casths (esym eq_S)).
Proof. by case: S2 / eq_S. Qed.

Lemma casthsKV S1 S2 (eq_S : S1 = S2) :
  cancel (casths (esym eq_S)) (casths eq_S).
Proof. by case: S2 / eq_S. Qed.

Lemma casths_sym S1 S2 (eq_S : S1 = S2) v1 v2 :
  v1 = casths eq_S v2 -> v2 = casths (esym eq_S) v1.
Proof. by move/(canLR (casthsK _)). Qed.

Lemma casths_is_linear S1 S2 (eq_S : S1 = S2) :
  linear (@casths _ _ eq_S).
Proof. by move=>a f g; case: S2 / eq_S; rewrite !casths_id. Qed.
Canonical casths_linear S1 S2 (eq_S : S1 = S2) := Linear (casths_is_linear eq_S).

Lemma deltav_cast S S' (eqS : S = S') (i : idx S) :
    casths eqS (deltav i) = deltav (castidx eqS i).
Proof. by case: S' / eqS; rewrite casths_id castidx_id. Qed.

Lemma cdv_cast S S' (eqS : S = S') (i : idx S) v :
    cdv (castidx eqS i) v = cdv i (casths (esym eqS) v).
Proof. by case: S' / eqS v=>v; rewrite casths_id castidx_id. Qed.

Lemma cdv_castV S S' (eqS : S = S') (i : idx S') v :
    cdv i (casths eqS v) = cdv (castidx (esym eqS) i) v.
Proof. by case: S' / eqS i=>i; rewrite casths_id castidx_id. Qed.

Definition castlf S T S' T' (eqST : (S = S') * (T = T')) (f : 'Hom(Hs S, Hs T)) :
  'Hom(Hs S', Hs T') :=
  let: erefl in _ = T' := eqST.2 return 'Hom(Hs S', Hs T') in
    let: erefl in _ = S' := eqST.1 return 'Hom(Hs S', Hs T) in f.

Lemma castlf_id S T erefl_ST (f : 'Hom(Hs S, Hs T)) : castlf erefl_ST f = f.
Proof. by case: erefl_ST => e_S e_T; rewrite [e_S]eq_axiomK [e_T]eq_axiomK. Qed.

Lemma castlfE S T S' T' (eqST : (S = S') * (T = T')) (f : 'Hom(Hs S, Hs T)) u :
  castlf eqST f u = casths eqST.2 (f (casths (esym eqST.1) u)).
Proof.
by do [case: eqST; case: S' /; case: T' /] in f u *; rewrite !casths_id castlf_id.
Qed.

Lemma castlf_comp S1 T1 S2 T2 S3 T3 (eq_S1 : S1 = S2) (eq_T1 : T1 = T2)
                                    (eq_S2 : S2 = S3) (eq_T2 : T2 = T3) f :
  castlf (eq_S2, eq_T2) (castlf (eq_S1, eq_T1) f)
    = castlf (etrans eq_S1 eq_S2, etrans eq_T1 eq_T2) f.
Proof.
by case: S2 / eq_S1 eq_S2; case: S3 /; case: T2 / eq_T1 eq_T2; case: T3 /.
Qed.

Lemma castlfK S1 T1 S2 T2 (eq_S : S1 = S2) (eq_T : T1 = T2) :
 cancel (castlf (eq_S, eq_T)) (castlf (esym eq_S, esym eq_T)).
Proof. by case: S2 / eq_S; case: T2 / eq_T. Qed.

Lemma castlfKV S1 T1 S2 T2 (eq_S : S1 = S2) (eq_T : T1 = T2) :
 cancel (castlf (esym eq_S, esym eq_T)) (castlf (eq_S, eq_T)).
Proof. by case: S2 / eq_S; case: T2 / eq_T. Qed.

(* This can be use to reverse an equation that involves a cast. *)
Lemma castlf_sym S1 T1 S2 T2 (eq_S : S1 = S2) (eq_T : T1 = T2) A1 A2 :
 A1 = castlf (eq_S, eq_T) A2 -> A2 = castlf (esym eq_S, esym eq_T) A1.
Proof. by move/(canLR (castlfK _ _)). Qed.

Lemma castlf_is_linear S T S' T' (eqST : (S = S') * (T = T')) :
  linear (@castlf _ _ _ _ eqST).
Proof.
move=>a f g; case: eqST => eqS eqT; case: S' / eqS; case: T' / eqT.
by rewrite !castlf_id.
Qed.
Canonical castlf_linear S T S' T' (eqST : (S = S') * (T = T')) :=
  Linear (castlf_is_linear eqST).

Lemma castlf_complf S T S' T' (eqST: S = T') (f: 'Hom(Hs S, Hs T))
  (g: 'Hom(Hs S', Hs T')) :
  castlf (eqST, erefl _) f \o g = f \o castlf (erefl _, esym eqST) g.
Proof.
by move: f g; case: T' / eqST => f g; rewrite !castlf_id.
Qed.

Lemma castlf_complfV S T S' T' (eqST: T' = S) (f: 'Hom(Hs S, Hs T))
  (g: 'Hom(Hs S', Hs T')) :
  f \o castlf (erefl _, eqST) g = castlf (esym eqST, erefl _) f \o g.
Proof.
by move: f g; case: S / eqST => f g; rewrite !castlf_id.
Qed.

Lemma castlf_complfG S1 T1 S2 S2' T2 (eqST: (S2 = S2') * (T2 = S1))
  (f: 'Hom(Hs S1, Hs T1)) (g: 'Hom(Hs S2, Hs T2)) :
  (f \o (castlf eqST g) = castlf (eqST.1, erefl _)
    (castlf (esym eqST.2, erefl _) f \o g))%VF.
Proof.
move: f g. case: eqST => eq1 eq2; case: S2' / eq1; case: S1 / eq2 => f g.
by rewrite !castlf_id.
Qed.

Lemma castlf_conj S T S' T' (eqST : (S = S') * (T = T')) (f: 'Hom(Hs S, Hs T)) :
  (castlf eqST f)^C = castlf eqST f^C.
Proof.
by do [case: eqST; case: S' /; case: T' /] in f *; rewrite !castlf_id.
Qed.

Lemma castlf_adj S T S' T' (eqST : (S = S') * (T = T')) (f: 'Hom(Hs S, Hs T)) :
  (castlf eqST f)^A = castlf (eqST.2,eqST.1) f^A.
Proof.
by do [case: eqST; case: S' /; case: T' /] in f *; rewrite !castlf_id.
Qed.

Lemma castlf_tr S T S' T' (eqST : (S = S') * (T = T')) (f: 'Hom(Hs S, Hs T)) :
  (castlf eqST f)^T = castlf (eqST.2,eqST.1) f^T.
Proof.
by do [case: eqST; case: S' /; case: T' /] in f *; rewrite !castlf_id.
Qed.

Lemma castlf1 S T (eqST : (S = T)) :  (castlf (eqST,eqST) (\1 : 'End(Hs S))) = \1.
Proof. by case: T / eqST; rewrite castlf_id. Qed.

(* conjV with conjv of each atomic space *)
Lemma conjvV S (x : mvector (@Hf S)) :
  (⊗ x)^*v = ⊗ (\mvector_(i:{i : I | i \in S}) ((x i)^*v)%VF).
Proof.
rewrite /inject /conjv r2vK; apply f_equal; apply/matrixP=> i j.
by rewrite !mxE rmorph_prod; apply eq_bigr=>k _; rewrite mvE /conjmx r2vK mxE.
Qed.

Lemma lfunPD S T (f g : 'Hom(Hs S, Hs T)) :
  (forall i, f (deltav i) = g (deltav i)) <-> f = g.
Proof.
split=> [P |-> //]; apply/lfunP=> u; rewrite (deccdv u) !linear_sum /=.
by apply eq_bigr=> i _; rewrite !linearZ /= (P i).
Qed.

Lemma default_scast (i : I) :
  Vector.dim (E i) = Vector.dim (Hs [set i]).
Proof. by rewrite dim_setten big_set1. Qed.

Definition inject_sv (i : I) (vi : E i) : Hs [set i] :=
  r2v (castmx (erefl _, (default_scast i)) (v2r vi)).

Lemma inject_sv_dotE (i : I) (u v : E i) :
  [<inject_sv u; inject_sv v>] = [<u ; v>].
Proof.
by rewrite dotp_mulmx /inject_sv !r2vK trmx_cast/=
  conjmx_cast castmx_mul castmx_id dotp_mulmx.
Qed.

Definition extract_sv (i : I) (vi : Hs [set i]) : E i :=
  r2v (castmx (erefl _, esym (default_scast i)) (v2r vi)).

Lemma inject_svK (i : I) : cancel (@inject_sv i) (@extract_sv i).
Proof. by move=>x; rewrite /extract_sv /inject_sv r2vK castmx_comp castmx_id v2rK. Qed.

Lemma extract_svK (i : I) : cancel (@extract_sv i) (@inject_sv i).
Proof. by move=>x; rewrite /extract_sv /inject_sv r2vK castmx_comp castmx_id v2rK. Qed.

Lemma inject_sv_inj (i : I) : injective (@inject_sv i).
Proof. exact: (can_inj (@inject_svK i)). Qed.

Lemma inject_sv_is_linear (i : I) : linear (@inject_sv i).
Proof. by move=>a x y; rewrite /inject_sv !linearP/=. Qed.
Canonical inject_sv_linear (i : I) := Linear (@inject_sv_is_linear i).

Lemma extract_sv_inj (i : I) : injective (@extract_sv i).
Proof. exact: (can_inj (@extract_svK i)). Qed.

Lemma extract_sv_is_linear (i : I) : linear (@extract_sv i).
Proof. by move=>a x y; rewrite /extract_sv !linearP/=. Qed.
Canonical extract_sv_linear (i : I) := Linear (@extract_sv_is_linear i).

Lemma extract_sv_dotE (i : I) (u v : Hs [set i]) :
  [<extract_sv u; extract_sv v>] = [<u ; v>].
Proof. by rewrite -inject_sv_dotE !extract_svK. Qed.

Definition inject_sf (i : I) (fi : 'End(E i)) : 'End(Hs [set i]) :=
  Vector.Hom (castmx ((default_scast i), (default_scast i)) (f2mx fi)).

Lemma inject_sf_comp (i : I) (fi gi : 'End(E i)) :
  inject_sf fi \o inject_sf gi = inject_sf (fi \o gi).
Proof. by apply/val_inj=>/=; rewrite !f2mx_comp /inject_sf/= castmx_mul. Qed.

Lemma inject_sf_apply (i : I) (fi : 'End(E i)) (vi : E i) :
  inject_sf fi (inject_sv vi) = inject_sv (fi vi).
Proof. by rewrite unlock/= /inject_sv !r2vK castmx_mul. Qed.

Definition extract_sf (i : I) (fi : 'End(Hs [set i])) : 'End(E i) :=
  Vector.Hom (castmx (esym (default_scast i), esym (default_scast i)) (f2mx fi)).

Lemma inject_sfK (i : I) : cancel (@inject_sf i) (@extract_sf i).
Proof. by move=>x; rewrite /extract_sf /inject_sf/= castmx_comp castmx_id f2mxK. Qed.

Lemma extract_sfK (i : I) : cancel (@extract_sf i) (@inject_sf i).
Proof. by move=>x; rewrite /extract_sf /inject_sf/= castmx_comp castmx_id f2mxK. Qed.

Lemma inject_sf_inj (i : I) : injective (@inject_sf i).
Proof. exact: (can_inj (@inject_sfK i)). Qed.

Lemma inject_sf_is_linear (i : I) : linear (@inject_sf i).
Proof. by move=>a x y; rewrite /inject_sf !linearP/=. Qed.
Canonical inject_sf_linear (i : I) := Linear (@inject_sf_is_linear i).

Lemma extract_sf_inj (i : I) : injective (@extract_sf i).
Proof. exact: (can_inj (@extract_sfK i)). Qed.

Lemma extract_sf_is_linear (i : I) : linear (@extract_sf i).
Proof. by move=>a x y; rewrite /extract_sf !linearP/=. Qed.
Canonical extract_sf_linear (i : I) := Linear (@extract_sf_is_linear i).

Lemma extract_sf_comp (i : I) (fi gi : 'End(Hs [set i])) :
  extract_sf fi \o extract_sf gi = extract_sf (fi \o gi).
Proof. by apply/val_inj=>/=; rewrite !f2mx_comp /extract_sf/= castmx_mul. Qed.

Lemma extract_sf_apply (i : I) (fi : 'End(Hs [set i])) (vi : Hs [set i]) :
  extract_sf fi (extract_sv vi) = extract_sv (fi vi).
Proof. by rewrite unlock/= /extract_sv !r2vK castmx_mul. Qed.

End FsetTensorSpace.

Local Open Scope lfun_scope.
Reserved Notation "''H_' S"      (at level 8, S at level 2, format "''H_' S").
Reserved Notation "''H[' H ]_ S" (at level 8, S at level 2). (* only parsing *)
Reserved Notation "''Idx_' S"      (at level 8, S at level 2, format "''Idx_' S").
Reserved Notation "''Idx[' H ]_ S" (at level 8, S at level 2). (* only parsing *)
Reserved Notation "''F_' S"     (at level 8, S at level 2, format "''F_' S").
Reserved Notation "''FV_' S"    (at level 8, S at level 2, format "''FV_' S").
Reserved Notation "''FdV_' S"   (at level 8, S at level 2, format "''FdV_' S").
Reserved Notation "''F_' ( S )" (at level 8). (* only parsing *)
Reserved Notation "''F_' ( S , T )" (at level 8, format "''F_' ( S ,  T )").
Reserved Notation "''F[' H ]_ S"    (at level 8, S at level 2). (* only parsing *)
Reserved Notation "''FV[' H ]_ S"   (at level 8, S at level 2). (* only parsing *)
Reserved Notation "''FdV[' H ]_ S"  (at level 8, S at level 2). (* only parsing *)
Reserved Notation "''F[' H ]_ ( S )"     (at level 8). (* only parsing *)
Reserved Notation "''F[' H ]_ ( S , T )" (at level 8). (* only parsing *)

Notation "''H[' H ]_ S" := (@Hs _ H S) (only parsing) : type_scope.
Notation "''H_' S" := 'H[_]_S : type_scope.
Notation "''Idx[' H ]_ S" := (@idx _ H S) (only parsing) : type_scope.
Notation "''Idx_' S" := 'Idx[_]_S : type_scope.
Notation "''F[' H ]_ ( S , T )" := ('Hom( @Hs _ H S, @Hs _ H T)) (only parsing): type_scope.
Notation "''FV[' H ]_ S" := 'F[H]_(set0, S) (only parsing) : type_scope.
Notation "''FdV[' H ]_ S" := 'F[H]_(S, set0) (only parsing) : type_scope.
Notation "''F[' H ]_ S" := 'F[H]_(S, S) (only parsing) : type_scope.
Notation "''F[' H ]_ ( S )" := 'F[H]_S (only parsing) : type_scope.
Notation "''F_' ( S , T )" := 'F[_]_(S, T) : type_scope.
Notation "''FV_' S" := 'F_(set0, S) : type_scope.
Notation "''FdV_' S" := 'F_(S, set0) : type_scope.
Notation "''F_' S" := 'F_(S, S) : type_scope.
Notation "''F_' ( S )" := 'F_S (only parsing) : type_scope.

Notation "A :<=: B" := (A \subset B) (at level 70, no associativity) : set_scope.

(* tensor product of fset, for define \tensor_(i : J) E i later *)
Section FsetTensorVect.
Context {I : finType} (E : I -> chsType).
Variables (J : finType) (fs: J -> {set I}).

(* a finType index J *)
(* fs : map each index : J to a {fset I} *)
(* the tensor product of index J *)

(* Definition mapf : {set {set I}} := [set fs i | i : J]. *)
Notation bdom := (\bigcup_i (fs i)).

Definition disf := forall i j, i != j -> [disjoint fs i & fs j].

Lemma map_cover (s : J) : fs s :<=: bdom.
Proof. by apply bigcup_sup. Qed.

Definition incl (A B: {set I}) (AsubB : A :<=: B) (a : {i | i \in A})
  : {i : I | i \in B} := exist _ (val a) (subsetP AsubB (val a) (projT2 a)).

Definition setsub (A: {set I}) (a : I) (sub: a \in A) : {i | i \in A}
  := exist _ a sub.

Lemma preidx_ex (x : {i | i \in bdom}) : {i | val x \in fs i}.
Proof. destruct x=>/=; move: i=>/bigcupP/sig2W [j Pj inj]; by exists j. Qed.

Definition flatidx (i: 'Idx[E]_bdom) : {dffun forall i : J, 'Idx[E]_(fs i)}
  := [ffun s : J => \mvector_(j : {i | i \in fs s}) i (incl (map_cover s) j)].

Definition preidx (j : {i | i \in bdom}) : J := projT1 (preidx_ex j).

Lemma preidxP (j : {i | i \in bdom}) : val j \in fs (preidx j).
Proof. by move: (projT2 (preidx_ex j)). Qed.

Lemma preidxU (i : J) (j : {k | k \in fs i}) : disf ->
  (preidx (incl (map_cover i) j)) = i.
Proof.
rewrite /disf=>dis; set k:= (incl (map_cover i) j).
have Q: val k = val j. by []. symmetry; move: (preidxP k).
apply boolp.contraPP; set m:= preidx k; rewrite Q.
move/eqP=> P1; move: (@dis _ _ P1). rewrite disjoint_subset=>/subsetP P2.
by apply/negP; apply: (P2 (val j)); destruct j.
Qed.

Definition packidx (f: {dffun forall i: J, 'Idx[E]_(fs i)}) : 'Idx[E]_bdom
  := \mvector_(j : {i | i \in bdom}) f (preidx j) (setsub (preidxP j)).

Lemma packidxE (f : {dffun forall i : J, 'Idx[E]_(fs i)}) : disf ->
  forall (i : J) (j: {k | k \in fs i}), packidx f (incl (map_cover i) j) = f i j.
Proof.
move=>dis i j; rewrite mvE.
move: (preidxU j dis) (preidxP (incl (map_cover i) j)) => P.
rewrite P /=; destruct j => /= Q.
by rewrite (eq_irrelevance Q i0).
Qed.

Lemma flatidxE (eAB : 'Idx[E]_bdom) (i : {i | i \in bdom}) :
  eAB i = flatidx eAB (preidx i) (setsub (preidxP i)).
Proof.
destruct i; rewrite ffunE mvE/= /incl.
congr (eAB (exist _ _ _)); by apply eq_irrelevance.
Qed.

Lemma flatidxK : cancel flatidx packidx.
Proof. by move=>e; apply/mvectorP=>j; rewrite mvE flatidxE. Qed.

Lemma packidxK : disf -> cancel packidx flatidx.
Proof.
by move=>dis e; apply/ffunP=>j; rewrite ffunE;
  apply/mvectorP=>k; rewrite mvE packidxE.
Qed.

Lemma flatidx_inj : injective flatidx.
Proof. exact: (can_inj flatidxK). Qed.

Lemma packidx_inj : disf -> injective packidx.
Proof. move=>dis; exact: (can_inj (packidxK dis)). Qed.

Definition injectv (x: mvector (fun i: J => 'H[E]_(fs i))) : 'H[E]_bdom
  := \sum_(e : 'Idx[E]_bdom) (\prod_i cdv (flatidx e i) (x i) *: deltav e).

Lemma deltavm (b : 'Idx[E]_bdom) :
  deltav b = injectv (\mvector_(i : J) deltav (flatidx b i)).
Proof.
rewrite /injectv (bigD1 b)//=.
rewrite (eq_bigr (fun=>1)).
by move=>i _; rewrite mvE cdvdelta eqxx.
rewrite prodr_const expr1n scale1r [X in _ + X]big1 ?addr0// =>i.
rewrite -(inj_eq flatidx_inj)=>/dffun_neqP[j/negPf nj].
pose fk k := ((flatidx i k) == (flatidx b k))%:R : C.
rewrite (eq_bigr fk)=>[k _|]; first by rewrite mvE cdvdelta.
suff ->: \prod_(i : J) fk i = 0 by rewrite scale0r.
by rewrite (bigD1 j)//= /fk nj mul0r.
Qed.

Lemma big_distr_idx (R: ringType) (F : forall j, 'Idx[E]_(fs j) -> R) : disf ->
  \prod_(i : J) (\sum_(j : 'Idx[E]_(fs i)) F i j) =
  \sum_(k : 'Idx[E]_bdom) \prod_(i : J) F i (flatidx k i).
Proof.
move=> dis; rewrite big_distr_dffun (reindex (fun x : 'Idx[E]_bdom =>
  ([ffun i: J => flatidx x i] : [finType of {dffun forall i: J, 'Idx[E]_(fs i)}]))).
exists (fun x => packidx x) => -[]; [move=> d _ |move=>f _].
by apply flatidx_inj => //; rewrite packidxK //; apply/ffunP=> i; rewrite ffunE.
by rewrite packidxK //; apply/ffunP=> i; rewrite ffunE.
by rewrite /=; apply eq_bigr=>k _; apply eq_bigr=>i _; rewrite ffunE.
Qed.

Lemma injectv_dot (x y : mvector (fun i : J => 'H[E]_(fs i))) :
  disf -> hdotp x y = [< injectv x ; injectv y >].
Proof.
move=> dis; rewrite /hdotp /injectv dotp_suml.
rewrite (eq_bigr (fun v=> [< \prod_i cdv (flatidx v i) (x i) *: deltav v;
          \prod_i cdv (flatidx v i) (y i) *: deltav v >])).
move=>v _; rewrite dotp_sumr (bigD1 v) //=.
rewrite -[RHS]addr0; congr (_ + _); rewrite big1 // => i /negPf niv.
by rewrite dotpZl dotpZr tcbase eq_sym niv !mulr0.
rewrite (eq_bigr (fun i=> \sum_j (cdv j (x i))^* * (cdv j (y i)))).
by move=>i _; rewrite dot_cdv.
rewrite [\sum_ _ _](eq_bigr (fun i=> \prod_i0
    ((cdv (flatidx i i0) (x i0))^* * cdv (flatidx i i0) (y i0)))).
by move=>i _; rewrite dotpZl dotpZr tcbase eqxx mulr1 rmorph_prod big_split.
by rewrite big_distr_idx.
Qed.

Lemma injectvZi (i : J) (a : C) (x : mvector (fun i : J => 'H[E]_(fs i))) :
  injectv (a *:_i x) = a *: injectv x.
Proof.
rewrite /injectv scaler_sumr; apply eq_bigr=>e _; rewrite scalerA.
congr (_ *: _); rewrite !(bigD1 i (P := predT)) //= mulrA.
congr (_ * _); first by rewrite mvE eqxx linearZ.
by apply: eq_bigr=> j ne_ji; rewrite mvE eq_sym (negbTE ne_ji) scale1r.
Qed.

Lemma injectvDi (i: J) (x: mvector (fun i : J => 'H[E]_(fs i))) (v: 'H[E]_(fs i)) :
  injectv (x +_i v) = injectv x + injectv (x[<i ← v>]).
Proof.
rewrite /injectv -big_split /=; apply eq_bigr=>e _. rewrite -scalerDl.
congr (_ *: _); rewrite !(bigD1 i (P := predT)) //=.
rewrite !(msetii, mvE) linearD /= mulrDl; congr (_ * _ + _ * _);
 by apply/eq_bigr=> j ne_ji; rewrite !(mset_ne, mvE) 1?eq_sym // addr0.
Qed.

Lemma injectv_is_mlinear : mlinear injectv.
Proof.
move=> i a x v /=; rewrite injectvDi injectvZi; congr (_ + injectv _).
by apply/mvectorP=> j; rewrite !mvE; case: eqP => //; rewrite scale1r.
Qed.

Lemma injectv_eq0P (x : mvector (fun i : J => 'H[E]_(fs i))) :
  disf -> reflect (exists i, x i = 0) (injectv x == 0).
Proof.
move=>dis; apply: (iffP eqP) => eq0; last first.
- by apply: mlinear0 => //; apply/injectv_is_mlinear.
apply/'exists_eqP; apply/contra_eqT: eq0 => eq0.
have {}eq0: forall i, exists j, cdv j (x i) != 0.
- move=> i; apply/existsP; rewrite -negb_forall.
  apply/contra: eq0 => /forallP /= eq0; apply/existsP.
  exists i. apply/eqP. rewrite -intro_dvl => j.
  by rewrite linear0; apply/eqP.
pose e := [ffun i : J => xchoose (eq0 i)].
rewrite /injectv; apply/eqP=>/cdvP /(_ (packidx e)) => /eqP; apply/negP.
rewrite linear0 linear_sum (bigD1 (packidx e)) //= [\sum_( _ | _) _]big1.
by move=>j /negPf nje; rewrite linearZ /= cdvdelta eq_sym nje mulr0.
rewrite linearZ /= cdvdelta eqxx packidxK // addr0 mulr1.
by apply/prodf_neq0 => i _; rewrite ffunE; apply/(xchooseP (eq0 i)).
Qed.

End FsetTensorVect.

(* tensor product of linear functions *)
Section FsetTensorLfun.
Context {I : finType} (E : I -> chsType).

(* fs : J -> {fset I}, for domain of each component *)
(* fs' : J -> {fset I}, for codomain of each component *)
(* f (j : J) : the linear functions of each component, Hs (fs j) -> Hs (fs' j) *)
Variables (J: finType) (fs fs': J -> {set I}).
Variable f : forall i : J, 'F[E]_((fs i), (fs' i)).

Notation bdom := (\bigcup_i (fs i)).
Notation bcdom := (\bigcup_i (fs' i)).

(* for each mvector x (domain), applyf x gives the mvector y (codomain) *)
Definition applyf (x : mvector (fun i : J => 'H[E]_(fs i))) :=
  \mvector_(i : J) f i (x i).

(* deltav : the state that has only 1 on j but 0 elsewhere *)

Definition liftlf_r (x : 'H[E]_bdom) (b : 'Idx[E]_bdom) :=
  (cdv b x) *: injectv (applyf (\mvector_(i : J) deltav (flatidx b i))).

Definition liftlf_def (x : 'H[E]_bdom) : 'H[E]_bcdom :=
  \sum_(b : 'Idx[E]_bdom) liftlf_r x b.

Lemma liftlf_def_is_linear : linear liftlf_def.
Proof.
move=>a u v; rewrite /liftlf_def scaler_sumr -big_split /=.
by apply eq_bigr=>i _; rewrite /liftlf_r linearP scalerDl scalerA.
Qed.
Canonical liftlf_def_linear := Linear liftlf_def_is_linear.
Definition liftlf := linfun liftlf_def.

(* if domains are well-defined, i.e., pairwise disjoint *)
Lemma liftlfE : disf fs ->  forall x, liftlf (injectv x) = injectv (applyf x).
Proof.
move=>dis x; rewrite /liftlf lfunE /= /liftlf_def /liftlf_r /applyf /injectv.
rewrite (eq_bigr (fun b=> \sum_e (\prod_i (cdv (flatidx b i) (x i) *
     cdv (flatidx e i) (f i ((deltav (flatidx b i)))))) *:  deltav e)).
move=>i _; rewrite scaler_sumr; apply eq_bigr=> e _.
rewrite scalerA; congr (_ *: _).
rewrite linear_sum /= (bigD1 i) //= [\sum_( _ | _) _]big1.
by move=>j /negPf nji; rewrite linearZ /= cdvdelta eq_sym nji mulr0.
rewrite addr0 linearZ /= cdvdelta eqxx mulr1 -big_split /=.
by apply eq_bigr=> j _; rewrite !mvE.
rewrite exchange_big /=; apply eq_bigr=> e _; rewrite -scaler_suml; congr (_ *: _).
rewrite [RHS](eq_bigr (fun i=> \sum_j cdv j (x i) * cdv (flatidx e i) (f i (deltav j)))).
move=>i _; rewrite mvE {1}(deccdv (x i)) !linear_sum; apply eq_bigr=> j _.
by rewrite !linearZ. by rewrite big_distr_idx.
Qed.

Lemma liftlf_delta b : liftlf (deltav b) = injectv (applyf (\mvector_(i : J) deltav (flatidx b i))).
Proof.
rewrite lfunE/=/liftlf_def/liftlf_r (bigD1 b)//= cdvdelta eqxx scale1r.
rewrite (eq_bigr (fun=>0)) => [j/negPf nj|].
by rewrite cdvdelta nj scale0r.
by rewrite sumr_const mul0rn addr0.
Qed.
End FsetTensorLfun.


(*==========================================================================
  Variables
  ==========================================================================*)

Require Import List.

Module Type VAR.
  Parameter Ty : Type.
End VAR.

Module Var (V : VAR).

Require Import Program.Equality.
Set Implicit Arguments.
Unset Strict Implicit.
Set Printing Implicit Defensive.

Definition Ty := V.Ty.
Definition Env := list Ty.

Inductive Var : Env -> Ty -> Type :=
| ZVAR : forall env ty, Var (ty :: env) ty
| SVAR : forall env ty ty', Var env ty -> Var (ty' :: env) ty.

(*==========================================================================
  Variable-domain maps.
  By instantiating P with Var we get renamings.
  By instantiating P with terms we get substitutions.
  ==========================================================================*)

Definition Map (P : Env -> Ty -> Type) env env' := forall t, Var env t -> P env' t.

(* Head, tail and cons *)
Definition tlMap P env env' ty (m : Map P (ty :: env) env') : Map P env env' := fun ty' v => m ty' (SVAR ty v).
Definition hdMap P env env' ty (m : Map P (ty :: env) env') : P env' ty := m ty (ZVAR _ _).
Implicit Arguments tlMap [P env env' ty].
Implicit Arguments hdMap [P env env' ty].

Program Definition consMap P env env' ty (v : P env' ty) (m:Map P env env') : Map P (ty :: env) env' :=
    fun ty' (var:Var (ty :: env) ty') =>
    match var with
    | ZVAR _ _ => v
    | SVAR _ _ _ var => m _ var
    end.
Implicit Arguments consMap [P env env' ty].

Axiom MapExtensional : forall P env env' (r1 r2 : Map P env env'), (forall ty var, r1 ty var = r2 ty var) -> r1 = r2.

Lemma hdConsMap : forall P env env' ty (v : P env' ty) (s : Map P env env'), hdMap (consMap v s) = v. Proof. auto. Qed.
Lemma tlConsMap : forall P env env' ty (v : P env' ty) (s : Map P env env'), tlMap (consMap v s) = s. Proof. intros. apply MapExtensional. auto. Qed.

Lemma consMapInv : forall P env env' ty (m:Map P (ty :: env) env'), exists m', exists v, m = consMap v m'.
intros. exists (tlMap m). exists (hdMap m).
apply MapExtensional. dependent destruction var; auto.
Qed.

Definition Renaming := Map Var.

Definition idRenaming env : Renaming env env := fun ty (var : Var env ty) => var.
Implicit Arguments idRenaming [].

Definition composeRenaming P env env' env'' (m : Map P env' env'') (r : Renaming env env') : Map P env env'' := fun t var => m _ (r _ var).

Lemma composeRenamingAssoc :
  forall P env env' env'' env''' (m : Map P env'' env''') r' (r : Renaming env env'),
  composeRenaming m (composeRenaming r' r) = composeRenaming (composeRenaming m r') r.
Proof. auto. Qed.

Lemma composeRenamingIdLeft : forall env env' (r : Renaming env env'), composeRenaming (idRenaming _) r = r.
Proof. intros. apply MapExtensional. auto. Qed.

Lemma composeRenamingIdRight : forall P env env' (m:Map P env env'), composeRenaming m (idRenaming _) = m.
Proof. intros. apply MapExtensional. auto. Qed.

End Var.


Require Export Iron.Language.SystemF2Data.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Data.Type.Operator.LiftTT.

(********************************************************************)
(* Substitution of Types in Types. *)
Fixpoint substTT (d: nat) (u: ty) (tt: ty) : ty
 := match tt with
    | TVar ix
    => match nat_compare ix d with
       | Eq => u
       | Gt => TVar (ix - 1)
       | _  => TVar  ix
       end

    |  TCon _
    => tt

    |  TForall t
    => TForall (substTT (S d) (liftTT 1 0 u) t)

    |  TApp t1 t2
    => TApp (substTT d u t1) (substTT d u t2)
  end.

(********************************************************************)
(* Substitution and type utils *)
Lemma substTT_getCtorOfType
 :  forall d t1 t2 t3
 ,  getCtorOfType t2                = Some t3
 -> getCtorOfType (substTT d t1 t2) = Some t3.
Proof.
 intros. gen d t1 t3.
 induction t2; try burn.
Qed.
Hint Resolve substTT_getCtorOfType.

Lemma substTT_makeTApps
 :  forall d t2 t1 ts
 ,  substTT d t2 (makeTApps t1 ts)
 =  makeTApps (substTT d t2 t1) (map (substTT d t2) ts).
Proof.
 intros. gen d t2 t1.
 induction ts; snorm; try rewritess; burn.
Qed.
Hint Rewrite substTT_makeTApps : global.

Lemma liftTT_makeTApps
 :  forall d n t1 ts
 ,  liftTT n d (makeTApps t1 ts)
 =  makeTApps (liftTT n d t1) (map (liftTT n d) ts).
Proof.
 intros. gen d n t1.
 induction ts; burn.
Qed.
Hint Rewrite liftTT_makeTApps : global.

Lemma takeTCon_substTT
 :  forall ix t1 tc t2
 ,  takeTCon t1                 = TCon tc
 -> takeTCon (substTT ix t2 t1) = TCon tc.
Proof.
 intros. gen ix t2.
 induction t1; burn.
Qed.

(********************************************************************)
Lemma substTT_wfT
 :  forall d ix t t2
 ,  wfT d t
 -> substTT (d + ix) t2 t = t.
Proof.
 intros. gen d ix t2.
 induction t; intros; inverts H; snorm;
  try (solve [omega]).

 - Case "TForall".
   f_equal.
   rrwrite (S (d + ix) = S d + ix).
   burn.

 - Case "TApp".
   f_equal; burn.
Qed.
Hint Resolve substTT_wfT.

Lemma substTT_closedT_id
 :  forall d t t2
 ,  closedT t
 -> substTT d t2 t = t.
Proof.
 intros.
 rrwrite (d = d + 0). eauto.
Qed.
Hint Resolve substTT_closedT_id.

Lemma substTT_closedT_id_list
 :  forall d ts t2
 ,  Forall closedT ts
 -> map (substTT d t2) ts = ts.
Proof.
 intros.
 induction ts.
 - snorm.
 - simpl.
   rewrite substTT_closedT_id.
   rewrite IHts; snorm.
   snorm.
Qed.
Hint Resolve substTT_closedT_id_list.

(********************************************************************)
(* If we lift at depth d, this creates an empty space and
   substituting into it doens't do anything. *)
Lemma substTT_liftTT
 :  forall d t1 t2
 ,  substTT d t2 (liftTT 1 d t1) = t1.
Proof.
 intros. gen d t2.
 induction t1; intros; simpl;
  try (solve [f_equal; burn]).

 - Case "TVar".
   lift_cases; unfold substTT;
    snorm; try omega; burn.
Qed.
Hint Rewrite substTT_liftTT : global.

(********************************************************************)
(* Lifting after substitution,
   with the lifting at a lower index. *)
Lemma liftTT_substTT_1
 :  forall n n' t1 t2
 ,  liftTT 1 n (substTT (n + n') t2 t1)
 =  substTT (1 + n + n') (liftTT 1 n t2) (liftTT 1 n t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros;
  try (solve [snorm; repeat f_equal; burn]).

 - Case "TVar".
   snorm; try omega.
   f_equal. omega.
   f_equal. omega.

 - Case "TForall".
   snorm.
   rewrite (IHt1 (S n) n').
   rewrite (liftTT_liftTT_11 0 n).
   burn.
Qed.

Lemma liftTT_substTT
 :  forall m n n' t1 t2
 ,  liftTT m n (substTT (n + n') t2 t1)
 =  substTT (m + n + n') (liftTT m n t2) (liftTT m n t1).
Proof.
 intros. gen n n'.
 induction m; intros; simpl.
 - burn.
 - rrwrite (S m = 1 + m).
   rewrite <- liftTT_plus.
   rewritess.
   rrwrite (m + n + n' = n + (m + n')) by omega.
   rewrite liftTT_substTT_1.
   burn.
Qed.
Hint Rewrite <- liftTT_substTT : global.

(********************************************************************)
(* Lifting after substitution,
   with the ligting at a higher index *)
Lemma liftTT_substTT'
 :  forall n n' t1 t2
 ,  liftTT 1 (n + n') (substTT n t2 t1)
 =  substTT n (liftTT 1 (n + n') t2) (liftTT 1 (1 + n + n') t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; try burn.

 - Case "TVar".
   repeat ( unfold liftTT; unfold substTT; fold liftTT; fold substTT
          ; try lift_cases
          ; try fbreak_nat_compare
          ; intros); try omega; burn.
   f_equal. omega.

 - Case "TForall".
   simpl. rewrite (IHt1 (S n) n').
   simpl. rewrite (liftTT_liftTT_11 0 (n + n')).
   burn.

 - Case "TApp".
   snorm.
   repeat rewritess. auto.
Qed.

(********************************************************************)
(* Commuting substitutions. *)
Lemma substTT_substTT
 :  forall n m t1 t2 t3
 ,  substTT (n + m) t3 (substTT n t2 t1)
 =  substTT n (substTT (n + m) t3 t2)
              (substTT (1 + n + m) (liftTT 1 n t3) t1).
Proof.
 intros. gen n m t2 t3.
 induction t1; intros; try burn.

 - Case "TVar".
   repeat (simpl; fbreak_nat_compare); try omega; burn.

 - Case "TForall".
   simpl.
   rewrite (IHt1 (S n) m).
   rewrite (liftTT_substTT_1 0 (n + m)).
   rewrite (liftTT_liftTT_11 0 n).
   burn.

 - Case "TApp".
   snorm. repeat rewritess. auto.
Qed.