Require Import XR_R.
Require Import XR_R0.
Require Import XR_Rle.
Require Import XR_Rle_antisym.
Require Import XR_Rsqr.
Require Import XR_Rsqr_incr_0.

Local Open Scope R_scope.

Lemma Rsqr_inj : forall x y:R, R0 <= x -> R0 <= y -> Rsqr x = Rsqr y -> x = y.
Proof.
  intros x y.
  intros hx hy heq.
  apply Rle_antisym.
  {
    apply Rsqr_incr_0.
    {
      right.
      exact heq.
    }
    { exact hx. }
    { exact hy. }
  }
  {
    apply Rsqr_incr_0.
    {
      right.
      symmetry.
      exact heq.
    }
    { exact hy. }
    { exact hx. }
  }
Qed.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require  Export parallel_lemmas.

(*********************************************************************)
(*  Construction statements                                                         *)
(*********************************************************************)

Definition on_line (A B C : Point) : Prop := Col A B C /\ B <> C.
Definition on_line_d (A B C : Point) (lambda : F) : Prop :=
  Col A B C /\ B <> C /\ B ** A = lambda * B ** C.
Definition inter_ll (I A B C D : Point) : Prop :=
  Col I A B /\ Col I C D /\ ~ parallel A B C D.
Definition on_parallel (A' A B C : Point) : Prop := B <> C  /\ parallel A A' B C.
Definition on_parallel_d (Y R P Q : Point) (lambda : F) : Prop :=
  P <> Q  /\ parallel Y R P Q /\ R ** Y = lambda * P ** Q.
Definition on_inter_line_parallel (Y R U V P Q : Point) : Prop :=
  ~Col R P Q /\ Col Y U V /\ parallel Y R P Q /\ ~ parallel P Q U V.
Definition on_inter_parallel_parallel (Y R U V W P Q : Point) : Prop :=
  ~Col R P Q /\ parallel Y R U V /\ parallel Y W P Q /\ ~ parallel P Q U V.
Definition is_midpoint (I A B : Point) := on_line_d I A B (1 / 2).
Definition mratio (Y U V : Point) (r : F) :=
  on_parallel_d Y U U V (r / (1 + r)) /\ 1 + r  <> 0.

(** Lemma to go from point at some distance to point on a line *)

Lemma on_line_to_on_line_d : forall A B C,
 on_line A B C -> on_line_d A B C (B**A / B**C).
Proof.
intros.
unfold on_line, on_line_d in *.
intuition.
field.
Geometry.
Qed.

Lemma on_parallel_to_on_parallel_d : forall  Y T A B,
 on_parallel Y T A B -> on_parallel_d Y T A B (T**Y / A**B).
Proof.
intros.
unfold on_parallel, on_parallel_d in *.
intuition.
field.
Geometry.
Qed.

Theorem on_lineex : forall P Q : Point, P <> Q -> {Y : Point | Col Y P Q}.
Proof with Geometry.
intros.
assert (T := A2a P Q 1)...
DecompExAnd T X.
exists X...
Qed.

Theorem on_line_ex : forall P Q : Point, P<>Q -> exists Y, on_line Y P Q.
Proof with Geometry.
intros.
assert {Y : Point | Col Y P Q}.
apply on_lineex...
DecompEx H0 Y.
exists Y.
unfold on_line...
Qed.

Theorem on_line_dex :
 forall (P Q : Point) (lambda : F),
 P <> Q -> {Y : Point | Col Y P Q /\ P ** Y = lambda * P ** Q}.
Proof with Geometry.
intros.
assert (T := A2a P Q lambda).
DecompExAnd T X.
exists X...
Qed.

Theorem inter_llex :
 forall P Q U V : Point,
 ~ parallel P Q U V -> {Y : Point | Col Y P Q /\ Col Y U V}.
Proof with Geometry.
intros.
assert (P <> Q).
eapply par_aux_1.
apply H...
assert (T := A2a P Q (S P U V / S4 P U Q V))...
elim T; intro O; intros...
decompose [and] p...
clear T p...

cut (O ** Q / P ** Q = - (S Q U V / S4 P U Q V))...
intro...

assert (S O U V = P ** O / P ** Q * S Q U V + O ** Q / P ** Q * S P U V)...
apply l2_9...

assert (P ** O / P ** Q = S P U V / S4 P U Q V)...
rewrite H2...
field...
clear H2; rename H5 into H2...

rewrite H2 in H4...
rewrite H3 in H4...
assert (S O U V = 0)...
rewrite H4; field...

exists O...
assert (P ** O / P ** Q = S P U V / S4 P U Q V)...
rewrite H2; field...
clear H2; rename H3 into H2...

assert (P ** Q + Q ** O = P ** O)...
rewrite <- H3 in H2...
assert (O ** Q / P ** Q = 1 - S P U V / S4 P U Q V)...
rewrite <- H2...
assert (O ** Q = - Q ** O)...
rewrite H4...
field...

assert (1 - S P U V / S4 P U Q V = (S4 P U Q V - S P U V) / S4 P U Q V)...
field...
rewrite H5 in H4...
clear H5...
unfold S4 in H4...
assert (S P U Q + S P Q V - S P U V = - S Q U V)...
assert (S P Q V = S P Q U + S P U V + S U Q V)...
rewrite H5...
assert (S P Q U = - S P U Q)...
rewrite H6...
assert (S U Q V = - S Q U V)...
rewrite H7...
ring...
rewrite H5 in H4...
rewrite H4...
unfold S4 in |- *...
field...
Qed.

Lemma inter_ll_ex :  forall P Q U V : Point,
 ~ parallel P Q U V -> exists Y, inter_ll Y P Q U V.
Proof with intuition.
intros.
assert  {Y : Point | Col Y P Q /\ Col Y U V}.
apply inter_llex...
DecompExAnd H0 Y.
exists Y.
unfold inter_ll...
Qed.

Theorem on_parallelex : forall P Q R : Point,
  Q<>R ->
  ~ Col P Q R ->
  exists Y, parallel Q R P Y.
Proof.
intros.
assert ({Y : Point | parallel Q R P Y}).
apply euclid_parallel_existence.
DecompEx H1 Y.
exists Y.
intuition.
Qed.

Theorem on_parallel_ex : forall P Q R : Point,
  Q<>R ->
  ~ Col P Q R ->
  exists Y, on_parallel Y P Q R.
Proof.
intros.
assert ({Y : Point | parallel Q R P Y}).
apply euclid_parallel_existence.
elim H1;intros.
exists x.
unfold on_parallel.
intuition.
Qed.

Lemma  on_parallel_d_ex :
    forall (P Q R : Point) (lambda : F),
   P<>Q ->
   ~ Col P Q R ->
   exists Y, on_parallel_d Y R P Q lambda.
Proof with Geometry.
intros.

assert ({Y':Point | (parallel P Q R Y') /\ R<>Y'}).
apply euclid_parallel_existence_strong...
DecompExAnd H1 Y'.
assert {Y : Point | Col Y R Y' /\ R ** Y =  (lambda * P**Q/R**Y') * R ** Y'}.
apply on_line_dex...
DecompExAnd H1 Y.
exists Y.
unfold on_parallel_d.
repeat split...
cut (parallel P Q R Y).
Geometry.
eapply col_par_par.
apply H4.
Geometry.
Geometry.
rewrite H6.
field.
Geometry.
Qed.


(** * Combi.LRrule.freeSchur : Free Schur functions *)
(******************************************************************************)
(*      Copyright (C) 2014-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/                              *)
(******************************************************************************)
(** * Free Schur functions

This file is the second step of the proof of the Littewood-Richardson rule.
We translate theorem [LRtriple_cat_equiv] in a algebraic setting. Specifically,
the main goal of this file is to lift the multiplication of Schur multivariate
polynomials to the non commutative setting.

- [commword n R w] == the commutative image of the word [w] as a multivariate
                      polynomial (of type [{mpoly R[n]}]).
- [homlang n d] == the type of homogenous langage over ['I_n.+1] of degre [d].
                      that is [{set d.-tuple 'I_n}].
- [polylang n R s] == the commutative image of the langage [s] where s is of
                      type [homlang n d].
- [catlang l1 l2] == the concatenation of homogeneous language: given
                      [s1] of degree [d1] and [s2] of degree [d2] return an
                      homogeneous language of degree [d1 + d2].
- [tabwordshape n sh] == the set of reading of tableaux over ['I_n.+1] of
                      shape [sh], where [sh] is of type ['P_d]
- [freeSchur n t] == the set of words whose recording tableau over ['I_n.+1]
                      is [t], where [t] is of type [stdtabn]
- [tabword_of_tuple w] == the bijection freeSchur -> tabwordshape as stated
                      in Theorem [tabword_of_tuple_freeSchur]:

  [
    forall Q : stdtabn d,
      [set tabword_of_tuple x | x in freeSchur n0 Q] = tabwordshape n0 (shape_deg Q)
  ]

The free Littlewood-Richardson rule:

- [LRsupport Q1 Q2] == the set of standard Littlewood-Richardson Q-tableau in
                      the product of the free Schur function indexed by [Q1]
                      and [Q2], that is the set of [Q] which forms a [LRtriple]
                      with [Q1] and [Q2].

The main result here is the free LR rule [free_LR_rule]:

  [
      catlang (freeSchur Q1) (freeSchur Q2) = \bigcup_(Q in LRsupport) freeSchur Q.
  ]

We then go back to commutative Schur polynomials:

- [hyper_stdtab sh] == the hyper standard tableau of shape sh as a [seq (seq nat)].
- [hyper_stdtabn sh] == the hyper standard tableau of shape sh as a
                         [stdtabn d] where sh is a ['P_d].
- [LRtab_set Q1 Q2 Q] == the set of standard Littlewood-Richardson Q-tableau in
                      the product of the free Schur function indexed by [Q1]
                      and [Q2] of shape [Q].
- [LRtab_coeff Q1 Q2] == the Littlewood-Richardson coefficient defined
                      as the cardinality of [LRtab_set Q1 Q2 Q].

Invariance with the choice of Q1 and Q2:

- [bij_LRsupport Q1 Q2] == a bijection from [LRsupport T1 T2] to [LRsupport Q1 Q2]
                      as long as [T1] and [Q1] have the same shape as well as
                      [T2] and [Q2]. It is used to show Theorem
                      [LRtab_coeff_shapeE]:

  [
      shape T1 = P1 -> shape T2 = P2 ->
       LRtab_coeff P = #|[set Q in (LRsupport T1 T2) | (shape Q == P)]|.
  ]

****************************************************************************)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype.
From mathcomp Require Import order tuple finfun bigop finset ssralg.
From SsrMultinomials Require Import ssrcomplements freeg mpoly.

Require Import tools ordtype partition Yamanouchi std tableau stdtab.
Require Import Schensted congr plactic stdplact Yam_plact Greene_inv shuffle.
Require Import Schur_mpoly.

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

Import Order.TTheory.
Local Open Scope ring_scope.
Import GRing.Theory.

(** * Commutative image of an homogeneous langage *)
Section CommutativeImage.

Variable n : nat.
Variable R : comRingType.

Definition commword (w : seq 'I_n) : {mpoly R[n]} := \prod_(i <- w) 'X_i.

Lemma perm_commword (u v : seq 'I_n) :
  perm_eq u v -> commword u = commword v.
Proof using . exact: perm_big. Qed.

Lemma commword_morph (u v : seq 'I_n) :
  commword (u ++ v) = (commword u) * (commword v).
Proof using . by rewrite /commword big_cat. Qed.

Lemma commtuple_morph d1 d2 (u : d1.-tuple 'I_n) (v : d2.-tuple 'I_n) :
  commword (cat_tuple u v) = (commword u) * (commword v).
Proof using . by rewrite commword_morph. Qed.

Definition homlang d := {set d.-tuple 'I_n}.
Definition polylang d (s : homlang d) := \sum_(w in s) commword w.
Definition catlang d1 d2 (s1 : homlang d1) (s2 : homlang d2) :
  homlang (d1 + d2) :=
 [set cat_tuple w1 w2 | w1 in s1, w2 in s2].

Lemma cat_tuple_inj d1 d2 (u x : d1.-tuple 'I_n) (v y : d2.-tuple 'I_n) :
  cat_tuple u v = cat_tuple x y -> (u, v) = (x, y).
Proof using .
rewrite /cat_tuple => [] [/eqP].
rewrite eqseq_cat; last by rewrite !size_tuple.
by move=> /andP [/eqP/val_inj -> /eqP/val_inj ->].
Qed.

Lemma catlangM d1 d2 (s1 : homlang d1) (s2 : homlang d2) :
  polylang s1 * polylang s2 = polylang (catlang s1 s2).
Proof using .
rewrite /polylang /catlang mulr_suml.
under eq_bigr do [rewrite mulr_sumr; under eq_bigr do rewrite -commword_morph].
rewrite pair_big /=.
rewrite -(big_imset (h := fun p => cat_tuple p.1 p.2) commword) /=;
  last by move=> [u v] [x y] /= _ _; apply: cat_tuple_inj.
apply: eq_bigl => w.
apply/idP/idP.
- move/imsetP => [] [u v] /=; rewrite unfold_in /= => /andP [Hu Hv] ->.
  exact: imset2_f.
- move/imset2P => [u v Hu Hv -> {w}].
  by apply/imsetP; exists (u, v) => //=; rewrite unfold_in /= Hu Hv.
Qed.

End CommutativeImage.

(** ** Row reading of tableau *)
Section TableauReading.

Context {disp : unit} {A : inhOrderType disp}.

Definition tabsh_reading_RS (sh : seq nat) (w : seq A) :=
  (to_word (RS w) == w) && (shape (RS (w)) == sh).

Lemma tabsh_reading_RSP (sh : seq nat) (w : seq A) :
  reflect
    (exists tab, [/\ is_tableau tab, shape tab = sh & to_word tab = w])
    (tabsh_reading_RS sh w).
Proof using .
apply (iffP idP).
- move=> /andP [/eqP HRS /eqP Hsh].
  exists (RS w); split => //; exact: is_tableau_RS.
- move=> [tab] [Htab Hsh Hw]; apply/andP.
  have:= RS_tabE Htab; rewrite Hw => ->.
  by rewrite Hw Hsh.
Qed.

Lemma tabsh_reading_RSE sh :
  tabsh_reading sh =1 tabsh_reading_RS sh.
Proof using .
move=> w.
apply/idP/idP.
- by move /tabsh_readingP/tabsh_reading_RSP.
- by move /tabsh_reading_RSP/tabsh_readingP.
Qed.

End TableauReading.

(** * Free Schur function : lifting Schur function is the free algebra *)
Section FreeSchur.

Variable R : comRingType.

Variable n0 : nat.
Local Notation n := (n0.+1).
Local Notation Schur sh := (Schur n0 R sh).
Local Notation homlang d := (homlang n d).

Section Degree.

Variable d : nat.

(* set of tableaux words on 'I_n of a given shape *)
Definition tabwordshape (sh : 'P_d) : homlang d :=
  [set t : d.-tuple 'I_n | tabsh_reading sh t ].
(* set of tableaux words on 'I_n of a given Q-symbol *)
Definition freeSchur (Q : stdtabn d) : homlang d  :=
  [set t : d.-tuple 'I_n | (RStabmap t).2 == Q].

Lemma freeSchurP Q (t : d.-tuple 'I_n) :
  t \in freeSchur Q = (val t \in langQ Q).
Proof using . by rewrite /freeSchur /langQ !inE /=. Qed.

Lemma size_RS_tuple (t : d.-tuple 'I_n) : size (to_word (RS t)) == d.
Proof using . by rewrite size_to_word -{2}(size_tuple t) size_RS. Qed.

(**  Bijection freeSchur -> tabwordshape *)
Definition tabword_of_tuple (t : d.-tuple 'I_n) : d.-tuple 'I_n :=
  Tuple (size_RS_tuple t).

Lemma perm_tabword_of_tuple (t : d.-tuple 'I_n) :
  perm_eq t (tabword_of_tuple t).
Proof using . rewrite /tabword_of_tuple /=; exact: perm_RS. Qed.

Lemma tabword_of_tuple_freeSchur_inj (Q : stdtabn d) :
  {in (freeSchur Q) &, injective tabword_of_tuple}.
Proof using .
move=> /= u v.
rewrite /freeSchur !inE => /eqP Hu /eqP Hv /(congr1 (@tval _ _)) /= H.
case: (bijRStab [inhOrderType of 'I_n]) => RSinv HK _.
apply: val_inj; rewrite -[val u]HK -[val v]HK; congr (RSinv _).
rewrite {RSinv HK} /RStab /=. apply: pqpair_inj => /=.
have:= (is_tableau_RS u). have:= is_tableau_RS v.
move: Hu Hv H; rewrite -!RStabmapE /RStabmap.
case: RSmap => [pu qu] /= ->; case: RSmap => [pv qv] /= -> Heq Hv Hu.
by rewrite -(RS_tabE Hu) -(RS_tabE Hv) Heq.
Qed.

Lemma tabword_of_tuple_freeSchur (Q : stdtabn d) :
  [set tabword_of_tuple x | x in freeSchur Q] = tabwordshape (shape_deg Q).
Proof using .
rewrite /freeSchur /tabwordshape /tabword_of_tuple.
apply/setP/subset_eqP/andP; split; apply/subsetP => w;
    rewrite !inE tabsh_reading_RSE /tabsh_reading_RS.
- move/imsetP => [t]; rewrite inE => /eqP HQ /(congr1 val) /= ->.
  rewrite (RS_tabE (is_tableau_RS t)) eq_refl /= {w}.
  by rewrite -HQ -!RStabmapE shape_RStabmapE.
- move/andP => [/eqP Hw /eqP Hsh]; apply/imsetP.
  have Hpair : is_RStabpair (RS w, val Q).
    by rewrite /is_RStabpair is_tableau_RS stdtabnP Hsh eq_refl.
  have Hpr : is_RSpair (RS w, yam_of_stdtab Q).
    have:= Hpair; rewrite /is_RStabpair /= => /andP [-> /=].
    move=> /andP [/yam_of_stdtabP -> /= /eqP ->].
    by rewrite shape_yam_of_stdtab.
  pose imw := (RStabinv (RSTabPair Hpair)).
  have Hsz : size (imw) == d.
    rewrite /imw /RStabinv /= -size_RS -RSmapE.
    rewrite (RSmapinv2K Hpr) /=.
    by rewrite size_RS size_tuple.
  exists (Tuple Hsz).
  + rewrite inE /= /imw.
    by have/(congr1 val) := RStabinvK (RSTabPair Hpair) => /= ->.
  + apply: val_inj => /=.
    rewrite /imw /RStabinv /= -Hw /=; congr (to_word _).
    by rewrite Hw -[RS (RSmapinv _ _)]RSmapE RSmapinv2K.
Qed.

End Degree.

(** ** Noncommutative lifting of Schur polynomials *)
Lemma SchurE d (Q : stdtabn d) :
  Schur (shape_deg Q) = polylang R (tabwordshape (shape_deg Q)).
Proof using .
rewrite Schur_tabsh_readingE /polylang /commword; apply eq_bigl => i /=.
by rewrite inE.
Qed.

(** ** Commutative image of freeSchur language *)
Lemma Schur_freeSchurE d (Q : stdtabn d) :
  Schur (shape_deg Q) = polylang R (freeSchur Q).
Proof using .
rewrite SchurE -tabword_of_tuple_freeSchur.
rewrite /polylang (big_imset _ (@tabword_of_tuple_freeSchur_inj _ Q)) /=.
apply: eq_bigr => t _; apply: perm_commword.
by rewrite perm_sym; exact: perm_RS.
Qed.

(** * The free Littlewood-Richardson rule *)
Section FreeLRrule.

Variables (d1 d2 : nat).
Variables (Q1 : stdtabn d1) (Q2 : stdtabn d2).

Definition LRsupport :=
  [set Q : stdtabn (d1 + d2) | pred_LRtriple_fast Q1 Q2 Q ].

Lemma free_LR_rule :
  catlang (freeSchur Q1) (freeSchur Q2) = \bigcup_(Q in LRsupport) freeSchur Q.
Proof using .
rewrite /catlang.
apply/setP/subset_eqP/andP; split; apply/subsetP=> t.
- move/imset2P => [w1 w2].
  rewrite !freeSchurP /= => Hw1 Hw2 ->.
  have:= conj Hw1 Hw2.
  rewrite LRtriple_cat_equiv // => [[H1 H2] [Q [Htriple /= Hcat]]].
  have:= is_stdtab_of_n_LRtriple (stdtabnP Q1) (stdtabnP Q2) Htriple.
  rewrite !size_tab_stdtabn => HQ.
  apply/bigcupP; exists (StdtabN HQ).
    rewrite /LRsupport inE -LRtriple_fastE //.
    apply/LRtripleP => //; exact: Htriple.
  by rewrite freeSchurP.
- move/bigcupP => [Q]; rewrite /LRsupport freeSchurP inE => Htriple /= Ht.
  have Hsz1 : size (take d1 t) == d1.
    by rewrite size_takel // size_tuple leq_addr.
  pose t1 := Tuple Hsz1.
  have Hsz2 : size (drop d1 t) == d2.
    by rewrite size_drop size_tuple addKn.
  pose t2 := Tuple Hsz2.
  have Hcat : t = cat_tuple t1 t2.
    by apply: val_inj => /=; rewrite cat_take_drop.
  have : val t1 \in langQ Q1 /\ val t2 \in langQ Q2.
    rewrite LRtriple_cat_equiv // !size_tuple !size_tab_stdtabn //.
    split; try by [].
    exists Q; split.
    + by apply/LRtripleP => //; rewrite LRtriple_fastE.
    + by rewrite /= cat_take_drop.
  move=> [/= Ht1 Ht2].
  apply/imset2P; apply: (Imset2spec (x1 := t1) (x2 := t2)).
  + by rewrite freeSchurP.
  + by rewrite freeSchurP.
  + by apply: val_inj; rewrite /= cat_take_drop.
Qed.

(** Alternative proof from [LRrule_langQ] *)
Lemma free_LR_rule_alternate :
  catlang (freeSchur Q1) (freeSchur Q2) = \bigcup_(Q in LRsupport) freeSchur Q.
Proof using .
rewrite /catlang.
apply/setP/subset_eqP/andP; split; apply/subsetP=> /= t.
- move/imset2P => [/= w1 w2].
  rewrite !freeSchurP /= => Hw1 Hw2 ->.
  have : exists u v, [/\ w1 ++ w2  = u ++ v, u \in langQ Q1 & v \in langQ Q2].
    by exists w1, w2.
  rewrite LRrule_langQ // => [] [w] [Htriple /= Hcat].
  have:= is_stdtab_of_n_LRtriple (stdtabnP Q1) (stdtabnP Q2) Htriple.
  rewrite !size_tab_stdtabn => HQ.
  apply/bigcupP; exists (StdtabN HQ).
    rewrite /LRsupport inE -LRtriple_fastE //.
    apply/LRtripleP => //; exact: Htriple.
  by rewrite freeSchurP.
- move/bigcupP => [/= Q]; rewrite /LRsupport freeSchurP inE -LRtriple_fastE //.
  move=> /(LRtripleP _ (stdtabnP Q1) (stdtabnP Q2)) Htriple /= Ht.
  have : exists Q, LRtriple Q1 Q2 Q /\ val t \in langQ Q by exists Q.
  rewrite -LRrule_langQ_alternate // => [] [/= u1] [/= u2] [Hcat Hu1 Hu2].
  have:= Hu1 => /size_langQ; rewrite size_tab_stdtabn => /eqP Hsz1.
  pose t1 := Tuple Hsz1.
  have:= Hu2 => /size_langQ; rewrite size_tab_stdtabn => /eqP Hsz2.
  pose t2 := Tuple Hsz2.
  apply/imset2P; apply: (Imset2spec (x1 := t1) (x2 := t2)).
  + by rewrite freeSchurP.
  + by rewrite freeSchurP.
  + exact: val_inj.
Qed.

(** Passing to commutative image in the free LR rule *)
Theorem LR_rule_tab :
  Schur (shape_deg Q1) * Schur (shape_deg Q2) =
    \sum_(Q in LRsupport) (Schur (shape_deg Q)).
Proof using .
rewrite !Schur_freeSchurE catlangM free_LR_rule.
rewrite -cover_imset /polylang.
rewrite big_trivIset /=; first last.
  apply/trivIsetP => S1 S2.
  move => /imsetP [/= T1]; rewrite inE => HT1 -> {S1}.
  move => /imsetP [/= T2]; rewrite inE => HT2 -> {S2}.
  rewrite /freeSchur => Hdiff.
  rewrite /disjoint; apply/pred0P => w /=.
  rewrite !inE; apply: negbTE; move: Hdiff; apply: contra.
  by move=> /andP [/eqP -> /eqP ->].
under [RHS]eq_bigr do rewrite Schur_freeSchurE.
rewrite (big_setID [set set0]) /= big1 ?add0r; first last => [i|].
  rewrite inE => /andP [_]; rewrite inE => /eqP ->.
  by rewrite big_set0.
rewrite (big_setID [set x | freeSchur x == set0]) /=.
rewrite [X in X + _]big1 ?add0r; first last => [i|].
  rewrite inE => /andP [_]; rewrite inE => /eqP ->.
  by rewrite /polylang big_set0.
rewrite -big_imset /=; first last => [T1 T2 /=|].
  rewrite inE => /andP []; rewrite inE => /set0Pn [x1 Hx1] _ _.
  move: Hx1; rewrite inE => /eqP Hx1 /setP/(_ x1); rewrite !inE Hx1.
  rewrite eq_refl => /esym/eqP; exact: val_inj.
apply: eq_bigl => s; rewrite !inE; apply/idP/idP.
+ move=> /andP [Hn0 /imsetP [Q HQ Hs]]; subst s.
  by rewrite imset_f //= inE HQ inE Hn0.
+ move/imsetP => [Q]; rewrite 2!inE => /andP [H1 H2] ->.
  by rewrite H1 /= imset_f.
Qed.

End FreeLRrule.

Definition hyper_stdtab sh := RS (std (hyper_yam sh)).
Lemma hyper_stdtabP sh : is_stdtab (hyper_stdtab sh).
Proof using . by rewrite /hyper_stdtab /= RSstdE std_is_std. Qed.

Lemma hyper_stdtabnP d (P : 'P_d) : is_stdtab_of_n d (hyper_stdtab P).
Proof using .
rewrite /is_stdtab_of_n /= hyper_stdtabP /= size_RS.
rewrite size_std -evalseq_eq_size (evalseq_hyper_yam (intpartnP P)).
by rewrite sumn_intpartn.
Qed.
Canonical hyper_stdtabn d (P : 'P_d) := StdtabN (hyper_stdtabnP P).

Lemma shape_hyper_stdtabnP d (P : 'P_d) : shape (hyper_stdtabn P) = P.
Proof using .
  rewrite shape_RS_std (shape_RS_yam (hyper_yamP (intpartnP P))).
  by rewrite (evalseq_hyper_yam (intpartnP P)).
Qed.
Lemma shaped_hyper_stdtabnP d (P : 'P_d) : shape_deg (hyper_stdtabn P) = P.
Proof using . apply: val_inj => /=; exact: shape_hyper_stdtabnP. Qed.

Section Coeffs.

Variables d1 d2 : nat.
Variables (P1 : 'P_d1) (P2 : 'P_d2).

Definition LRtab_set (P : 'P_(d1 + d2)) :=
  [set Q in (LRsupport (hyper_stdtabn P1) (hyper_stdtabn P2)) | (shape Q == P)].
Definition LRtab_coeff (P : 'P_(d1 + d2)) := #|LRtab_set P|.

Theorem LRtab_coeffP :
  Schur P1 * Schur P2 = \sum_P (Schur P) *+ LRtab_coeff P.
Proof using .
rewrite /LRtab_coeff /LRtab_set.
have:= LR_rule_tab (hyper_stdtabn P1) (hyper_stdtabn P2).
rewrite !shaped_hyper_stdtabnP => ->.
move : (LRsupport _ _) => LR.
rewrite (partition_big (@shape_deg (d1 + d2)) predT) //=.
apply: eq_bigr => P _.
under eq_bigr => T /andP [_ /eqP ->] do [].
rewrite sumr_const; congr (_ *+ _).
by apply: eq_card => i /=; rewrite unfold_in inE.
Qed.

Lemma size_RSmapinv2_yam d
      (disp : unit) (Typ : inhOrderType disp)
      (tab : seq (seq Typ)) (T : stdtabn d) :
  size (RSmapinv2 (tab, yam_of_stdtab T)) = d.
Proof using .
rewrite -{2}(size_tab_stdtabn T) -size_yam_of_stdtab // /RSmapinv2 /=.
elim: (yam_of_stdtab _) tab => [//= | w0 w /= IHw] tab.
case: (invinstabnrow _ _) => [tr lr].
by rewrite size_rcons IHw.
Qed.

(** ** Invariance with respect to choice of the Q-Tableau *)
Section Bij_LRsupport.

Section ChangeUT.

Variable (U1 T1 : stdtabn d1) (U2 T2 : stdtabn d2).
Hypothesis Hsh1 : shape U1 = shape T1.
Hypothesis Hsh2 : shape U2 = shape T2.

Section TakeDrop.

Context {disp : unit} {T : inhOrderType disp}.

Lemma RStabE (w : seq T) : (RStab w).1 = (RS w).
Proof using . by rewrite RStabmapE. Qed.

Definition changeUT T1 T2 (w : seq T) : seq T :=
  (RSmapinv2 (RS (take d1 w), yam_of_stdtab T1)) ++
  (RSmapinv2 (RS (drop d1 w), yam_of_stdtab T2)).

Variable w : seq T.
Hypothesis Htake : shape (RS (take d1 w)) = shape U1.
Hypothesis Hdrop : shape (RS (drop d1 w)) = shape U2.

Lemma changeUtakeP : is_RStabpair (RS (take d1 w), val U1).
Proof using Htake.
by rewrite /is_RStabpair is_tableau_RS Htake /= eq_refl andbT.
Qed.
Lemma changeUdropP : is_RStabpair (RS (drop d1 w), val U2).
Proof using Hdrop.
by rewrite /is_RStabpair is_tableau_RS Hdrop /= eq_refl andbT.
Qed.
Lemma changeTtakeP : is_RStabpair (RS (take d1 w), val T1).
Proof using Hsh1 Htake.
by rewrite /is_RStabpair is_tableau_RS Htake /= Hsh1 eq_refl andbT.
Qed.
Lemma changeTdropP : is_RStabpair (RS (drop d1 w), val T2).
Proof using Hdrop Hsh2.
by rewrite /is_RStabpair is_tableau_RS Hdrop /= Hsh2 eq_refl andbT.
Qed.
Lemma toDepRSPair (u : seq T) d (t : stdtabn d) :
  forall H : is_RStabpair (RS u, val t),
  RSmapinv2 (RS u, yam_of_stdtab t) = RStabinv (RSTabPair H).
Proof using . by []. Qed.

Lemma plact_changeUT_take : take d1 (changeUT T1 T2 w) =Pl take d1 w.
Proof using Hsh1 Htake.
rewrite /changeUT take_size_cat; last by rewrite /= size_RSmapinv2_yam.
rewrite (toDepRSPair changeTtakeP).
apply Sch_plact; apply/eqP.
by rewrite -[LHS]RStabE RStabinvK //.
Qed.

Lemma plact_changeUT_drop : drop d1 (changeUT T1 T2 w) =Pl drop d1 w.
Proof using Hdrop Hsh2.
rewrite /changeUT drop_size_cat; last by rewrite /= size_RSmapinv2_yam.
rewrite (toDepRSPair changeTdropP).
apply Sch_plact; apply/eqP.
by rewrite -[LHS]RStabE RStabinvK //.
Qed.

Lemma plact_changeUT : changeUT T1 T2 w =Pl w.
Proof using Hdrop Hsh1 Hsh2 Htake.
rewrite /changeUT -{3}(cat_take_drop d1 w).
apply: plact_cat.
- have:= plact_changeUT_take.
  by rewrite /changeUT take_size_cat // size_RSmapinv2_yam.
- have:= plact_changeUT_drop.
  by rewrite /changeUT drop_size_cat // size_RSmapinv2_yam.
Qed.

End TakeDrop.

Lemma changeUTK (disp : unit) (T : inhOrderType disp) (w : seq T) :
  (take d1 w) \in langQ U1 ->
  (drop d1 w) \in langQ U2 ->
  changeUT U1 U2 (changeUT T1 T2 w) = w.
Proof using Hsh1 Hsh2.
rewrite !inE /= /changeUT => /eqP Htake /eqP Hdrop.
rewrite ?take_size_cat ?drop_size_cat ?size_RSmapinv2_yam //.
have Htk : shape (RS (take d1 w)) = shape U1.
  by rewrite -RStabmapE shape_RStabmapE Htake.
have Hdp : shape (RS (drop d1 w)) = shape U2.
  by rewrite -RStabmapE shape_RStabmapE Hdrop.
have -> : RS (RSmapinv2 (RS (take d1 w), yam_of_stdtab T1)) = RS (take d1 w).
  by rewrite (toDepRSPair (changeTtakeP _)) -RStabE RStabinvK /=.
have -> : RS (RSmapinv2 (RS (drop d1 w), yam_of_stdtab T2)) = RS (drop d1 w).
  by rewrite (toDepRSPair (changeTdropP _)) -RStabE RStabinvK /=.
rewrite -{3}(cat_take_drop d1 w); congr (_ ++ _).
- move: Htake; rewrite /RStabmap /= -!RSmapE.
  case H : (RSmap (take d1 w)) => [Pt Qt] <- /=.
  rewrite stdtab_of_yamK -/((Pt, Qt).2) -H; last exact: is_yam_RSmap2.
  by rewrite RSmapK.
- move: Hdrop; rewrite /RStabmap /= -!RSmapE.
  case H : (RSmap (drop d1 w)) => [Pt Qt] <- /=.
  rewrite stdtab_of_yamK -/((Pt, Qt).2) -H; last exact: is_yam_RSmap2.
  by rewrite RSmapK.
Qed.

Section DefBij.

Variable Q : stdtabn (d1 + d2).
Hypothesis HTriple : pred_LRtriple U1 U2 Q.
Let w := RSmapinv2 (yamtab (shape Q), yam_of_stdtab Q).

Lemma RSpairyamQ : is_RSpair (yamtab (shape Q), yam_of_stdtab Q).
Proof using .
rewrite /= yamtabP /=; last by apply: is_part_sht; exact: stdtabP.
by rewrite yam_of_stdtabP //= shape_yam_of_stdtab // shape_yamtab.
Qed.

Lemma bij_LRsupportP :
  is_stdtab_of_n (d1 + d2)
    (RStab (changeUT T1 T2 (RSmapinv2 (yamtab (shape Q), yam_of_stdtab Q)))).2.
Proof using .
rewrite /is_stdtab_of_n /=.
apply/andP; split; first exact: is_stdtab_RStabmap2.
rewrite /size_tab /= -shape_RStabmapE RStabmapE -/(size_tab _) size_RS size_cat.
by rewrite !size_RSmapinv2_yam.
Qed.
Definition bij_LRsupport := StdtabN bij_LRsupportP.

Lemma take_drop_langQ :
  ((take d1 w) \in langQ U1 /\ (drop d1 w) \in langQ U2).
Proof using HTriple.
have:= HTriple => /LRtripleP-/(_ (stdtabnP _) (stdtabnP _)) Htriple.
have Hszw : size w = (d1 + d2)%N by rewrite /w size_RSmapinv2_yam.
rewrite LRtriple_cat_equiv //; split.
- rewrite size_take size_tab_stdtabn Hszw.
  case: d2 => [| n]; first by rewrite addn0 ltnn.
  by rewrite addnS ltnS leq_addr.
- by rewrite size_drop size_tab_stdtabn Hszw addKn.
- exists (val Q); split; first exact: Htriple.
  rewrite cat_take_drop /w inE /= /RStabmap RSmapinv2K; last exact: RSpairyamQ.
  by rewrite yam_of_stdtabK.
Qed.

Lemma shape_bij_LRsupport : shape bij_LRsupport = shape Q.
Proof using HTriple Hsh1 Hsh2.
have:= take_drop_langQ; rewrite /= -shape_RStabmapE RStabmapE.
rewrite !inE => [] [/eqP HU1 /eqP HU2].
have -> : RS (changeUT T1 T2 w) = RS w.
  apply/eqP; rewrite -plactic_RS;
  by apply: plact_changeUT; rewrite -RStabmapE shape_RStabmapE ?HU1 ?HU2.
rewrite /w -RSmapE shape_RSmap_eq /w RSmapinv2K; last exact: RSpairyamQ.
by rewrite //= shape_yam_of_stdtab.
Qed.

Lemma shape_takeRS : shape (RS (take d1 w)) = shape U1.
Proof using HTriple.
have:= take_drop_langQ; rewrite -/w => /= [] [Htake _].
move: Htake; rewrite inE => /eqP <-.
by rewrite -RStabmapE shape_RStabmapE.
Qed.

Lemma shape_dropRS : shape (RS (drop d1 w)) = shape U2.
Proof using HTriple.
have:= take_drop_langQ; rewrite -/w => /= [] [_ Hdrop].
move: Hdrop; rewrite inE => /eqP <-.
by rewrite -RStabmapE shape_RStabmapE.
Qed.

Lemma predLR_bij_LRsupport : pred_LRtriple T1 T2 bij_LRsupport.
Proof using HTriple Hsh1 Hsh2.
apply/LRtripleP => //=.
have:= take_drop_langQ; rewrite -/w => /= [] [Htake Hdrop].
apply LRtriple_cat_langQ => //.
- have Hpair := changeTtakeP shape_takeRS.
  rewrite (toDepRSPair Hpair) inE.
  by have/(congr1 (fun p => (val p).2)) := RStabinvK (RSTabPair Hpair) => /= ->.
- have Hpair := changeTdropP shape_dropRS.
  rewrite (toDepRSPair Hpair) inE.
  by have/(congr1 (fun p => (val p).2)) := RStabinvK (RSTabPair Hpair) => /= ->.
Qed.

End DefBij.

Lemma card_LRtab_set_leq (P : seq nat) :
  #|[set Q in (LRsupport U1 U2) | (shape Q == P)]| <=
  #|[set Q in (LRsupport T1 T2) | (shape Q == P)]|.
Proof using Hsh1 Hsh2.
rewrite /LRsupport.
have Hsimpl A B C :
    [set Q in (LRsupport A B) | (shape Q == C)] =
    [set Q : stdtabn (d1 + d2) | pred_LRtriple A B Q & (shape Q == C)].
  apply/setP => Q; rewrite /LRsupport 2!inE [RHS]inE.
  by congr (_ && _); rewrite LRtriple_fastE.
rewrite !{}Hsimpl.
rewrite -(card_in_imset (f := bij_LRsupport)).
- apply subset_leqif_cards; apply/subsetP => Qres /imsetP [Q].
  rewrite inE => /andP [Hpred /eqP <-] -> {Qres}.
  rewrite inE; apply/andP; split.
  + exact: predLR_bij_LRsupport.
  + by rewrite shape_bij_LRsupport.
- move=> Q1 Q2; rewrite inE => /andP [HQ1 /eqP HshQ1].
  rewrite inE => /andP [HQ2 /eqP]; rewrite -HshQ1 {HshQ1} => Heqsh.
  move=>/(congr1 (@val _ _ _)); rewrite /=.
  set w1 := (X in changeUT _ _ X).
  set w2 := (X in _ = (RStab (changeUT _ _ X)).2) => Heq1.
  have : RS w1 = RS w2.
    rewrite -!RSmapE /w1 /w2 !RSmapinv2K; first last.
    + rewrite /is_RSpair yamtabP /=; last by apply: is_part_sht; exact: stdtabP.
      by rewrite yam_of_stdtabP //= shape_yamtab shape_yam_of_stdtab.
    + rewrite /is_RSpair yamtabP /=; last by apply: is_part_sht; exact: stdtabP.
      by rewrite yam_of_stdtabP //= shape_yamtab shape_yam_of_stdtab.
    + by rewrite /= Heqsh.
  have:= take_drop_langQ HQ1.
  have:= plact_changeUT (shape_takeRS HQ1) (shape_dropRS HQ1); rewrite -/w1.
  rewrite plactic_RS => /eqP <- [HQ1take HQ1drop].
  have:= take_drop_langQ HQ2.
  have:= plact_changeUT (shape_takeRS HQ2) (shape_dropRS HQ2); rewrite -/w2.
  rewrite plactic_RS => /eqP <- [HQ2take HQ2drop].
  rewrite -!RStabE => Heq2.
  have {Heq1 Heq2 HQ1take HQ1drop HQ2take HQ2drop} Heq : w1 = w2.
    rewrite -(changeUTK HQ1take HQ1drop) -(changeUTK HQ2take HQ2drop).
    congr changeUT.
    rewrite -(RStabK (changeUT T1 T2 w1)) -(RStabK (changeUT T1 T2 w2)).
    congr RStabinv.
    apply val_inj; move: Heq1 Heq2 => /=.
    case: (RStabmap (changeUT T1 T2 w1)) => A1 B1.
    by case: (RStabmap (changeUT T1 T2 w2)) => A2 B2 /= -> ->.
  apply val_inj.
  rewrite /= -(yam_of_stdtabK (stdtabnP Q1)) -(yam_of_stdtabK (stdtabnP Q2)).
  congr stdtab_of_yam.
  have:= RSmapinv2K (RSpairyamQ Q1); rewrite -/w1 Heq /w2.
  by rewrite (RSmapinv2K (RSpairyamQ Q2)) => [] [_ ->].
Qed.

End ChangeUT.

Lemma card_LRtab_set_shapeE P (U1 T1 : stdtabn d1) (U2 T2 : stdtabn d2) :
  shape T1 = shape U1 -> shape T2 = shape U2 ->
  #|[set Q in (LRsupport U1 U2) | (shape Q == P)]| =
  #|[set Q in (LRsupport T1 T2) | (shape Q == P)]|.
Proof using .
by move=> H1 H2; apply anti_leq; rewrite !card_LRtab_set_leq // H1 H2.
Qed.

Theorem LRtab_coeff_shapeE (T1 : stdtabn d1) (T2 : stdtabn d2) P :
  shape T1 = P1 -> shape T2 = P2 ->
  LRtab_coeff P = #|[set Q in (LRsupport T1 T2) | (shape Q == P)]|.
Proof using .
rewrite /LRtab_coeff /LRtab_set => H1 H2.
by apply card_LRtab_set_shapeE; rewrite shape_hyper_stdtabnP ?H1 ?H2.
Qed.

End Bij_LRsupport.

End Coeffs.

End FreeSchur.

(** ** Conjugating tableaux in the free LR rule *)
Section Conj.

Variables d1 d2 : nat.

Lemma LRsupport_conj (T1 : stdtabn d1) (T2 : stdtabn d2):
  LRsupport (conj_stdtabn T1) (conj_stdtabn T2) =
            (@conj_stdtabn _) @: (LRsupport T1 T2).
Proof using .
apply/setP => T; rewrite inE.
apply/idP/idP.
- rewrite -LRtriple_fastE; try exact: is_stdtab_conj => //; last exact: stdtabnP.
  move=> H.
  apply/imsetP; exists (conj_stdtabn T).
  + rewrite inE -LRtriple_fastE //.
    rewrite pred_LRtriple_conj // conj_tabK; first exact H.
    * exact: stdtabP.
    * apply val_inj; rewrite /= conj_tabK //; exact: stdtabP.
- move=> /imsetP [U]; rewrite inE -LRtriple_fastE //.
  rewrite pred_LRtriple_conj // => H -> {T}.
  rewrite -LRtriple_fastE; try exact: is_stdtab_conj.
  exact: H.
Qed.

Theorem LRtab_coeff_conj (P1 : 'P_d1) (P2 : 'P_d2) (P : 'P_(d1 + d2)) :
  LRtab_coeff P1 P2 P =
  LRtab_coeff (conj_intpartn P1) (conj_intpartn P2) (conj_intpartn P).
Proof using .
rewrite [RHS](LRtab_coeff_shapeE
                (T1 := conj_stdtabn (hyper_stdtabn P1))
                (T2 := conj_stdtabn (hyper_stdtabn P2))); first last.
  - by rewrite shape_conj_tab shape_hyper_stdtabnP.
  - by rewrite shape_conj_tab shape_hyper_stdtabnP.
rewrite /LRtab_coeff /LRtab_set LRsupport_conj.
have Hinj : injective (conj_stdtabn (n:=d1 + d2)).
  apply inv_inj => T; apply val_inj; rewrite /= conj_tabK //; exact: stdtabP.
rewrite -(@card_imset _ _ (@conj_stdtabn _)) //.
rewrite !setIdE imsetI; last by move=> a b /= _ _; exact: Hinj.
congr (card (mem (_ :&: _))).
apply/setP => T; rewrite !inE.
apply/idP/idP.
- move/imsetP => [U]; rewrite inE => /eqP HU -> /=.
  by rewrite shape_conj_tab HU.
- move/eqP => H; apply/imsetP; exists (conj_stdtabn T).
  + by rewrite inE /= shape_conj_tab H /= conj_partK.
  + apply val_inj => //=; rewrite conj_tabK //; exact: stdtabP.
Qed.

End Conj.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e512m569_16limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e384m317_6limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import PocklingtonRefl.

Open Local Scope positive_scope.

Lemma prime142948719999101 : prime 142948719999101.
Proof.
 apply (Pocklington_refl
         (Pock_certif 142948719999101 2 ((7256280203, 1)::(2,2)::nil) 1)
        ((Pock_certif 7256280203 2 ((33285689, 1)::(2,1)::nil) 1) ::
         (Pock_certif 33285689 3 ((4160711, 1)::(2,3)::nil) 1) ::
         (Pock_certif 4160711 7 ((416071, 1)::(2,1)::nil) 1) ::
         (Pock_certif 416071 13 ((3, 3)::(2,1)::nil) 28) ::
         (Proof_certif 3 prime3) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime8901234567890123456789017: prime  8901234567890123456789017.
apply (Pocklington_refl

(SPock_certif
8901234567890123456789017
2
((11521380934487542399, 1)::nil))
(
(SPock_certif
11521380934487542399
2
((142948719999101, 1)::nil))
:: (Proof_certif 142948719999101 prime142948719999101) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e511m481_16limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Export SpecSyntax.
Require Export BoilerplateFunctions.
Set Implicit Arguments.

(*************************************************************************)
(* Reduction relation                                                    *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | tt       => True
    | abs _ _  => True
    | _        => False
  end.

Inductive red : Tm → Tm → Prop :=
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm 0 t2 t12)
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2').

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Unit :
      Typing Γ tt tunit
  | T_Abs {t T1 T2} :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12.


Require Import Util Option AllInRel Get Setoid.
Require Export paco3.
Require Import Coq.Logic.FunctionalExtensionality ClassicalFacts.

Axiom propositional_extensionality : prop_extensionality.

Notation "p =3= q" :=
  (forall x0 x1 x2, p x0 x1 x2 <-> (q x0 x1 x2:Prop))
    (at level 50, no associativity).

Definition R3Eq A B C (R R' : A -> B -> C -> Prop) :=
  R =3= R'.

Lemma pred3_extensionality A B C (R R' : A -> B -> C -> Prop)
  : R =3= R' -> R = R'.
Proof.
  intros.
  do 3 (eapply functional_extensionality; intros).
  eapply propositional_extensionality. eauto.
Qed.

Set Implicit Arguments.

Section Tower3.
  Variables A B C : Type.
  Variable f : (A -> B -> C -> Prop) -> (A -> B -> C -> Prop).

  Definition inf3 I (F: I -> A -> B -> C -> Prop) : A -> B -> C -> Prop :=
    fun a b c => forall i:I, F i a b c.

  Inductive T3 : (A -> B -> C -> Prop) -> Prop :=
  | T3_step R : T3 R -> T3 (f R)
  | T3_lim I (F : I -> A -> B -> C -> Prop)
    : (forall i, T3 (F i)) -> T3 (inf3 F).

  Definition companion3 (R : A -> B -> C -> Prop) : A -> B -> C -> Prop :=
    fun a b c => forall S, T3 S -> R <3= S -> S a b c.

  Notation "'㚘'" := companion3 (at level 0).

  Lemma T_companion3 x : T3 (companion3 x).
    repeat (eapply T3_lim; intros).
    eauto.
  Qed.

  Lemma companion3_monotone : monotone3 companion3.
    hnf; intros. hnf; intros.
    eapply IN; eauto.
  Qed.

  Lemma companion3_inc R : R <3= companion3 R.
    intros; hnf; eauto.
  Qed.

  Lemma companion3_idem x : companion3 (companion3 x) = companion3 x.
    eapply pred3_extensionality. split.
    - intros H; eapply H; eauto using T_companion3.
    - eapply companion3_inc.
  Qed.

  Lemma companion3_img x : T3 x -> companion3 x = x.
    intros; eapply pred3_extensionality.
    split; intros; eauto using companion3_inc.
    eapply H0; eauto.
  Qed.

  Definition inf3_closed (P: (A -> B -> C -> Prop) -> Prop) :=
    forall I (F : I -> A -> B -> C -> Prop),
      (forall i, P (F i)) -> P (inf3 F).

  Theorem tower_ind3 P
    : inf3_closed P ->
      (forall x, P (companion3 x) -> P (f (companion3 x))) ->
      forall x, P (companion3 x).
  Proof.
    intros.
    do 3 (eapply H; intros).
    clear x i1.
    induction i0; eauto.
    rewrite <- (companion3_img i0).
    eapply H0. rewrite companion3_img; eauto.
  Qed.

  Lemma companion3_fold R
    : monotone3 f -> f (companion3 R) <3= companion3 R.
  Proof.
    intro.
    eapply tower_ind3.
    - hnf; intros. hnf; intros. eauto.
    - intros. eapply H; eauto.
  Qed.

  Lemma companion3_unfold
    : companion3 bot3 <3= f (companion3 bot3).
  Proof.
    intros. eapply PR; intros.
    - econstructor 1. eapply T_companion3.
    - isabsurd.
  Qed.

  Section UptoLemma3.
    Variable g : (A -> B -> C -> Prop) -> (A -> B -> C -> Prop).
    Hypothesis gP : monotone3 g.

    Lemma upto3 :
      (forall x, g (companion3 x) <3= companion3 x -> g (f (companion3 x)) <3= f (companion3 x)) ->
      (forall x, g (companion3 x) <3= companion3 x).
    Proof.
      intros H1 H2.
      eapply tower_ind3.
      - intros; hnf; intros; eauto.
        hnf; eauto.
      - intros; eauto.
    Qed.

    Lemma upto_below3 :
      (forall x, g (companion3 x) <3= companion3 x) -> g <4= companion3.
    Proof.
      intros H1 r; intros.
      eapply H1. eapply gP; eauto.
      eapply companion3_inc.
    Qed.

    Lemma upto_char3 :
      monotone3 f ->
      g <4= companion3 ->
      forall x, g (companion3 x) <3= companion3 x -> g (f (companion3 x)) <3= f (companion3 x).
    Proof.
      intros gM H1 r H2; intros.
      eapply H1; eauto.
      econstructor 1. eapply T_companion3.
    Qed.
  End UptoLemma3.
End Tower3.


(* Software Foundations *)
(* Exercice 2 stars, poly_exercises *)

Inductive list(X: Type): Type:=
|nil: list X
|cons: X -> list X -> list X.

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

Notation "[]":= nil.
Notation "h :: t":= (cons h t) (at level 60, right associativity).
Notation "[ x ; .. ; y ]" :=(cons x .. (cons y nil) ..).

Fixpoint repeat{X: Type}(n: X)(count: nat): list X:=
    match count with
    |O        => []
    |S count' => n::(repeat n count')
    end.

Example test_repeat1: repeat true 2 = [true; true].
Proof. reflexivity. Qed.

Fixpoint app {X:Type}(l1 l2: list X): list X :=
    match l1 with
    |[]     => l2
    |h1::t1 => h1::(app t1 l2)
    end.

Theorem nil_app: forall (X: Type)(l: list X), app [] l = l.
Proof.
    reflexivity.
Qed.

Fixpoint snoc{X: Type}(s: list X)(v: X) :=
    match s with
    |[]   => [v]
    |h::t => h::(snoc t v)
    end.

Fixpoint rev{X: Type}(l: list X): list X :=
    match l with
    |[]   => []
    |h::t => snoc (rev t) h
    end.

Theorem rev_snoc: forall (X: Type)(v: X)(s: list X),
      rev (snoc s v) = v :: (rev s).
Proof.
    intros. induction s as [|s'].
    reflexivity.
    simpl. rewrite IHs. simpl. reflexivity.
Qed.

Theorem rev_involutive: forall (X: Type)(l: list X),
      rev (rev l) = l.
Proof.
    intros. induction l as [|h t].
    reflexivity.
    simpl. rewrite rev_snoc. rewrite IHt. reflexivity.
Qed.

Notation "l1 ++ l2" := (app l1 l2).

Theorem snoc_with_append: forall (X: Type)(l1 l2: list X)(v: X),
      snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
    intros. induction l1 as [|h1 t1].
    simpl. reflexivity.
    simpl. rewrite IHt1. reflexivity.
Qed.


From ch2o_compcert Require Export ifs_ch2o_core_c ch2o_safety_bigstep.
From ch2o Require Export restricted_smallstep.

Local Open Scope string_scope.

Theorem ifs_ch2o_safe: ch2o_safe_program Γ δ (λ z, z = 2%Z).
Proof.
eapply ch2o_safe_program_bigstep with (1:=Γ_valid) (2:=δ_valid) (3:=δ_main) (4:=eq_refl) (6:=eq_refl).
assert (17 ÷ 2 = 8)%Z. reflexivity.
assert (15 ÷ 5 = 3)%Z. reflexivity.
assert (8 ÷ 3 = 2)%Z. reflexivity.
assert (2 = (17 ÷ 2) ÷ (15 ÷ 5))%Z. reflexivity.
rewrite H2 at 2.
repeat econstructor; try (unfold int_lower || unfold int_upper); simpl; lia.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Module STLC.

Inductive ty : Type :=
| Bool  : ty
| Arrow : ty -> ty -> ty.

Inductive tm : Type :=
| var : string -> tm
| app : tm -> tm -> tm
| abs : string -> ty -> tm -> tm
| tru : tm
| fls : tm
| test : tm -> tm -> tm -> tm.

Open Scope string_scope.

Definition x := "x".
Definition y := "y".
Definition z := "z".

Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Notation idB :=
(abs x Bool (var x)).

Notation idBB :=
(abs x (Arrow Bool Bool) (var x)).

Notation idBBBB :=
(abs x (Arrow (Arrow Bool Bool)
(Arrow Bool Bool))
(var x)).

Notation k := (abs x Bool (abs y Bool (var x))).

Notation notB := (abs x Bool (test (var x) fls tru)).

Inductive value : tm -> Prop :=
| v_abs : forall x T t,
value (abs x T t)
| v_tru :
value tru
| v_fls :
value fls.

Hint Constructors value.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
match t with
| var x' =>
if eqb_string x x' then s else t
| abs x' T t1 =>
abs x' T (if eqb_string x x' then t1 else ([x:=s] t1))
| app t1 t2 =>
app ([x:=s] t1) ([x:=s] t2)
| tru =>
tru
| fls =>
fls
| test t1 t2 t3 =>
test ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive substi (s : tm) (x : string) : tm -> tm -> Prop :=
| s_var1 :
substi s x (var x) s

.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
[x:=s]t = t' <-> substi s x t t'.
Proof. hammer_hook "Stlc" "Stlc.STLC.substi_correct".
Admitted.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
| ST_AppAbs : forall x T t12 v2,
value v2 ->
(app (abs x T t12) v2) --> [x:=v2]t12
| ST_App1 : forall t1 t1' t2,
t1 --> t1' ->
app t1 t2 --> app t1' t2
| ST_App2 : forall v1 t2 t2',
value v1 ->
t2 --> t2' ->
app v1 t2 --> app v1  t2'
| ST_TestTru : forall t1 t2,
(test tru t1 t2) --> t1
| ST_TestFls : forall t1 t2,
(test fls t1 t2) --> t2
| ST_Test : forall t1 t1' t2 t3,
t1 --> t1' ->
(test t1 t2 t3) --> (test t1' t2 t3)

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
(app idBB idB) -->* idB.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example1".
eapply multi_step.
apply ST_AppAbs.
apply v_abs.
simpl.
apply multi_refl.  Qed.

Lemma step_example2 :
(app idBB (app idBB idB)) -->* idB.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example2".
eapply multi_step.
apply ST_App2. auto.
apply ST_AppAbs. auto.
eapply multi_step.
apply ST_AppAbs. simpl. auto.
simpl. apply multi_refl.  Qed.

Lemma step_example3 :
app (app idBB notB) tru -->* fls.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example3".
eapply multi_step.
apply ST_App1. apply ST_AppAbs. auto. simpl.
eapply multi_step.
apply ST_AppAbs. auto. simpl.
eapply multi_step.
apply ST_TestTru. apply multi_refl.  Qed.

Lemma step_example4 :
app idBB (app notB tru) -->* fls.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example4".
eapply multi_step.
apply ST_App2. auto.
apply ST_AppAbs. auto. simpl.
eapply multi_step.
apply ST_App2. auto.
apply ST_TestTru.
eapply multi_step.
apply ST_AppAbs. auto. simpl.
apply multi_refl.  Qed.

Lemma step_example1' :
app idBB idB -->* idB.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example1'". normalize.  Qed.

Lemma step_example2' :
app idBB (app idBB idB) -->* idB.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example2'". normalize. Qed.

Lemma step_example3' :
app (app idBB notB) tru -->* fls.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example3'". normalize.  Qed.

Lemma step_example4' :
app idBB (app notB tru) -->* fls.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example4'". normalize.  Qed.

Lemma step_example5 :
app (app idBBBB idBB) idB
-->* idB.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example5".
Admitted.

Lemma step_example5_with_normalize :
app (app idBBBB idBB) idB
-->* idB.
Proof. hammer_hook "Stlc" "Stlc.STLC.step_example5_with_normalize".
Admitted.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
| T_Var : forall Gamma x T,
Gamma x = Some T ->
Gamma |- var x \in T
| T_Abs : forall Gamma x T11 T12 t12,
(x |-> T11 ; Gamma) |- t12 \in T12 ->
Gamma |- abs x T11 t12 \in Arrow T11 T12
| T_App : forall T11 T12 Gamma t1 t2,
Gamma |- t1 \in Arrow T11 T12 ->
Gamma |- t2 \in T11 ->
Gamma |- app t1 t2 \in T12
| T_Tru : forall Gamma,
Gamma |- tru \in Bool
| T_Fls : forall Gamma,
Gamma |- fls \in Bool
| T_Test : forall t1 t2 t3 T Gamma,
Gamma |- t1 \in Bool ->
Gamma |- t2 \in T ->
Gamma |- t3 \in T ->
Gamma |- test t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Example typing_example_1 :
empty |- abs x Bool (var x) \in Arrow Bool Bool.
Proof. hammer_hook "Stlc" "Stlc.STLC.typing_example_1".
apply T_Abs. apply T_Var. reflexivity.  Qed.

Example typing_example_1' :
empty |- abs x Bool (var x) \in Arrow Bool Bool.
Proof. hammer_hook "Stlc" "Stlc.STLC.typing_example_1'". auto.  Qed.

Example typing_example_2 :
empty |-
(abs x Bool
(abs y (Arrow Bool Bool)
(app (var y) (app (var y) (var x))))) \in
(Arrow Bool (Arrow (Arrow Bool Bool) Bool)).
Proof with auto using update_eq. hammer_hook "Stlc" "Stlc.STLC.typing_example_2".
apply T_Abs.
apply T_Abs.
eapply T_App. apply T_Var...
eapply T_App. apply T_Var...
apply T_Var...
Qed.

Example typing_example_2_full :
empty |-
(abs x Bool
(abs y (Arrow Bool Bool)
(app (var y) (app (var y) (var x))))) \in
(Arrow Bool (Arrow (Arrow Bool Bool) Bool)).
Proof. hammer_hook "Stlc" "Stlc.STLC.typing_example_2_full".
Admitted.

Example typing_example_3 :
exists T,
empty |-
(abs x (Arrow Bool Bool)
(abs y (Arrow Bool Bool)
(abs z Bool
(app (var y) (app (var x) (var z)))))) \in
T.
Proof with auto. hammer_hook "Stlc" "Stlc.STLC.typing_example_3".
Admitted.

Example typing_nonexample_1 :
~ exists T,
empty |-
(abs x Bool
(abs y Bool
(app (var x) (var y)))) \in
T.
Proof. hammer_hook "Stlc" "Stlc.STLC.typing_nonexample_1".
intros Hc. inversion Hc.

inversion H. subst. clear H.
inversion H5. subst. clear H5.
inversion H4. subst. clear H4.
inversion H2. subst. clear H2.
inversion H5. subst. clear H5.
inversion H1.  Qed.

Example typing_nonexample_3 :
~ (exists S T,
empty |-
(abs x S
(app (var x) (var x))) \in
T).
Proof. hammer_hook "Stlc" "Stlc.STLC.typing_nonexample_3".
Admitted.

End STLC.


(** ** set

set というのはゴール内の部分項を指定した変数に束縛した上で
部分項をその変数に置換する tactic です。

証明項の形からは、let 式を構築します。

set の変種として、pose があり、これは純粋に let 式を構築するだけの tactic です。

まず、pose からみていきましょう。

*)

Goal 1 + 1 = 2.
Proof.
  pose (foo := 3 + 4).
(**
前提: <<foo := 3 + 4 : nat>>

pose により、前提に foo := 3 + 4 が追加されています。
*)
  Show Proof.
(**
証明項: <<(let foo := 3 + 4 in ?Goal)>>

証明項では、let 式により、foo が定義されています。

次に、set では行われる変数への置換が起きないことを確認してみましょう。
*)
  pose (bar := 1 + 1).
(**
前提: <<bar := 1 + 1 : nat>>
ゴール: <<1 + 1 = 2>>

pose により、前提に bar が追加されましたが、
ゴールは変化していません。
*)
  Show Proof.
(**
証明項: <<(let foo := 3 + 4 in let bar := 1 + 1 in ?Goal)>>

証明項では let 式により、bar が定義されています。
*)
Abort.

(**
次は、set では変数による置換も行われることを確認してみましょう。
*)

Goal 1 + 1 = 2.
Proof.
  set (baz := 1 + 1).
(**
前提: <<baz := 1 + 1 : nat>>
ゴール: <<baz = 2>>

set により、baz が前提に追加され、ゴール内の 1 + 1 が baz に置換されていることがわかります。
*)
  Show Proof.
(**
証明項: <<(let baz := 1 + 1 in ?Goal)>>

証明項では、let 式により、baz が定義されています。
ゴールの型はここには表示されていないので、ゴール内で置換がおきたかどうかは
この証明項の表示からはわかりません。
*)

Abort.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Shared definitions for containers                                       *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect
  LibRelation LibOperation LibInt LibMonoid.
Generalizable Variables A B K T.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Operators *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definitions *)

Class BagEmpty T := { empty : T }.
Class BagSingle A T := { single : A -> T }.
Class BagSingleBind A B T := { single_bind : A -> B -> T }.
Class BagIn A T := { is_in : A -> T -> Prop }.
Class BagBinds A B T := { binds : T -> A -> B -> Prop }.
Class BagRead A B T := { read : T -> A -> B }.
Class BagUpdate A B T := { update : T -> A -> B -> T }.
Class BagUnion T := { union : T -> T -> T }.
Class BagInter T := { inter : T -> T -> T }.
Class BagIncl T := { incl : binary T }.
Class BagDisjoint T := { disjoint : binary T }.
Class BagRestrict T K := { restrict : T -> K -> T }.
Class BagRemove T K := { remove : T -> K -> T }.
Class BagFold I F T := { fold : monoid_op I -> F -> T -> I }.
Class BagCard T := { card : T -> nat }.
Class BagDom T K := { dom : T -> K }.
Class BagImg T K := { img : T -> K }.
Class BagIndex A T := { index : T -> A -> Prop }.

Definition notin `{BagIn A T} x m :=
  ~ (is_in x m).

(*-- LATER: make [finite] a typeclass *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Notation *)

Notation "\{}" := (empty)
  : container_scope.
Notation "\{ x }" := (single x)
  : container_scope.
Notation "x '\in' m" := (is_in x m)
  (at level 39) : container_scope.
Notation "x '\notin' E" := (notin x E)
  (at level 39) : container_scope.
Notation "x \:= v" := (single_bind x v)
  (at level 29) : container_scope.
Notation "m [ x ]" := (read m x)
  (at level 7, format "m [ x ]", left associativity).
Notation "m [ x := v ]" := (update m x v)
  (at level 7, format "m [ x := v ]", left associativity).

(* DEPRECATED
Notation "m [ x ]" := (read m x)
  (at level 9, format "m [ x ]").
Notation "m [ x := v ]" := (update m x v)
  (at level 9, format "m [ x  :=  v ]").
*)

(* DEPRECATED
Notation "m \( x )" := (read m x)
  (at level 33, format "m \( x )", only parsing) : container_scope.
Notation "m \( x := v )" := (update m x v)
  (at level 33, format "m \( x := v )", only parsing) : container_scope.
*)

Notation "m1 '\c' m2" := (incl m1 m2)
  (at level 38) : container_scope.
Notation "m1 '\u' m2" := (union m1 m2)
  (at level 37, right associativity) : container_scope.
Notation "m1 '\n' m2" := (inter m1 m2)
  (at level 36, right associativity) : container_scope.
Notation "m1 '\-' m2" := (remove m1 m2)
  (at level 35) : container_scope.
Notation "m1 '\|' m2" := (restrict m1 m2)
  (at level 34) : container_scope.
Notation "m1 '\#' m2" := (disjoint m1 m2)
  (at level 37, right associativity) : container_scope.

Open Scope container_scope.

(* --TODO: bug with spaces *)
Notation "''{' x '}'" := (single x) (format "''{' x '}'")
  : container_scope.

Notation "M \-- i" := (M \- \{i}) (at level 35) : container_scope.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [forall x \in E, P x] notation *)

Notation "'forall_' x '\in' E ',' P" :=
  (forall x, x \in E -> P)
  (at level 200, x ident) : container_scope.
Notation "'forall_' x y '\in' E ',' P" :=
  (forall x y, x \in E -> y \in E -> P)
  (at level 200, x ident, y ident) : container_scope.
Notation "'forall_' x y z '\in' E ',' P" :=
  (forall x y z, x \in E -> y \in E -> z \in E -> P)
  (at level 200, x ident, y ident, z ident) : container_scope.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [exists x \in E st P x] notation *)

Notation "'exists_' x '\in' E ',' P" :=
  (exists x, x \in E /\ P)
  (at level 200, x ident) : container_scope.
Notation "'exists_' x y '\in' E ',' P" :=
  (exists x, x \in E /\ y \in E /\ P)
  (at level 200, x ident, y ident) : container_scope.
Notation "'exists_' x y z '\in' E ',' P" :=
  (exists x, x \in E /\ y \in E /\ z \in E /\ P)
  (at level 200, x ident, y ident, z ident) : container_scope.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Foreach *)

Definition foreach `{BagIn A T} (P:A->Prop) (E:T) :=
  forall x, x \in E -> P x.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [index] for natural numbers *)

Instance int_index : BagIndex int int.
Proof using. intros. constructor. exact (fun n (i:int) => 0 <= i < n). Defined.

Lemma int_index_eq : forall (n i : int),
  index n i = (0 <= i < n).
Proof using. auto. Qed.

Global Opaque int_index.

Lemma int_index_le : forall i n m : int,
  index n i -> n <= m -> index m i.
Proof using. introv. do 2 rewrite @int_index_eq. math. Qed.

Lemma int_index_prove : forall (n i : int),
  0 <= i -> i < n -> index n i.
Proof using. intros. rewrite~ int_index_eq. Qed.

Lemma int_index_succ : forall n i, n >= 0 ->
  index (n + 1) i = (index n i \/ i = n).
Proof using.
  introv P. do 2 rewrite int_index_eq. extens. iff H.
  apply or_classic_l. math.
  destruct H; math.
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Derivable *)

(** Bag update can be defined as bag union with a singleton bag *)

Instance bag_update_as_union_single : forall A B T
  `{BagSingleBind A B T} `{BagUnion T},
  BagUpdate A B T.
  constructor. apply (fun m k v => m \u (k \:= v)). Defined.

Global Opaque bag_update_as_union_single.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties *)

Section Properties.

Context {A T:Type}
  {BI: BagIn A T} {BE: BagEmpty T} {BS: BagSingle A T}
  {BN: BagInter T} {BU: BagUnion T} {BR: BagRemove T T} {BC: BagCard T}
  {BL: BagIncl T} {BD: BagDisjoint T}.

(** In *)

Class In_empty_eq :=
  { in_empty_eq : forall x, x \in \{} = False }.
Class In_empty :=
  { in_empty : forall x, x \in \{} -> False }.

Class Notin_eq :=
  { notin_eq : forall x E, (x \notin E) = ~ (x \in E) }.
Class Notin_empty :=
  { notin_empty : forall x, x \notin \{} }.

Class In_single_eq :=
  { in_single_eq : forall x y, x \in \{y} = (x = y) }.
Class In_single :=
  { in_single : forall x y, x \in \{y} -> x = y }.
Class In_single_self :=
  { in_single_self : forall x, x \in \{x} }.

Class In_extens_eq :=
  { in_extens_eq : forall E F, (forall x, x \in E = x \in F) -> E = F }.
Class In_extens :=
  { in_extens : forall E F, (forall x, x \in E <-> x \in F) -> E = F }.

Class Is_empty_eq :=
  { is_empty_eq : forall E, (E = \{}) = (forall x, x \in E -> False) }.
Class Is_empty_prove :=
  { is_empty_prove : forall E, (forall x, x \in E -> False) -> E = \{} }.
Class Is_empty_inv :=
  { is_empty_inv : forall x E, E = \{} -> x \in E -> False }.
Class Is_nonempty_prove :=
  { is_nonempty_prove : forall x E, x \in E -> E <> \{} }.

Class Is_single_eq :=
  { is_single_eq : forall x E, (E = \{x}) = (x \in E /\ (forall y, y \in E -> y = x)) }.
Class Is_single_prove :=
  { is_single_prove : forall x E, x \in E -> (forall y, y \in E -> y = x) -> E = \{x} }.
Class Is_single_inv :=
  { is_single_inv : forall x y E, E = \{x} -> y \in E -> y = x }.
Class Notin_single_eq :=
  { notin_single_eq : forall x y, x \notin \{y} = (x <> y) }.

Class In_inter_eq :=
  { in_inter_eq : forall x E F, x \in (E \n F) = (x \in E /\ x \in F) }.
Class In_inter :=
  { in_inter : forall x E F, x \in E -> x \in F -> x \in (E \n F) }.
Class In_inter_inv :=
  { in_inter_inv : forall x E F, x \in (E \n F) -> x \in E /\ x \in F }.

Class Notin_inter_eq :=
  { notin_inter_eq : forall x E F, x \notin (E \n F) = (x \notin E \/ x \notin F) }.
Class Notin_inter_l :=
  { notin_inter_l : forall x E F, x \notin E -> x \notin (E \n F) }.
Class Notin_inter_r :=
  { notin_inter_r : forall x E F, x \notin F -> x \notin (E \n F) }.
Class Notin_inter_inv :=
  { notin_inter_inv : forall x E F, x \notin (E \n F) -> x \notin E \/ x \notin F }.

Class In_union_eq :=
  { in_union_eq : forall x (E F : T), x \in (E \u F) = (x \in E \/ x \in F) }.
Class In_union_l :=
  { in_union_l : forall x E F, x \in E -> x \in (E \u F) }.
Class In_union_r :=
  { in_union_r : forall x E F, x \in F -> x \in (E \u F) }.
Class In_union_inv :=
  { in_union_inv : forall x (E F : T), x \in (E \u F) -> (x \in E \/ x \in F) }.

Class Notin_union_eq :=
  { notin_union_eq : forall x E F, x \notin (E \u F) = (x \notin E /\ x \notin F) }.
Class Notin_union :=
  { notin_union : forall x E F, x \notin E -> x \notin F -> x \notin (E \u F) }.
Class Notin_union_inv :=
  { notin_union_inv : forall x E F, x \notin (E \u F) -> x \notin E /\ x \notin F }.

Class In_remove_eq :=
  { in_remove_eq : forall x (E F : T), x \in (E \- F) = (x \in E /\ x \notin F) }.
Class Remove_incl :=
  { remove_incl : forall (E F : T), (E \- F) \c E }.
Class Remove_disjoint :=
  { remove_disjoint : forall (E F : T), F \# (E \- F) }.

(** Incl *)

Class Incl_in_eq :=
  { incl_in_eq : forall E F, (E \c F) = (forall x, x \in E -> x \in F) }.
Class Incl_prove :=
  { incl_prove : forall E F, (forall x, x \in E -> x \in F) -> E \c F }.
Class Incl_inv :=
  { incl_inv : forall x E F, E \c F -> x \in E -> x \in F}.

Class Incl_refl :=
  { incl_refl : refl incl }.
Class Incl_trans :=
  { incl_trans : trans incl }.
Class Incl_antisym := (* this is double inclusion *)
  { incl_antisym : antisym incl }.
Class Incl_order :=
  { incl_order : LibOrder.order incl }.

Class Empty_incl :=
  { empty_incl : forall E, \{} \c E }.
Class Incl_empty :=
  { incl_empty : forall E, (E \c \{}) = (E = \{}) }.
Class Incl_empty_inv :=
  { incl_empty_inv : forall E, E \c \{} -> E = \{} }.

Class Single_incl_r_eq :=
  { single_incl_r_eq : forall x E, (\{x} \c E) = (x \in E) }.
Class Single_incl_r :=
  { single_incl_r : forall x E, x \in E -> \{x} \c E }.

Class Single_incl_l_eq :=
  { single_incl_l_eq : forall x E, (E \c \{x}) = (E = \{} \/ E = \{x}) }.

Class Incl_union_l :=
  { incl_union_l : forall E F G, E \c F -> E \c (F \u G) }.
Class Incl_union_r :=
  { incl_union_r : forall E F G, E \c G -> E \c (F \u G) }.

Class Union_incl_eq :=
  { union_incl_eq : forall E F G, ((E \u F) \c G) = (E \c G /\ F \c G) }.
Class Union_incl :=
  { union_incl : forall E F G, E \c G -> F \c G -> (E \u F) \c G }.
Class Union_incl_inv :=
  { union_incl_inv : forall E F G, (E \u F) \c G -> E \c G /\ F \c G }.

Class Incl_inter_eq :=
  { incl_inter_eq : forall E F G, E \c (F \n G) = (E \c F /\ E \c G) }.
Class Incl_inter :=
  { incl_inter : forall E F G, E \c F -> E \c G -> E \c (F \n G) }.
Class Incl_inter_inv :=
  { incl_inter_inv : forall E F G, E \c (F \n G) -> E \c F /\ E \c G }.

(** Union *)

Class Union_assoc :=
  { union_assoc : assoc union }.
Class Union_comm :=
  { union_comm : comm union }.
Class Union_comm_assoc :=
  { union_comm_assoc : comm_assoc union }.
Class Union_empty_l :=
  { union_empty_l : neutral_l union empty }.
Class Union_empty_r :=
  { union_empty_r : neutral_r union empty }.
Class Union_empty_inv :=
  { union_empty_inv : forall E F, E \u F = \{} -> E = \{} /\ F = \{} }.
Class Union_self :=
  { union_self : idempotent2 union }.

(** Intersection *)

Class Inter_assoc :=
  { inter_assoc : assoc inter }.
Class Inter_comm :=
  { inter_comm : comm inter }.
Class Inter_comm_assoc :=
  { inter_comm_assoc : comm_assoc inter }.
Class Inter_empty_l :=
  { inter_empty_l : absorb_l inter empty }.
Class Inter_empty_r :=
  { inter_empty_r : absorb_r inter empty }.
Class Inter_self :=
  { inter_self : idempotent2 inter }.

(** Removal *)

  (* --TODO: add more *)

(** Cardinal *)

Class Card_empty :=
  { card_empty : card \{} = 0%nat }.
Class Card_single :=
  { card_single : forall X, card \{X} = 1%nat }.
Class Card_union :=
  { card_union : forall E F, card (E \u F) = (card E + card F)%nat }.
Class Card_disjoin_union :=
  { card_disjoin_union : forall E F, E \# F -> card (E \u F) = (card E + card F)%nat }.
Class Card_union_le :=
  { card_union_le : forall E F, card (E \u F) <= (card E + card F)%nat }.

(** Disjointness *)

Class Disjoint_sym :=
  { disjoint_sym : sym disjoint }.
Class Disjoint_eq :=
  { disjoint_eq : forall E F, (E \# F) = (forall x, x \in E -> x \in F -> False) }.
Class Disjoint_not_eq :=
  { disjoint_not_eq : forall E F, (~ (E \# F)) = (exists x, x \in E /\ x \in F) }.
Class Disjoint_prove :=
  { disjoint_prove : forall E F, (forall x, x \in E -> x \in F -> False) -> E \# F }.
Class Disjoint_inv :=
  { disjoint_inv : forall x E F, (E \# F) -> x \in E -> x \in F -> False }.
Class Disjoint_single_l_eq :=
  { disjoint_single_l_eq : forall x E, (\{x} \# E) = x \notin E }.
Class Disjoint_single_r_eq :=
  { disjoint_single_r_eq : forall x E, (E \# \{x}) = x \notin E }.

Class Inter_disjoint :=
  { inter_disjoint : forall E F, E \# F -> E \n F = \{} }.

  (* --TODO: add more *)

End Properties.

(** Lemmas with premises and operators in the conclusion
    need additional Arguments *)

Arguments is_empty_inv {A} {T} {BI} {BE} {Is_empty_inv} [x] [E].
Arguments is_nonempty_prove {A} {T} {BI} {BE} {Is_nonempty_prove} [x] [E].

Arguments in_single A T {BI} {BS} {In_single} [x] [y].
Arguments is_single_inv {A} {T} {BI} {BS} {Is_single_inv} [x] y [E].

Arguments in_inter {A} {T} {BI} {BN} {In_inter} [x] [E] [F].
Arguments in_inter_inv {A} {T} {BI} {BN} {In_inter_inv} [x] [E] [F].

Arguments notin_inter_l {A} {T} {BI} {BN} {Notin_inter_l} [x] [E] [F].
Arguments notin_inter_r {A} {T} {BI} {BN} {Notin_inter_r} [x] [E] [F].
Arguments notin_inter_inv {A} {T} {BI} {BN} {Notin_inter_inv} [x] [E] [F].

Arguments in_union_l {A} {T} {BI} {BU} {In_union_l} [x] [E] [F].
Arguments in_union_r {A} {T} {BI} {BU} {In_union_r} [x] [E] [F].
Arguments in_union_inv {A} {T} {BI} {BU} {In_union_inv} [x] [E] [F].

Arguments notin_union {A} {T} {BI} {BU} {Notin_union} [x] [E] [F].
Arguments notin_union_inv {A} {T} {BI} {BU} {Notin_union_inv} [x] [E] [F].

Arguments incl_prove {A} {T} {BI} {BL} {Incl_prove} [E] [F].
Arguments incl_inv {A} {T} {BI} {BL} {Incl_inv} [x] [E] [F].
Arguments incl_trans {T} [BL] {Incl_trans} y [x] [z].
Arguments incl_empty_inv {T} {BE} {BL} {Incl_empty_inv} [E].

Arguments incl_union_l {T} {BU} {BL} {Incl_union_l} [E] [F] [G].
Arguments incl_union_r {T} {BU} {BL} {Incl_union_r} [E] [F] [G].
Arguments incl_inter {T} {BN} {BL} {Incl_inter} [E] [F] [G].
Arguments incl_inter_inv {T} {BN} {BL} {Incl_inter_inv} [E] [F] [G].

Arguments union_empty_inv {T} {BE} {BU} {Union_empty_inv} [E] [F].

Arguments disjoint_sym {T} {BD} {Disjoint_sym}.
Arguments disjoint_prove {A} {T} {BI} {BD} {Disjoint_prove} [E] [F].
Arguments disjoint_inv {A} {T} {BI} {BD} {Disjoint_inv} [x] [E] [F].
Arguments disjoint_single_l_eq {A} {T} {BI} {BS} {BD} {Disjoint_single_l_eq}.
Arguments disjoint_single_r_eq {A} {T} {BI} {BS} {BD} {Disjoint_single_r_eq}.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Derived Properties *)

Section DerivedProperties.

Context {A T:Type}
  {BI: BagIn A T} {BE: BagEmpty T} {BS: BagSingle A T}
  {BN: BagInter T} {BU: BagUnion T} {BR: BagRemove T T} {BC: BagCard T}
  {BL: BagIncl T} {BD: BagDisjoint T}.

(** In *)

Global Instance in_empty_of_in_empty_eq :
  In_empty_eq ->
  In_empty.
Proof using. constructor. introv I. rewrite~ in_empty_eq in I. Qed.

Global Instance notin_eq_of_nothing :
  Notin_eq.
Proof using. constructor. intros. unfold notin. auto. Qed.

Global Instance notin_empty_of_in_empty_eq :
  In_empty_eq ->
  Notin_empty.
Proof using. constructor. introv I. rewrite~ in_empty_eq in I. Qed.

Global Instance in_single_of_in_single_eq :
  In_single_eq ->
  In_single.
Proof using. constructor. introv I. rewrite~ in_single_eq in I. Qed.

Global Instance in_single_self_of_in_single_eq :
  In_single_eq ->
  In_single_self.
Proof using. constructor. intros. rewrite~ in_single_eq. Qed.

Global Instance in_extens_eq_of_in_extens :
  In_extens ->
  In_extens_eq.
Proof using. constructor. introv I. apply in_extens. intros. rewrite* I. Qed.

Global Instance is_empty_eq_of_in_empty_eq :
  In_extens ->
  In_empty_eq ->
  Is_empty_eq.
Proof using.
  constructor. intros. extens. iff M.
    subst. introv N. rewrite* in_empty_eq in N.
    apply in_extens. iff N. false* M. rewrite* in_empty_eq in N.
Qed.

Global Instance is_empty_prove_of_is_empty_eq :
  Is_empty_eq ->
  Is_empty_prove.
Proof using. constructor. introv I. rewrite* is_empty_eq. Qed.

Global Instance is_empty_inv_of_is_empty_eq :
  Is_empty_eq ->
  Is_empty_inv.
Proof using. constructor. introv I1 I2. rewrite* is_empty_eq in I1. Qed.

Global Instance is_nonempty_prove_of_is_empty_eq :
  Is_empty_eq ->
  Is_nonempty_prove.
Proof using. constructor. introv I1 I2. rewrite is_empty_eq in I2. eauto. Qed.

Global Instance is_single_eq_of_in_single_eq :
  In_extens ->
  In_single_eq ->
  Is_single_eq.
Proof using.
  constructor. intros. extens. iff M (M1&M2).
    subst. split. rewrite* in_single_eq. introv N. rewrite* in_single_eq in N.
    apply in_extens. iff N.
      rewrite* (M2 x0). rewrite* in_single_eq.
      rewrite* in_single_eq in N. subst*.
Qed.

Global Instance is_single_prove_of_is_single_eq :
  Is_single_eq ->
  Is_single_prove.
Proof using. constructor. introv I. rewrite* is_single_eq. Qed.

Global Instance is_single_inv_of_is_single_eq :
  Is_single_eq ->
  Is_single_inv.
Proof using. constructor. introv I1 I2. rewrite* is_single_eq in I1. Qed.

Global Instance notin_single_eq_of_in_single_eq :
  In_single_eq ->
  Notin_single_eq.
Proof using. constructor. intros. unfold notin. rewrite in_single_eq. eauto. Qed.

Global Instance in_inter_of_in_inter_eq :
  In_inter_eq ->
  In_inter.
Proof using. constructor. introv I1 I2. rewrite* in_inter_eq. Qed.

Global Instance in_inter_inv_of_in_inter_eq :
  In_inter_eq ->
  In_inter_inv.
Proof using. constructor. introv I. rewrite~ <- in_inter_eq. Qed.

Global Instance notin_inter_l_of_notin_inter_eq :
  Notin_inter_eq ->
  Notin_inter_l.
Proof using. constructor. introv I. rewrite~ notin_inter_eq. Qed.

Global Instance notin_inter_r_of_notin_inter_eq :
  Notin_inter_eq ->
  Notin_inter_r.
Proof using. constructor. introv I. rewrite~ notin_inter_eq. Qed.

Global Instance notin_inter_inv_of_notin_inter_eq :
  Notin_inter_eq ->
  Notin_inter_inv.
Proof using. constructor. introv I. rewrite~ notin_inter_eq in I. Qed.

Global Instance in_union_l_of_in_union_eq :
  In_union_eq ->
  In_union_l.
Proof using. constructor. introv I. rewrite* in_union_eq. Qed.

Global Instance in_union_r_of_in_union_eq :
  In_union_eq ->
  In_union_r.
Proof using. constructor. introv I. rewrite* in_union_eq. Qed.

Global Instance in_union_inv_of_in_union_eq :
  In_union_eq ->
  In_union_inv.
Proof using. constructor. introv I. rewrite~ @in_union_eq in I. Qed.

Global Instance notin_union_of_notin_union_eq :
  Notin_union_eq ->
  Notin_union.
Proof using. constructor. introv I1 I2. rewrite~ notin_union_eq. Qed.

Global Instance notin_union_inv_of_notin_union_eq :
  Notin_union_eq ->
  Notin_union_inv.
Proof using. constructor. introv I. rewrite~ notin_union_eq in I. Qed.

  (* --TODO: in remove properties?*)

(** Incl *)

Global Instance incl_prove_of_in_eq :
  Incl_in_eq ->
  Incl_prove.
Proof using. constructor. introv I. rewrite* incl_in_eq. Qed.

Global Instance incl_inv_of_in_eq :
  Incl_in_eq ->
  Incl_inv.
Proof using. constructor. introv I1 I2. rewrite* incl_in_eq in I1. Qed.

Global Instance incl_order_of_incl_in_eq :
  In_extens ->
  Incl_in_eq ->
  Incl_order.
Proof using.
  constructor. constructor.
  intros x. rewrite* incl_in_eq.
  intros E F G I1 I2. rewrite incl_in_eq. rewrite incl_in_eq in I1,I2. autos*.
  intros E F I1 I2. rewrite incl_in_eq in I1,I2. apply* in_extens.
Qed.

Global Instance incl_refl_of_incl_order :
  Incl_order ->
  Incl_refl.
Proof using. constructor. apply order_refl. apply incl_order. Qed.

Global Instance incl_trans_of_incl_order :
  Incl_order ->
  Incl_trans.
Proof using. constructor. apply order_trans. apply incl_order. Qed.

Global Instance incl_antisym_of_incl_order :
  Incl_order ->
  Incl_antisym.
Proof using. constructor. apply order_antisym. apply incl_order. Qed.

Global Instance empty_incl_inv_of_incl_in_eq_and_in_empty_eq :
  Incl_in_eq ->
  In_empty_eq ->
  Empty_incl.
Proof using.
  constructor. intros. rewrite incl_in_eq. introv M.
  rewrite in_empty_eq in M. false.
Qed.

Global Instance incl_empty_of_in_empty_eq_and_incl_in_eq :
  In_extens ->
  In_empty_eq ->
  Incl_in_eq ->
  Incl_empty.
Proof using.
  constructor. intros. extens. rewrite incl_in_eq. iff M.
    apply in_extens. iff N. applys* M. rewrite in_empty_eq in N. false.
    subst. introv N. rewrite in_empty_eq in N. false.
Qed.

Global Instance incl_empty_inv_of_incl_empty :
  Incl_empty ->
  Incl_empty_inv.
Proof using. constructor. introv I. rewrite~ incl_empty in I. Qed.

Global Instance single_incl_r_eq_of_in_single_eq_and_and_incl_in_eq :
  In_extens ->
  In_single_eq ->
  Incl_in_eq ->
  Single_incl_r_eq.
Proof using.
  constructor. intros. extens. rewrite incl_in_eq. iff M.
    applys* M. rewrite~ in_single_eq.
    introv N. rewrite in_single_eq in N. subst~.
Qed.

Global Instance single_incl_r_of_single_incl_r_eq:
  Single_incl_r_eq ->
  Single_incl_r.
Proof using.
  constructor. intros. rewrite single_incl_r_eq. assumption.
Qed.

Global Instance single_incl_l_eq_of_in_empty_eq_and_in_single_eq_and_and_incl_in_eq :
  In_extens ->
  In_empty_eq ->
  In_single_eq ->
  Incl_in_eq ->
  Single_incl_l_eq.
Proof using.
  constructor. intros. extens. rewrite incl_in_eq. iff M.
    tests: (x \in E).
      right. apply* is_single_prove. introv N. forwards~ R: M y.
        rewrite* in_single_eq in R.
      left. apply in_extens. iff N. forwards~ R: M x0.
        rewrite* in_single_eq in R. subst. false*.
        rewrite in_empty_eq in N. false.
    introv N. rewrite in_single_eq. destruct M.
      subst. rewrite in_empty_eq in N. false.
      subst. rewrite in_single_eq in N. auto.
Qed.

Global Instance union_incl_eq_of_in_union_eq_and_and_incl_in_eq :
  In_extens ->
  In_union_eq ->
  Incl_in_eq ->
  Union_incl_eq.
Proof using.
  constructor. intros. extens. repeat rewrite incl_in_eq. iff M (M1&M2).
    split. intros x N. specializes M x. rewrite* in_union_eq in M.
           intros x N. specializes M x. rewrite* in_union_eq in M.
    intros x N. specializes M1 x. specializes M2 x. rewrite* in_union_eq in N.
Qed.

Global Instance incl_union_l_of_incl_in_eq_and_in_union_eq :
  Incl_in_eq ->
  In_union_eq ->
  Incl_union_l.
Proof using.
  constructor. introv I. rewrite incl_in_eq. rewrite incl_in_eq in I.
  (* coqbug on "rewrite incl_in_eq in *" *)
  introv N. rewrite* in_union_eq.
Qed.

Global Instance incl_union_r_of_incl_union_l :
  Incl_union_l ->
  Union_comm ->
  Incl_union_r.
Proof using. constructor. introv I. rewrite union_comm. apply* @incl_union_l. Qed.

Global Instance union_incl_of_union_incl_eq :
  Union_incl_eq ->
  Union_incl_eq.
Proof using. constructor. intros_all. rewrite* union_incl_eq. Qed.

Global Instance union_incl_inv_of_union_incl_eq :
  Union_incl_eq ->
  Union_incl_inv.
Proof using. constructor. introv I. rewrite union_incl_eq in I. destruct* I. Qed.

Global Instance incl_inter_eq_of_in_inter_eq_and_and_incl_in_eq :
  In_extens ->
  In_inter_eq ->
  Incl_in_eq ->
  Incl_inter_eq.
Proof using.
  constructor. intros. extens. repeat rewrite incl_in_eq. iff M (M1&M2).
    split. intros x N. specializes M x. rewrite* in_inter_eq in M.
           intros x N. specializes M x. rewrite* in_inter_eq in M.
    intros x N. specializes M1 N. specializes M2 N. rewrite* in_inter_eq.
Qed.

Global Instance incl_inter_of_incl_inter_eq :
  Incl_inter_eq ->
  Incl_inter.
Proof using. constructor. intros. rewrite* incl_inter_eq. Qed.

Global Instance incl_inter_inv_of_incl_inter_eq :
  Incl_inter_eq ->
  Incl_inter_inv.
Proof using. constructor. introv N. rewrite* incl_inter_eq in N. Qed.

(** Local tactic [contain_by_in_double] to prove inclusion *)

Hint Rewrite @in_union_eq @in_inter_eq
  @in_empty_eq @in_single_eq : rew_in_eq.

Ltac contain_by_in_double :=
  intros_all; apply in_extens; intros;
  autorewrite with rew_in_eq;
  intuition (try solve [auto|eauto|auto_false|false]).

(** Union *)

Global Instance union_comm_form_in_union_eq :
  In_extens ->
  In_union_eq ->
  Union_comm.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance union_assoc_form_in_union_eq :
  In_extens ->
  In_union_eq ->
  Union_assoc.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance union_comm_assoc_of_union_comm_and_union_assoc :
  Union_comm ->
  Union_assoc ->
  Union_comm_assoc.
Proof using.
  constructor. intros_all. do 2 rewrite union_assoc.
  rewrite (union_comm _ x). auto.
Qed.

Global Instance union_empty_l_of_in_union_eq_and_in_empty_eq :
  In_extens ->
  In_union_eq ->
  In_empty_eq ->
  Union_empty_l.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance union_empty_r_of_union_empty_l :
  Union_empty_l -> Union_comm -> Union_empty_r.
Proof using. constructor. intros_all. rewrite union_comm. apply union_empty_l. Qed.

Global Instance union_empty_inv_of_in_union_eq :
  In_extens ->
  In_empty_eq ->
  In_union_eq ->
  Union_empty_inv.
Proof using.
  constructor. introv N. split.
    apply in_extens. iff R. rewrite <- N. rewrite* in_union_eq. rewrite* in_empty_eq in R.
    apply in_extens. iff R. rewrite <- N. rewrite* in_union_eq. rewrite* in_empty_eq in R.
Qed.

Global Instance union_self_of_in_union_eq :
  In_extens ->
  In_union_eq ->
  Union_self.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance notin_union_eq_of_in_union_eq :
  In_union_eq ->
  Notin_union_eq.
Proof using. constructor. intros. unfold notin. rewrite @in_union_eq. extens*. eauto. Qed.

(** Inter *)

Global Instance inter_comm_form_in_inter_eq :
  In_extens ->
  In_inter_eq ->
  Inter_comm.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance inter_assoc_form_in_inter_eq :
  In_extens ->
  In_inter_eq ->
  Inter_assoc.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance inter_comm_assoc_of_inter_comm_and_inter_assoc :
  Inter_comm ->
  Inter_assoc ->
  Inter_comm_assoc.
Proof using.
  constructor. intros_all. do 2 rewrite inter_assoc.
  rewrite (inter_comm _ x). auto.
Qed.

Global Instance inter_empty_l_of_in_inter_eq_and_in_empty_eq :
  In_extens ->
  In_inter_eq ->
  In_empty_eq ->
  Inter_empty_l.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance inter_empty_r_of_inter_empty_l :
  Inter_empty_l ->
  Inter_comm ->
  Inter_empty_r.
Proof using. constructor. intros_all. rewrite inter_comm. apply inter_empty_l. Qed.

Global Instance inter_self_of_in_inter_eq :
  In_extens ->
  In_inter_eq ->
  Inter_self.
Proof using. constructor. contain_by_in_double. Qed.

(** Remove *)

Global Instance remove_incl_of_in_remove_eq_and_incl_in_eq :
  In_remove_eq ->
  Incl_in_eq ->
  Remove_incl.
Proof using.
  constructor. intros. rewrite incl_in_eq. introv N. rewrite* in_remove_eq in N.
Qed.

Global Instance remove_disjoint_of_in_remove_eq_and_disjoint_eq :
  In_remove_eq ->
  Disjoint_eq ->
  Remove_disjoint.
Proof using.
  constructor. intros. rewrite disjoint_eq. introv N M.
  rewrite* in_remove_eq in M.
Qed.

(** Disjoint *)

Global Instance disjoint_not_eq_of_disjoint_eq :
  Disjoint_eq ->
  Disjoint_not_eq.
Proof using.
  constructor. intros. rewrite disjoint_eq. extens. iff M.
  { rew_logic in M. destruct M as [x M]. rew_logic* in M. }
  { destruct M as [x M]. rew_logic. exists x. rew_logic*. }
Qed. (* --LATER: rew_logic below binder to simplify proof. *)

Global Instance disjoint_prove_of_disjoint_eq :
  Disjoint_eq ->
  Disjoint_prove.
Proof using. constructor. intros. rewrite* disjoint_eq. Qed.

Global Instance disjoint_inv_of_disjoint_eq :
  Disjoint_eq ->
  Disjoint_inv.
Proof using. constructor. introv I I1 I2. rewrite* disjoint_eq in I. Qed.

Global Instance disjoint_single_l_eq_of_disjoint_eq_and_in_single_eq :
  Disjoint_eq ->
  In_single_eq ->
  Disjoint_single_l_eq.
Proof using.
  constructor. intros. rewrite disjoint_eq. unfold notin. extens. iff M.
    introv N. specializes M N. rewrite* in_single_eq. false.
    introv N1 N2. rewrite in_single_eq in N1. subst. false.
Qed.

Global Instance disjoint_sym_of_disjoint_eq :
  Disjoint_eq ->
  Disjoint_sym.
Proof using. constructor. intros x y. do 2 rewrite* disjoint_eq. Qed.

Global Instance disjoint_single_r_eq_of_disjoint_single_l :
  Disjoint_single_l_eq ->
  Disjoint_sym ->
  Disjoint_single_r_eq.
Proof using.
  constructor. intros_all.
  rewrites (>> sym_inv_eq disjoint_sym). apply disjoint_single_l_eq.
Qed.

Global Instance inter_disjoint_of_disjoint_eq_and_in_inter_eq :
  In_extens ->
  In_empty_eq ->
  Disjoint_eq ->
  In_inter_eq ->
  Inter_disjoint.
Proof using.
  constructor. introv M. apply in_extens. rewrite disjoint_eq in M. iff N.
    rewrite in_inter_eq in N. false*.
    rewrite in_empty_eq in N. false.
Qed.

End DerivedProperties.


(** Author: Cristina Cornes

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

From Coq Require Import List Relation_Operators Transitive_Closure.

Local Open Scope list_scope.

Section Lexicographic_Exponentiation.

  Variable A : Type.
  Variable leA : A -> A -> Prop.
  Let Nil := nil (A:=A).
  Let List := list A.

  Inductive Ltl : List -> List -> Prop :=
    | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x)
    | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y)
    | Lt_tl (a:A) (x y:List) : Ltl x y -> Ltl (a :: x) (a :: y).

  Inductive Desc : List -> Prop :=
    | d_nil : Desc Nil
    | d_one (x:A) : Desc (x :: Nil)
    | d_conc (x y:A) (l:List) :
        leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).

  Definition Pow : Type := sig Desc.

  Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b).

End Lexicographic_Exponentiation.

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

  Notation Power := (Pow A leA).
  Notation Lex_Exp := (lex_exp A leA).
  Notation ltl := (Ltl A leA).
  Notation Descl := (Desc A leA).

  Notation List := (list A).
  Notation Nil := (nil (A:=A)).
  (* useless but symmetric *)
  Notation Cons := (cons (A:=A)).
  Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).

  (* Hint Resolve d_one d_nil t_step. *)

  Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
  Proof.
    simple induction x.
    simple induction z.
    simpl; intros H.
    inversion_clear H.
    simpl; intros; apply (Lt_nil A leA).
    intros a l HInd.
    simpl.
    intros.
    inversion_clear H.
    apply (Lt_hd A leA); auto with sets.
    apply (Lt_tl A leA).
    apply (HInd y y0); auto with sets.
  Qed.

  Lemma right_prefix :
    forall x y z:List,
      ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
  Proof.
    intros x y; generalize x.
    elim y; simpl.
    right.
    exists x0; auto with sets.
    intros.
    inversion H0.
    left; apply (Lt_nil A leA).
    left; apply (Lt_hd A leA); auto with sets.
    generalize (H x1 z H3).
    simple induction 1.
    left; apply (Lt_tl A leA); auto with sets.
    simple induction 1.
    simple induction 1; intros.
    rewrite H8.
    right; exists x2; auto with sets.
  Qed.

  Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
  Proof.
    intros.
    inversion H.
    generalize (app_cons_not_nil _ _ _ H1); simple induction 1.
    cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
    intro.
    generalize (app_eq_unit _ _ H0).
    simple induction 1; simple induction 1; intros.
    rewrite H4; auto using d_nil with sets.
    discriminate H5.
    generalize (app_inj_tail _ _ _ _ H0).
    simple induction 1; intros.
    rewrite <- H4; auto with sets.
  Qed.

  Lemma desc_tail :
    forall (x:List) (a b:A),
      Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
  Proof.
    intro.
    apply rev_ind with
      (A := A)
      (P := fun x:List =>
        forall a b:A,
          Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
    intros.

    inversion H.
    cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
      auto with sets; intro.
    generalize H0.
    intro.
    generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
      simple induction 1.
    intros.

    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
    generalize H1.
    rewrite <- H10; rewrite <- H7; intro.
    apply (t_step A leA); auto with sets.

    intros.
    inversion H0.
    generalize (app_cons_not_nil _ _ _ H3); intro.
    elim H1.

    generalize H0.
    generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
      simple induction 1.
    intro.
    generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro.
    generalize (H x0 b H6).
    intro.
    apply t_trans with (A := A) (y := x0); auto with sets.

    apply t_step.
    generalize H1.
    rewrite H4; intro.

    generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
    intros.
    generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
    intro.
    generalize H10.
    rewrite H12; intro.
    generalize (app_inj_tail _ _ _ _ H13); simple induction 1.
    intros.
    rewrite <- H11; rewrite <- H16; auto with sets.
  Qed.

  Lemma dist_aux :
    forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y.
  Proof.
    intros z D.
    elim D.
    intros.
    cut (x ++ y = Nil); auto with sets; intro.
    generalize (app_eq_nil _ _ H0); simple induction 1.
    intros.
    rewrite H2; rewrite H3; split; apply d_nil.

    intros.
    cut (x0 ++ y = Cons x Nil); auto with sets.
    intros E.
    generalize (app_eq_unit _ _ E); simple induction 1.
    simple induction 1; intros.
    rewrite H2; rewrite H3; split.
    apply d_nil.

    apply d_one.

    simple induction 1; intros.
    rewrite H2; rewrite H3; split.
    apply d_one.

    apply d_nil.

    do 5 intro.
    intros Hind.
    do 2 intro.
    generalize x0.
    apply rev_ind with
      (A := A)
      (P := fun y0:List =>
        forall x0:List,
          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
          Descl x0 /\ Descl y0).

    intro.
    generalize (app_nil_end x1); simple induction 1; simple induction 1.
    split. apply d_conc; auto with sets.

    apply d_nil.

    do 3 intro.
    generalize x1.
    apply rev_ind with
      (A := A)
      (P := fun l0:List =>
        forall (x1:A) (x0:List),
          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil ->
          Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).

    simpl.
    split.
    generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
    simple induction 1; auto with sets.

    apply d_one.
    do 5 intro.
    generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
    simple induction 1.
    generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1.
    intro E.
    generalize (app_inj_tail _ _ _ _ E).
    simple induction 1; intros.
    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
    rewrite <- H7; rewrite <- H10; generalize H6.
    generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1.
    rewrite E1.
    intro.
    generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
    simple induction 1; split.
    auto with sets.

    generalize H14.
    rewrite <- H10; intro.
    apply d_conc; auto with sets.
  Qed.

  Lemma dist_Desc_concat :
    forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y.
  Proof.
    intros.
    apply (dist_aux (x ++ y) H x y); auto with sets.
  Qed.

  Lemma desc_end :
    forall (a b:A) (x:List),
      Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
      clos_trans A leA a b.
  Proof.
    intros a b x.
    case x.
    simpl.
    simple induction 1.
    intros.
    inversion H1; auto with sets.
    inversion H3.

    simple induction 1.
    generalize (app_comm_cons l (Cons a Nil) a0).
    intros E; rewrite <- E; intros.
    generalize (desc_tail l a a0 H0); intro.
    inversion H1.
    apply t_trans with (y := a0); auto with sets.

    inversion H4.
  Qed.

  Lemma ltl_unit :
    forall (x:List) (a b:A),
      Descl (x ++ Cons a Nil) ->
      ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil).
  Proof.
    intro.
    case x.
    intros; apply (Lt_nil A leA).

    simpl; intros.
    inversion_clear H0.
    apply (Lt_hd A leA a b); auto with sets.

    inversion_clear H1.
  Qed.

  Lemma acc_app :
    forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
      Acc Lex_Exp << x1 ++ x2, y1 >> ->
      forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
  Proof.
    intros.
    apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
    auto with sets.

    unfold lex_exp; simpl; auto with sets.
  Qed.

  Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
  Proof.
    unfold well_founded at 2.
    simple induction a; intros x y.
    apply Acc_intro.
    simple induction y0.
    unfold lex_exp at 1; simpl.
    apply rev_ind with
      (A := A)
      (P := fun x:List =>
	forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
    intros.
    inversion_clear H0.

    intro.
    generalize (well_founded_ind (wf_clos_trans A leA H)).
    intros GR.
    apply GR with
      (P := fun x0:A =>
        forall l:List,
          (forall (x1:List) (y:Descl x1),
            ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
          forall (x1:List) (y:Descl x1),
            ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>).
    intro; intros HInd; intros.
    generalize (right_prefix x2 l (Cons x1 Nil) H1).
    simple induction 1.
    intro; apply (H0 x2 y1 H3).

    simple induction 1.
    intro; simple induction 1.
    clear H4 H2.
    intro; generalize y1; clear y1.
    rewrite H2.
    apply rev_ind with
      (A := A)
      (P := fun x3:List =>
        forall y1:Descl (l ++ x3),
          ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>).
    intros.
    generalize (app_nil_end l); intros Heq.
    generalize y1.
    clear y1.
    rewrite <- Heq.
    intro.
    apply Acc_intro.
    simple induction y2.
    unfold lex_exp at 1.
    simpl; intros x4 y3. intros.
    apply (H0 x4 y3); auto with sets.

    intros.
    generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
    simple induction 1.
    intros.
    generalize (desc_end x4 x1 l0 (conj H8 H5)); intros.
    generalize y1.
    rewrite <- (app_ass l l0 (Cons x4 Nil)); intro.
    generalize (HInd x4 H9 (l ++ l0)); intros HInd2.
    generalize (ltl_unit l0 x4 x1 H8 H5); intro.
    generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2).
    simple induction 1; intros.
    generalize (H4 H12 H10); intro.
    generalize (Acc_inv H14).
    generalize (acc_app l l0 H12 H14).
    intros f g.
    generalize (HInd2 f); intro.
    apply Acc_intro.
    simple induction y3.
    unfold lex_exp at 1; simpl; intros.
    apply H15; auto with sets.
  Qed.

End Wf_Lexicographic_Exponentiation.


Module M .
Inductive symb : Type :=
  minus : symb
| zero : symb
| succ : symb
| quot : symb
.
End M.

Definition beq_symb (f g : M.symb) : bool :=
 match f, g with
  M.minus, M.minus => true
| M.zero, M.zero => true
| M.succ, M.succ => true
| M.quot, M.quot => true
| _, _ => false
 end .

(* Tactic to decide beq_symb_ok from CoLoR VSignature
Ltac beq_symb_ok := intros f g; split;
  [destruct f; destruct g; simpl; intro; (discr || refl)
    | intro; subst g; destruct f; refl].
 *)

Lemma beq_symb_ok : forall f g : M.symb, beq_symb f g = true <-> f = g .
Proof .
  intros f g . split . (* break into
                            beq_symb f g = true -> f = g  and
                            f = g -> beq_symb f g = true *)
  (* for first case, we can simply, though tediously, do a case analysis over
     all possible cominbations of f and g.  Since there are 4 symbols, this will
     generate 16 total subcases. *)
  destruct f .
    destruct g .
      simpl . intro . reflexivity .
      simpl . intro . discriminate .
      simpl . intro . discriminate .
      simpl . intro . discriminate .
    destruct g .
      simpl . intro . discriminate .
      simpl . intro . reflexivity .
      simpl . intro . discriminate .
      simpl . intro . discriminate .
Restart .
  intros f g ; split .
  (* All of the above cases are identical, except for refl / discr, so we'll
     make use of the fact that the semi-colon operator applies what comes after
     it to EACH generated subcase to collapse the above (incomplete) case
     analysis into one line *)
  destruct f ; destruct g ; simpl ; intro ; (discriminate || reflexivity ) .
  (* We now start the other half of the original proof,
     f = g -> beq_symb f g = true *)
  intro .
    (* given the hypothesis 'f = g', we can replace g with f in the rest of the
       proof using the substitute tactic *)
  subst g .
  (* Now we again do a case analysis over f, but this time only four cases
     are generated since we have "f f" instead of "f g" as arguments.
     We'll still use ; to apply reflexivity to all generated subgoals
   *)
  destruct f ; reflexivity .
Qed .