(** * Combi.MPoly.homogsym : Homogenous Symmetric Polynomials *)
(******************************************************************************)
(*      Copyright (C) 2016-2018 Florent Hivert <florent.hivert@lri.fr>        *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
(** * The Space of Homogeneous Symmetric Polynomials

In this file we study the vector space of homogeneous symmetric polynomials.
The main goal is to construct its classical basis and Cauchy's scalar product.

- [f \is d.-homsym] == f is a homogenerous of degree d symmetric polynomial.
- [f \is [in R[n], d.-homsym]] == idem specifying the ring and number of
                     variables.
- [{homsym R[n, d]}] == the space of homogenerous of degree [d] symmetric
                     polynomials in [n] variables over [R].
- [p *h q]        == the product of two homogeneous symmetric polynomial as a
                     homogeneous symmetric polynomials.

The classical bases:

- ['he[la]]       == the elementary hom. sym. poly. associated to [la]
- ['hh[la]]       == the complete   hom. sym. poly. associated to [la]
- ['hp[la]]       == the power sum  hom. sym. poly. associated to [la]
- ['hm[la]]       == the monomial   hom. sym. poly. associated to [la]
- ['hs[la]]       == the Schur      hom. sym. poly. associated to [la]

- [in_homsym d p] == if [p] is a polynomial [{mpoly R[n]}] which is both
                     symmetric and homogeneous of degree [d], return it as a
                     [{homsym R[n, d]}]. It is canonically linear.

- ['he]           == the elementary hom. sym. basis
- ['hh]           == the complete   hom. sym. basis
- ['hp]           == the power sum  hom. sym. basis
- ['hm]           == the monomial   hom. sym. basis
- ['hs]           == the Schur      hom. sym. basis

The omega involution

- [omegahomsym f] == the image of f under the omega involution.

Changing the base ring and the number of variables:

- [intpart_of_mon m] == if [m] is the monomial [x_1^{i_1}x_2^{i_2}...x_n^{i_n}]
                     returns the integer partition [n^{i_n}...2^{i_2}1^{i_1}]
- [intpartn_of_mon H] == the same as an [intpart_of_mon d] where [H] is a proof of
                     [mnmwgt m = d]

- [map_homsym mor f] == change the base ring of the hom. sym. poly [f] using
                     the ring morphism [mor]. This is canonically additive.
- [cnvarhomsym n f] == change the number of variables of the hom. sym. poly
                     [f] by sending elementary to elementary. This is
                     canonically linear.

The scalar product:

- ['[ u | v ]]    == the scalar product of hom. sym. poly., only defined over
                     the field [algC].
- ['[ u | v ] _(n, d)] == the scalar product of hom. sym. poly. specifying
                     the number of variable and degree.

The main results are [symbm_basis], [symbe_basis], [symbs_basis],
[symbh_basis], [symbp_basis] which asserts that they are all bases (if the
characteristic of the base ring is zero for [symbp_basis]), and the definition
of the scalar product.
 *)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp Require Import finset path tuple bigop ssralg order.
From mathcomp Require Import perm fingroup matrix vector.
From mathcomp Require ssrnum algC.
From SsrMultinomials Require Import ssrcomplements freeg mpoly.

Require Import tools sorted ordtype permuted partition permcent.
Require Import antisym Schur_mpoly Schur_altdef sympoly.

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

Import GRing.Theory.

Local Open Scope ring_scope.

Reserved Notation "{ 'homsym' T [ n , d ] }"
  (at level 0, T, n, d at level 2, format "{ 'homsym'  T [ n ,  d ] }").
Reserved Notation "'[ p | q ]"
  (at level 2, format "'[hv' ''[' p  | '/ '  q ] ']'").
Reserved Notation "'[ p | q ] _( R , n )"
  (at level 2, format "'[hv' ''[' p  | '/ '  q ] ']' '_(' R ,  n )").

Definition ishomogsym1 {n} {R : ringType} (d : nat) :
  qualifier 0 {sympoly R[n]} := [qualify p | sympol p \is d.-homog].

Module SymPolyHomogKey.
Fact homogsym1_key {n} {R : ringType} d : pred_key (@ishomogsym1 n R d).
Proof. by []. Qed.
Definition homogsym1_keyed {n R} d := KeyedQualifier (@homogsym1_key n R d).
End SymPolyHomogKey.
Canonical SymPolyHomogKey.homogsym1_keyed.

Notation "d .-homsym" := (@ishomogsym1 _ _ d)
  (at level 1, format "d .-homsym") : form_scope.
Notation "[ 'in' R [ n ] , d .-homsym ]" := (@ishomogsym1 n R d)
  (at level 0, R, n at level 2, d at level 0,
     format "[ 'in'  R [ n ] ,  d .-homsym ]") : form_scope.

(** ** Homogeneous symmetric polynomials *)
Section DefType.

Variable n : nat.
Variable R : ringType.
Variable d : nat.

Implicit Types p q : {sympoly R[n]}.

Lemma homsymE p : (p \is d.-homsym) = (sympol p \is d.-homog).
Proof. by []. Qed.

Fact symdhom_submod_closed : submod_closed [in R[n], d.-homsym].
Proof.
split => [|a p q Hp Hq]; rewrite !homsymE.
- exact: dhomog0.
- by apply rpredD => //; apply rpredZ.
Qed.
Canonical symdhom_addPred    := AddrPred   symdhom_submod_closed.
Canonical symdhom_oppPred    := OpprPred   symdhom_submod_closed.
Canonical symdhom_zmodPred   := ZmodPred   symdhom_submod_closed.
Canonical symdhom_submodPred := SubmodPred symdhom_submod_closed.

Hypothesis Hvar : (d <= n.+1)%N.

Record homogsym : predArgType :=
  HomogSym {homsym :> {sympoly R[n]}; _ : homsym \is d.-homsym }.

Canonical  homogsym_subType := Eval hnf in [subType for @homsym].
Definition homogsym_eqMixin := Eval hnf in [eqMixin of homogsym by <:].
Canonical  homogsym_eqType  := Eval hnf in EqType homogsym homogsym_eqMixin.

Definition homogsym_choiceMixin := [choiceMixin of homogsym by <:].
Canonical  homogsym_choiceType  :=
  Eval hnf in ChoiceType homogsym homogsym_choiceMixin.

Definition homogsym_of of phant R := homogsym.

Identity Coercion type_homsym_of : homogsym_of >-> homogsym.

Lemma homsym_inj : injective homsym. Proof. exact: val_inj. Qed.

End DefType.

(* We need to break off the section here to let the argument scope *)
(* directives take effect.                                         *)
Bind Scope ring_scope with homogsym_of.
Bind Scope ring_scope with homogsym.
Arguments homogsym n%N R%R.
Arguments homsym_inj n%N R%R d%N.

Notation "{ 'homsym' T [ n , d ] }" := (homogsym_of n d (Phant T)).

Section HomogSymLModType.

Variable n : nat.
Variable R : ringType.
Variable d : nat.

Definition homogsym_zmodMixin := [zmodMixin of {homsym R[n, d]} by <:].
Canonical  homogsym_zmodType  :=
  Eval hnf in ZmodType {homsym R[n, d]} homogsym_zmodMixin.
Canonical  homogsymen_zmodType  :=
  Eval hnf in ZmodType (homogsym n R d) homogsym_zmodMixin.

Definition homogsym_lmodMixin := [lmodMixin of {homsym R[n, d]} by <:].
Canonical  homogsym_lmodType  :=
  Eval hnf in LmodType R {homsym R[n, d]} homogsym_lmodMixin.
Canonical  homogsymen_lmodType :=
  Eval hnf in LmodType R (homogsym n R d) homogsym_lmodMixin.

Lemma homsym_is_linear :
  linear (@homsym n R d : {homsym R[n, d]} -> {sympoly R[n]}).
Proof. by []. Qed.
Canonical homsym_additive   := Additive   homsym_is_linear.
Canonical homsym_linear     := AddLinear  homsym_is_linear.

Lemma homsym_is_dhomog (x : {homsym R[n, d]}) : sympol x \is d.-homog.
Proof. by case: x. Qed.

(*
Coercion dhomog_of_homogsym (p : {homsym R[n, d]}) :=
  DHomog (homsym_is_dhomog p).

Lemma dhomog_of_sym_is_linear : linear (@homsym n R d).
Proof. by []. Qed.
Canonical dhomog_of_sym_additive := Additive  dhomog_of_sym_is_linear.
Canonical dhomog_of_sym_linear   := AddLinear dhomog_of_sym_is_linear.
 *)

End HomogSymLModType.

Import GRing.Theory.
Local Open Scope ring_scope.

(** ** Homogeneous symmetric polynomials as a vector space *)
Section Vector.

Variable n0 : nat.
Local Notation n := (n0.+1).
Variable R : comRingType.

Variable d : nat.
Local Notation SF := {sympoly R[n]}.
Implicit Type (la : 'P_d).

Definition homsymm la : {homsym R[n, d]} := HomogSym (symm_homog n R la).
Definition homsyme la : {homsym R[n, d]} := HomogSym (prod_syme_homog n R la).
Definition homsymh la : {homsym R[n, d]} := HomogSym (prod_symh_homog n R la).
Definition homsymp la : {homsym R[n, d]} := HomogSym (prod_symp_homog n R la).
Definition homsyms la : {homsym R[n, d]} := HomogSym (syms_homog n0 R la).

Lemma homsymmE (f : {homsym R[n, d]}) :
  f = \sum_(l : 'P_d) f@_(mpart l) *: homsymm l.
Proof.
by apply val_inj; rewrite /= {1}(homog_symmE (homsym_is_dhomog f)) !linear_sum.
Qed.

Fact homogsym_vecaxiom :
  Vector.axiom #|[set p : 'P_d | size p <= n]| {homsym R[n, d]}.
Proof.
pose b := [set p : 'P_d | size p <= n].
pose t := enum_tuple (pred_of_set b).
have sztntht k : size (tnth t k) <= n.
  by have := mem_tnth k t; rewrite /t mem_enum inE.
exists (fun p : {homsym R[n, d]} => \row_(i < #|b|) p@_(mpart (tnth t i))).
  by move=> c p q; apply/matrixP=> i j; rewrite !mxE /= mcoeffD mcoeffZ.
exists (fun r : 'rV[R]_(#|b|) =>
          \sum_(i < #|b|) (r ord0 i) *: (homsymm (tnth t i))).
- move=> p; rewrite [RHS]homsymmE.
  rewrite (bigID (mem b)) /= [X in _ + X]big1 ?addr0 => [|la]; first last.
    rewrite inE => /negbTE H .
    by apply val_inj; apply val_inj; rewrite /= /symm H scaler0.
  rewrite [RHS](eq_bigl (fun la => la \in b)); first last.
    by move=> i /=; rewrite inE.
  rewrite -[RHS]big_enum /= -[enum _]/(tval t).
  rewrite big_tuple; apply eq_bigr => i _; congr (_ *: _).
  by rewrite mxE.
- move=> r /=; apply/matrixP=> i j.
  rewrite mxE !raddf_sum ord1 /= (bigD1 j) //=.
  rewrite !linearZ /= mcoeff_symm ?sztntht //.
  rewrite perm_refl mulr1 big1 ?addr0 //.
  move=> k Hkj.
  rewrite !linearZ /= mcoeff_symm ?sztntht //.
  suff : ~~(perm_eq (mpart (n := n) (tnth t k)) (mpart (n := n) (tnth t j))).
    by move /negbTE ->; rewrite mulr0.
  move: Hkj; apply contra => /perm_partm/(congr1 val)/eqP.
  rewrite /= !mpartK // !(tnth_nth (rowpartn d)) /t /= => H.
  apply/eqP/val_inj/eqP => /=.
  by rewrite -(nth_uniq (rowpartn d) _ _ (enum_uniq (pred_of_set b))) // -cardE.
Qed.
Definition homogsym_vectMixin := VectMixin homogsym_vecaxiom.
Canonical homogsym_vectType :=
  Eval hnf in VectType R {homsym R[n, d]} homogsym_vectMixin.

End Vector.

Notation "''he[' k ]" := (homsyme _ _ k)
                              (at level 8, k at level 2, format "''he[' k ]").
Notation "''hh[' k ]" := (homsymh _ _ k)
                              (at level 8, k at level 2, format "''hh[' k ]").
Notation "''hp[' k ]" := (homsymp _ _ k)
                              (at level 8, k at level 2, format "''hp[' k ]").
Notation "''hm[' k ]" := (homsymm _ _ k)
                              (at level 8, k at level 2, format "''hm[' k ]").
Notation "''hs[' k ]" := (homsyms _ _ k)
                              (at level 8, k at level 2, format "''hs[' k ]").

(** ** Products of homogeneous symmetric polynomials *)
Section HomogSymProd.

Variable n : nat.
Variable R : comRingType.
Variable c d : nat.

Fact homsymprod_subproof (p : {homsym R[n, c]}) (q : {homsym R[n, d]}) :
  homsym p * homsym q \is (c + d).-homsym.
Proof. by apply: dhomogM => /=; apply: homsym_is_dhomog. Qed.
Canonical homsymprod p q : {homsym R[n, c + d]} :=
  HomogSym (homsymprod_subproof p q).
Definition homsymprodr_head k p q := let: tt := k in homsymprod q p.

Notation homsymprodr := (homsymprodr_head tt).
Local Notation "p *h q" := (homsymprod p q)
                             (at level 20, format "p  *h  q").

Fact homsymprod_is_linear p : linear (homsymprod p).
Proof.
by move=> a /= u v; apply val_inj; rewrite /= mulrDr -scalerAr.
Qed.
Canonical homsymprod_additive p := Additive (homsymprod_is_linear p).
Canonical homsymprod_linear p := Linear (homsymprod_is_linear p).

Lemma homsymprodrE p q : homsymprodr p q = q *h p. Proof. by []. Qed.
Lemma homsymprodr_is_linear p : linear (homsymprodr p).
Proof.
by move=> a /= u v; apply val_inj; rewrite /= mulrDl -scalerAl.
Qed.
Canonical homsymprodr_additive p := Additive (homsymprodr_is_linear p).
Canonical homsymprodr_linear p := Linear (homsymprodr_is_linear p).

Lemma homsymprod0r p : p *h 0 = 0. Proof. exact: raddf0. Qed.
Lemma homsymprodBr p q1 q2 : p *h (q1 - q2) = p *h q1 - p *h q2.
Proof. exact: raddfB. Qed.
Lemma homsymprodNr p q : p *h (- q) = - p *h q.
Proof. exact: raddfN. Qed.
Lemma homsymprodDr p q1 q2 : p *h (q1 + q2) = p *h q1 + p *h q2.
Proof. exact: raddfD. Qed.
Lemma homsymprodMnr p q m : p *h (q *+ m) = (p *h q) *+ m.
Proof. exact: raddfMn. Qed.
Lemma homsymprod_sumr p I r (P : pred I) (q : I -> {homsym R[n, d]}) :
  p *h (\sum_(i <- r | P i) q i) = \sum_(i <- r | P i) p *h q i.
Proof. exact: raddf_sum. Qed.
Lemma homsymprodZr a p q : p *h (a *: q) = a *: (p *h q).
Proof. by rewrite linearZ. Qed.

Lemma homsymprod0l p : 0 *h p = 0.
Proof. by rewrite -homsymprodrE linear0. Qed.
Lemma homsymprodNl p q : (- q) *h p = - q *h p.
Proof. by rewrite -!homsymprodrE linearN. Qed.
Lemma homsymprodDl p q1 q2 : (q1 + q2) *h p = q1 *h p + q2 *h p.
Proof. by rewrite -!homsymprodrE linearD. Qed.
Lemma homsymprodBl p q1 q2 : (q1 - q2) *h p = q1 *h p - q2 *h p.
Proof. by rewrite -!homsymprodrE linearB. Qed.
Lemma homsymprodMnl p q m : (q *+ m) *h p = q *h p *+ m.
Proof. by rewrite -!homsymprodrE linearMn. Qed.
Lemma homsymprod_suml p I r (P : pred I) (q : I -> {homsym R[n, c]}) :
  (\sum_(i <- r | P i) q i) *h p = \sum_(i <- r | P i) q i *h p.
Proof. by rewrite -!homsymprodrE linear_sum. Qed.
Lemma homsymprodZl p a q : (a *: q) *h p = a *: q *h p.
Proof. by rewrite -!homsymprodrE linearZ. Qed.

End HomogSymProd.

Notation homsymprodr := (homsymprodr_head tt).
Notation "p *h q" := (homsymprod p q)
                       (at level 20, format "p  *h  q").

Section HomSymProdGen.

Variable n0 : nat.
Local Notation n := (n0.+1).
Variable R : comRingType.
Local Notation HSF := {homsym R[n, _]}.

Import LeqGeqOrder.

Variables (d l0 : nat) (la : seq nat).
Hypotheses (Hla : is_part_of_n d la)
           (Hlla : is_part_of_n (l0 + d)%N (l0 :: la)).
Notation Plla := (IntPartN Hlla).
Notation Pla := (IntPartN Hla).

Lemma homsymprod_hh : 'hh[Plla] = 'hh[rowpartn l0] *h 'hh[Pla] :> HSF.
Proof. by apply val_inj; rewrite /= prod_genM intpartn_cons. Qed.
Lemma homsymprod_he : 'he[Plla] = 'he[rowpartn l0] *h 'he[Pla] :> HSF.
Proof. by apply val_inj; rewrite /= prod_genM intpartn_cons. Qed.
Lemma homsymprod_hp : 'hp[Plla] = 'hp[rowpartn l0] *h 'hp[Pla] :> HSF.
Proof. by apply val_inj; rewrite /= prod_genM intpartn_cons. Qed.

End HomSymProdGen.

Section InHomSym.

Variable n0 d : nat.
Local Notation n := (n0.+1).
Variable R : comRingType.
Local Notation Pol := {mpoly R[n]}.
Local Notation HSF := {homsym R[n, d]}.

Local Notation "''pi_' d" :=
  (pihomog [measure of mdeg] d) (at level 5, format "''pi_' d").

(** TODO: Contribute to Pierre-Yves's multinomials *)
Lemma msym_pihomog nv s (p : {mpoly R[nv]}) :
  msym s ('pi_d p) = 'pi_d (msym s p).
Proof.
rewrite (mpolyE p) ![_ (\sum_(m <- msupp p) _)]linear_sum /=.
rewrite [msym s _]linear_sum linear_sum /=.
apply eq_bigr => m _; rewrite !linearZ /=; congr (_ *: _).
rewrite msymX !pihomogX /=.
have -> : mdeg [multinom m ((s^-1)%g i) | i < nv] = mdeg m.
  rewrite /mdeg; apply perm_big.
  by apply/tuple_permP; exists (s^-1)%g.
by case: (mdeg m == d); rewrite ?msym0 ?msymX.
Qed.

Lemma pihomog_sym nv (p : {mpoly R[nv]}) :
  p \is symmetric -> 'pi_d p \is symmetric.
Proof. by move=> /issymP Hp; apply/issymP => s; rewrite msym_pihomog Hp. Qed.

Definition in_homsym (p : Pol) : HSF :=
  \sum_(la : 'P_d) p@_(mpart la) *: 'hm[la].

Fact in_homsym_is_linear : linear in_homsym.
Proof.
rewrite /in_homsym => a u v.
rewrite linear_sum /= -big_split /=; apply eq_bigr => la _.
by rewrite scalerA -scalerDl mcoeffD mcoeffZ.
Qed.
Canonical in_homsym_additive := Additive  in_homsym_is_linear.
Canonical in_homsym_linear   := AddLinear in_homsym_is_linear.

Lemma in_homsymE (p : HSF) : in_homsym p = p.
Proof. by rewrite {2}(homsymmE p). Qed.

End InHomSym.

(** ** The omega involution *)
Section OmegaHomSym.

Variable n0 d : nat.
Local Notation n := (n0.+1).
Variable R : comRingType.
Local Notation HSF := {homsym R[n, d]}.
Implicit Types (p q : HSF) (la : intpartn d).

Fact omegahomsym_subproof p : omegasf p \is d.-homsym.
Proof using. by apply: omegasf_homog; rewrite -homsymE; case: p. Qed.
Definition omegahomsym p : HSF := HomogSym (omegahomsym_subproof p).
Fact omegahomsym_is_linear : linear omegahomsym.
Proof using.
by move=> a f g; apply val_inj; rewrite /= !linearD !linearZ /=.
Qed.
Canonical omegahomsym_additive   := Additive  omegahomsym_is_linear.
Canonical omegahomsym_linear     := AddLinear omegahomsym_is_linear.

Lemma omega_homsymh la :
  head 0%N la <= n -> omegahomsym 'hh[la] = 'he[la].
Proof using. by move=> Hd; apply val_inj; rewrite /= omegasf_prodsymh. Qed.
Lemma omega_homsyme la :
  head 0%N la <= n -> omegahomsym 'he[la] = 'hh[la].
Proof using. by move=> Hd; apply val_inj; rewrite /= omegasf_prodsyme. Qed.
Lemma omega_homsyms la :
  d <= n -> omegahomsym 'hs[la] = 'hs[conj_intpartn la].
Proof using. by move=> Hd; apply val_inj; rewrite /= omegasf_syms. Qed.
Lemma omega_homsymp la :
  head 0%N la <= n -> omegahomsym 'hp[la] = (-1) ^+ (d - size la) *: 'hp[la].
Proof using. by move=> Hd; apply val_inj; rewrite /= omegasf_prodsymp. Qed.

End OmegaHomSym.

Section OmegaProd.

Variable n0 : nat.
Local Notation n := (n0.+1).
Variable R : comRingType.

Lemma omegahomsym_rmorph c d (p : {homsym R[n, c]}) (q : {homsym R[n, d]}) :
  omegahomsym (p *h q) = (omegahomsym p) *h (omegahomsym q).
Proof. by apply val_inj; rewrite /= rmorphM. Qed.

End OmegaProd.

(** * The classical bases of homogeneous symmetric polynomials *)
Section HomSymField.

Variable n0 d : nat.
Local Notation n := (n0.+1).
Variable R : fieldType.
Local Notation HSF := {homsym R[n, d]}.

Local Notation Basis := (#|{:'P_d}|.-tuple HSF).
Definition symbe : Basis := [tuple of [seq 'he[la] | la : 'P_d]].
Definition symbh : Basis := [tuple of [seq 'hh[la] | la : 'P_d]].
Definition symbm : Basis := [tuple of [seq 'hm[la] | la : 'P_d]].
Definition symbs : Basis := [tuple of [seq 'hs[la] | la : 'P_d]].
Definition symbp : Basis := [tuple of [seq 'hp[la] | la : 'P_d]].

Hypothesis Hd : (d <= n)%N.

Lemma basis_homsym : [set p : 'P_d | (size p <= n)%N] =i {:'P_d}.
Proof using Hd.
move=> la.
rewrite !inE; apply: (leq_trans _ Hd).
by rewrite -[X in (_ <= X)%N](sumn_intpartn la); apply: size_part.
Qed.

Lemma dim_homsym :
  \dim (fullv (vT := [vectType R of HSF])) = #|{:'P_d}|.
Proof using Hd.
by rewrite dimvf /Vector.dim /=; apply eq_card; apply basis_homsym.
Qed.

Lemma symbm_free : free symbm.
Proof using Hd.
apply/freeP => co.
rewrite (reindex _ (onW_bij _ (@enum_rank_bij [finType of 'P_d]))) /=.
rewrite (eq_bigr (fun la : 'P_d => (co (enum_rank la)) *: 'hm[la])); first last.
  move=> la _; rewrite (nth_map (rowpartn _)) /= -?cardE ?ltn_ord //.
  by rewrite -?enum_val_nth enum_rankK.
move => /(congr1 val).
rewrite /= linear_sum /= => /symm_unique0 H i.
rewrite -(enum_valK i); apply H.
apply: (leq_trans _ Hd).
rewrite -[X in (_ <= X)%N](sumn_intpartn (enum_val i)).
exact: size_part.
Qed.

Lemma symbm_basis : basis_of fullv symbm.
Proof using Hd.
by rewrite basisEfree symbm_free subvf size_map size_tuple /= dim_homsym.
Qed.

Lemma symbs_basis : basis_of fullv symbs.
Proof using Hd.
rewrite basisEdim size_map size_tuple dim_homsym leqnn andbT.
rewrite -(span_basis symbm_basis).
apply/span_subvP => s /mapP [/= la]; rewrite !mem_enum => _ ->{s}.
have -> : 'hm[la] = \sum_(mu : 'P_d) 'K^-1(la, mu) *: 'hs[mu] :> HSF.
  by apply val_inj; rewrite /= (symm_syms _ _ la) !linear_sum.
rewrite span_def; apply memv_suml => mu _; apply memvZ.
rewrite big_map (bigD1_seq mu) /= ?mem_enum ?inE ?enum_uniq //.
rewrite -[X in X \in _]addr0.
by apply memv_add; [exact: memv_line | exact: mem0v].
Qed.
Lemma symbs_free : free symbs.
Proof. exact/basis_free/symbs_basis. Qed.

Theorem mcoeff_symbs (la : 'P_d) f :
  coord symbs (enum_rank la) f =
  (alternpol 'X_[rho n] * sympol (homsym f))@_(mpart la + rho n).
Proof.
have /coord_span -> : f \in span symbs.
  by rewrite (span_basis symbs_basis) memvf.
rewrite !coord_sum_free ?(basis_free symbs_basis) //.
rewrite (reindex _ (onW_bij _ (@enum_rank_bij [finType of 'P_d]))) /=.
rewrite !linear_sum /= mulr_sumr linear_sum /= (bigD1 la) //=.
rewrite (nth_map (rowpartn d)) -?cardE ?ltn_ord // nth_enum_rank.
rewrite -scalerAr linearZ /=.
have Hszp (nu : 'P_d) : size nu <= n.
  by apply: (leq_trans _ Hd); rewrite -{2}(sumn_intpartn nu) size_part.
rewrite mcoeff_alt_SchurE // eq_refl mulr1 big1 ?addr0 // => mu /negbTE Hmula.
rewrite (nth_map (rowpartn d)) -?cardE ?ltn_ord // nth_enum_rank.
rewrite -scalerAr linearZ /=.
by rewrite mcoeff_alt_SchurE // Hmula mulr0.
Qed.

Local Notation E := [tuple mesym n R i.+1 | i < n].

Definition intpart_of_mon m : seq nat :=
  rev (flatten [tuple nseq (m i) i.+1 | i < n]).

Lemma intpart_of_monP m : mnmwgt m = d -> is_part_of_n d (intpart_of_mon m).
Proof using.
rewrite /mnmwgt => H.
rewrite /= is_part_sortedE; apply/and3P; split.
- rewrite /intpart_of_mon sumn_rev sumn_flatten -[X in _ == X]H.
  rewrite sumnE big_map big_tuple.
  apply/eqP/eq_bigr => /= i _.
  by rewrite sumnE tnth_mktuple big_nseq iter_addn_0 mulnC.
- rewrite /intpart_of_mon /= rev_sorted.
  apply/(sorted.sortedP 0%N) => //=; first exact: leq_trans.
  move=> i j; rewrite !nth_flatten.
  rewrite size_flatten.
  have -> : shape [seq nseq (m i0) i0.+1 | i0 : 'I_n] = m.
    rewrite /shape -map_comp (tuple_map_ord m) /=.
    apply eq_map => k /=.
    by rewrite size_nseq.
  move=> /andP [Hij Hjm]; have Him := leq_ltn_trans Hij Hjm.
  have:= reshape_indexP Hjm; have:= reshape_offsetP Hjm.
  have:= reshape_indexP Him; have:= reshape_offsetP Him.
  rewrite size_tuple => Hc1 Hr1 Hc2 Hr2.
  do 2 (rewrite (nth_map ord0); last by rewrite size_enum_ord).
  rewrite !(mnm_nth 0) !nth_nseq !nth_enum_ord //= {Hr1 Hr2}.
  rewrite {}Hc1 {}Hc2 ltnS; move: Hij.
  by rewrite (reshape_leq m) => /orP [/ltnW | /andP [/eqP ->]].
- rewrite /intpart_of_mon; rewrite mem_rev; apply/flatten_mapP => /= [[s _]].
  by move=> /nseqP [].
Qed.
Canonical intpartn_of_mon m (H : mnmwgt m = d) := IntPartN (intpart_of_monP H).

Local Lemma Esym : (forall i : 'I_n, E`_i \is symmetric).
Proof using.
move=> i; rewrite (nth_map i) ?size_tuple //.
by rewrite -tnth_nth tnth_ord_tuple mesym_sym.
Qed.

Lemma comp_symbe m (H : mnmwgt m = d) :
  'X_[m] \mPo E = 'he[intpartn_of_mon H].
Proof using.
rewrite comp_mpolyX /= /prod_gen /intpartn_of_mon /intpart_of_mon /=.
rewrite rmorph_prod /= [RHS](perm_big _ (permEl (perm_rev _))) /=.
rewrite big_flatten /= big_map /= -big_enum /=; apply eq_bigr => i _.
rewrite big_nseq tnth_mktuple.
by rewrite -big_const_ord prodr_const cardT -cardE card_ord.
Qed.

Lemma in_homsym_comp_symbe m (H : mnmwgt m = d) :
  in_homsym d ('X_[m] \mPo E) = 'he[intpartn_of_mon H].
Proof using. by rewrite comp_symbe in_homsymE. Qed.

Lemma symbe_basis : basis_of fullv symbe.
Proof using Hd.
rewrite basisEdim size_map size_tuple dim_homsym leqnn andbT.
apply/subvP => /= p _; rewrite span_def big_map.
have:= sym_fundamental_homog (sympolP p) (homsym_is_dhomog p).
move=> [t [Hp /dhomogP Hhomt]].
have {Hp} -> : p = \sum_(m <- msupp t) t@_m *: in_homsym d ('X_[m] \mPo E).
  apply val_inj; apply val_inj; rewrite /= -{1}Hp {1}(mpolyE t) {Hp}.
  rewrite !linear_sum /=; apply eq_big_seq => m /Hhomt /= Hm.
  rewrite !linearZ /=; congr (_ *: _).
  by rewrite in_homsym_comp_symbe /= comp_symbe /=.
rewrite big_seq; apply memv_suml => m Hm; apply memvZ.
rewrite (in_homsym_comp_symbe (Hhomt m Hm)).
move: (intpartn_of_mon _) => {m Hm} la.
rewrite (bigD1_seq la) /= ?mem_enum ?inE ?enum_uniq //.
rewrite -[X in X \in _]addr0.
apply memv_add; first exact: memv_line.
exact: mem0v.
Qed.
Lemma symbe_free : free symbe.
Proof. exact/basis_free/symbe_basis. Qed.

Lemma symbh_basis : basis_of fullv symbh.
Proof using Hd.
rewrite basisEdim size_map size_tuple dim_homsym leqnn andbT.
rewrite -(span_basis symbe_basis).
apply/span_subvP => s /mapP [/= la]; rewrite !mem_enum => _ ->{s}.
have -> : 'he[la] = \sum_(mu : 'P_d) coeff_prodgen (fun d (la : 'P_d) =>
            (-1)^+(d - size la) * (perm_partn la)%:R) la mu *: 'hh[mu] :> HSF.
  by apply val_inj; rewrite /= linear_sum /= (prod_prodgen (syme_to_symh n0 R)).
rewrite span_def; apply memv_suml => mu _; apply memvZ.
rewrite big_map (bigD1_seq mu) /= ?mem_enum ?inE ?enum_uniq //.
rewrite -[X in X \in _]addr0.
by apply memv_add; [exact: memv_line | exact: mem0v].
Qed.
Lemma symbh_free : free symbh.
Proof. exact/basis_free/symbh_basis. Qed.

Lemma symbp_basis : [char R] =i pred0 -> basis_of fullv symbp.
Proof using Hd.
move=> Hchar.
rewrite basisEdim size_map size_tuple dim_homsym leqnn andbT.
rewrite -(span_basis symbh_basis).
apply/span_subvP => s /mapP [/= la]; rewrite !mem_enum => _ ->{s}.
pose co := fun (n : nat) (l : 'P_n) => (permcent.zcard l)%:R^-1 : R.
have -> : 'hh[la] = \sum_(mu : 'P_d)
                     coeff_prodgen co la mu *: 'hp[mu] :> HSF.
  apply val_inj; rewrite /= linear_sum /=.
  by rewrite (prod_prodgen (fun n => symh_to_symp n0 n Hchar)).
rewrite span_def; apply memv_suml => mu _; apply memvZ.
rewrite big_map (bigD1_seq mu) /= ?mem_enum ?inE ?enum_uniq //.
rewrite -[X in X \in _]addr0.
by apply memv_add; [exact: memv_line | exact: mem0v].
Qed.
Lemma symbp_free : [char R] =i pred0 -> free symbp.
Proof. by move=> Hchar; apply/basis_free/symbp_basis. Qed.

End HomSymField.

Notation "''he'" := (symbe _ _ _) (at level 8, format "''he'").
Notation "''hh'" := (symbh _ _ _) (at level 8, format "''hh'").
Notation "''hp'" := (symbp _ _ _) (at level 8, format "''hp'").
Notation "''hm'" := (symbm _ _ _) (at level 8, format "''hm'").
Notation "''hs'" := (symbs _ _ _) (at level 8, format "''hs'").

(** ** Changing the base field *)
Section ChangeField.

Variable R S : fieldType.
Variable mor : {rmorphism R -> S}.

Variable n0 d : nat.
Local Notation n := (n0.+1).
Local Notation HSFR := {homsym R[n, d]}.
Local Notation HSFS := {homsym S[n, d]}.

Fact map_sympoly_d_homog (p : HSFR) : map_sympoly mor p \is d.-homsym.
Proof.
rewrite homsymE /=; apply/dhomogP => /= m.
rewrite mcoeff_msupp mcoeff_map_mpoly => Hm.
have {Hm} : p@_m != 0.
  move: Hm; apply contra => /eqP ->.
  by apply/eqP; apply: (rmorph0 mor).
rewrite -mcoeff_msupp => Hm.
by have /dhomogP/(_ _ Hm) := homsym_is_dhomog p.
Qed.
Definition map_homsym (p : HSFR) : HSFS := HomogSym (map_sympoly_d_homog p).

Fact map_homsym_is_additive : additive map_homsym.
Proof. by move=> /= p q; apply val_inj; rewrite /= rmorphB. Qed.
Canonical map_homsym_additive := Additive map_homsym_is_additive.

Lemma scale_map_homsym (r : R) (p : HSFR) :
  map_homsym (r *: p) = (mor r) *: (map_homsym p).
Proof. by apply val_inj; rewrite /= scale_map_sympoly. Qed.

Lemma coord_map_homsym (b : #|{:'P_d}|.-tuple HSFR) j (f : HSFR) :
  basis_of fullv b ->
  basis_of fullv (map_tuple map_homsym b) ->
  coord (map_tuple map_homsym b) j (map_homsym f) = mor (coord b j f).
Proof.
move=> Hbasis Hmap_basis.
have toSf : f \in span b by rewrite (span_basis Hbasis) // memvf.
rewrite {1}(coord_span toSf) raddf_sum /=.
rewrite (eq_bigr
           (fun i : 'I_#|{:'P_d}| =>
              (mor (coord b i f)) *: (map_tuple map_homsym b)`_i )).
  by rewrite coord_sum_free //; apply: (basis_free Hmap_basis).
move=> i _; rewrite /= scale_map_homsym.
congr (_ *: _); apply esym; apply nth_map.
by rewrite size_tuple ltn_ord.
Qed.

Lemma map_homsymm la : map_homsym 'hm[la] = 'hm[la].
Proof. by apply val_inj; rewrite /= map_symm. Qed.
Lemma map_homsyme la : map_homsym 'he[la] = 'he[la].
Proof. by apply val_inj; rewrite /= map_syme_prod. Qed.
Lemma map_homsymh la : map_homsym 'hh[la] = 'hh[la].
Proof. by apply val_inj; rewrite /= map_symh_prod. Qed.
Lemma map_homsymp la : map_homsym 'hp[la] = 'hp[la].
Proof. by apply val_inj; rewrite /= map_symp_prod. Qed.
Lemma map_homsyms la : map_homsym 'hs[la] = 'hs[la].
Proof. by apply val_inj; rewrite /= map_syms. Qed.

Lemma map_homsymbm : map_tuple map_homsym 'hm = 'hm.
Proof. by apply eq_from_tnth => i; rewrite !tnth_map map_homsymm. Qed.
Lemma map_homsymbe : map_tuple map_homsym 'he = 'he.
Proof. by apply eq_from_tnth => i; rewrite !tnth_map map_homsyme. Qed.
Lemma map_homsymbh : map_tuple map_homsym 'hh = 'hh.
Proof. by apply eq_from_tnth => i; rewrite !tnth_map map_homsymh. Qed.
Lemma map_homsymbp : map_tuple map_homsym 'hp = 'hp.
Proof. by apply eq_from_tnth => i; rewrite !tnth_map map_homsymp. Qed.
Lemma map_homsymbs : map_tuple map_homsym 'hs = 'hs.
Proof. by apply eq_from_tnth => i; rewrite !tnth_map map_homsyms. Qed.

End ChangeField.

(** ** Extracting coords *)
Section Coord.

Variable n0 d : nat.
Local Notation n := (n0.+1).
Variable R : fieldType.
Local Notation HSF := {homsym R[n, d]}.
Implicit Type (la : 'P_d).

Lemma symbmE la : ('hm)`_(enum_rank la) = 'hm[la] :> HSF.
Proof. by rewrite /symbm tupleE /= (nth_map la) ?nth_enum_rank // -cardE. Qed.
Lemma symbeE la : ('he)`_(enum_rank la) = 'he[la] :> HSF.
Proof. by rewrite /symbe tupleE /= (nth_map la) ?nth_enum_rank // -cardE. Qed.
Lemma symbhE la : ('hh)`_(enum_rank la) = 'hh[la] :> HSF.
Proof. by rewrite /symbh tupleE /= (nth_map la) ?nth_enum_rank // -cardE. Qed.
Lemma symbpE la : ('hp)`_(enum_rank la) = 'hp[la] :> HSF.
Proof. by rewrite /symbp tupleE /= (nth_map la) ?nth_enum_rank // -cardE. Qed.
Lemma symbsE la : ('hs)`_(enum_rank la) = 'hs[la] :> HSF.
Proof. by rewrite /symbs tupleE /= (nth_map la) ?nth_enum_rank // -cardE. Qed.

Let er_eqE (la mu : 'P_d) :
  (enum_rank la == enum_rank mu) = (la == mu).
Proof. by rewrite inj_eq //; apply: enum_rank_inj. Qed.

Local Notation coord := (coord (vT := [vectType R of HSF])).

Hypothesis (Hd : (d <= n)%N).
Lemma coord_symbm la mu : coord 'hm (enum_rank mu) 'hm[la] = (la == mu)%:R.
Proof. by rewrite -symbmE coord_free ?er_eqE; last exact: symbm_free. Qed.
Lemma coord_symbe la mu : coord 'he (enum_rank mu) 'he[la] = (la == mu)%:R.
Proof. by rewrite -symbeE coord_free ?er_eqE; last exact: symbe_free. Qed.
Lemma coord_symbh la mu : coord 'hh (enum_rank mu) 'hh[la] = (la == mu)%:R.
Proof. by rewrite -symbhE coord_free ?er_eqE; last exact: symbh_free. Qed.
Lemma coord_symbs la mu : coord 'hs (enum_rank mu) 'hs[la] = (la == mu)%:R.
Proof. by rewrite -symbsE coord_free ?er_eqE; last exact: symbs_free. Qed.

Lemma coord_symbp (char0 : [char R] =i pred0) la mu :
  coord 'hp (enum_rank mu) 'hp[la] = (la == mu)%:R.
Proof. by rewrite -symbpE coord_free ?er_eqE; last exact/symbp_free. Qed.

End Coord.

(** ** Changing the number of variables *)
Section ChangeNVar.

Variable R : comRingType.
Variable m0 n0 : nat.
Local Notation m := m0.+1.
Local Notation n := n0.+1.
Variable d : nat.
Hypothesis Hd : (d <= m)%N || (n0 < m)%N.

Fact cnvarhomsym_subproof (p : {homsym R[m, d]}) :
  (cnvarsym n0 p) \is d.-homsym.
Proof using.
case: p => [p] /=; rewrite unfold_in /= => Hp; rewrite unfold_in.
rewrite /cnvarsym /=; apply/mwmwgt_homogP.
have [f [Hf Hfhom]] := sym_fundamental_homog (sympolP p) Hp.
rewrite /sympolyf; case: (sym_fundamental _) => [g []] /=.
by rewrite -Hf => H _; rewrite (msym_fundamental_un H).
Qed.
Definition cnvarhomsym (p : {homsym R[m, d]}) : {homsym R[n, d]} :=
  HomogSym (cnvarhomsym_subproof p).
Fact cnvarhomsym_is_linear : linear cnvarhomsym.
Proof. by move=> a f g; apply val_inj; rewrite /= !linearD !linearZ /=. Qed.
Canonical cnvarhomsym_additive   := Additive  cnvarhomsym_is_linear.
Canonical cnvarhomsym_linear     := AddLinear cnvarhomsym_is_linear.

Lemma cnvarhomsyme la : cnvarhomsym 'he[la] = 'he[la].
Proof using Hd. by apply val_inj; rewrite /= -/'e[_] cnvar_prodsyme. Qed.
Lemma cnvarhomsymh la : cnvarhomsym 'hh[la] = 'hh[la].
Proof using Hd. by apply val_inj; rewrite /= -/'h[_] cnvar_prodsymh. Qed.
Lemma cnvarhomsymp la : cnvarhomsym 'hp[la] = 'hp[la].
Proof using Hd. by apply val_inj; rewrite /= -/'p[_] cnvar_prodsymp. Qed.
Lemma cnvarhomsymm la : cnvarhomsym 'hm[la] = 'hm[la].
Proof using Hd. by apply val_inj; rewrite /= cnvar_symm. Qed.
Lemma cnvarhomsyms la : cnvarhomsym 'hs[la] = 'hs[la].
Proof using Hd. by apply val_inj; rewrite /= cnvar_syms. Qed.

End ChangeNVar.

Import ssrnum algC GRing.Theory Num.Theory.

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

(** * The scalar product *)
Section ScalarProduct.

Variable n0 d : nat.
Local Notation n := (n0.+1).
Local Notation algCF := [numFieldType of algC].
Local Notation HSF := {homsym algC[n, d]}.

Definition homsymdot (p q : HSF) : algC :=
  \sum_(i < #|{:'P_d}|)
   (zcard (enum_val i))%:R * (coord 'hp i p) * (coord 'hp i q)^*.
Definition homsymdotr_head k p q := let: tt := k in homsymdot q p.

Notation homsymdotr := (homsymdotr_head tt).
Notation "''[' u | v ]" := (homsymdot u v) : ring_scope.

Lemma homsymdotE p q :
  '[ p | q ] =
  \sum_(la : 'P_d) (zcard la)%:R *
    (coord 'hp (enum_rank la) p) * (coord 'hp (enum_rank la) q)^*.
Proof.
rewrite /homsymdot [RHS](reindex _ (onW_bij _ (@enum_val_bij _))) /=.
by apply/eq_bigr => i _; rewrite enum_valK.
Qed.
Lemma homsymdotrE p q : homsymdotr p q = '[q | p]. Proof. by []. Qed.

Lemma homsymdotr_is_linear p :
  linear (homsymdotr p : HSF -> algC^o).
Proof.
move=> a u v.
rewrite linear_sum -big_split; apply: eq_bigr => x _ /=.
rewrite linearD linearZ /= mulrDr mulrDl !mulrA; congr (_ + _).
by rewrite [_ * a]mulrC -!mulrA.
Qed.
Canonical homsymdotr_additive p := Additive (homsymdotr_is_linear p).
Canonical homsymdotr_linear p := Linear (homsymdotr_is_linear p).

Lemma homsymdot0l p : '[0 | p] = 0.
Proof. by rewrite -homsymdotrE linear0. Qed.
Lemma homsymdotNl p q : '[- q | p] = - '[q | p].
Proof. by rewrite -!homsymdotrE linearN. Qed.
Lemma homsymdotDl p q1 q2 : '[q1 + q2 | p] = '[q1 | p] + '[q2 | p].
Proof. by rewrite -!homsymdotrE linearD. Qed.
Lemma homsymdotBl p q1 q2 : '[q1 - q2 | p] = '[q1 | p] - '[q2 | p].
Proof. by rewrite -!homsymdotrE linearB. Qed.
Lemma homsymdotMnl p q n : '[q *+ n | p] = '[q | p] *+ n.
Proof. by rewrite -!homsymdotrE linearMn. Qed.
Lemma homsymdot_suml p I r (P : pred I) (q : I -> HSF) :
  '[\sum_(i <- r | P i) q i | p] = \sum_(i <- r | P i) '[q i | p].
Proof. by rewrite -!homsymdotrE linear_sum. Qed.
Lemma homsymdotZl p a q : '[a *: q | p] = a * '[q | p].
Proof. by rewrite -!homsymdotrE linearZ. Qed.

Lemma homsymdotC p q : '[p | q] = ('[q | p])^*.
Proof.
rewrite /homsymdot rmorph_sum /=.
apply: eq_bigr=> x _; rewrite !rmorphM conjCK -!mulrA.
have /geC0_conj -> : 0 <= ((zcard (enum_val x))%:R : algC).
  by rewrite -nnegrE ?nnegrE ?ler01 ?ler0n ?oner_neq0.
by congr (_ * _); rewrite mulrC.
Qed.

Lemma homsymdotBr p q1 q2 : '[p | q1 - q2] = '[p | q1] - '[p | q2].
Proof. by rewrite !(homsymdotC p) -rmorphB homsymdotBl. Qed.
Canonical homsymdot_additive p := Additive (homsymdotBr p).

Lemma homsymdot0r p : '[p | 0] = 0. Proof. exact: raddf0. Qed.
Lemma homsymdotNr p q : '[p | - q] = - '[p | q].
Proof. exact: raddfN. Qed.
Lemma homsymdotDr p q1 q2 : '[p | q1 + q2] = '[p | q1] + '[p | q2].
Proof. exact: raddfD. Qed.
Lemma homsymdotMnr p q n : '[p | q *+ n] = '[p | q] *+ n.
Proof. exact: raddfMn. Qed.
Lemma homsymdot_sumr p I r (P : pred I) (q : I -> HSF) :
  '[p | \sum_(i <- r | P i) q i] = \sum_(i <- r | P i) '[p | q i].
Proof. exact: raddf_sum. Qed.
Lemma homsymdotZr a p q : '[p | a *: q] = a^* * '[p | q].
Proof. by rewrite !(homsymdotC p) homsymdotZl rmorphM. Qed.

Lemma homsymdotpp (Hd : (d <= n)%N) la mu :
  '[ 'hp[la] | 'hp[mu] ] = (zcard la)%:R * (la == mu)%:R.
Proof.
rewrite homsymdotE (bigD1 mu) //= big1 ?addr0 => [| nu /negbTE Hneq].
- rewrite !(coord_symbp Hd) // eq_refl /= conjC1 mulr1.
  by case: eqP => [-> //| _]; rewrite !mulr0.
- by rewrite !(coord_symbp Hd) // [mu == nu]eq_sym Hneq conjC0 mulr0.
Qed.

Lemma homsymdot_omegasf f g :
  (d <= n)%N -> '[ omegahomsym f | omegahomsym g ] = '[ f | g ].
Proof.
move=> Hd; have /andP [/eqP Hfull Hfree]:= symbp_basis Hd char0_algC.
have:= (memvf g); rewrite -Hfull => /coord_span ->.
rewrite raddf_sum /= !homsymdot_sumr; apply eq_bigr => i _.
have:= (memvf f); rewrite -Hfull => /coord_span ->.
rewrite raddf_sum /= !homsymdot_suml; apply eq_bigr => j _.
rewrite !linearZ /= !homsymdotZl !homsymdotZr; congr (_ * (_ * _)).
rewrite ![_`_i](nth_map (rowpartn d)) -?cardE //.
rewrite ![_`_j](nth_map (rowpartn d)) -?cardE //.
rewrite !omega_homsymp //;
  try by apply: (leq_trans (leq_head_sumn _)); rewrite sumn_intpartn.
rewrite homsymdotZl homsymdotZr !homsymdotpp //.
case: eqP => /= [->|_]; rewrite ?mulr0 // !mulr1 !mulrA.
move: (nth _ _ _) => la {i j}.
have /conj_Cint -> : (-1) ^+ (d - size la) \in Cint by apply rpred_sign.
by rewrite -exprD addnn -muln2 exprM sqrr_sign mul1r.
Qed.

End ScalarProduct.

Notation homsymdotr := (homsymdotr_head tt).
Notation "''[' u | v ]" := (homsymdot u v) : ring_scope.
Notation "''[' u | v ] _( n , d )" :=
  (@homsymdot n d u v) (only parsing) : ring_scope.


Require Import Arith.
Require Import ZArith.
Require Import Bool.
Open Scope Z_scope.
Definition twopfive (a b c d e : Z) : Z := a + b + c + d + e.
Check twopfive.
Section mab.
        Variables a b c d e : Z.
        Definition f :Z := a + b + c+d+e.
        Check f.
End mab.

Check f.
Definition twopseven (x : Z) : Z :=
        2 * (x*x) + 3 * x + 3.

Check nat.

Inductive kkk : Set :=
| k : kkk
| kk : kkk -> kkk.

Check k.
Check nat.
Check kkk.
Check Type.
Check Set.

Lemma id_P:forall P, P -> P.
Proof.
        intros.
        assumption.
Qed.

Lemma id_PP:forall P, (P -> P) -> (P ->P).
Proof.
        intros P pf.
        assumption.
Qed.

Lemma imp_trans:
        forall P Q R,(P -> Q) -> (Q -> R) -> P -> R.
Proof.
        intros P Q R h1 h2 p.
        apply h2.
        apply h1.
        assumption.
Qed.

Lemma imp_perm:
        forall P Q R,
        (P -> Q -> R) -> (Q -> P -> R).
Proof.
        intros P Q R h1 q p.
        apply h1.
        assumption.
        assumption.
Qed.

Lemma ignore_Q :
        forall P Q R, (P -> R) -> P -> Q -> R.
Proof.
        intros P Q R h1 p q.
        apply h1.
        assumption.
Qed.

Lemma delta_imp :
        forall P Q, (P -> P -> Q) -> P -> Q.
Proof.
        intros P Q h1 p.
        apply h1.
        assumption.
        assumption.
Qed.

Lemma delta_impR:
        forall P Q, (P -> Q) -> (P -> P -> Q).
Proof.
        intros P Q h1 p p'.
        apply h1.
        assumption.
Qed.

Lemma diamond :
        forall P Q R T, (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
        intros P Q R T h1 h2 h3 p.
        apply h3.
        apply h1.
        assumption.
        apply h2.
        assumption.
Qed.

Lemma weak_peirce:
        forall P Q,
        ((((P-> Q) -> P) -> P) -> Q) -> Q.
Proof.
        intros P Q h.
        apply h.
        intros h1.
        apply h1.
        intros p.
        apply h.
        intro.
        assumption.
Qed.


(* Universe hierarchy *)

Check Type.

Set Printing Universes.

Check Type.

Universes i j.

Parameter (A:Type@{i}).
Parameter (B:nat -> Type@{i}).
Check forall x:nat, B x.

Fail Constraint i < Set.
Fail Constraint i = Set.

Constraint i < j.

Check Type@{i} : Type@{j}.

Fail Check Type@{j} : Type@{i}.

Check Type@{i} -> Type@{i}.

Check ((forall (P : Prop), nat -> P) : Prop).

Check ((forall (A : Type), A -> False) : Prop).

Fail Check ((forall (A : Type), A -> Empty_set) : Set).

Universes k l.

Check ((forall (A : Type@{k}), A -> Empty_set) : Type@{l}).

(** Type eliminations *)

Section TypeElim.
  Variable b : bool.

  Check (match b return Type with
         | true => nat
         | false => bool
         end).

  Check (match b return Prop with
         | true => True
         | false => False
         end).

  Check (match b return (nat : Set) with
         | true => 0
         | false => 1
         end).

End TypeElim.

(** Prop eliminations *)
Section PropElim.
  Variable P : Prop.
  Variable b : or P P.

  Fail Check (match b return Type with
              | or_introl _ => nat
              | or_intror _ => bool
              end).

  Fail Check (match b return Prop with
         | or_introl _ => P
         | or_intror _ => P
         end).

  Fail Check (match b return (nat : Set) with
         | or_introl _ => 0
         | or_intror _ => 1
         end).

  Check (match b return P with
         | or_introl p => p
         | or_intror p => p
         end).

End PropElim.

Section PropSingleton.
  Variable b : (True : Prop).

  Check (match b return Type with
              | I => nat
              end).

  Check (match b return Prop with
         | I => False
         end).

  Check (match b return (nat : Set) with
         | I => 0
         end).

  Check (match b return True with
         | I => I
         end).

End PropSingleton.

Section PropSingletonEq.
  Variables (A : Type) (x y : A).
  Variable b : (@eq A x y : Prop).

  Check (match b return Type with
              | eq_refl => nat
              end).

  Variable (P : A -> Type).

  Check (match b in eq _ y return P y -> P x with
         | eq_refl => fun x : P x => x
         end).

End PropSingletonEq.

Section PropExElim.
  Variables (A : Type) (P : A -> Prop).
  (* [exist x : A, P x] is a notation for [ex A P]
     where:

     Inductive ex (A : Type) (P : A -> Prop) : Prop :=
       ex_intro : forall x : A, P x -> exists y, P y
  *)
  Fail Definition project (e : exists x : A, P x) : A :=
    match e return A with
    | ex_intro _ witness proof => witness
    end.

  (* [{ x : A | P x} is a notation for [sig A P] where:

  Inductive sig (A : Type) (P : A -> Prop) : Type :=
	exist : forall x : A, P x -> {x : A | P x}
  *)
  Definition project (e' : { x : A | P x }) : A :=
   match e' return A with
      | exist _ witness proof => witness
   end.
End PropExElim.

Require Import Arith.

Inductive collatz : nat -> Set :=
| collatz_terminates : collatz 1
| collatz_0 n : n mod 2 = 0 -> collatz (n / 2) -> collatz n
| collatz_1 n : n mod 2 = 1 -> collatz (3 * n + 1) -> collatz n.

Fixpoint collatz_steps {n : nat} (c : collatz n) : nat :=
  match c with
  | collatz_terminates => 0
  | collatz_0 n _ c => S (collatz_steps c)
  | collatz_1 n _ c => S (collatz_steps c)
  end.

Inductive squash (A : Type) : Prop :=
| sq : A -> squash A.

Axiom collatz_conjecture: forall n, squash (collatz n).

(** Elimination restrictions ensure "irrealizable" axioms in [Prop] do not endanger the
    computations in Type. E.g. we cannot get "non-standard" numbers.
*)

Fail Definition collatz_steps_of (n : nat) : nat :=
  match collatz_conjecture n with
  | sq _ collatzn => collatz_steps collatzn
  end.


Require Import Coq.Strings.Ascii.
Require Import Coq.ZArith.ZArith.

Require Import Fetch.

Definition Byte := ascii.

Local Open Scope bool.

Definition eqb (lhs rhs: Byte) : bool :=
  match (lhs, rhs) with
  | (Ascii l1 l2 l3 l4 l5 l6 l7 l8, Ascii r1 r2 r3 r4 r5 r6 r7 r8) =>
      (Bool.eqb l1 r1) && (Bool.eqb l2 r2)
      && (Bool.eqb l3 r3) && (Bool.eqb l4 r4)
      && (Bool.eqb l5 r5) && (Bool.eqb l6 r6)
      && (Bool.eqb l7 r7) && (Bool.eqb l8 r8)
  end.

Lemma eqb_reflection (lhs rhs: Byte) :
  eqb lhs rhs = true <-> lhs = rhs.
Proof.
  split. (* -> *)
    intros. unfold eqb in H.
    destruct lhs. destruct rhs.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.andb_true_iff in H. destruct H.
    apply Bool.eqb_prop in H; rewrite H; clear H.
    apply Bool.eqb_prop in H0; rewrite H0; clear H0.
    apply Bool.eqb_prop in H1; rewrite H1; clear H1.
    apply Bool.eqb_prop in H2; rewrite H2; clear H2.
    apply Bool.eqb_prop in H3; rewrite H3; clear H3.
    apply Bool.eqb_prop in H4; rewrite H4; clear H4.
    apply Bool.eqb_prop in H5; rewrite H5; clear H5.
    apply Bool.eqb_prop in H6; rewrite H6; clear H6.
    reflexivity.
  (* <- *)
    intros. unfold eqb.
    destruct lhs. destruct rhs. inversion H.
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.andb_true_iff. split; [| apply Bool.eqb_reflx].
    apply Bool.eqb_reflx.
Qed.

Definition feqb (lhs rhs: @Fetch Byte) := Fetch.eqb lhs rhs eqb.

Lemma feqb_reflection (lhs rhs: @Fetch Byte):
  feqb lhs rhs = true -> lhs = rhs.
Proof.
  intros. unfold feqb in H. unfold eqb in H.
  destruct lhs.
    destruct rhs; [| discriminate H | discriminate H].
      apply eqb_reflection in H. rewrite H. reflexivity.
    destruct rhs; [discriminate H | | discriminate H].
      apply N.eqb_eq in H. rewrite H. reflexivity.
    discriminate H.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Well_Ordering.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Author: Cristina Cornes.
    From: Constructing Recursion Operators in Type Theory
    L. Paulson  JSC (1986) 2, 325-355 *)

Require Import Eqdep.

Section WellOrdering.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive WO : Type :=
    sup : forall (a:A) (f:B a -> WO), WO.

  Inductive le_WO : WO -> WO -> Prop :=
    le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f).

  Theorem wf_WO : well_founded le_WO.
  Proof.
    unfold well_founded in |- *; intro.
    apply Acc_intro.
    elim a.
    intros.
    inversion H0.
    apply Acc_intro.
    generalize H4; generalize H1; generalize f0; generalize v.
    rewrite H3.
    intros.
    apply (H v0 y0).
    cut (f = f1).
    intros E; rewrite E; auto.
    symmetry  in |- *.
    apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5).
  Qed.

End WellOrdering.

Section Characterisation_wf_relations.

  (** Wellfounded relations are the inverse image of wellordering types *)
  (*  in course of development                                          *)

  Variable A : Type.
  Variable leA : A -> A -> Prop.

  Definition B (a:A) := {x : A | leA x a}.

  Definition wof : well_founded leA -> A -> WO A B.
  Proof.
    intros.
    apply (well_founded_induction_type H (fun a:A => WO A B)); auto.
    intros x H1.
    apply (sup A B x).
    unfold B at 1 in |- *.
    destruct 1 as [x0].
    apply (H1 x0); auto.
Qed.

End Characterisation_wf_relations.


Require Import Arith.
Require Import Ensembles.
Require Import Coq.Lists.List.

Require Import folProp.
Require Import subAll.
Require Import folLogic3.
Require Export Languages.
Require Export LNN.

Section NN.

Definition NN1 := forallH 0 (notH (equal (Succ (var 0)) Zero)).
Definition NN2 :=
  forallH 1
    (forallH 0
       (impH (equal (Succ (var 0)) (Succ (var 1))) (equal (var 0) (var 1)))).
Definition NN3 := forallH 0 (equal (Plus (var 0) Zero) (var 0)).
Definition NN4 :=
  forallH 1
    (forallH 0
       (equal (Plus (var 0) (Succ (var 1))) (Succ (Plus (var 0) (var 1))))).
Definition NN5 := forallH 0 (equal (Times (var 0) Zero) Zero).
Definition NN6 :=
  forallH 1
    (forallH 0
       (equal (Times (var 0) (Succ (var 1)))
          (Plus (Times (var 0) (var 1)) (var 0)))).
Definition NN7 := forallH 0 (notH (LT (var 0) Zero)).
Definition NN8 :=
  forallH 1
    (forallH 0
       (impH (LT (var 0) (Succ (var 1)))
          (orH (LT (var 0) (var 1)) (equal (var 0) (var 1))))).
Definition NN9 :=
  forallH 1
    (forallH 0
       (orH (LT (var 0) (var 1))
          (orH (equal (var 0) (var 1)) (LT (var 1) (var 0))))).
Definition NNStar :=
  forallH 1
    (forallH 0
       (impH (orH (LT (var 0) (var 1)) (equal (var 0) (var 1)))
          (LT (var 0) (Succ (var 1))))).

Definition NN :=
  Ensembles.Add _
    (Ensembles.Add _
       (Ensembles.Add _
          (Ensembles.Add _
             (Ensembles.Add _ (Ensembles.Add _ (Ensembles.Add _ (Ensembles.Add _ (Singleton _ NN1) NN2) NN3) NN4) NN5)
             NN6) NN7) NN8) NN9.

Lemma closedNN1 : ClosedSystem LNN NN.
Proof.
unfold ClosedSystem in |- *.
unfold NN in |- *.
intros.
repeat induction H; auto.
Qed.

Lemma closedNN : forall v : nat, ~ In_freeVarSys LNN v NN.
Proof.
unfold not in |- *; intros.
unfold In_freeVarSys in H.
induction H as (x, H).
elim closedNN1 with v x; tauto.
Qed.

Lemma nn1 : forall a : Term, SysPrf NN (notH (equal (Succ a) Zero)).
Proof.
intros.
replace (notH (equal (Succ a) Zero)) with
 (substituteFormula LNN (notH (equal (Succ (var 0)) Zero)) 0 a).
apply forallE.
apply Axm; repeat (try right; constructor) || left.
reflexivity.
Qed.

Lemma nn2 :
 forall a b : Term, SysPrf NN (impH (equal (Succ a) (Succ b)) (equal a b)).
Proof.
intros.
set (m := fun x : nat => match x with
                         | O => a
                         | S _ => b
                         end) in *.
replace (impH (equal (Succ a) (Succ b)) (equal a b)) with
 (subAllFormula LNN
    (impH (equal (Succ (var 0)) (Succ (var 1))) (equal (var 0) (var 1)))
    (fun x : nat =>
     match le_lt_dec 2 x with
     | left _ => var x
     | right _ => m x
     end)).
apply (subAllCloseFrom LNN).
simpl in |- *.
apply Axm; repeat (try right; constructor) || left.
simpl in |- *.
induction (le_lt_dec 2 0).
elim (le_not_lt _ _ a0).
auto.
induction (le_lt_dec 2 1).
elim (le_not_lt _ _ a0).
auto.
reflexivity.
Qed.

Lemma nn3 : forall a : Term, SysPrf NN (equal (Plus a Zero) a).
Proof.
intros.
replace (equal (Plus a Zero) a) with
 (substituteFormula LNN (equal (Plus (var 0) Zero) (var 0)) 0 a).
apply forallE.
apply Axm; repeat (try right; constructor) || left.
reflexivity.
Qed.

Lemma nn4 :
 forall a b : Term, SysPrf NN (equal (Plus a (Succ b)) (Succ (Plus a b))).
Proof.
intros.
set (m := fun x : nat => match x with
                         | O => a
                         | S _ => b
                         end) in *.
replace (equal (Plus a (Succ b)) (Succ (Plus a b))) with
 (subAllFormula LNN
    (equal (Plus (var 0) (Succ (var 1))) (Succ (Plus (var 0) (var 1))))
    (fun x : nat =>
     match le_lt_dec 2 x with
     | left _ => var x
     | right _ => m x
     end)).
apply (subAllCloseFrom LNN).
simpl in |- *.
apply Axm; repeat (try right; constructor) || left.
simpl in |- *.
induction (le_lt_dec 2 0).
elim (le_not_lt _ _ a0).
auto.
induction (le_lt_dec 2 1).
elim (le_not_lt _ _ a0).
auto.
reflexivity.
Qed.

Lemma nn5 : forall a : Term, SysPrf NN (equal (Times a Zero) Zero).
Proof.
intros.
replace (equal (Times a Zero) Zero) with
 (substituteFormula LNN (equal (Times (var 0) Zero) Zero) 0 a).
apply forallE.
apply Axm; repeat (try right; constructor) || left.
reflexivity.
Qed.

Lemma nn6 :
 forall a b : Term, SysPrf NN (equal (Times a (Succ b)) (Plus (Times a b) a)).
Proof.
intros.
set (m := fun x : nat => match x with
                         | O => a
                         | S _ => b
                         end) in *.
replace (equal (Times a (Succ b)) (Plus (Times a b) a)) with
 (subAllFormula LNN
    (equal (Times (var 0) (Succ (var 1)))
       (Plus (Times (var 0) (var 1)) (var 0)))
    (fun x : nat =>
     match le_lt_dec 2 x with
     | left _ => var x
     | right _ => m x
     end)).
apply (subAllCloseFrom LNN).
simpl in |- *.
apply Axm; repeat (try right; constructor) || left.
simpl in |- *.
induction (le_lt_dec 2 0).
elim (le_not_lt _ _ a0).
auto.
induction (le_lt_dec 2 1).
elim (le_not_lt _ _ a0).
auto.
reflexivity.
Qed.

Lemma nn7 : forall a : Term, SysPrf NN (notH (LT a Zero)).
Proof.
intros.
replace (notH (LT a Zero)) with
 (substituteFormula LNN (notH (LT (var 0) Zero)) 0 a).
apply forallE.
apply Axm; repeat (try right; constructor) || left.
reflexivity.
Qed.

Lemma nn8 :
 forall a b : Term,
 SysPrf NN (impH (LT a (Succ b)) (orH (LT a b) (equal a b))).
Proof.
intros.
set (m := fun x : nat => match x with
                         | O => a
                         | S _ => b
                         end) in *.
replace (impH (LT a (Succ b)) (orH (LT a b) (equal a b))) with
 (subAllFormula LNN
    (impH (LT (var 0) (Succ (var 1)))
       (orH (LT (var 0) (var 1)) (equal (var 0) (var 1))))
    (fun x : nat =>
     match le_lt_dec 2 x with
     | left _ => var x
     | right _ => m x
     end)).
apply (subAllCloseFrom LNN).
simpl in |- *.
apply Axm; repeat (try right; constructor) || left.
simpl in |- *.
induction (le_lt_dec 2 0).
elim (le_not_lt _ _ a0).
auto.
induction (le_lt_dec 2 1).
elim (le_not_lt _ _ a0).
auto.
reflexivity.
Qed.

Lemma nn9 :
 forall a b : Term, SysPrf NN (orH (LT a b) (orH (equal a b) (LT b a))).
Proof.
intros.
set (m := fun x : nat => match x with
                         | O => a
                         | S _ => b
                         end) in *.
replace (orH (LT a b) (orH (equal a b) (LT b a))) with
 (subAllFormula LNN
    (orH (LT (var 0) (var 1))
       (orH (equal (var 0) (var 1)) (LT (var 1) (var 0))))
    (fun x : nat =>
     match le_lt_dec 2 x with
     | left _ => var x
     | right _ => m x
     end)).
apply (subAllCloseFrom LNN).
simpl in |- *.
apply Axm; repeat (try right; constructor) || left.
simpl in |- *.
induction (le_lt_dec 2 0).
elim (le_not_lt _ _ a0).
auto.
induction (le_lt_dec 2 1).
elim (le_not_lt _ _ a0).
auto.
reflexivity.
Qed.

End NN.

(*
Definition NNPlus := (Add ? NN NNStar).

Lemma nnStar : (a,b:Term)
 (SysPrf NNPlus (impH (orH (LT a b) (equal a b)) (LT a (Succ b)))).
Proof.
Intros.
LetTac m := [x:nat]
Cases x of
O => a
|(S _) => b
end.
Replace (impH (orH (LT a b) (equal a b)) (LT a (Succ b)))
with (subAllFormula LNN (impH (orH (LT (var (0)) (var (1))) (equal (var (0)) (var (1))))
        (LT (var (0)) (Succ (var (1))))) [x:nat]Cases (le_lt_dec (2) x) of
         (left _) => (var x)
       | (right _) => (m x) end).
Apply (subAllCloseFrom LNN).
Simpl.
Apply Axm; Repeat ((Try Right; Constructor) Orelse Left).
Simpl.
NewInduction (le_lt_dec (2) (0)).
Elim (le_not_lt ? ? a0).
Auto.
NewInduction (le_lt_dec (2) (1)).
Elim (le_not_lt ? ? a0).
Auto.
Reflexivity.
Qed.

Lemma NNPlusExtends : (Included ? NN NNPlus).
Proof.
Intros.
Unfold Included NNPlus.
Intros.
Left.
Assumption.
Qed.

Lemma closedNNPlus1 : (ClosedSystem LNN NNPlus).
Proof.
Unfold ClosedSystem.
Unfold NNPlus.
Intros.
Repeat Induction H; Auto.
Qed.

Lemma closedNNPlus : (v:nat)~(In_freeVarSys LNN v NNPlus).
Proof.
Unfold not; Intros.
Unfold In_freeVarSys in H.
Induction H.
Elim closedNNPlus1 with v x; Tauto.
Qed.
*)


From Undecidability.L Require Export Tactics.LTactics Functions.Encoding Datatypes.LBool L.
Import HOAS_Notations.

(* * Definition of L-decidability *)

Definition decides (u:term) P := forall (s:term), exists b : bool, (app u (ext s) == ext b /\ (if b then P s else ~P s)).

Definition ldec (P : term -> Prop) :=
  exists u : term, proc u /\ decides u P.

(* * Complement, conj and disj of predicates *)

Definition complement (P : term -> Prop) := fun t => ~ P t.

Definition conj (P : term -> Prop) (Q : term -> Prop) := fun t => P t /\ Q t.

Definition disj (P : term -> Prop) (Q : term -> Prop) := fun t => P t \/ Q t.

(* * Deciders for complement, conj and disj of ldec predicates *)
Definition tcompl (u : term) : term := Eval cbn in convert (λ x, !!(ext negb) (!!u x)).

Definition tconj (u v : term) : term := Eval cbn in convert (λ x, !!(ext andb) (!!u x) (!!v x)).

Definition tdisj (u v : term) : term := Eval cbn in convert (λ x, !!(ext orb) (!!u x) (!!v x)).

#[global] Hint Unfold tcompl tconj tdisj : Lrewrite.
#[global] Hint Opaque tcompl tconj tdisj : Lrewrite.
#[global] Hint Unfold tcompl tconj tdisj : LProc.
#[global] Hint Opaque tcompl tconj tdisj : LProc.

(* * L-decidable predicates are closed under complement, conj and disj *)

Lemma ldec_complement P : ldec P -> ldec (complement P).
Proof.
  intros [u [[cls_u lam_u] H]]. exists (tcompl u). unfold tcompl. split. Lproc.
  intros s. destruct (H s) as [b [A Ps]];exists (negb b).
  split.
  -Lsimpl. rewrite A. now Lsimpl.
  -destruct b;simpl; intuition.
Qed.

Lemma ldec_conj P Q : ldec P -> ldec Q -> ldec (conj P Q).
Proof.
  intros [u [[cls_u lam_u] decP]] [v [[cls_v lam_v] decQ]].
  exists (tconj u v). unfold tconj. split. Lproc.
  intros s.  destruct (decP s) as [b  [Hu Ps]], (decQ s) as [b' [Hv Qs]];exists (andb b b').
  split.
  -Lsimpl. rewrite Hu,Hv. now Lsimpl.
  -destruct b,b';simpl;unfold conj;intuition.
Qed.

Lemma ldec_disj P Q : ldec P -> ldec Q -> ldec (disj P Q).
Proof.
  intros [u [[cls_u lam_u] decP]] [v [[cls_v lam_v] decQ]].
  exists (tdisj u v). unfold tdisj. split. Lproc.
  intros s.  destruct (decP s) as [b  [Hu Ps]], (decQ s) as [b' [Hv Qs]];exists (orb b b').
  split.
  -Lsimpl. rewrite Hu,Hv. now Lsimpl.
  -destruct b,b';simpl;unfold disj;intuition.
Qed.

Lemma dec_ldec (P:term -> Prop) (f: term -> bool) {If : computable f}: (forall x, reflect (P x) (f x)) ->ldec P.
Proof.
  intros H.
  exists (ext f). split. Lproc.
  intros s. eexists. split.
  -Lsimpl. reflexivity.
  -destruct (H s);assumption.
Qed.

Arguments dec_ldec {_} f {_} _.


Require Import Bool.
Require Export MR0_D.
Require Export MR0_L.

Section DerivedProperties.

Variable l : blocklist.

(** The current system state satisfy  I_1:clh=0 *)
Hypothesis list_from_zero_current : list_from_zero l = true.

(*allocate: list_from_zero*)
Theorem allocate_list_from_zero : forall(r: nat),
  list_from_zero (allocate r l) = true.
Proof.
  intros. unfold list_from_zero; simpl.
  rewrite <- bl_end_allocate_equal.
  apply lfr_equal_bfr in list_from_zero_current.
  case (allocate r l); simpl.
  - reflexivity.
  - intros. assumption. Qed.

(*release: list_from_zero
Theorem release_list_from_zero : forall (b: Block),
  busy_block_in_list b l ->
  list_from_zero (release b l) = true.
Proof.
Proof. (* FILL IN HERE *) Admitted.
*)

(** The current system state satisfy  I_6:*)
Hypothesis list_from_zero_current : list_from_zero l = true.
(*allocate2 : list_not_gap*)
Theorem allocate_list_not_gap : forall (l: blocklist) (r: nat),
  list_not_gap l = true -> list_not_gap (allocate r l) = true.
Proof.
  intros. induction l.
  - unfold allocate. simpl. case r; simpl; try (intros; reflexivity). assumption.
    assert (H1: list_not_gap (allocate r (b :: l)) = list_not_gap (allocate r l)).
    { apply (lng_relate_allocate l r b). assumption. }
    rewrite H1. apply lng_equal_minus in H. apply IHl in H. assumption. Qed.

(*allocate3 : list_not_zeroB*)
Theorem allocate_list_not_zeroB : forall (l: blocklist) (r: nat),
  list_not_zeroB l = true -> list_not_zeroB (allocate r l) = true.
Proof.
  intros. induction l.
  - unfold allocate; simpl. case r; simpl; try (intros; reflexivity).
  - assert (H1: list_not_zeroB (allocate r (b :: l)) = list_not_zeroB (allocate r l)).
    { apply (lnz_relate_allocate l r b). assumption. }
    rewrite H1. apply lnz_equal_minus in H. apply IHl in H. assumption. Qed.

(*release1 : list_from_zero*)
Theorem release_list_from_zero : forall (l: blocklist) (b: Block),
  list_from_zero l = true -> list_from_zero (release b l) = true.
Proof.
  intros. unfold list_from_zero. unfold release.

Proof. (* FILL IN HERE *) Admitted.

(*release2 : list_not_gap*)
Theorem release_list_not_gap : forall (l: blocklist) (b: Block),
  list_not_gap l = true -> list_not_gap (release b l) = true.
Proof. (* FILL IN HERE *) Admitted.

(*release3 : list_not_zeroB*)
Theorem release_list_not_zeroB : forall (l: blocklist) (b: Block),
  list_not_zeroB l = true -> list_not_zeroB (release b l) = true.
Proof. (* FILL IN HERE *) Admitted.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert.
Require Import CTL_def hilbert hilbert_hist.

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

(** * Axiomatization of Lange and Stirling

Lange and Stirling give an axiomatization of CTL based on a game semantics. We
show that this axiomatization is equivalent to the Hilbert system employed in
our completeness proof.

Note: The Infrastructure for Hilbert proofs only works for the "Canonical"
Hilbert system for a given type of formulas. We use modules to ensure that the
right system is considered canonical at the right time. *)

Module LS.
Section Hilbert.

(** The defined logical operations are only available once the respective
records ([pSystem] etc.) have been declared. Hence we introduce local notations
and later restate some of the axioms and rules using the defined notations from
[modular_hilbert.v] *)

  Local Notation "s ---> t" := (fImp s t).
  Local Notation "~~: s" := (s ---> fF).
  Local Notation "s :\/: t" := (~~: s ---> t).
  Local Notation "s :/\: t" := (~~: (s ---> ~~: t)).
  Local Notation "s <--> t" := ((s ---> t) :/\: (t ---> s)).
  Definition fEX s := (~~: fAX (~~: s)).
  Definition fER s t := (~~: fAU (~~: s) (~~: t)).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN s : prv (((s ---> fF) ---> fF)  ---> s)
  | rNec s : prv s -> prv (fAX s)
  | axN s t : prv (fAX (s ---> t) ---> fAX s ---> fAX t)

  | axSer s : prv (fAX (~~: s) ---> ~~: fAX s)

  | axARf' s t : prv (fAR s t ---> t :/\: (s :\/: fAX (fAR s t)))
  | ARel' s t u :
      prv (u ---> t :/\: (s :\/: fAX (fAR (s :\/: u) (t :\/: u)))) ->
      prv (u ---> fAR s t)

  | axERf' s t : prv (fER s t ---> t :/\: (s :\/: fEX (fER s t)))
  | ERel' s t u :
      prv (u ---> t :/\: (s :\/: fEX (fER (s :\/: u) (t :\/: u)))) ->
      prv (u ---> fER s t)

  | axAUcmp' s t : prv (fAU s t <--> ~~: fER (~~: s) (~~: t)).
End Hilbert.

Canonical Structure prv_mSystem := MSystem rMP axK axS.
Canonical Structure prv_pSystem := PSystem axDN.
Canonical Structure prv_kSystem := KSystem rNec axN.

(** restate axioms/rule using notations from modular_hilbert.v *)

Lemma ARel s t u :
  prv (u ---> t :/\: (s :\/: fAX (fAR (s :\/: u) (t :\/: u)))) ->
  prv (u ---> fAR s t).
Proof. exact: ARel'. Qed.

Lemma axARf s t : prv (fAR s t ---> t :/\: (s :\/: fAX (fAR s t))).
Proof. exact: axARf'. Qed.

Lemma ERel s t u :
      prv (u ---> t :/\: (s :\/: fEX (fER (s :\/: u) (t :\/: u)))) ->
      prv (u ---> fER s t).
Proof. exact: ERel'. Qed.

Lemma axERf s t : prv (fER s t ---> t :/\: (s :\/: fEX (fER s t))).
Proof. exact: axERf'. Qed.

Lemma axAUcmp s t : prv (fAU s t <--> ~~: fER (~~: s) (~~: t)).
Proof. exact: axAUcmp'. Qed.

(** ** Completeness

We show completenes of the Hilbert system LS by showing admissibility of the
rules and axoms of the Hilbert system IC. *)

(** Helper Lemmas *)

Lemma ARI s t : prv (s ---> t ---> fAR s t).
Proof. apply: rAIL. apply ARel. rule axAcase; do 2 Intro. ApplyH axAI. ApplyH axOIl. Qed.

Lemma ERI s t : prv (s ---> t ---> fER s t).
Proof. apply: rAIL. apply ERel. rule axAcase; do 2 Intro. ApplyH axAI. ApplyH axOIl. Qed.

(** Rules/Axioms of inductive Hilbert system *)

Lemma AR_ind s t u : prv (u ---> t) -> prv (u ---> (s ---> fF) ---> fAX u) -> prv (u ---> fAR s t).
Proof.
  move => H1 H2. apply: ARel.
  Intro. ApplyH axAI; [ApplyH H1|]. Intro.
  Have (fAX u); [by ApplyH H2|drop]. apply: rNorm.
  Intro. ApplyH ARI. ApplyH axOIr. ApplyH axOIl. ApplyH H1.
Qed.

Lemma axARE s t  : prv (fAR s t ---> t).
Proof. rewrite -> axARf. exact: axAEl. Qed.

Lemma axARu s t  : prv (fAR s t ---> ~~: s ---> fAX (fAR s t)).
Proof. rewrite -> axARf at 1. rule axAcase. by drop. Qed.

Lemma AU_ind s t u : prv (t ---> u) -> prv (s ---> fAX u ---> u) -> prv ((fAU s t) ---> u).
Proof.
  move => H1 H2. rewrite -> axAUcmp, <- (axDN u). rule ax_contraNN. apply: ERel.
  Intro; ApplyH axAI; first by Rev; rule ax_contraNN.
  rewrite {1}/Or. rewrite -> modular_hilbert.axDN. Intro.
  Have (fEX (~~: u)). Intro. Apply* 2. ApplyH H2. Rev. drop. apply: rNorm. exact: axDN.
  drop. apply: rEXn.
  Intro. ApplyH ERI. ApplyH axOIr. ApplyH axOIl. rewrite -> H1. Rev. exact: axI.
Qed.

Lemma axAUI s t : prv (t ---> fAU s t).
Proof.
  rewrite -> axAUcmp. rewrite -> (axDNI t) at 1. rule ax_contraNN.
  rewrite -> axERf. exact: axAEl.
Qed.

Lemma axAUf s t : prv (s ---> fAX (fAU s t) ---> fAU s t).
Proof.
  apply: rAIL. rule ax_contra. rewrite -> axAUcmp, modular_hilbert.axDN.
  rewrite -> axERf at 1. rule axAcase. Intro.
  (* need to help unification*)
  set u := ~~: (s :/\: _). ApplyH (axOE (~~: s) (fEX (fER (~~: s) (~~: t))) u); rewrite /u.
  - Intro. ApplyH axAcase. do 2 Intro. Apply* 2.
  - Intro. ApplyH axAcase. do 2 Intro. Apply* 2.
Qed.

Lemma ax_serial : prv (~~: (fAX fF)).
Proof. Intro. ApplyH (axSer fF). drop. apply: rNec. exact: axI. Qed.

End LS.

Theorem LS_translation s : IC.prv s -> LS.prv s.
Proof.
  elim => {s}; eauto using LS.prv,LS.axARE,LS.axARu,LS.AR_ind,LS.AU_ind,LS.axAUI, LS.axAUf.
Qed.

(** ** Soundness

We show soundness by proving all rules admissible in IC *)

(** Set up the Infrastructure for Hilbert proofs for the system IC *)
Import IC.

(** The lemmas below correspond, up to propositional reasoning, to the hilbert
lemmas for the soundness proof of the Gentzen system (file hilbert_hist.v) *)

Lemma ERel (s t u : form) :
      prv (u ---> t :/\: (s :\/: EX (ER (s :\/: u) (t :\/: u)))) ->
      prv (u ---> ER s t).
Proof.
  move => H.
  rewrite /ER. rewrite -> (axAsT (~~: s)), (axAsT (~~: t)). apply: AUH_hil.
  - rule axAcase. rewrite -[~~: t ---> _]/(~~: (~~: t)). rewrite -> axDNE.
    rule axB; last apply H. exact: axAEl.
  - rewrite /AU_. rewrite <- axAsT. do ! rewrite <- dmO. rewrite <- dmER.
    rewrite -> H at 1. exact: axAEr.
Qed.

Lemma ARel s t u :
  prv (u ---> t :/\: (s :\/: AX (AR (s :\/: u) (t :\/: u)))) ->
  prv (u ---> AR s t).
Proof.
  move => H. rewrite <- (axDNE (AR s t)), dmAR.
  rewrite -> (axAsT (~~: s)), (axAsT (~~: t)). apply: ARH_hil.
  - rule ax_contraNN. rule axB; last apply H. exact: axAEl.
  - rewrite /EU_. rewrite <- axAsT. do ! rewrite <- dmO. rewrite <- dmAR.
    rewrite /EX. rewrite -> axDNE.
    do 2 Intro. rewrite -> H at 3. ApplyH axAcase. Intro. by ApplyH axOE.
Qed.

Lemma axARf s t : prv (fAR s t ---> t :/\: (s :\/: fAX (fAR s t))).
Proof. rewrite -> axAReq at 1. exact: axI. Qed.

Lemma axERf s t : prv (ER s t ---> t :/\: (s :\/: EX (ER s t))).
Proof. exact: axERu. Qed.

Lemma axAUcmp s t : prv (fAU s t <--> ~~: ER (~~: s) (~~: t)).
Proof. rule axAI; rewrite -> dmER, axDNE, axDNE; exact: axI. Qed.

Lemma axSer s : prv (fAX (~~: s) ---> ~~: fAX s).
Proof.
  rewrite {2}/Neg. rewrite <- ax_serial. apply rAIL. rewrite -> axABBA.
  apply: rNorm. rule axAcase. exact: axI.
Qed.

Lemma LS_sound s : LS.prv s -> prv s.
Proof. elim => {s} *; eauto using prv,ERel,ARel,axARf,axERf,axAUcmp,axSer. Qed.


Set Implicit Arguments.

(**

Build with

  > coqc imp.v

using a recent version of Coq (e.g., 8.5pl1).

*)

Require Import List. Import ListNotations.

(** Syntax *)

Inductive val : Type :=
| VTrue : val
| VFalse : val.

Lemma val_eq_dec : forall v1 v2 : val, {v1=v2}+{v1<>v2}.
Proof. decide equality. Qed.

Inductive exp : Type :=
| EVal : val -> exp
| EAnd : exp -> exp -> exp.

Lemma exp_eq_dec : forall e1 e2 : exp, {e1=e2}+{e1<>e2}.
Proof. decide equality. apply val_eq_dec. Qed.

Inductive com : Type :=
| CSkip : com
| CPrint : exp -> com
| CIte : exp -> com -> com -> com
| CWhile : exp -> com -> com
| CSeq : com -> com -> com.

Lemma com_eq_dec : forall c1 c2 : com, {c1=c2}+{c1<>c2}.
Proof.
  decide equality.
  apply exp_eq_dec.
  apply exp_eq_dec.
  apply exp_eq_dec.
Qed.

(** Semantics *)

Fixpoint eval (e : exp) : val :=
  match e with
  | EVal v => v
  | EAnd e1 e2 =>
    let v1 := eval e1 in
    let v2 := eval e2 in
    match v1, v2 with
    | VFalse, VFalse => VFalse
    | VFalse, VTrue => VFalse
    | VTrue, VFalse => VFalse
    | VTrue, VTrue => VTrue
    end
  end.

Definition state := list val.

Inductive step : com -> state -> com -> state -> Prop :=
| step_print :
    forall s e,
      step (CPrint e) s CSkip (s ++ [eval e])

| step_ite_true :
    forall s e c1 c2,
      eval e = VTrue ->
      step (CIte e c1 c2) s c1 s

| step_ite_false :
    forall s e c1 c2,
      eval e = VFalse ->
      step (CIte e c1 c2) s c2 s

| step_while :
    forall s e c,
      step (CWhile e c) s (CIte e (CSeq c (CWhile e c)) CSkip) s

| step_cseq1 :
    forall s c2,
      step (CSeq CSkip c2) s c2 s

| step_cseq2 :
    forall s s' c1 c1' c2,
      step c1 s c1' s' ->
      step (CSeq c1 c2) s (CSeq c1' c2) s'.

(*the transitive closure of the step relation*)
Inductive step_plus : com -> state -> com -> state -> Prop :=
| step1 :
    forall c s c' s',
      step c s c' s' ->
      step_plus c s c' s'

| step_trans :
    forall c s c'' s'' c' s',
      step c s c'' s'' ->
      step_plus c'' s'' c' s' ->
      step_plus c s c' s'.

Lemma step_plus_trans :
  forall c s c'' s'' c' s',
    step_plus c s c'' s'' ->
    step_plus c'' s'' c' s' ->
    step_plus c s c' s'.
Proof.
  intros until s'; intros H.
  revert c' s'.
  induction H.
  { intros cx sx H2.
    eapply step_trans; eauto. }
  intros cx sx H2.
  eapply step_trans; eauto.
Qed.

(** Constant Propagation *)

Fixpoint constprop (c : com) :=
  match c with
  | CSkip => CSkip
  | CPrint e => CPrint e
  | CIte (EVal VTrue) c1 c2 => constprop c1
  | CIte (EVal VFalse) c1 c2 => constprop c2
  (*we could of course do more constprop in the next case...*)
  | CIte (EAnd e1 e2) c1 c2 => CIte (EAnd e1 e2) (constprop c1) (constprop c2)
  (*and in this one as well...*)
  | CWhile e c' => CWhile e (constprop c')
  | CSeq c1 c2 => CSeq (constprop c1) (constprop c2)
  end.

(** Simulation Relation/Proof *)

Inductive com_match : com -> com -> Prop :=
| com_match_skip :
    com_match CSkip CSkip

| com_match_print :
    forall e,
      com_match (CPrint e) (CPrint e)

| com_match_ite_false :
    forall c1 c1' c2,
      com_match c1 c1' ->
      com_match (CIte (EVal VTrue) c1 c2) c1'

| com_match_ite_true :
    forall c1 c2 c2',
      com_match c2 c2' ->
      com_match (CIte (EVal VFalse) c1 c2) c2'

| com_match_ite_other :
    forall e c1 c1' c2 c2',
      com_match c1 c1' ->
      com_match c2 c2' ->
      com_match (CIte e c1 c2) (CIte e c1' c2')

| com_match_while :
    forall e c c',
      com_match c c' ->
      com_match (CWhile e c) (CWhile e c')

| com_match_cseq :
    forall c1 c1' c2 c2',
      com_match c1 c1' ->
      com_match c2 c2' ->
      com_match (CSeq c1 c2) (CSeq c1' c2').

Lemma constprop_com_match :
  forall c, com_match c (constprop c).
Proof.
  induction c; try solve[constructor|constructor; auto].
  destruct e; [destruct v; constructor; auto|constructor; auto].
Qed.

Definition R (c : com) (s : state) (c' : com) (s' : state) :=
  s=s' /\ com_match c c'.

Lemma com_match_skip_step_plus :
  forall c s,
    com_match c CSkip ->
    c = CSkip \/ step_plus c s CSkip s.
Proof.
  intros c s H; revert s.
  induction c; try solve[inversion H].
  { intros s; constructor. auto. }
  intros s. inversion H; subst.
  { destruct (IHc1 H4 s).
    { subst c1.
      right. constructor. constructor. auto. }
    right. eapply step_trans; eauto. constructor; auto. }
  destruct (IHc2 H4 s).
  { subst c2.
    right. constructor. constructor. auto. }
  right. eapply step_trans; eauto. constructor; auto.
Qed.

Lemma step_plus_seq :
  forall c1 c1' c2 s s',
    step_plus c1 s c1' s' ->
    step_plus (CSeq c1 c2) s (CSeq c1' c2) s'.
Proof.
  intros until s'; intros H.
  induction H.
  { constructor.
    constructor; auto. }
  eapply step_plus_trans; eauto.
  constructor.
  constructor; auto.
Qed.

Lemma step_plus_seq_CSkip :
  forall c1 c2 s,
    step_plus c1 s CSkip s ->
    step_plus (CSeq c1 c2) s c2 s.
Proof.
  intros c1 c2 s H.
  eapply step_plus_trans.
  eapply step_plus_seq in H.
  apply H.
  constructor.
  constructor.
Qed.

(** Main simulation diagram *)

Lemma diagram :
  forall c s d t d' t',
    step d t d' t' ->
    R c s d t ->
    exists c' s',
      step_plus c s c' s' /\
      R c' s' d' t'.
Proof.
  intros c s d t d' t' H H1.
  revert d' t' H.
  destruct H1 as [H1 H2]; subst s.
  induction H2.
  { intros d' t'; inversion 1; subst. }
  { intros d' t'; inversion 1; subst.
    exists CSkip, (t++[eval e]); split; [constructor; auto|].
    split; auto; constructor. }
  { intros d' t' H.
    destruct (IHcom_match _ _ H) as [c1'' [s'' [H3 H4]]].
    exists c1'', s''; split; auto.
    eapply step_trans; eauto.
    constructor; auto. }
  { intros d' t' H.
    destruct (IHcom_match _ _ H) as [c1'' [s'' [H3 H4]]].
    exists c1'', s''; split; auto.
    eapply step_trans; eauto.
    constructor; auto. }
  { intros d' t' H.
    inversion H; subst.
    { exists c1, t'; split.
      constructor.
      constructor; auto.
      split; auto. }
    { exists c2, t'; split.
      constructor.
      constructor; auto.
      split; auto. }}
  { intros d' t'; inversion 1; subst.
    exists (CIte e (CSeq c (CWhile e c)) CSkip), t'; split.
    constructor.
    constructor.
    split; auto.
    constructor.
    constructor; auto.
    constructor; auto.
    constructor. }
  intros d' t'; inversion 1; subst.
  { apply (@com_match_skip_step_plus _ t') in H2_.
    exists c2, t'; split.
    { destruct H2_.
      { subst c1.
        constructor.
        constructor. }
      apply step_plus_seq_CSkip; auto. }
    split; auto. }
  destruct (@IHcom_match1 _ _ H5) as [c1'' [t'' [H7 H8]]].
  exists (CSeq c1'' c2), t''; split.
  apply step_plus_seq; auto.
  destruct H8; subst t''.
  split; auto.
  constructor; auto.
Qed.

Lemma consequence1 :
  forall c s d t d' t',
    step_plus d t d' t' ->
    R c s d t ->
    exists c' s',
      step_plus c s c' s' /\
      R c' s' d' t'.
Proof.
  intros c s d t d' t' H; revert c s.
  induction H.
  { intros cx sx H2.
    eapply diagram in H; eauto. }
  intros cx sx H2.
  eapply diagram in H; eauto.
  destruct H as [cy [sy [H3 H4]]].
  destruct (IHstep_plus _ _ H4) as [cz [sz [H5 H6]]].
  exists cz, sz; split; auto.
  eapply step_plus_trans; eauto.
Qed.

(* Theorem:
   If the constant-propagated version of command [c] produces
   event list [ev_list], then so does [c]. *)

Lemma consequence2 :
  forall c d' ev_list,
    step_plus (constprop c) [] d' ev_list ->
    exists c', step_plus c [] c' ev_list.
Proof.
  intros c d' ev_list H.
  assert (H2: R c [] (constprop c) []).
  { split; auto.
    apply constprop_com_match. }
  destruct (consequence1 H H2) as [c' [s' [H3 H4]]].
  destruct H4; subst s'.
  exists c'; auto.
Qed.


(** * Ordering of the String datatype *)

(** The NatDed development, Pierre Letouzey, 2019.
    This file is released under the CC0 License, see the LICENSE file *)

Require Import Bool Orders Ascii AsciiOrder String.
Local Open Scope string_scope.

Inductive string_lt : string -> string -> Prop :=
 | LtEmpty a s : "" < String a s
 | LtHead a a' s s' : (a < a')%char -> String a s < String a' s'
 | LtTail a s s' : s < s' -> String a s < String a s'
where "u < v" := (string_lt u v) : string_scope.
Hint Constructors string_lt.

Lemma string_lt_strorder : StrictOrder string_lt.
Proof.
 split.
 - intros s. red. induction s; inversion_clear 1; auto.
   now apply ascii_lt_strorder in H0.
 - red. intros x y z H; revert z. induction H; inversion_clear 1; auto.
   constructor. eapply ascii_lt_strorder; eauto.
Qed.

Definition string_le s s' := s<s' \/ s=s'.
Infix "<=" := string_le : string_scope.

Lemma string_le_lteq s s' : s<=s' <-> s<s' \/ s=s'.
Proof.
 reflexivity.
Qed.

Fixpoint string_compare s s' :=
  match s, s' with
  | "", "" => Eq
  | "", _ => Lt
  | _, "" => Gt
  | String a s, String a' s' =>
    match (a ?= a')%char with
    | Eq => string_compare s s'
    | Lt => Lt
    | Gt => Gt
    end
  end.

Infix "?=" := string_compare (at level 70) : string_scope.

Lemma string_compare_spec s s' :
 CompareSpec (s=s') (s<s') (s'<s) (s?=s').
Proof.
 revert s'.
 induction s as [|a s IH]; destruct s' as [|a' s']; simpl; auto.
 case ascii_compare_spec; intros H; subst; simpl; auto.
 case IH; intros H; subst; auto.
Qed.

Definition string_eqb s s' :=
 match s ?= s' with
 | Eq => true
 | _ => false
 end.

Definition string_ltb s s' :=
 match s ?= s' with
 | Lt => true
 | _ => false
 end.

Definition string_leb s s' :=
 match s ?= s' with
 | Gt => false
 | _ => true
 end.

Infix "=?" := string_eqb : string_scope.
Infix "<?" := string_ltb : string_scope.
Infix "<=?" := string_leb : string_scope.

Lemma string_eqb_spec (s s' : string) : reflect (s = s') (s =? s').
Proof.
 unfold string_eqb.
 assert (H := string_compare_spec s s').
 destruct string_compare; constructor; inversion H; auto.
 intros <-. assert (~(s < s)) by apply string_lt_strorder. auto.
 intros <-. assert (~(s < s)) by apply string_lt_strorder. auto.
Qed.

Theorem string_eqb_refl : forall s,
  (s =? s) = true.
Proof.
Admitted.

Lemma string_ltb_spec (s s' : string) : BoolSpec (s < s') (s' <= s) (s <? s').
Proof.
 unfold string_ltb, string_le.
 assert (H := string_compare_spec s s').
 destruct string_compare; constructor; inversion H; auto.
Qed.

Lemma string_leb_spec (s s' : string) : BoolSpec (s <= s') (s' < s) (s <=? s').
Proof.
 unfold string_leb, string_le.
 assert (H := string_compare_spec s s').
 destruct string_compare; constructor; inversion H; auto.
Qed.

Module StringOT <: UsualOrderedType.
 Definition t := string.
 Definition eq := @Logic.eq string.
 Definition eq_equiv := @eq_equivalence string.
 Definition lt := string_lt.
 Lemma lt_compat : Proper (eq==>eq==>iff) lt.
 Proof. now intros ? ? -> ? ? ->. Qed.
 Definition lt_strorder := string_lt_strorder.
 Definition compare := string_compare.
 Definition compare_spec := string_compare_spec.
 Definition eq_dec := string_dec.
End StringOT.


From CoqAlgs Require Export Base.
From CoqAlgs Require Export Ord.
(* From CoqAlgs Require Export BTree. *)
From CoqAlgs Require Export EBTree.
(* From CoqAlgs Require Export Sorting.Sort. *)

Inductive color : Set :=
    | Red : color
    | Black : color.

Definition RBTree (A : Type) : Type := EBTree color A.

Definition empty {A : Type} : RBTree A := E.

Definition singleton {A : Type} (x : A) : RBTree A := N Red E x E.

Function balance
  {A : Type} (c : color)
  (l : RBTree A) (v : A) (r : RBTree A) : RBTree A :=
match c with
    | Red => N Red l v r
    | Black =>
        match l, v, r with
            | N Red (N Red a xv b) yv c, zv, d
            | N Red a xv (N Red b yv c), zv, d
            | a, xv, N Red (N Red b yv c) zv d
            | a, xv, N Red b yv (N Red c zv d) =>
                N Red (N Black a xv b) yv (N Black c zv d)
            | l, v, r => N Black l v r
        end
end.

Definition makeBlack {A : Type} (t : RBTree A) :=
match t with
    | E => E
    | N _ l v r => N Black l v r
end.

Function ins {A : Type} (leb : A -> A -> bool) (x : A) (t : RBTree A) : RBTree A :=
match t with
    | E => N Red E x E
    | N c l v r =>
        if leb x v
        then balance c (ins leb x l) v r
        else balance c l v (ins leb x r)
end.

Definition insert {A : Type} (leb : A -> A -> bool) (x : A) (t : RBTree A) : RBTree A :=
  makeBlack (ins leb x t).

Fixpoint fromList {A : Type} (leb : A -> A -> bool) (l : list A) : RBTree A :=
match l with
    | [] => E
    | h :: t => insert leb h (fromList leb t)
end.

(** Properties of [isEmpty]. *)

Lemma isEmpty_balance :
  forall {A : Type} (c : color) (v : A) (l r : RBTree A),
    isEmpty (balance c l v r) = false.
Proof.
  intros.
  functional induction balance c l v r;
  cbn; reflexivity.
Qed.

Lemma isEmpty_makeBlack :
  forall {A : Type} (t : RBTree A),
    isEmpty (makeBlack t) = isEmpty t.
Proof.
  destruct t; cbn; reflexivity.
Qed.

Lemma isEmpty_ins :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (t : RBTree A),
    isEmpty (ins leb x t) = false.
Proof.
  intros.
  functional induction ins leb x t;
  cbn; rewrite ?isEmpty_balance; reflexivity.
Qed.

Lemma isEmpty_insert :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (t : RBTree A),
    isEmpty (insert leb x t) = false.
Proof.
  intros. unfold insert. rewrite isEmpty_makeBlack, isEmpty_ins. reflexivity.
Qed.

(** Properties of [singleton]. *)

Lemma Elem_singleton :
  forall {A : Type} {x y : A},
    Elem x (singleton y) <-> x = y.
Proof.
  unfold singleton. split.
    inv 1; inv H1.
    intros ->. auto.
Qed.

Lemma isBST_singleton :
  forall {A : Ord} (x : A),
    isBST (singleton x).
Proof.
  unfold singleton. intros. constructor; auto; inv 1.
Qed.

Lemma isBST2_singleton :
  forall {A : Ord} (x : A),
    isBST2 (singleton x).
Proof.
  constructor; auto.
Qed.

(** Properties of [balance]. *)

Lemma Elem_balance :
  forall {A : Type} (c : color) (x v : A) (l r : RBTree A),
    Elem x (balance c l v r) <-> Elem x l \/ x = v \/ Elem x r.
Proof.
  split;
  functional induction balance c l v r;
  auto; intros H.
    all: Elem'.
    all: decompose [or] H; clear H; subst; Elem'.
Qed.

Lemma isBST_balance :
  forall (A : Ord) (c : color) (v : A) (l r : RBTree A),
    isBST (N c l v r) -> isBST (balance c l v r).
Proof.
  intros.
  functional induction balance c l v r;
  isBST'; Elem'; trich.
Qed.

Lemma All_balance :
  forall {A : Type} (P : A -> Prop) (c : color) (v : A) (l r : RBTree A),
    All P (balance c l v r) <-> All P l /\ P v /\ All P r.
Proof.
  intros.
  functional induction balance c l v r;
  firstorder All'.
Qed.

Lemma isBST2_balance :
  forall (A : Ord) (c : color) (v : A) (l r : RBTree A),
    isBST2 (N c l v r) -> isBST2 (balance c l v r).
Proof.
  intros.
  functional induction balance c l v r;
  isBST2';
  do 2 match goal with
      | y : match _ with | _ => _ end |- _ => clear y
      | H : All _ ?t |- All _ ?t => induction H; constructor; isBST2; trich
  end.
Qed.

(** Properties of [makeBlack]. *)

Lemma Elem_makeBlack :
  forall {A : Type} (x : A) (t : RBTree A),
    Elem x (makeBlack t) <-> Elem x t.
Proof.
  split; destruct t; cbn; auto; inv 1.
Qed.

Lemma isBST_makeBlack :
  forall (A : Ord) (t : RBTree A),
    isBST t -> isBST (makeBlack t).
Proof.
  destruct t; cbn; inv 1.
Qed.

Lemma isBST2_makeBlack :
  forall (A : Ord) (t : RBTree A),
    isBST2 t -> isBST2 (makeBlack t).
Proof.
  destruct t; cbn; inv 1.
Qed.

(** Properties of [ins]. *)

Lemma Elem_ins :
  forall {A : Type} (leb : A -> A -> bool) (x y : A) (t : RBTree A),
    Elem x (ins leb y t) <-> x = y \/ Elem x t.
Proof.
  intros until t. revert x.
  functional induction ins leb y t;
  intros; rewrite ?Elem_balance, ?Elem_N, ?IHl, ?IHr;
  firstorder.
Qed.

Lemma isBST_ins :
  forall (A : Ord) (x : A) (t : RBTree A),
    isBST t -> isBST (ins trich_leb x t).
Proof.
  intros. functional induction ins trich_leb x t.
    constructor; auto; inv 1.
    apply isBST_balance. isBST'. apply Elem_ins in H. inv H. trich.
    apply isBST_balance. isBST'. apply Elem_ins in H. inv H. trich.
Qed.

Lemma All_ins :
  forall {A : Type} (leb : A -> A -> bool) (P : A -> Prop) (x : A) (t : RBTree A),
    All P (ins leb x t) <-> P x /\ All P t.
Proof.
  intros.
  functional induction ins leb x t;
  rewrite ?All_balance, ?IHr;
  firstorder All'.
Qed.

Lemma isBST2_ins :
  forall (A : Ord) (x : A) (t : RBTree A),
    isBST2 t -> isBST2 (ins trich_leb x t).
Proof.
  intros. functional induction ins trich_leb x t; isBST.
    auto.
    apply isBST2_balance. isBST2'. apply All_ins. split; trich.
    apply isBST2_balance. isBST2'. apply All_ins. split; trich.
Qed.

(** Properties of [insert]. *)

Lemma Elem_insert :
  forall {A : Type} (leb : A -> A -> bool) (x y : A) (t : RBTree A),
    Elem x (insert leb y t) <-> x = y \/ Elem x t.
Proof.
  unfold insert. intros. rewrite Elem_makeBlack, Elem_ins. reflexivity.
Qed.

Lemma isBST_insert :
  forall {A : Ord} (x : A) (t : RBTree A),
    isBST t -> isBST (insert trich_leb x t).
Proof.
  intros. unfold insert. apply isBST_makeBlack, isBST_ins. assumption.
Qed.

Lemma isBST2_insert :
  forall (A : Ord) (x : A) (t : RBTree A),
    isBST2 t -> isBST2 (insert trich_leb x t).
Proof.
  intros. unfold insert. apply isBST2_makeBlack, isBST2_ins. assumption.
Qed.

(** Properties of [inorder]. *)

Lemma Elem_inorder :
  forall (A : Type) (x : A) (t : RBTree A),
    In x (inorder t) <-> Elem x t.
Proof.
  split.
    induction t; cbn; intros; try apply in_app_or in H; firstorder.
      subst. firstorder.
    induction 1; cbn; apply in_or_app; firstorder.
Qed.

(** Properties of [fromList]. *)

Lemma Elem_fromList :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (l : list A),
    Elem x (fromList leb l) <-> In x l.
Proof.
  split.
    induction l as [| h t]; cbn; intros.
      inv H.
      rewrite Elem_insert in H. inv H.
    induction l as [| h t]; cbn; intros.
      inv H.
      rewrite Elem_insert. inv H.
Qed.

Lemma isBST_fromList :
  forall (A : Ord) (l : list A),
    isBST (fromList trich_leb l).
Proof.
  induction l as [| h t]; cbn.
    constructor.
    apply isBST_insert. assumption.
Qed.

Lemma isBST2_fromList :
  forall (A : Ord) (l : list A),
    isBST2 (fromList trich_leb l).
Proof.
  induction l as [| h t]; cbn.
    constructor.
    apply isBST2_insert. assumption.
Qed.

(** TODO: implement [join] and [split] *)


Require Import XR_R.
Require Import XR_Rlt.
Require Import XR_Rlt_irrefl.
Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Rsqr.
Require Import XR_Rsqr_neg.
Require Import XR_Rsqr_le_abs_0.

Local Open Scope R_scope.

Lemma Rsqr_lt_abs_0 : forall x y:R, Rsqr x < Rsqr y -> Rabs x < Rabs y.
Proof.
  intros x y h.
  assert (th:=Rsqr_le_abs_0).
  specialize (th x y).
  destruct th as [ th | th ].
  {
    left.
    exact h.
  }
  { exact th. }
  {
    exfalso.
    apply Rlt_irrefl with (Rsqr x).
    unfold Rabs in th.
    destruct (Rcase_abs x) as [ hx | hx ] ;
    destruct (Rcase_abs y) as [ hy | hy ].
    {
      pattern x at 1 ; rewrite (Rsqr_neg x).
      rewrite th.
      rewrite <- Rsqr_neg.
      exact h.
    }
    {
      pattern x at 1 ; rewrite (Rsqr_neg x).
      rewrite th.
      exact h.
    }
    {
      pattern x at 2 ; rewrite th.
      rewrite <- Rsqr_neg.
      exact h.
    }
    {
      pattern x at 2 ; rewrite th.
      exact h.
    }
  }
Qed.


Require Import BA.NatList.
Require Import BA.Basics.

(* X is call a type argument*)
Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check (list nat). (* (list nat : Set) *)

Fixpoint repeatP (X:Type) (n:nat) (x:X) : list X :=
     match n with
      | O => nil X
      | S n => cons  X x (repeatP  X n x )
     end.

Example test_repeat :
  repeatP bool 1 false  = cons bool false (nil bool).
Proof. reflexivity. Qed.

 (* Exercise: 2 starsM (mumble_grumble) *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

 (* --> d (b a 5) is not well-typed because the actual type of X is not given.
The correct term should be (d mumble (b a 5))
    -->  (d mumble (b a 5))  this one is the solution above .
    -->  (d bool (b a 5)) same scenario but with a different type (here bool).
    -->  (e bool true) simple enough.
    -->  (e mumble (b c 0)) ok.
    -->  (e bool (b c 0)) can not match bool and numble
    -->  (c) same scenario as using a bool or any inductie type. false,
true, O, S n*)

(* now let us make things more elegant with implicit argument. *)

Arguments nil {X}.
Arguments cons {X} _ _.

Fixpoint repeat0 {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count'=> cons x (repeat0 x count')
  end.

(* Haskell -> Coq

tails :: [a] -> [[a]]
tails []     = [[]]
tails (x:xs) = (x:xs) : tails xs *)

Fixpoint tails {X:Type} (xs:list X): list(list X):=
      match xs with
        | nil => nil
        | (cons x xs) => cons (cons x xs) (tails xs)
      end.

Compute (tails (cons 1(cons 2(cons 3 nil)))).

Check @nil.

Fixpoint app {X:Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons x xs => cons x (app xs l2)
  end.

Notation "x : y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Inductive prod (X Y: Type): Type :=
  |pair : X -> Y -> prod X Y.

Arguments pair {X}{Y}_ _.

Notation "( x , y )" := (pair x  y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p: X*Y)  : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x : xs, y : ys => (x, y) : (combine xs ys)
  end.

(* Exercise: 2 stars, recommended (split).
This version of mine is not good enough because i used the list xys two times.
After having more experience i'll change it. *)

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) :=
   match l with
     | [] => ([], [])
     | ((x,y):xys) => ((x:(fst (split xys))), (y:snd (split xys)))
   end.

Compute (split [(1,false),(2,false)]).

Example test_split:
  split [(1,false),(2,false)] = ([1,2],[false,false]).
Proof. reflexivity. Qed.

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

(* Exercise: 1 star, optional (hd_error_poly)*)

Definition hd_error {X : Type} (l : list X) : option X :=
    match l with
     | [] => None
     |(x:_) => Some x
    end.

Check @hd_error.

Example test_hd_error1 : hd_error [1,2] = Some 1.
 Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1],[2]] = Some [1].
 Proof. reflexivity. Qed.

(*Higher-Order Functions*)

Fixpoint filter {X:Type} (test: X-> bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h : t => if test h then h : (filter test t)
                        else filter test t
  end.

(* Exercise: 2 stars (filter_even_gt7) *)

(* the anonymous function fun should be used as the lambda function in Haskell *)

Definition filter_even_gt7 (l : list nat) : list nat:=
  filter (fun x => evenb x) (filter (fun n => leb 7 n ) l).

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8].
  Proof. simpl. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
  Proof. reflexivity. Qed.

(* Exercise: 3 stars (partition) *)
Definition oddb (n:nat) : bool := negb (evenb n).

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
   ((filter test l), (filter (fun x  => negb (test x )) l)).

Example test_partition1: partition oddb [1,2,3,4,5] = ([1,3,5], [2,4]).
  Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5,9,0] = ([], [5,9,0]).
  Proof. reflexivity. Qed.

Fixpoint map {X Y:Type} (f: X -> Y) (xs:list X):list Y :=
    match xs with
     |[] => []
     | (x:ys) => f x: map f ys
    end.

(* Exercise: 2 stars, recommended (flat_map)*)

Fixpoint concat {X:Type} (xss:list(list X)): (list X):=
     match xss with
       |[] => []
       |(x:xs) => x  ++ (concat xs)
      end.

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
    match l with
     | [] => []
     | xs => concat (map f xs)
    end.

Compute ( flat_map (fun n => [n,n,n]) [1,5,4]).

Example test_flat_map1:
  flat_map (fun n => [n,n,n]) [1,5,4]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
 Proof. reflexivity. Qed.

Fixpoint fold {X Y:Type} (f: X ->Y -> Y) (l:list X) (b:Y)
                         : Y :=
  match l with
  | nil => b
  | h : t => f h (fold f t b)
  end.

 (* Exercise: 3 starsM (fold_map)*)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
    fold (fun x res => f x: res) l [].

Compute(fold_map (fun x => x+1 )[1,2,3,4,5]).

Example fold_map0:
        fold_map (fun x => x+1 )[1,2,3,4,5]=[2,3,4,5,6].
Proof. reflexivity. Qed.


Require Import Iron.Language.SystemF2.KiJudge.

(* Substitution of types in types preserves kinding.
   Must also subst new new type into types in env higher than ix
   otherwise indices that reference subst type are broken, and
   the resulting type env would not be well formed *)
Theorem subst_type_type_ix
 :  forall ix ke t1 k1 t2 k2
 ,  get ix ke = Some k2
 -> KIND ke t1 k1
 -> KIND (delete ix ke) t2 k2
 -> KIND (delete ix ke) (substTT ix t2 t1) k1.
Proof.
 intros. gen ix ke t2 k1 k2.
 induction t1; intros; simpl; inverts_kind; eauto.

 Case "TVar".
  fbreak_nat_compare.
  SCase "n = ix".
   rewrite H in H4.
   inverts H4. auto.

  SCase "n < ix".
   apply KIVar. rewrite <- H4.
   apply get_delete_above; auto.

  SCase "n > ix".
   apply KIVar. rewrite <- H4.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below. omega.

 Case "TForall".
  apply KIForall.
  rewrite delete_rewind.
  eapply IHt1; eauto.
   apply kind_kienv_weaken; auto.
Qed.

Theorem subst_type_type_ix_forall2
 :  forall ix ke t2 k2 ts ks
 ,  get ix ke = Some k2
 -> Forall2 (KIND ke) ts ks
 ->          KIND (delete ix ke) t2 k2
 -> Forall2 (KIND (delete ix ke)) (map (substTT ix t2) ts) ks.
Proof.
 intros.
 eapply Forall2_map_left.
 apply (Forall2_impl
            (fun t k => KIND ke t k)
            (fun t k => KIND (delete ix ke) (substTT ix t2 t) k)
            ts ks).
  intros. eapply subst_type_type_ix; eauto.
  eauto.
Qed.

Theorem subst_type_type
 :  forall ke t1 k1 t2 k2
 ,  KIND (ke :> k2) t1 k1
 -> KIND ke         t2 k2
 -> KIND ke (substTT 0 t2 t1) k1.
Proof.
 intros.
 unfold substTT.
 rrwrite (ke = delete 0 (ke :> k2)).
 eapply subst_type_type_ix; burn.
Qed.


(* p52 ex3.2 *)

Parameter P Q R T : Prop.

Lemma id_P : P -> P.
Proof.
  intro.
  assumption.
Qed.

Lemma id_PP : (P -> P) -> (P -> P).
Proof.
  intros H p.
  assumption.
Qed.

Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  exact (fun X Y Z => Y (X Z)).
Qed.

Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros.
  apply H; assumption.
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  intros.
  apply H; assumption.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  intros.
  apply H; assumption.
Qed.

Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
Proof.
  intros.
  apply H.
  assumption.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros.
  apply H1.
  apply H.
  assumption.
  apply H0.
  assumption.
Qed.

Lemma weak_peirce: ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros.
  apply H.
  intros.
  apply H0.
  intros.
  apply H.
  intros.
  assumption.
Qed.