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


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import HoTT.Basics Types.Prod Types.Forall Types.Paths.
Require Export Tactics.BinderApply.

(** * Extra tactics for homotopy type theory. *)

(** ** Tactics for dealing with [Funext] *)
(** *** Tactics about [transport]ing with [path_forall] *)

(** Given using the variable names from [transport : forall {A : Type} (P : A -> Type) {x y : A}, x = y -> P x -> P y] and [path_forall : {Funext} -> forall {A B} (f g : forall x : A, B x), (forall x : A, f x = g x) -> f = g]:

The high-level idea is that we don't really need functional extensionality if we end up just applying the functions to arguments anyway.  That is, if we have that [forall x, f x = g x], and we only talk about [f y] and [f z], then we don't actually need to transport across [f = g], just [f y = g y] and [f z = g z].

In a bit more detail, if we are transporting across [path_forall f g H], and in the function [P], all instances of [f] are applied to some expressions, say we only see [f x], [f y], ..., [f z], then we can eliminate the [path_forall] by explicitly transporting across [H x], [H y], ..., [H z].  The lemma [path_forall_1_beta] expresses this fact in the case that we see [f] applied to only a single argument in [P], and the tactic [transport_path_forall_hammer] is some fancy Ltac to auto-infer what [P] is and what the argument to [f] is.

The way the tactic does this is by creating an evar for [P] and an evar for the argument to [f], and then using a combination of [assert], [pattern], etc to figure out what each should be.  If you want to see how it works, you can step through each step of [transport_path_forall_hammer] when trying to prove [path_forall_2_beta]. *)

(** First, we prove some helpful lemmas about [path_forall] and [transport] *)
Local Ltac path_forall_beta_t :=
  lazymatch goal with
    | [ |- context[@path_forall ?H ?A ?B ?f ?g ?e] ]
      => let X := fresh in
         pose proof (eissect (@path_forall H A B f g) e) as X;
           case X;
           generalize (@path_forall H A B f g e);
           clear X; clear e;
           intro X; destruct X;
           cbn;
           unfold apD10;
           rewrite !(path_forall_1 f)
  end;
  reflexivity.

(** The basic idea is expressed in the type of this lemma. *)
Lemma path_forall_1_beta `{Funext} A B x P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x)) f g (@path_forall _ _ _ _ _ e) Px
  = @transport (B x) P (f x) (g x) (e x) Px.
Proof.
  path_forall_beta_t.
Defined.

(** The powerful recursive case *)
Lemma path_forall_recr_beta' `{Funext} A B x0 P f g e Px
: @transport (forall a : A, B a)
             (fun f => P f (f x0))
             f
             g
             (@path_forall _ _ _ _ _ e)
             Px
  = @transport ((forall a, B a) * B x0)%type
               (fun x => P (fst x) (snd x))
               (f, f x0)
               (g, g x0)
               (path_prod' (@path_forall _ _ _ _ _ e) (e x0))
               Px.
Proof.
  path_forall_beta_t.
Defined.

(** Rewrite the recursive case after clean-up *)
Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px
: @transport (forall a : A, B a)
             (fun f => P f (f x0))
             f
             g
             (@path_forall _ _ _ _ _ e)
             Px
  = @transport (forall x : A, B x)
               (fun x => P x (g x0))
               f
               g
               (@path_forall H A B f g e)
               (@transport (B x0)
                           (fun y => P f y)
                           (f x0)
                           (g x0)
                           (e x0)
                           Px).
Proof.
  etransitivity.
  - apply path_forall_recr_beta'.
  - refine (transport_path_prod' _ _ _ _).
Defined.

(** The sledge-hammer for computing with [transport]ing across a [path_forall].  Note that it uses [rewrite], and so should only be used in opaque proofs. *)

(** This helper tactic takes a [term] and a function [f], finds [f x] in [term] and patterns that, returning a pair [(x, term')] such that [term' (f x) ≡ term]. *)
Ltac pull_app term f :=
  let term' := (eval cbv beta in term) in
  match term' with
    | context[f ?x]
      => match eval pattern (f x) in term' with
           | ?term' (f x) => constr:((x, term'))
         end
  end.

Ltac infer_path_forall_recr_beta term :=
  let path_forall_recr_beta' :=
      match term with
        | @transport _ (fun x => @?P0 x) _ _ (@path_forall ?H ?A ?B ?f ?g ?e) _
          => constr:(fun x0 P Px => @path_forall_recr_beta H A B x0 P f g e Px)
      end in
  let Px := match term with @transport _ _ _ _ _ ?Px => constr:(Px) end in
  let P0 := match term with @transport _ (fun f => @?P0 f) _ _ _ _ => constr:(P0) end in
  (** pattern some [f x0] in [P0] *)
  (** Hopefully, no goal will have a variable called [WORKAROUND_FOR_BUG_3458] in the context.  At least not until bug #3458 is fixed. *)
  let P0f := constr:(fun WORKAROUND_FOR_BUG_3458 => ltac:(
                                                      let ret := pull_app (P0 WORKAROUND_FOR_BUG_3458) WORKAROUND_FOR_BUG_3458 in
                                                      exact ret)) in
  let x0 := match P0f with fun f => (?x0, @?P f) => constr:(x0) end in
  let P := match P0f with fun f => (?x0, @?P f) => constr:(P) end in
  let ret := constr:(path_forall_recr_beta' x0 P Px) in
  let retT := type of ret in
  let ret' := (eval cbv beta in ret) in
  let retT' := (eval cbv beta in retT) in
  constr:(ret' : retT').

Ltac transport_path_forall_hammer_helper :=
  let term := match goal with
                | |- context[@transport ?At (fun x => @?Bt x) ?ft ?gt (@path_forall ?H ?A ?B ?f ?g ?e) ?Px]
                  => constr:(@transport At Bt ft gt (@path_forall H A B f g e) Px)
              end in
  let lem := infer_path_forall_recr_beta term in
  pattern term;
    refine (transport _ lem^ _);
    cbv beta.

Ltac transport_path_forall_hammer :=
  transport_path_forall_hammer_helper;
  rewrite ?transport_const;
  repeat (
      transport_path_forall_hammer_helper;
      rewrite ?transport_const
    ).

(** An example showing that it works *)
Lemma path_forall_2_beta' `{Funext} A B x0 x1 P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
  = @transport (B x0 * B x1)%type (fun x => P (fst x) (snd x)) (f x0, f x1) (g x0, g x1) (path_prod' (e x0) (e x1)) Px.
Proof.
  transport_path_forall_hammer.
  repeat match goal with
           | [ |- context[e ?x] ] => induction (e x)
         end;
    cbn.
  reflexivity.
Qed.

Lemma path_forall_2_beta `{Funext} A B x0 x1 P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
  = transport (fun y : B x1 => P (g x0) y) (e x1)
     (transport (fun y : B x0 => P y (f x1)) (e x0) Px).
Proof.
  transport_path_forall_hammer.
  reflexivity.
Qed.

(** ** A more powerful variant of [path_induction] *)
(** We first define some helper tactics, and then define [path_induction_hammer], which has poor computational behavior, but is vastly more powerful than [path_induction], and removes paths which are discoverably contractible, and paths which only appear in the goal, etc. *)

(** A variant of [induction] which also tries [destruct] and [case], and may be extended to using other [destruct]-like tactics. *)
Ltac induction_hammer H :=
  destruct H || induction H || (case H; clear H).

(** Takes a term of type [_ = _], and tries to replace it by [idpath] by trying to prove that it's an hProp.  The ordering of attempts is tuned for speed. *)
Ltac clear_contr_path p :=
  let H := fresh in
  let T := type of p in
  progress (
      first [ assert (H : idpath = p) by exact (center _)
            | assert (H : idpath = p)
              by (
                  let a := match goal with |- @paths (?x = ?y) ?a ?b => constr:(a) end in
                  let b := match goal with |- @paths (?x = ?y) ?a ?b => constr:(b) end in
                  let x := match goal with |- @paths (?x = ?y) ?a ?b => constr:(x) end in
                  let y := match goal with |- @paths (?x = ?y) ?a ?b => constr:(y) end in
                  apply (@equiv_inv _ _ _ (@equiv_ap _ _ _ (@isequiv_apD10 _ _ _ x y) a b));
                  exact (center _)
                )
            | pose proof (@path_contr T _ idpath p) as H ];
      destruct H;
      (* now reduce any matches on [idpath] (and on other things too) *)
      cbv iota in *
    ).

(** Use both [induction_hammer] and [clear_contr_path] on a path, to try to get rid of it *)
Ltac clear_path_no_check p :=
  induction_hammer p || clear_contr_path p.
Ltac clear_path p :=
  let t := type of p in
  lazymatch eval hnf in t with
    | @paths _ _ _ => clear_path_no_check p || fail 1 "cannot clear path" p
    | _ => fail 0 "clear_path only works on paths;" p "is not a path"
  end.

(** Run [clear_path] on hypotheses *)
(** We don't match only on things of type [_ = _], because maybe that's the head normal form, but it's hiding behind something else; [clear_path] will make sure it's of the right type.  We include some redundant cases at the top, for speed; it is faster to try to destruct everything first, and then do the full battery of tactics, than to just run the hammer. *)
Ltac step_clear_paths :=
  idtac;
  match goal with
    | [ p : _ = _ |- _ ] => destruct p
    | [ p : _ = _ |- _ ] => clear_path_no_check p
    | [ p : _ |- _ ] => clear_path p
  end.
Ltac clear_paths := progress repeat step_clear_paths.

(** Run [clear_path] on anything inside a [match] *)
Ltac step_clear_paths_in_match :=
  idtac;
  match goal with
    | [ |- context[match ?p with idpath => _ end] ] => progress destruct p
    | [ |- context[match ?p with idpath => _ end] ] => clear_path_no_check p
  end.
Ltac clear_paths_in_match := progress repeat step_clear_paths_in_match.

(** Now some lemmas about trivial [match]es *)
Definition match_eta {T} {x y : T} (H0 : x = y)
: (H0 = match H0 in (_ = y) return (x = y) with
          | idpath => idpath
        end)
  := match H0 with idpath => idpath end.

Definition match_eta1 {T} {x : T} (E : x = x)
: (match E in (_ = y) return (x = y) with
     | idpath => idpath
   end = idpath)
  -> idpath = E
  := fun H => ((H # match_eta E) ^)%path.

Definition match_eta2 {T} {x : T} (E : x = x)
: (idpath
   = match E in (_ = y) return (x = y) with
       | idpath => idpath
     end)
  -> idpath = E
  := fun H => match_eta1 E (H ^)%path.

(** And now the actual tactic.  Note that the order of the cases in the [match goal with ... end] is somewhat finely tuned for speed. *)
Ltac step_path_induction_hammer :=
  idtac;
  match goal with
    | _ => reflexivity
    | _ => intro
    | _ => progress cbn in *
    | _ => exact (contr _)
    | [ p : _ = _ |- _ ]
      => progress destruct p (* placed up here for speed *)
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta1 _ H); destruct H'
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta2 _ H); destruct H'
    | _ => step_clear_paths
    | _ => expand; step_clear_paths_in_match
    | _ => progress auto with path_hints
    | _ => done
    | _ => exact (center _)
  end.

Ltac path_induction_hammer := progress repeat step_path_induction_hammer.

(** * Miscellaneous tactics *)

(** Substitute all hypotheses with bodies, i.e., of the form [H := _]. *)
Ltac subst_body :=
  repeat match goal with
           | [ H := _ |- _ ] => subst H
         end.

(** Some tactics to do things with some arbitrary hypothesis in the context.  These tactics are similar to, e.g., [assumption]. *)

Ltac do_with_hyp tac :=
  idtac;
  match goal with
    | [ H : _ |- _ ] => tac H
  end.

Ltac rewrite_hyp' := do_with_hyp ltac:(fun H => rewrite H).
Ltac rewrite_hyp := repeat rewrite_hyp'.
Ltac rewrite_rev_hyp' := do_with_hyp ltac:(fun H => rewrite <- H).
Ltac rewrite_rev_hyp := repeat rewrite_rev_hyp'.

Ltac apply_hyp' := do_with_hyp ltac:(fun H => apply H).
Ltac apply_hyp := repeat apply_hyp'.
Ltac eapply_hyp' := do_with_hyp ltac:(fun H => eapply H).
Ltac eapply_hyp := repeat eapply_hyp'.

(** Run [simpl] on a hypothesis before rewriting with it. *)
Ltac simpl_do_clear tac term :=
  let H := fresh in
  assert (H := term);
    cbn in H |- *;
    tac H;
    clear H.

(** The behavior of [simpl rewrite] with respect to implicit arguments is slightly different from that of [rewrite].  In some ways, it is a little more like [erewrite], but in fact both [rewrite] and [erewrite] use magic that we are unable to exactly duplicate with a user-defined tactic.

The point is that for a user-defined tactic, Coq has to resolve the meaning of the term passed to it in some way before the tactic begins executing.  In particular, if that term involves maximally inserted implicit arguments, then it will have to fill them in; but often there will be no way to do that.  If we declared the argument of [simpl rewrite] as a [constr], then this would cause it to fail.  Instead, we declare it as an [open_constr], which allows Coq to fill in those implicit arguments with existential variables, which can then be instantiated later during the rewriting. *)

Tactic Notation "simpl" "rewrite"      open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    H) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> H) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- H) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- H in hyp) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    H in * ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in * ) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- H in * |- ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    !H) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> !H) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- !H) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    !H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    !H in * ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in * ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    !H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    !H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> !H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- !H in * |- ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    ?H) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> ?H) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- ?H) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    ?H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    ?H in * ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    ?H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    ?H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * |- ) term.

Ltac head_hnf expr := let expr' := eval hnf in expr in head expr'.

(* given a [matcher] that succeeds on some hypotheses and fails on
   others, destruct any matching hypotheses, and then execute [tac]
   after each [destruct].

   The [tac] part exists so that you can, e.g., [simpl in *], to
   speed things up. *)
Ltac destruct_all_matches_then matcher tac :=
  repeat match goal with
           | [ H : ?T |- _ ] => matcher T; destruct H; tac
         end.

Ltac destruct_all_matches matcher := destruct_all_matches_then matcher ltac:(simpl in *).
Ltac destruct_all_matches' matcher := destruct_all_matches_then matcher idtac.

(** matches anything whose type has a [T] in it *)
Ltac destruct_type_matcher T HT :=
  match HT with
    | context[T] => idtac
  end.
Ltac destruct_type T := destruct_all_matches ltac:(destruct_type_matcher T).
Ltac destruct_type' T := destruct_all_matches' ltac:(destruct_type_matcher T).

Ltac destruct_head_matcher T HT :=
  match head HT with
    | T => idtac
  end.
Ltac destruct_head T := destruct_all_matches ltac:(destruct_head_matcher T).
Ltac destruct_head' T := destruct_all_matches' ltac:(destruct_head_matcher T).

Ltac destruct_head_hnf_matcher T HT :=
  match head_hnf HT with
    | T => idtac
  end.
Ltac destruct_head_hnf T := destruct_all_matches ltac:(destruct_head_hnf_matcher T).
Ltac destruct_head_hnf' T := destruct_all_matches' ltac:(destruct_head_hnf_matcher T).

(** Turns a context object, obtained via, e.g., [match goal with |- context G[...] => ... end], into a lambda / gallina function. *)
Ltac context_to_lambda G :=
  let ret := constr:(fun x => let k := x in
                              ltac:(
                                let ret := context G[k] in
                                exact ret)) in
  (eval cbv zeta in ret).