(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.algebra.CPoly_NthCoeff.
Require Export CoRN.algebra.CFields.
Require Export CoRN.tactics.Rational.
Require Import Lia.
Import CRing_Homomorphisms.coercions.
Set Automatic Introduction.

(**
* Degrees of Polynomials
** Degrees of polynomials over a ring
%\begin{convention}%
Let [R] be a ring and write [RX] for the ring of polynomials
over [R].
%\end{convention}%
*)

Section Degree_def.

Variable R : CRing.

(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)
(**
The length of a polynomial is the number of its coefficients. This is
a syntactical property, as the highest coefficient may be [0]. Note that
the `zero' polynomial [cpoly_zero] has length [0],
a constant polynomial has length [1] and so forth. So the length
is always [1] higher than the `degree' (assuming that the highest
coefficient is [[#][0]])!
*)

Arguments cpoly_zero {CR}.
Arguments cpoly_linear [CR].

Fixpoint lth_of_poly (p : RX) : nat :=
  match p with
  | cpoly_zero       => 0
  | cpoly_linear d q => S (lth_of_poly q)
  end.

(**
When dealing with constructive polynomials, notably over the reals or
complex numbers, the degree may be unknown, as we can not decide
whether the highest coefficient is [[#][0]]. Hence,
degree is a relation between polynomials and natural numbers; if the
degree is unknown for polynomial [p], degree(n,p) doesn't hold for
any [n].  If we don't know the degree of [p], we may still
know it to be below or above a certain number. E.g. for the polynomial
$p_0 +p_1 X +\cdots + p_{n-1} X^{n-1}$#p0 +p1 X + ... + p(n-1)
X^(n-1)#, if $p_i \mathrel{\#}0$#pi apart from 0#, we can say that the
`degree is at least [i]' and if $p_{j+1} = \ldots =p_n =0$#p(j+1)
= ... =pn =0# (with [n] the length of the polynomial), we can say
that the `degree is at most [j]'.
*)

Definition degree_le n (p : RX) : Prop := forall m, n < m -> nth_coeff m p [=] [0].

Definition degree n (p : RX) : CProp := nth_coeff n p [#] [0] and degree_le n p.

Definition monic n (p : RX) : Prop := nth_coeff n p [=] [1] /\ degree_le n p.

Definition odd_cpoly (p : RX) : CProp := {n : nat | Codd n | degree n p}.

Definition even_cpoly (p : RX) : CProp := {n : nat | Ceven n | degree n p}.

Definition regular (p : RX) : CProp := {n : nat | degree n p}.

End Degree_def.

Arguments degree_le [R].
Arguments degree [R].
Arguments monic [R].
Arguments lth_of_poly [R].

Section Degree_props.

Variable R : CRing.

Add Ring R: (CRing_Ring R).

(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)

Lemma degree_le_wd : forall (p p' : RX) n,
 p [=] p' -> degree_le n p -> degree_le n p'.
Proof.
 unfold degree_le in |- *. intros.
 Step_final (nth_coeff m p).
Qed.

Lemma degree_wd : forall (p p' : RX) n, p [=] p' -> degree n p -> degree n p'.
Proof.
 unfold degree in |- *. intros p p' n H H0.
 elim H0. clear H0. intros. split.
 astepl (nth_coeff n p). auto.
  apply degree_le_wd with p; auto.
Qed.

Lemma monic_wd : forall (p p' : RX) n, p [=] p' -> monic n p -> monic n p'.
Proof.
 unfold monic in |- *. intros.
 elim H0. clear H0. intros. split.
 Step_final (nth_coeff n p).
 apply degree_le_wd with p; auto.
Qed.

Lemma degree_imp_degree_le : forall (p : RX) n, degree n p -> degree_le n p.
Proof.
 unfold degree in |- *. intros p n H. elim H. auto.
Qed.

Lemma degree_le_cpoly_zero n: degree_le n (cpoly_zero R).
Proof. intro. reflexivity. Qed.

Lemma degree_le_c_ : forall c : R, degree_le 0 (_C_ c).
Proof.
 unfold degree_le in |- *. intros c m. elim m; intros.
 elim (lt_irrefl _ H).
 simpl in |- *. algebra.
Qed.

Lemma degree_c_ : forall c : R, c [#] [0] -> degree 0 (_C_ c).
Proof.
 unfold degree in |- *. intros. split. simpl in |- *. auto. apply degree_le_c_.
Qed.

Lemma monic_c_one : monic 0 (_C_ ([1]:R)).
Proof.
 unfold monic in |- *. intros. split. simpl in |- *. algebra. apply degree_le_c_.
Qed.

Lemma degree_le_x_ : degree_le 1 (_X_:RX).
Proof.
 unfold degree_le in |- *.
 intro. elim m. intros. elim (lt_n_O _ H).
 intro. elim n. intros. elim (lt_irrefl _ H0).
 intros. simpl in |- *. algebra.
Qed.

Lemma degree_x_ : degree 1 (_X_:RX).
Proof.
 unfold degree in |- *. split. simpl in |- *. algebra. exact degree_le_x_.
Qed.

Lemma monic_x_ : monic 1 (_X_:RX).
Proof.
 unfold monic in |- *. split. simpl in |- *. algebra. exact degree_le_x_.
Qed.

Lemma degree_le_mon : forall (p : RX) m n,
 m <= n -> degree_le m p -> degree_le n p.
Proof.
 unfold degree_le in |- *. intros. apply H0.
 apply le_lt_trans with n; auto with arith.
Qed.

Lemma degree_le_inv : forall (p : RX) n, degree_le n p -> degree_le n [--]p.
Proof.
 unfold degree_le in |- *. intros.
 astepl ( [--] (nth_coeff m p)).
 Step_final ( [--] ([0]:R)).
Qed.

Lemma degree_le_plus : forall (p q : RX) n,
 degree_le n p -> degree_le n q -> degree_le n (p[+]q).
Proof.
 unfold degree_le in |- *. intros.
 astepl (nth_coeff m p[+]nth_coeff m q).
 Step_final ([0][+] ([0]:R)).
Qed.

Lemma degree_le_minus : forall (p q : RX) n,
 degree_le n p -> degree_le n q -> degree_le n (p[-]q).
Proof.
 unfold degree_le in |- *. intros.
 astepl (nth_coeff m p[-]nth_coeff m q).
 Step_final ([0][-] ([0]:R)).
Qed.

Lemma Sum_degree_le : forall (f : nat -> RX) (n k l : nat), k <= S l ->
 (forall i, k <= i -> i <= l -> degree_le n (f i)) -> degree_le n (Sum k l f).
Proof.
 unfold degree_le in |- *. intros. induction  l as [| l Hrecl]; intros.
 generalize (toCle _ _ H); clear H; intro H.
  inversion H as [|m0 X].
   unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
   apply eq_transitive with (nth_coeff m ([0]:RX)).
    apply nth_coeff_wd. algebra. algebra.
    inversion X. rename H3 into kis0. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
  apply eq_transitive with (nth_coeff m (f 0)).
   apply nth_coeff_wd. cut (f 0[-][0] [=] f 0). auto. algebra.
   apply H0; try auto. rewrite kis0; auto.
  elim (le_lt_eq_dec _ _ H); intro y.
  apply eq_transitive_unfolded with (nth_coeff m (Sum k l f[+]f (S l))).
   apply nth_coeff_wd. algebra.
   astepl (nth_coeff m (Sum k l f) [+]nth_coeff m (f (S l))).
  astepr ([0][+] ([0]:R)). apply bin_op_wd_unfolded.
  apply Hrecl. auto with arith. intros.
    apply H0. auto. auto. auto.
     apply H0. auto with arith. auto. auto.
    rewrite y. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
 apply eq_transitive_unfolded with (nth_coeff m ([0]:RX)).
  apply nth_coeff_wd. algebra. algebra.
Qed.

Lemma degree_le_Sum (l: list (cpoly R)) n:
  (forall p, In p l -> degree_le n p) -> degree_le n (cm_Sum l).
Proof.
 induction l; intros.
  apply degree_le_cpoly_zero.
 change (degree_le n (a [+] cm_Sum l)).
 apply degree_le_plus; intuition.
Qed.

Lemma degree_inv : forall (p : RX) (n : nat), degree n p -> degree n [--]p.
Proof.
 unfold degree in |- *. intros p n H.
 elim H. clear H. intros. split.
 astepl ( [--] (nth_coeff n p)). algebra.
  apply degree_le_inv; auto.
Qed.

Lemma degree_plus_rht : forall (p q : RX) m n,
 degree_le m p -> degree n q -> m < n -> degree n (p[+]q).
Proof.
 unfold degree in |- *. unfold degree_le in |- *. intros.
 elim X. clear X. intros.
 split.
  astepl (nth_coeff n p[+]nth_coeff n q).
  astepl ([0][+]nth_coeff n q).
  astepl (nth_coeff n q). auto.
  intros.
 astepl (nth_coeff m0 p[+]nth_coeff m0 q).
 cut (m < m0). intro.
  Step_final ([0][+] ([0]:R)).
 apply lt_trans with n; auto.
Qed.

Lemma degree_minus_lft : forall (p q : RX) m n,
 degree_le m p -> degree n q -> m < n -> degree n (q[-]p).
Proof.
 intros.
 apply degree_wd with ( [--]p[+]q).
  Step_final (q[+][--]p).
 apply degree_plus_rht with m.
   apply degree_le_inv. auto. auto. auto.
Qed.

Lemma monic_plus : forall (p q : RX) m n,
 degree_le m p -> monic n q -> m < n -> monic n (p[+]q).
Proof.
 unfold monic in |- *. unfold degree_le in |- *. intros.
 elim H0. clear H0. intros.
 split.
  astepl (nth_coeff n p[+]nth_coeff n q).
  astepl ([0][+]nth_coeff n q).
  Step_final (nth_coeff n q).
 intros.
 astepl (nth_coeff m0 p[+]nth_coeff m0 q).
 cut (m < m0). intro.
  Step_final ([0][+] ([0]:R)).
 apply lt_trans with n; auto.
Qed.

Lemma monic_minus : forall (p q : RX) m n,
 degree_le m p -> monic n q -> m < n -> monic n (q[-]p).
Proof.
 intros.
 apply monic_wd with ( [--]p[+]q).
  Step_final (q[+][--]p).
 apply monic_plus with m.
   apply degree_le_inv. auto. auto. auto.
Qed.

Lemma degree_le_mult : forall (p q : RX) m n,
 degree_le m p -> degree_le n q -> degree_le (m + n) (p[*]q).
Proof.
 unfold degree_le in |- *. intros.
 astepl (Sum 0 m0 (fun i : nat => nth_coeff i p[*]nth_coeff (m0 - i) q)).
 apply Sum_zero. auto with arith.
  intros.
 cut ({m < i} + {n < m0 - i}). intro.
  elim H4; clear H4; intros.
   Step_final ([0][*]nth_coeff (m0 - i) q).
  Step_final (nth_coeff i p[*][0]).
 elim (lt_eq_lt_dec m i); intro.
  elim a; intro.
   auto.
  right.
  lia.
 right.
 lia.
Qed.

Lemma degree_le_Product (l: list (cpoly R)) n:
  (forall p, In p l -> degree_le n p) ->
  degree_le (length l * n) (cr_Product l).
Proof.
 induction l; intros.
  apply (degree_le_c_ [1]).
 change (degree_le (n + length l * n) (a [*] cr_Product l)).
 apply degree_le_mult; intuition.
Qed.

Lemma degree_le_mult_constant_l (p: cpoly R) (x: R) (n: nat):
  degree_le n p -> degree_le n (_C_ x [*] p).
Proof with auto.
 intros.
 replace n with (0 + n)%nat...
 apply degree_le_mult...
 apply degree_le_c_.
Qed.

Lemma degree_le_mult_constant_r (p: cpoly R) (x: R) (n: nat):
  degree_le n p -> degree_le n (p [*] _C_ x).
Proof with auto.
 intros.
 replace n with (n + 0)%nat...
 apply degree_le_mult...
 apply degree_le_c_.
Qed.

Lemma degree_mult_aux : forall (p q : RX) m n, degree_le m p -> degree_le n q ->
 nth_coeff (m + n) (p[*]q)  [=] nth_coeff m p[*]nth_coeff n q.
Proof.
 unfold degree_le in |- *. intros.
 astepl (Sum 0 (m + n) (fun i : nat => nth_coeff i p[*]nth_coeff (m + n - i) q)).
 astepl (Sum 0 m (fun i : nat => nth_coeff i p[*]nth_coeff (m + n - i) q) [+]
   Sum (S m) (m + n) (fun i : nat => nth_coeff i p[*]nth_coeff (m + n - i) q)).
 astepr (nth_coeff m p[*]nth_coeff n q[+][0]).
 apply bin_op_wd_unfolded.
  elim (O_or_S m); intro y.
   elim y. clear y. intros x y. rewrite <- y in H. rewrite <- y.
   apply eq_transitive_unfolded with
     (Sum 0 x (fun i : nat => nth_coeff i p[*]nth_coeff (S x + n - i) q) [+]
       nth_coeff (S x) p[*]nth_coeff (S x + n - S x) q).
    apply Sum_last with (f := fun i : nat => nth_coeff i p[*]nth_coeff (S x + n - i) q).
   astepr ([0][+]nth_coeff (S x) p[*]nth_coeff n q).
   apply bin_op_wd_unfolded.
    apply Sum_zero. auto with arith. intros.
     cut (n < S x + n - i). intro.
     Step_final (nth_coeff i p[*][0]).
    lia.
   replace (S x + n - S x) with n. algebra. auto with arith.
    rewrite <- y in H. rewrite <- y.
  pattern n at 2 in |- *. replace n with (0 + n - 0).
  apply Sum_one with (f := fun i : nat => nth_coeff i p[*]nth_coeff (0 + n - i) q).
  auto with arith.
 apply Sum_zero. auto with arith. intros.
  cut (m < i). intro.
  Step_final ([0][*]nth_coeff (m + n - i) q).
 auto.
Qed.

Lemma lead_coeff_product_1 (n: nat) (l: list (cpoly R)):
  (forall p, In p l -> (nth_coeff n p [=] [1] /\ degree_le n p)) ->
  nth_coeff (length l * n) (cr_Product l) [=] [1].
Proof with auto.
 intro H.
 induction l.
  simpl. reflexivity.
 change (nth_coeff (n + length l * n) (a [*] cr_Product l)[=][1]).
 rewrite degree_mult_aux.
   setoid_replace (nth_coeff n a) with ([1]:R).
    rewrite IHl.
     apply mult_one.
    intros. apply H...
   apply H...
  apply H...
 apply degree_le_Product.
 intros. apply H...
Qed.

Hint Resolve degree_mult_aux: algebra.

Lemma monic_mult : forall (p q : RX) m n,
 monic m p -> monic n q -> monic (m + n) (p[*]q).
Proof.
 unfold monic in |- *. intros.
 elim H. clear H. intros. elim H0. clear H0. intros. split.
 astepl (nth_coeff m p[*]nth_coeff n q).
  Step_final ([1][*] ([1]:R)).
 apply degree_le_mult; auto.
Qed.

Lemma degree_le_nexp : forall (p : RX) m n,
 degree_le m p -> degree_le (m * n) (p[^]n).
Proof.
 intros. induction  n as [| n Hrecn]; intros.
 replace (m * 0) with 0.
   apply degree_le_wd with (_C_ ([1]:R)). algebra.
    apply degree_le_c_.
  auto.
 replace (m * S n) with (m * n + m).
  apply degree_le_wd with (p[^]n[*]p). algebra.
   apply degree_le_mult; auto.
 auto.
Qed.

Lemma monic_nexp : forall (p : RX) m n, monic m p -> monic (m * n) (p[^]n).
Proof.
 intros. induction  n as [| n Hrecn]; intros.
 replace (m * 0) with 0.
   apply monic_wd with (_C_ ([1]:R)). algebra.
    apply monic_c_one.
  auto.
 replace (m * S n) with (m * n + m).
  apply monic_wd with (p[^]n[*]p). algebra.
   apply monic_mult; auto.
 auto.
Qed.

Lemma lt_i_lth_of_poly : forall i (p : RX),
 nth_coeff i p [#] [0] -> i < lth_of_poly p.
Proof.
 intros i. induction  i as [| i Hreci]; intros; rename X into H.
 induction  p as [| s p Hrecp]; intros.
   simpl in H. elim (ap_irreflexive_unfolded _ _ H).
   simpl in |- *. auto with arith.
  induction  p as [| s p Hrecp]; intros.
  simpl in H. elim (ap_irreflexive_unfolded _ _ H).
  simpl in |- *. simpl in H. apply lt_n_S. auto.
Qed.

Lemma poly_degree_lth : forall p : RX, degree_le (lth_of_poly p) p.
Proof.
 unfold degree_le in |- *. intros. apply not_ap_imp_eq. intro.
 elim (lt_not_le _ _ H). apply lt_le_weak.
 apply lt_i_lth_of_poly. auto.
Qed.

Lemma Cpoly_ex_degree : forall p : RX, {n : nat | degree_le n p}.
Proof.
 intros. exists (lth_of_poly p). apply poly_degree_lth.
Qed.

Lemma poly_as_sum'' : forall (p : RX) n,
 degree_le n p -> p [=] Sum 0 n (fun i => _C_ (nth_coeff i p) [*]_X_[^]i).
Proof.
 unfold degree_le in |- *. intros. apply all_nth_coeff_eq_imp. intros.
 apply eq_symmetric_unfolded.
 apply eq_transitive_unfolded with
   (Sum 0 n (fun i0 : nat => nth_coeff i (_C_ (nth_coeff i0 p) [*]_X_[^]i0))).
  apply nth_coeff_sum with (p_ := fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i).
 apply eq_transitive_unfolded
   with (Sum 0 n (fun i0 : nat => nth_coeff i0 p[*]nth_coeff i (_X_[^]i0))).
  apply Sum_wd. intros. algebra.
  elim (le_lt_dec i n); intros.
  astepr (nth_coeff i p[*][1]).
  astepr (nth_coeff i p[*]nth_coeff i (_X_[^]i)).
  apply Sum_term with (i := i) (f := fun i0 : nat => nth_coeff i0 p[*]nth_coeff i (_X_[^]i0)).
    auto with arith. auto.
   intros.
  Step_final (nth_coeff j p[*][0]).
 astepr ([0]:R).
 apply Sum_zero. auto with arith. intros.
  cut (i <> i0). intro.
  Step_final (nth_coeff i0 p[*][0]).
 intro; rewrite <- H2 in H1.
 apply (le_not_lt i n); auto.
Qed.

Hint Resolve poly_as_sum'': algebra.

Lemma poly_as_sum' : forall p : RX,
 p [=] Sum 0 (lth_of_poly p) (fun i => _C_ (nth_coeff i p) [*]_X_[^]i).
Proof.
 intros. apply poly_as_sum''. apply poly_degree_lth.
Qed.

Lemma poly_as_sum : forall (p : RX) n, degree_le n p ->
 forall x, p ! x [=] Sum 0 n (fun i => nth_coeff i p[*]x[^]i).
Proof.
 intros.
 astepl (Sum 0 n (fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i)) ! x.
 apply eq_transitive_unfolded with (Sum 0 n (fun i : nat => (_C_ (nth_coeff i p) [*]_X_[^]i) ! x)).
  apply Sum_cpoly_ap with (f := fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i).
 apply Sum_wd. intros.
 astepl ((_C_ (nth_coeff i p)) ! x[*] (_X_[^]i) ! x).
 Step_final (nth_coeff i p[*]_X_ ! x[^]i).
Qed.

Lemma degree_le_zero : forall p : RX, degree_le 0 p -> {a : R | p [=] _C_ a}.
Proof.
 unfold degree_le in |- *. intros.
 exists (nth_coeff 0 p).
 apply all_nth_coeff_eq_imp. intros.
 elim (O_or_S i); intro y.
  elim y. clear y. intros x y. rewrite <- y.
  cut (0 < S x). intro. Step_final ([0]:R). auto with arith.
   rewrite <- y. algebra.
Qed.

Lemma degree_le_1_imp : forall p : RX,
 degree_le 1 p -> {a : R | {b : R | p [=] _C_ a[*]_X_[+]_C_ b}}.
Proof.
 unfold degree_le in |- *. intros.
 exists (nth_coeff 1 p). exists (nth_coeff 0 p).
 apply all_nth_coeff_eq_imp. intros.
 elim i; intros. simpl in |- *. ring.
 elim n; intros.
 simpl in |- *. algebra.
 simpl in |- *. apply H. auto with arith.
Qed.

Lemma degree_le_cpoly_linear : forall (p : cpoly R) c n,
 degree_le (S n) (c[+X*]p) -> degree_le n p.
Proof.
 unfold degree_le in |- *. intros.
 change (nth_coeff (S m) (cpoly_linear _ c p)  [=] [0]) in |- *.
 apply H. auto with arith.
Qed.

Lemma degree_le_cpoly_linear_inv (p: cpoly R) (c: R) (n: nat):
  degree_le n p -> degree_le (S n) (c[+X*]p).
Proof. intros H [|m] E. inversion E. apply (H m). auto with arith. Qed.

Lemma monic_cpoly_linear : forall (p : cpoly R) c n, monic (S n) (c[+X*]p) -> monic n p.
Proof.
 unfold monic in |- *. intros. elim H. clear H. intros. split. auto.
 apply degree_le_cpoly_linear with c. auto.
Qed.

Lemma monic_one : forall (p : cpoly R) c, monic 1 (c[+X*]p) -> forall x, p ! x [=] [1].
Proof.
 intros. cut (monic 0 p). unfold monic in |- *. intros. elim H0. clear H0.
 intros H0 H1.
  elim (degree_le_zero _ H1). intro d. intros.
  astepl (_C_ d) ! x.
  astepl d.
  astepl (nth_coeff 0 (_C_ d)).
  Step_final (nth_coeff 0 p).
 apply monic_cpoly_linear with c. auto.
Qed.

Lemma monic_apzero : forall (p : RX) n, monic n p -> p [#] [0].
Proof.
 unfold monic in |- *. intros.
 elim H. clear H. intros.
 apply nth_coeff_ap_zero_imp with n.
 astepl ([1]:R). apply one_ap_zero.
Qed.

End Degree_props.

#[global]
Hint Resolve poly_as_sum'' poly_as_sum' poly_as_sum: algebra.
#[global]
Hint Resolve degree_mult_aux: algebra.

Section degree_props_Field.
(**
** Degrees of polynomials over a field
%\begin{convention}% Let [F] be a field and write [FX] for the ring of
polynomials over [F].
%\end{convention}%
*)

Variable F : CField.

(* begin hide *)
Notation FX := (cpoly_cring F).
(* end hide *)

Lemma degree_mult : forall (p q : FX) m n,
 degree m p -> degree n q -> degree (m + n) (p[*]q).
Proof.
 unfold degree in |- *. intros. rename X into H. rename X0 into H0.
 elim H. clear H. intros H1 H2. elim H0. clear H0. intros H3 H4.
 split.
  astepl (nth_coeff m p[*]nth_coeff n q). algebra.
  apply degree_le_mult; auto.
Qed.

Lemma degree_nexp : forall (p : FX) m n, degree m p -> degree (m * n) (p[^]n).
Proof.
 intros. induction  n as [| n Hrecn]; intros.
 replace (m * 0) with 0.
   apply degree_wd with (_C_ ([1]:F)). algebra.
    apply degree_c_. algebra.
   auto.
 replace (m * S n) with (m * n + m).
  apply degree_wd with (p[^]n[*]p). algebra.
   apply degree_mult; auto.
 auto.
Qed.

Lemma degree_le_mult_imp : forall (p q : FX) m n,
 degree m p -> degree_le (m + n) (p[*]q) -> degree_le n q.
Proof.
 unfold degree in |- *. unfold degree_le in |- *. intros.  rename H0 into H1. rename H into H0. rename X into H. elim H. clear H. intros H2 H3.
 elim (Cpoly_ex_degree _ q). unfold degree_le in |- *. intro N. intro H4.
 (* Set_ not necessary *)
 cut (forall k i : nat, n < i -> N - k < i -> nth_coeff i q [=] [0]). intro H5.
  elim (le_lt_dec m0 N); intros H6.
   replace m0 with (N - (N - m0)). apply H5 with (N - n).
    lia. lia. lia.
    apply H4; auto.
 intro. induction  k as [| k Hreck]; intros.
 apply H4. rewrite <- minus_n_O in H5; auto.
  elim (le_lt_eq_dec (N - k) i); try intro y. auto. rewrite y in Hreck.
   apply mult_cancel_lft with (nth_coeff m p). auto. astepr ([0]:F).
   apply eq_transitive_unfolded with
     (Sum 0 (m + i) (fun j : nat => nth_coeff j p[*]nth_coeff (m + i - j) q)).
   pattern i at 1 in |- *. replace i with (m + i - m).
   apply eq_symmetric_unfolded.
    apply Sum_term with (f := fun j : nat => nth_coeff j p[*]nth_coeff (m + i - j) q).
      auto with arith. auto with arith.
     intros. elim (le_lt_dec j m); intros.
    cut (i < m + i - j). intro.
      cut (n < m + i - j). intro.
       Step_final (nth_coeff j p[*][0]).
      lia. lia.
     Step_final ([0][*]nth_coeff (m + i - j) q).
   auto with arith.
  astepl (nth_coeff (m + i) (p[*]q)).
  cut (m + n < m + i). intro.
   auto.
  auto with arith.
 lia.
Qed.

Lemma degree_mult_imp : forall (p q : FX) m n,
 degree m p -> degree (m + n) (p[*]q) -> degree n q.
Proof.
 unfold degree in |- *. intros. rename X into H. rename X0 into H0.
 elim H. clear H. intros H H1.
 elim H0. clear H0. intros H0 H2.
 cut (degree_le n q). intro H3. split.
  apply mult_cancel_ap_zero_rht with (nth_coeff m p).
   astepl (nth_coeff (m + n) (p[*]q)). auto.
   assumption.
 apply degree_le_mult_imp with p m; auto.
 unfold degree in |- *. split. auto.
 assumption.
Qed.

End degree_props_Field.


(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Avi Shinnar
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

Require Import Arith List Omega.

Require Import Ynot.Axioms.
Require Import Ynot.Util.
Require Import Ynot.Heap.
Require Import Ynot.Hprop.
Require Import Ynot.Separation.
Require Import Ynot.Sep.

Set Implicit Arguments.

(* I used these to explicitly transform an himp goal -- there's probably a better way *)
Lemma hprop_mp(P1 P2 P3:hprop) : (P1 ==> P2) -> (P2 ==> P3) -> (P1 ==> P3).
Proof. intros. red. intros. pose (H h H1). apply (H0 h p). Qed.

Lemma hprop_mp_conc(P1 P2 P3:hprop) : (P2 ==> P3) -> (P1 ==> P2) -> (P1 ==> P3).
Proof. intros. red. intros. pose (H0 h H1). apply (H h p). Qed.

(* split separating conjunction into two pieces *)
Lemma split_sep(P:nat->hprop)(len i:nat)(H:i <= len)(start:nat) :
  ((iter_sep P start len) ==> (iter_sep P start i) * (iter_sep P (start + i) (len - i))).
Proof. revert i H start.
  induction len ; intros.
  assert (i = 0) ; [ omega | subst ; sep fail auto].
  induction i ; simpl ; intros ; assert (start + 0 = start) ; try omega.
  rewrite H0 ; sep fail auto.
  assert (start + S i = ((S start) + i)) ; try omega ;
  rewrite H1 ; clear H0; sep fail ltac:(try subst; auto).
  replace (S (start + i)) with (S start + i) by omega.
  sep fail auto.
Qed.

(* join two adjacent separating conjunctions *)
Lemma join_sep(P:nat->hprop)(len i:nat)(H:i <= len)(start:nat) :
  (iter_sep P start i) * (iter_sep P (start + i) (len - i)) ==> iter_sep P start len.
Proof. revert i H start.
  induction len ; intros.
  assert (i = 0) ; [omega | sep fail auto].
  induction i ; simpl ; intros ; assert (start + 0 = start) ; try omega.
  rewrite H0 ; sep fail auto.
  assert (start + S i = ((S start) + i)) ; try omega ; rewrite H1 ; sep fail auto.
(*  replace (S (start + i)) with (S start + i) by omega.
  sep fail auto. *)
Qed.

(* split out a particular index, leaving the front and rear *)
Lemma split_index_sep(P:nat->hprop)(start len i:nat) :
  i < len ->
  (iter_sep P start len) ==>
  (iter_sep P start i) * (P (start + i)) * (iter_sep P (1 + start + i) (len - i - 1)).
Proof.
  intros. assert (i <= len). omega. assert (1 <= len - i). omega.
  eapply hprop_mp. apply (split_sep P H0 start). sep fail auto.
  eapply hprop_mp. apply (split_sep P H1 (start + i)).
  assert (S (start + i) = start + i + 1). omega. rewrite H2. sep fail auto.
Qed.

(* opposite of above *)
Lemma join_index_sep(P:nat->hprop)(start len i:nat) :
  i < len ->
  (iter_sep P start i) * (P (start + i)) * (iter_sep P (1 + start + i) (len - i - 1)) ==>
  (iter_sep P start len).
Proof.
  intros. eapply hprop_mp_conc. assert (i <= len). omega.
  apply (join_sep P H0 start). sep fail auto. assert (1 <= len - i). omega.
  eapply hprop_mp_conc. apply (join_sep P H0 (start + i)).
  assert (S (start + i) = start + i + 1). omega. rewrite H1. sep fail auto.
Qed.

(* simplify proof for iterating separating conjunction implication *)
Lemma iter_imp(P1 P2:nat->hprop)(len start:nat) :
  (forall i, i >= start -> i < len + start -> P1 i ==> P2 i) ->
  iter_sep P1 start len ==> iter_sep P2 start len.
Proof. revert start.
  induction len. sep fail auto. sep fail auto. eapply himp_split. apply H. auto. omega.
  apply (IHlen (S start)). intros. apply H. omega. omega.
Qed.

Lemma sp_index_hyp(P:nat->hprop)(Q R:hprop)(start len i:nat) :
  i < len ->
  iter_sep P start i * P (start + i) * iter_sep P (1 + start + i) (len - i - 1) * Q ==> R
  ->
  iter_sep P start len * Q ==> R.
Proof.
  intros. eapply hprop_mp. eapply himp_split. apply (split_index_sep P start H).
  sep fail auto. auto.
Qed.

Lemma sp_index_conc(P:nat->hprop)(Q R:hprop)(start len i:nat) :
  i < len ->
  R ==> iter_sep P start i * P (start + i) * iter_sep P (1 + start + i) (len - i - 1) * Q ->
  R ==> iter_sep P start len * Q.
Proof.
  intros. eapply hprop_mp_conc. eapply himp_split. apply (join_index_sep P start H).
  sep fail auto. auto.
Qed.

(* extra tactics *)

Ltac split_index' := idtac;
  match goal with
    | [ |- iter_sep ?P ?s ?len * ?Q ==> ?R ] =>
      eapply (sp_index_hyp P)
    | [ |- ?R ==> iter_sep ?P ?s ?len * ?Q] =>
      eapply (sp_index_conc P)
  end.

Ltac split_index := search_prem split_index' || search_conc split_index'.


Require Import ssreflect ssrnat ssrbool seq eqtype Ring Group.

Module Import RF := Ring.RingFacts.

(* Reflection principle for (in)equality *)

CoInductive eqneq (m n : nat) : bool -> bool -> Set :=
 | Equal     of m == n : eqneq m n true false
 | Different of m != n : eqneq m n false true.

Lemma eqneqP m n: eqneq m n (m == n) (m != n).
  by case A0: eq_op; rewrite /negb; constructor; rewrite A0. Qed.

(*************************************************)

Definition swap_neq {i j : nat}: i != j -> j != i. by rewrite eq_sym.  Defined.

Axiom X: forall {i j : nat}, (i != j) -> R -> ZZ.

Axiom ST0: forall {i j : nat} (ij : (i != j)) r s, X ij (r + s) = X ij r .* X ij s.

Lemma Xzero: forall {i j : nat} (ij : (i != j)), X ij 0 = Id.
intros. apply (GCr (X ij 0)). by rewrite -{3}(plus_0_l 0) ST0 IdG. Qed.

Lemma ST0': forall {i j : nat} (ij : (i != j)) r, X ij (- r) = (X ij r) ^-1.
intros. apply (GCr (X ij r)). by rewrite -ST0 IG (inv_l) Xzero. Qed.

Lemma ST0'' {i j} a b (ij : i != j): X ij a ^ X ij b = X ij a.
expand. by rewrite -ST0' -?ST0 plus_comm -plus_assoc inv_r plus_0_l. Qed.

Axiom ST1: forall {i j k : nat} (ij : (i != j)) (ik : (i != k)) (jk : (j != k)) r s,
 [~ X ij r , X jk s ] = X ik (r * s).

Lemma ST1': forall {i j k : nat} (ij : (i != j)) (ik : (i != k)) (jk : (j != k)) r s,
 [~ X jk r , X ij s ] = X ik (- s * r).
intros. by rewrite -comm_inv ST1 -ST0' inv_mul. Qed.

Lemma ST1'' {i j k} a b (ik : i != k) (kj : k!= j) (ij : i!=j):
 X ik a ^ X kj b = X ij (a * b) .* X ik a.
by rewrite conj_com -ST0' ST1' mul_inv inv_mul invI. Qed.

Lemma ST1''2 {i j k} a b {ij : i != j} {ki : k != i} (kj : k != j):
X ij a ^ X ki b = X kj (- (b * a)) .* X ij a.
by rewrite conj_com -ST0' ST1 inv_mul. Qed.

Axiom ST2: forall {i j k l : nat} (ij : (i != j)) (kl : (k != l)) r s, j != k -> i != l ->
 [~ X ij r, X kl s ] = Id.

Lemma ST2': forall {i j k} {ik : i != k} {jk : j != k} (ij : i != j) a b, X ik a ^ X jk b = X ik a.
intros. rewrite conj_com -ST0' ST2. by rewrite IdG. exact (swap_neq ik). exact jk. Qed.

Corollary ST2'_swap: forall {i j k} {ik : i != k} {jk : j != k} (ij : i != j) a b, X ik a .* X jk b = X jk b .* X ik a.
intros. rewrite -{2}(ST2' ij a b). by cancellate. Qed.

Lemma ST2'': forall {i j k} {ki : k != i} {kj : k != j} (ij : i != j) a b, X ki a ^ X kj b = X ki a.
intros. rewrite conj_com -ST0' ST2. by rewrite IdG. exact (swap_neq kj). exact ki. Qed.

Corollary ST2''_swap: forall {i j k} {ki : k != i} {kj : k != j} (ij : i != j) a b, X ki a .* X kj b = X kj b .* X ki a.
intros. rewrite -{2}(ST2'' ij a b). by cancellate. Qed.

Lemma ST2''' {i j k l : nat} (ij : i != j) (kl : k != l) (jk : j != k) (il : i != l) r s:
 X ij r ^ X kl s = X ij r. rewrite conj_com -ST0' ST2. by rewrite IdG. by exact (swap_neq il). by exact (swap_neq jk). Qed.

(* These 2 axioms are needed to get rid of proof-relevant nature of parameter "p" of Z *)

Axiom swapI : forall {i j : nat} (p : i != j), swap_neq (swap_neq p) = p.

Axiom irrelev : forall {i j : nat} (p q : i != j), p = q.

(* Tits relative generators z_{ij}(a, r) *)

Definition Z {i j : nat} (p : i != j) (r s : R) : ZZ := locked ((X p r) ^ (X (swap_neq p) s)).

Lemma Zdef {i j} (p : i!= j) r s: (X (p) r) ^ (X (swap_neq p) s) = Z p r s. by unlock Z. Qed.

Lemma Zdef'{i j} (p : i!= j) r s: (X (swap_neq p) r) ^ (X p s) = Z (swap_neq p) r s.
by unlock Z; rewrite swapI. Qed.

Lemma Zdef''{i j} {p : i != j} {q  : j != i} r s: (X p r) ^ (X q s) = Z p r s.
by rewrite /Z -lock (irrelev (swap_neq p) q). Qed.

Lemma Zadd {i j} (ij : i != j) (r s t : R): Z ij (r+s) t = Z ij r t .* Z ij s t.
unlock Z. by rewrite -mul_conj ST0. Qed.

Lemma Zinv {i j} (ij : i != j) (r s : R): Z ij (-r) s = (Z ij r s)^-1.
by unlock Z; rewrite /conj ST0' ?GIM ?GA GII. Qed.

Lemma Zzero {i j} (ij : i != j) (s : R): Z ij s 0 = X ij s.
by rewrite /Z -?lock Xzero /conj IdI IdG GId. Qed.

Lemma Zd i j (ij : i!=j) (ji : j!=i) a b:
 X ji (- a) .* X ij b .* X ji a = Z ij b a.
by rewrite /Z -lock (irrelev (swap_neq ij) ji) /conj ST0'. Qed.

Lemma Zd' i j (ij : i!=j) (ji : j!=i) a b:
 X ji (a) .* X ij b .* X ji (-a) = Z ij b (-a).
move: (Zd i j ij ji (-a) b). by rewrite ?invI. Qed.

Corollary Zd2 i j (ij : i!=j) (ji : j!=i) a b g:
  g .* X ji (- a) .* X ij b .* X ji a = g .* Z ij b a.
by rewrite (GA g) GA Zd. Qed.

Corollary Zd2' i j (ij : i!=j) (ji : j!=i) a b g:
  g .* X ji (a) .* X ij b .* X ji (-a) = g .* Z ij b (-a).
move: (Zd2 i j ij ji (-a) b g). by rewrite ?invI. Qed.

Ltac collectZ := rewrite -?GA -?ST0' ?invI ?Zdef'' ?Zd2 ?Zd2' ?Zd ?Zd'.

Lemma ZX {i j} (ij : i!=j) a b: let ji := swap_neq ij in
Z ij a b .* X ij (-a) = X ji (- b) .* X ji b ^ X ij (- a).
by intros; rewrite /Z -?lock -/ji ST0' comm_d1'' comm_d2 GII -?ST0'. Qed.

Lemma ZX' {i j} (ij : i!=j) a b g: let ji := swap_neq ij in
g .* Z ij a b .* X ij (-a) = g .* X ji (- b) .* X ji b ^ X ij (- a).
intros. by rewrite ?(GA g) ZX. Qed.

Section S0.

Context (i j k l : nat) (a b c d : R) (ij : i != j) (ik : i != k) (jk : j != k)
                                      (kl : k != l) (il : i != l) (jl : j != l).
Let ji := (swap_neq ij). Let ki := (swap_neq ik). Let kj := (swap_neq jk).
Let lk := (swap_neq kl). Let li := (swap_neq il). Let lj := (swap_neq jl).

Lemma C3': (Z ij a b) ^ (X ki c) = X ki (- (c * a * b)) .* X kj (- (c * a)) .* Z ij a b.
by rewrite /Z -lock -/ji -conj_mul swap_comm ST2 //; cancel;
rewrite conj_mul ST1''2  mul_conj ST1'' Zdef; rsimpl. Qed.

End S0.

Section S1.
Context (i j k l : nat) (a b c d : R) (ij : i != j) (ik : i != k) (jk : j != k)
                                      (kl : k != l) (il : i != l) (jl : j != l).
Let ji := (swap_neq ij). Let ki := (swap_neq ik). Let kj := (swap_neq jk).
Let lk := (swap_neq kl). Let li := (swap_neq il). Let lj := (swap_neq jl).

(* Shorter and slicker relation taken from Petrov's Russian thesis (Lemma 7)*)

Ltac rotate1 := rewrite ?GA; move /rotate; rewrite ?GA.

(* Lemma C1slicker : (Z ij a b) ^ (X ij c) = (Z ij a b) ^ (X ij c).
rewrite {2}/Z -?lock -/ji -{2}(mul_1_l a) -(ST1 ik ij kj) -conj_mul comm_conj.
rewrite ?conj_mul ST1''2 ST1'' ?mul_conj ST2''// ST1''2 ST2'_swap // GA -ST0.
rewrite ST1'' ST2'// (ST2''_swap ji) GA -ST0; rsimpl; rewrite comm_d1 mul_conj.
rewrite ?GIM -?ST0' ?invI (ST2'_swap ij) conj_mul (ST2'_swap ji) conj_mul -{4}(mul_1_r a) mul_assoc -dist_l.
rewrite 2!ST1''2 ?mul_conj ?Zdef''; rsimpl. rewrite (plus_comm _ a) ?inv_plus (ST0 _ (-a)).
rewrite -?inv_mul 4!GA -ST1'' -4!GA.
symmetry. apply eqIdP'. replace conj with (locked conj); [| by rewrite -?lock].
do 5 rotate. rewrite ?ST0'. apply eqIdP. rewrite GII -?lock.
Check eqIdP'.

 ?inv_mul ?ST0' ?conjI.
apply (GCr (X ki (a * b) ^ X ij c)). cancel.

 -4!GA.
rewrite -?inv_mul ?GA -ST1''.
rewrite ?GA ST2''_swap -?inv_mul. Check ST1''.
assert (X ki (-(a*b)) ^ X ij c = Id).
rewrite ST1''.

 Qed.

*)

(* [ ~ X ki (a * b) .* X kj (a * (b * c + 1)), X ik (- (c * b) - 1) .* X jk b] *)

Lemma C1: (Z ij a b) ^ (X ij c) =
   X kj (a * (b * c + 1)) .* X ki (a * b) .*
   X ik (- ((c * b + 1) * a * (b * c + 1) * b)) .* X ij ((c * b + 1) * a * (b * c + 1)) .* Z kj (- (a * (b * c + 1))) (- b) .*
   X jk (- (b * a * b * (c * b + 1))) .* X ji (- (b * a * b)) .* Z ki (- (a * b)) (c * b + 1).

rewrite /Z -lock -conj_mul -/ji.
move: (ST1' ik ij kj a (-(1))); rsimpl => <-.
rewrite conj_mul comm_conj ST1'' ST1''2
        comm_conj ?mul_conj ST2'' // ST2' // ST1'' ST1''2; rsimpl.
rewrite ST2''_swap // ?GA -ST0 ST2'_swap // -GA -ST0 -{3}(mul_1_r a) mul_assoc -dist_l.
rewrite comm_d2 ?GIM -?ST0' inv_plus ?invI mul_conj {1}ST2''_swap //.
rewrite ?conj_mul Zdef'' ST1''2 ?mul_conj.
by rewrite ST1'' ?Zdef'' -(swapI ik) C3' ?swapI -?GA -?lock; rsimpl. Qed.

Lemma C1': (Z ij a b) ^ (X ij c) =
  X ik ((c * b + 1) * a) .* X jk (- (b * a)) .*
  X ki (- ((b * c + 1) * b * a * b)) .* X ji (- (b * a * b)) .* Z jk (b * a) (- (b * c + 1)) .*
  X kj (b * (c * b + 1) * a * (b * c + 1)) .* X ij ((c * b + 1) * a * (b * c + 1)) .* Z ik (- ((c * b + 1) * a)) (- b).

rewrite /Z -lock -conj_mul -/ji.
move: (ST1 ik ij kj a 1). rsimpl. move => <-.
rewrite conj_mul comm_conj ST1'' ST1''2 comm_conj ?mul_conj ST2'' // ST2' // ST1'' ST1''2; rsimpl.
rewrite ST2''_swap // ?GA -ST0 ST2'_swap // -GA -ST0 -{2}(mul_1_l a) -dist_r.
rewrite comm_d2 ?GIM -?ST0' invI mul_conj {1}ST2''_swap //.
rewrite ?conj_mul 2!ST1'' ?mul_conj ST1''2 ?Zdef ST1''2.
by rewrite ?inv_mul ?mul_inv ?invI -?GA -?lock -?mul_assoc. Qed.

Lemma C2: (Z ij a b) ^ (X ji c) = (Z ij a (b + c)). by rewrite /Z -?lock -/ji -conj_mul ST0. Qed.

Lemma C3: (Z ij a b) ^ (X jk c) = X jk (- (b * a * c)) .* X ik (a * c) .* Z ij a b.
by rewrite /Z -lock -/ji -conj_mul swap_comm ST2 //
           IdG conj_mul ST1'' mul_conj ST1''2 Zdef; rsimpl. Qed.

Lemma C4: (Z ij a b) ^ (X kj c) = X ki (c * b * a * b) .* X kj (c * b * a) .* Z ij a b.
by rewrite /Z -lock -/ji -conj_mul swap_comm ST1' GA
        conj_mul ST1''2 ?mul_conj ?conj_mul ST0'' ST1'' ST2' // Zdef; rsimpl. Qed.

Lemma C4': (Z ij a b) ^ (X ik c) = X jk (- (b * a * b * c)) .* X ik (a * b * c) .* Z ij a b.
by rewrite /Z -lock -/ji -conj_mul swap_comm ST1 GA
        conj_mul ST1'' ?mul_conj ?conj_mul ST0'' ST1''2 ST2'' // Zdef; rsimpl. Qed.

Lemma C5: (Z ij a b) ^ (X kl c) = Z ij a b.
by rewrite /Z -lock -/ji -conj_mul swap_comm ST2 // IdG
           conj_mul (conj_com (X ij a)) -ST0' ST2// IdG Zdef. Qed.

End S1.

Corollary C10 i j k a b (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in

Z ij a b = X kj a .* X ki (a * b) .* X ik (- (a * b)) .* X ij a .* Z kj (- a) (- b)
.* X jk (- (b * a * b)) .* X ji (- (b * a * b)) .* Z ki (- (a * b)) 1.

intros. move: (C1 i j k a b 0 ij ik jk) => /=. rewrite -/ji -/ki -/kj; rsimpl.
rewrite ?Xzero. by rewrite /conj IdI IdG GId. Qed.

Corollary C1'0 i j k a b (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in

Z ij a b = X ik a .* X jk (- (b * a)) .* X ki (- (b * a * b)) .* X ji (- (b * a * b))
.* Z jk (b * a) (- (1)) .* X kj (b * a) .* X ij a .* Z ik (- a) (- b).

intros. move: (C1' i j k a b 0 ij ik jk) => /=. rewrite -/ji -/ki -/kj; rsimpl.
rewrite ?Xzero. by rewrite /conj IdI IdG GId. Qed.

(* Petrov's relation and its variations *)

Ltac rotate1 := rewrite ?GA; move /rotate; rewrite ?GA.
Ltac simplify := expand; rewrite -?Zinv -?ST0' ?invI -?GA; rsimpl.

Lemma RG0 i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij (a * b) c =
   X jk (- (c * a)) .* X ik a .*
   X ij (a * b) ^ X ki (- (b * c))        .* Z ik (- a) (- (b * c))
.* X ji (- (c * a * b * c)) ^ X kj (- b)  .* Z jk (c * a) (- b).

intros. rewrite {1}/Z -lock -/ji -{1}(ST1 ik ij kj) comm_conj.
rewrite ?ST1'' ?ST1''2. rsimpl. rewrite comm_d2.
rewrite ?GIM -?ST0' ?invI mul_conj ?conj_mul ST1'' Zdef C3
        mul_conj Zdef ST1''2; simplify. done. Qed.

Lemma RG1 i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ki (a * b) c = X ij (- (c * a)) .* X kj a .* X ji (b * c * a * b) .* X ki (a * b)
.* Z kj (- a) (- (b * c)) .* X jk (- (b * c * a * b * c))
.* X ik (- (c * a * b * c)) .* Z ij (c * a) (- b).
intros. rewrite {1}/Z -lock -/ik -{1}(ST1 kj ki ji) comm_conj.
rewrite ?ST1'' ?ST1''2. rsimpl. rewrite comm_d2.
rewrite ?GIM -?ST0' ?invI mul_conj ?conj_mul ST1''.
rewrite Zdef C3 mul_conj Zdef' ST1''2; simplify; rewrite -/kj. done. Qed.

Lemma RG0'  i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij (a * b) c = Z ij (a * b) c.
intros. move: (RG0 k i j b (-c) (-a) ki kj ij) => /=.
rewrite (irrelev (swap_neq ki) ik).
rewrite (irrelev (swap_neq ij) ji).
rewrite (irrelev (swap_neq kj) jk).
rsimpl. replace (conj) with (locked conj).
 move => H. symmetry in H. rewrite ?Zinv in H.
apply eqIdP in H. apply rotate in H.

rewrite -?Zinv -?GA in H. apply eqIdP in H.
rewrite -?Zinv -?ST0' ?invI -?lock in H.
symmetry in H.  *)

(* Petrov relations can be deduced from the following 6-relation (which is not inside relative Steinberg subgroup) *)

Lemma SixRelation i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
X ki (- (b * c)) .* Z jk (c * a) b .* X ij (- (a * b)) .* Z ki (b * c) a .* X jk (- (c * a)) .* Z ij (a * b) c = Id.

intros. move: (HallWitt'' (X ik (a)) (X ji c) (X kj b)).
rewrite -?ST0' ?invI. do 3 rewrite ST1' ST1''; rsimpl.
expand. conjugate_r (X jk (-(c*a))). collectZ. rewrite ?ST0'; cancel.
by rewrite -?ST0'. Qed.

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

Lemma RG1 i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
let RHS := X jk (- (b * c * a * b)) .* X ik (a * b) .* X ji (- (b * c * a * b * c))
.* X ki (- (c * a * b * c)) .* Z kj (- (c * a)) (- b)
.* Z ik (- (a * b)) (- c) .* X kj (c * a) .* X ij a in
Z ij a (b * c) = RHS.  intros.
rewrite /Z -lock -/ji -(ST1 jk ji ki) /Comm ?conj_mul.

rewrite ST1'' (mul_conj (X ki c)) Zdef ST1''2 (mul_conj (X jk b ^-1)) -?ST0'.
rewrite -(swapI jk) C4 -/ji ?swapI -?mul_assoc
         (mul_conj (X jk (- b))) Zdef' -/kj ST1''.

rewrite ?mul_conj ST2'// ST1'' C2 inv_r C4' Zdef ST1''2; rsimpl.
by rewrite Zzero ?ST0'; cancel; rewrite -?ST0' -?GA. Qed.

Lemma RG2 i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
let RHS := X ki (- (c * a * b * c)) .* X kj (- (c * a)) .* X ji (- (b * c * a * b * c))
.* X jk (b * c * a * b) .* Z ik (- (a * b)) (- c) .* Z kj (c * a) b
.* X ik (a * b) .* X ij a in
Z ij a (b * c) = RHS. intros.
rewrite /Z -lock -/ji.
move: (@ST1' j k i jk ji ki c (-b)). rewrite ?invI => <-. rewrite /Comm ?conj_mul.

rewrite ST1''2 mul_conj Zdef' -/kj ST1'' -?ST0' ?invI.
rewrite ?(mul_conj (X ki (-c))) C4' Zdef ST1''2.
rewrite ?mul_conj ST2''// ST1''2 -(swapI jk) C2 C4 ?swapI Zdef' ST1''.
by rsimpl; rewrite ?ST0'; cancel; rewrite -?ST0' inv_l Zzero -/kj -?GA. Qed.

(* ====== *)

Lemma Petro

Corollary RG1' i j k a b c: forall (ij : i!=j) (ik : i!=k) (jk : j!=k),
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a (b * c) = X jk (- (b * c * a * b)) .* X ik (a * b) .* (X ji (- (b * c * a * b * c))
.* X ki (- (c * a * b * c)) .* Z kj (- (c * a)) (- b)) .* Z ik (- (a * b)) (- c) .* X kj (c * a) .* X ij a.
intros. by rewrite (RG1 i j k a b c) -/ji -/ki -/kj ?GA. Qed.

Corollary RG2' i j k a b c (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a (b * c) = X ki (c * a * b * c) .* X kj (c * a) .* X ji (- (b * c * a * b * c))
.* X jk (- (b * c * a * b)) .* Z ik (a * b) c .* Z kj (- (c * a)) (- b)
.* X ik (- (a * b)) .* X ij a.
intros. replace (b * c) with (-b * -c); [| by rsimpl].
by rewrite (RG2 i j k a (-b) (-c)) -/ji -/ki -/kj; rsimpl. Qed.

(* ====== *)

Corollary RG1'' i j k a b c: forall (ij : i!=j) (ik : i!=k) (jk : j!=k),
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a (b * c) = X ij a .* X kj (c * a) .* Z ik (- (a * b)) (- c) .* Z kj (- (c * a)) (- b)
.* X ki (- (c * a * b * c)) .* X ji (- (b * c * a * b * c)) .* X ik (a * b) .* X jk (- (b * c * a * b)).

intros. by rewrite -{1}(invI a) Zinv (RG1' i j k (-a) b c) -/ji -/ki -/kj;
 expand; rewrite -?ST0' -?Zinv -?GA; rsimpl. Qed.

Corollary RG2'' i j k a b c: forall (ij : i!=j) (ik : i!=k) (jk : j!=k),
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a (b * c) = X ij a .* X kj (c * a) .* Z ik (- (a * b)) (- c) .* Z kj (- (c * a)) (- b)
.* X ki (- (c * a * b * c)) .* X ji (- (b * c * a * b * c)) .* X ik (a * b) .* X jk (- (b * c * a * b)).
intros. by rewrite -{1}(invI a) Zinv (RG1' i j k (-a) b c) -/ji -/ki -/kj;
 expand; rewrite -?ST0' -?Zinv -?GA; rsimpl. Qed.

(* ====== *)

Corollary RG1bis i j k (a b c : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij (a * b) c =  X jk (- (c * a)) .* X ik a .* Z ik (- a) (- (b * c)) .* X kj (b * c * a * b)
               .* X ij (a * b) .* X ki (- (b * c * a * b * c)) .* X ji (- (c * a * b * c)) .* Z jk (c * a) (- b).

intros. apply eqIdP'. rewrite ?GIM -?Zinv -?ST0' ?invI -?GA -?mul_inv.
by rewrite (RG1' i k j a b (-c)) ?swapI -/ji -/ki -/kj; rsimpl; rewrite ?ST0' ?Zinv ?GA; do 2 cancel. Qed.

Corollary RG2bis i j k (a b c : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij (a * b) c =  Z jk (- (c * a)) b .* X ij (a * b) .* X ik a .* Z ik (- a) (- (b * c))
.* X ji (- (c * a * b * c)) .* X jk (c * a) .* X ki (- (b * c * a * b * c)) .* X kj (- (b * c * a * b)).

intros. move: (RG2' i k j a (-b) c ik ij kj) => /=; rewrite ?swapI -/ji -/ki -/kj -?GA ?Zinv; rsimpl.
move /eqIdP''; rewrite ?GIM -?ST0' -?Zinv ?invI. do 4 (move /rotate; rewrite ?GA). move /eqIdP => ->.
by rewrite ?GIM -?Zinv -?ST0' ?invI ?GA. Qed.

(* ====== *)

Corollary R12 i j k (a b : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a b = X jk (- (b * a)) .* X ik a .* Z ik (- a) (- b) .* X kj (b * a) .* X ij a
.* X ki (- (b * a * b)) .* X ji (- (b * a * b)) .* Z jk (b * a) (- (1)).

intros. move: (RG1bis i j k a 1 b ij ik jk) => /=.
by rewrite ?swapI -/ji -/ki -/kj; rsimpl. Qed.

Corollary R22 i j k (a b : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a b = Z jk (- (b * a)) 1 .* X ij a .* X ik a .* Z ik (- a) (- b)
.* X ji (- (b * a * b)) .* X jk (b * a) .* X ki (- (b * a * b))
.* X kj (- (b * a)).

intros. move: (RG2bis i j k a 1 b ij ik jk) => /=.
by rewrite ?swapI -/ji -/ki -/kj; rsimpl. Qed.

(* ====== *)

Corollary R12' i j k (a b : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a b = Z jk (b * a) (- (1)) .* X ji (- (b * a * b)) .* X ki (- (b * a * b))
.* X ij a .* X kj (b * a) .* Z ik (- a) (- b) .* X ik a .* X jk (- (b * a)).

intros. move: (RG1bis i j k (-a) 1 b ij ik jk) => /=.
rewrite ?swapI -/ji -/ki -/kj; rsimpl.
rewrite Zinv. rewrite -{2}(GII (Z ij a b)) => ->.
by rewrite ?GIM -?Zinv -?ST0' ?invI -?GA //. Qed.

Corollary R12'' i j k (a b : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a b = X jk (b * a) .* X ik (- a) .* Z ik a b .* X kj (- (b * a)) .* X ij a
.* X ki (b * a * b) .* X ji (- (b * a * b)) .* Z jk (- (b * a)) 1.

intros. move: (RG1bis i j k (-a) (-(1)) b ij ik jk) => /=.
rewrite ?swapI -/ji -/ki -/kj; rsimpl.
rewrite Zinv. rewrite -{2}(GII (Z ij a b)) => ->.
by rewrite ?GIM -?Zinv -?ST0' ?invI -?GA //. Qed.

Corollary R22'  i j k (a b : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a b = X kj (- (b * a)) .* X ki (- (b * a * b)) .* X jk (b * a)
.* X ji (- (b * a * b)) .* Z ik (- a) (- b) .* X ik a .* X ij a
.* Z jk (- (b * a)) 1.

intros. move: (RG2bis i j k (-a) 1 b ij ik jk) => /=.
rewrite ?swapI -/ji -/ki -/kj; rsimpl.
rewrite Zinv. rewrite -{2}(GII (Z ij a b)) => ->.
by rewrite ?GIM -?Zinv -?ST0' ?invI -?GA //. Qed.

Corollary R22'' i j k (a b : R) (ij : i!=j) (ik : i!=k) (jk : j!=k):
let ji := swap_neq ij in let ki := swap_neq ik in let kj := swap_neq jk in
Z ij a b = Z jk (b * a) (- (1)) .* X ij a .* X ik (- a) .* Z ik a b
.* X ji (- (b * a * b)) .* X jk (- (b * a)) .* X ki (b * a * b)
.* X kj (b * a).

intros. move: (RG2bis i j k (-a) (-(1)) b ij ik jk) => /=.
rewrite ?swapI -/ji -/ki -/kj; rsimpl.
rewrite -{2}(GII (Z ij a b)) => ->.
by rewrite ?GIM -?Zinv -?ST0' ?invI -?GA //. Qed.

(* ====== *)

Lemma StrangeL {i j k} {ij : i != j} {ik : i != k} {jk : j != k} {ji : j != i} {ki : k != i} {kj : k != j} a b c:
[ ~ X ik ((c * b + 1) * a) .* X jk (- (b * a)), X ki b .* X kj (b * c + 1)] ^ (X ij (-c)) = Z ij a b.
rewrite comm_conj ?mul_conj ?ST1'' ?ST1''2 ST2'' // ST2' //; rsimpl.
rewrite -GA -ST0 (ST2''_swap ji) GA -ST0 (plus_comm _ (1))
        dist_r plus_assoc inv_r plus_0_r -plus_assoc inv_l plus_0_l mul_1_l
        comm_d2 ?GIM -?ST0' ?invI ?conj_mul mul_conj Zdef'' ST1''
        ?mul_conj C3 ST1''2 Zdef''; rsimpl.

move: (R12' i j k a b ij ik jk) => /=.

rewrite (irrelev (swap_neq jk) kj) (irrelev (swap_neq ij) ji) (irrelev (swap_neq ik) ki).
Admitted.

(* Lemmata about conjugation with Weyl elements *)

Definition W {i j} (ij : i != j) := let ji := (swap_neq ij) in X ij (1) .* X ji (-(1)) .* X ij (1).

Lemma Wconj1 i j k (ij : i != j) (jk : j != k) (ik : i != k) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 (X ki a) ^ W ij = X kj a.
intros. rewrite /W -/ji 2!conj_mul ST1'' mul_conj ST1'' ST2' // ?mul_conj ?ST1'' ST2' // (ST2''_swap) //.
rsimpl. rewrite ?ST0'. cancel. rewrite (ST2''_swap) //. cancel. done. Qed.

Lemma Wconj1' i j k (ij : i != j) (jk : j != k) (ik : i != k) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 (X jk a) ^ W ij = X ik (-a).
intros. rewrite /W -/ji 2!conj_mul ST1''2 mul_conj ST1''2 ST2'' // ?mul_conj ?ST1''2 ST2'' // ST2'_swap //.
rsimpl. rewrite ?ST0'. cancel. rewrite -?ST0' (ST2'_swap) // ?ST0'. cancel. done. Qed.

Lemma Wconj2 i j k (ij : i != j) (jk : j != k) (ik : i != k) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 (X ik a) ^ W ij = X jk a.
intros. rewrite /W -/ji 2!conj_mul ST2'' // ST1''2 mul_conj ST2'' // ST1''2.
rsimpl. rewrite (ST2'_swap) // ST0'. cancel. done. Qed.

Lemma Wconj2' i j k (ij : i != j) (jk : j != k) (ik : i != k) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 (X kj a) ^ W ij = X ki (-a).
intros. rewrite /W -/ji 2!conj_mul ST2' // ST1'' mul_conj ST2' // ST1''.
rsimpl. rewrite (ST2''_swap) // ?ST0'. cancel. done. Qed.

Lemma Wconj3 i j k l (ij : i != j) (ik : i != k) (jk : j != k) (il : i != l) (kl : k != l) (jl : j!=l) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 let li := swap_neq il in let lk := swap_neq kl in let lj := swap_neq jl in
 (X kl a) ^ W ij = X kl a.
intros. rewrite /W -/ji ?conj_mul. by do 3 rewrite ST2''' //. Qed.

Lemma Wconj4 i j k (ij : i != j) (jk : j != k) (ik : i != k) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 (X ji a) ^ W ij = X ij (-a).
intros. rewrite -{1}(mul_1_r a) -(ST1 jk ji ki) comm_conj Wconj1 Wconj1' -/kj ST1. by rsimpl. Qed.

Lemma Wconj4' i j k (ij : i != j) (jk : j != k) (ik : i != k) a:
let ji := swap_neq ij in let kj := swap_neq jk in let ki := swap_neq ik in
 (X ij a) ^ W ij = X ji (-a).
intros. rewrite -{1}(mul_1_r a) -(ST1 ik ij kj) comm_conj Wconj2 Wconj2' -/ki ST1. by rsimpl. Qed.


Require Import db util.
Require Import Arith.EqNat.
Require Import List Unicode.Utf8 Arith.Peano_dec.
Require Import CpdtTactics.

Definition env := nat.

Record closure : Type := close {
  cl_tm : tm;
  cl_en : env
}.

Record cell : Type := cl {
  cell_cl : closure;
  cell_env : env
}.

Definition heap := Map nat cell.

Record configuration : Type := conf {
  conf_h : heap;
  conf_c : closure
}.

Definition I (e : tm) : configuration := conf nil (close e 0).

Notation " x ↦ M " := (x, M) (at level 40).
Notation " ⟨ Φ ⟩ m " := (conf Φ m) (at level 40).
Notation " ⟨ Ψ , b ⟩ N " := (conf (b :: Ψ) N) (at level 40).
Notation " ⟨ Φ , b , Ψ ⟩ N " := (conf (Ψ ++ b :: Φ) N) (at level 40).
Notation " { M , e } " := (cl M e).
Notation " < M , e > " := (close M e).

(* cactus lookup: lookup deBruijn index i at location x in heap h yields
location y *)
Inductive cactus_lookup : nat → nat → heap → (nat * cell) → Prop :=
  | zero : forall x Φ M Υ, cactus_lookup 0 x (Φ ++ (x ↦ M) :: Υ) (x, M)
  | pred : forall x y c Φ M Υ i, cactus_lookup i x Φ c →
            cactus_lookup (S i) y (Φ ++ (y ↦ {M, x}):: Υ) c.

Fixpoint clu (v env:nat) (h:heap) : option (nat * cell) := match lookup env h with
  | None => None
  | Some (cl c a) => match v with
    | S n => clu n a h
    | 0 => Some (env, cl c a)
    end
  end.

Fixpoint update (h : heap) (l : env) (v : closure) : heap := match h with
  | [] => []
  | (u, cl c e)::h => if beq_nat l u then (u, cl v e) :: update h l v else (u, cl c e)::update h l v
  end.

Lemma lookup_update : ∀ h l c v e,
  lookup l h = Some (cl c e) →
  lookup l (update h l v) = Some (cl v e).
induction h; intros. inversion H. simpl. destruct a. destruct c0. unfold lookup
in H. unfold find in H. simpl in H. destruct (beq_nat l n) eqn:bln. invert H.
unfold lookup. unfold find. simpl. rewrite bln. reflexivity. unfold lookup.
unfold find. simpl. rewrite bln. rewrite <- (IHh l c). unfold lookup.
unfold find. reflexivity. apply H. Qed.

Lemma lookup_update' : ∀ h l c v e l',
  lookup l h = Some (cl c e) →
  l <> l' →
  lookup l (update h l' v) = Some (cl c e).
induction h; intros. inversion H. simpl. destruct a. destruct c0. unfold lookup
in H. unfold find in H. simpl in H. destruct (beq_nat l n) eqn:bln. invert H.
destruct (beq_nat l' n) eqn:bln'. apply beq_nat_true in bln. apply beq_nat_true
in bln'. subst. unfold not in H0. specialize (H0 eq_refl). invert H0. unfold
lookup. unfold find. simpl. rewrite bln. reflexivity. destruct (beq_nat l' n)
eqn:bln'. unfold lookup.  unfold find. simpl. rewrite bln. erewrite <- (IHh l c).
unfold find.  reflexivity. apply H. assumption. unfold lookup. unfold find.
simpl. rewrite bln. erewrite <- (IHh l c). reflexivity. assumption.
assumption. Qed.

Lemma domain_update : ∀ h l v,
  domain (update h l v) = domain h.
induction h. auto. intros. simpl. destruct a. destruct c. simpl. destruct
(PeanoNat.Nat.eqb l n); auto. simpl. rewrite IHh. reflexivity.
simpl. rewrite IHh. reflexivity.
Qed.

Lemma update_nodomain : ∀ h l v,
  l ∉ domain h → update h l v = h.
induction h. auto. intros. simpl in H. destruct a. unfold not in H. simpl in *.
destruct c. destruct (eq_nat_dec l n). subst. specialize (H (or_introl
eq_refl)). invert H. rewrite <- PeanoNat.Nat.eqb_neq in n0. rewrite n0.
rewrite IHh. reflexivity. unfold not. intros. specialize (H (or_intror H0)).
assumption.
Qed.

Definition closed_under (c : closure) (h : heap)  : Prop := match c with
  | close t e => forevery (fvs t)
      (λ x, ∃e' c', clu x e h = Some (e',c') ∧ In e' (domain h))
  end.

Definition closed (t : tm) : Prop := closed_under (close t 0) nil.

Definition well_formed_heap (h : heap) : Prop := forevery h
  (λ x, match x with | (v,cl c e') => closed_under c h end).

Definition well_formed (c : configuration) : Prop := match c with
  | conf h t => closed_under t h ∧ well_formed_heap h
  end.

Reserved Notation " c1 '⇓' c2 " (at level 50).
Inductive step : configuration → configuration → Type :=
  | Id : ∀ M x y z Φ Ψ v e, clu y e Φ = Some (x, {M, z}) →
                    ⟨Φ⟩M ⇓ ⟨Ψ⟩v →
    ⟨Φ⟩close (var y) e ⇓ ⟨update Ψ x v⟩v
  | Abs : ∀ N Φ e, ⟨Φ⟩close (:λN) e ⇓ ⟨Φ⟩close (:λN) e
  | App : ∀ N M B B' Φ Ψ Υ f e ne ae, isfresh (domain Ψ) f → f > 0 →
          ⟨Φ⟩close M e ⇓ ⟨Ψ⟩close (:λB) ne →
      ⟨Ψ, f ↦ {close N e, ne}⟩close B f ⇓ ⟨Υ⟩close (:λB') ae   →
              ⟨Φ⟩close (M@N) e ⇓ ⟨Υ⟩close (:λB') ae
where " c1 '⇓' c2 " := (step c1 c2).

Variable id_const app_const : nat.

Fixpoint time_cost {c1 c2} (s : step c1 c2) : nat := match s with
  | Id _ _ v _ _ _ _ _ lu th => id_const * v + time_cost th
  | Abs _ _ _ => 0
  | App _ _ _ _ _ _ _ _ _ _ _ _ _ m b => app_const + time_cost m + time_cost b
  end.
(*
Fixpoint stack_cost {c1 c2} (s : step c1 c2) : nat := match s with
  | Id _ _ _ _ _ _ _ _ v e => 2 + stack_cost e
  | Abs _ _ _ => 0
  | App _ _ _ _ _ _ _ _ _ _ _ _ m b => 2 + max (stack_cost m) (stack_cost b)
  end.

Fixpoint heap_cost {c1 c2} (s : step c1 c2) : nat := match s with
  | Id _ _ _ _ _ _ _ _ lu e => heap_cost e
  | Abs _ _ _ => 0
  | App _ _ _ _ _ _ _ _ _ _ _ _ m b => 3 + heap_cost m + heap_cost b
  end.
*)
Definition configuration' := sigT well_formed.
Definition step' (c1 c2: configuration') : Type := match (c1, c2) with
  | (existT _ c1 _, existT _ c2 _) => step c1 c2 end.

Lemma well_formed_inf : ∀ c x c' n  Φ Υ,
  well_formed (⟨Φ, x ↦ cl c' n, Υ⟩c) →
  well_formed (⟨Φ, x ↦ cl c' n, Υ⟩c').
  intros. split. inversion H. unfold well_formed_heap in H1. apply forevery_app in H1.
  destruct H1. simpl in H2. destruct H2. auto.
  auto. inversion H. auto. Qed.

Lemma values_only : ∀ c e M Ψ, c ⇓ ⟨Ψ⟩close M e → value M.
intros. induce X.
- invert H0. apply IHX with (e:=e1) (Ψ0:=Ψ). reflexivity.
- invert H0. simpl. constructor.
- invert H0. apply IHX2 with (e:=e0) (Ψ:=Ψ0). reflexivity.
Qed.

(*
Lemma well_formed_inf' : ∀ Φ Ψ x c c' n,
  well_formed (⟨Φ, x ↦ cl c' n, Ψ⟩c) →
  well_formed (⟨Φ, x ↦ cl c n, Ψ⟩c).
intros. split.  inversion H. apply forevery_app in H1. destruct H1. unfold
closed_under. destruct c. unfold closed_under in H0. simpl in H2. destruct H2.
unfold closed_under. rewrite forevery_app.  with (m:=n) (m':=n). assumption.
unfold well_formed_heap. unfold closed_under.  unfold well_formed_heap in H0.
unfold closed_under in H0. rewrite domain_inf with (m:=N) (m':=M). rewrite
forevery_app. rewrite forevery_app in H0. destruct H0. split. crush. crush.
Qed.

TODO
Lemma cactus_lookup_inf : ∀ v x y m n e Φ Υ, cactus_lookup v x (Φ ++ (y ↦ {m, n}) :: Υ) e → ∀ M, cactus_lookup v x (Φ ++ (y ↦ {M, n}) :: Υ) e.
intros.

Lemma inf_well_formed : ∀ c x c' n  Φ Υ, well_formed (⟨Φ, x ↦ cl c' n, Υ⟩c) →
  well_formed (⟨Φ, x ↦ cl c n, Υ⟩c).
  intros. inversion H. split. induction Υ. simpl. destruct c. induction (fvs e).
  simpl. auto. simpl.
  destruct (eq_nat_dec x n0). simpl. unfold domain. rewrite
  map_app. simpl. unfold domain in H0. rewrite map_app in H0. simpl in H0.
  kapply forevery_app in H1. destruct H1. simpl in
  H2. destruct H2. unfold closed_under in H0. clear H1 H2 H3.  (inversion H. apply forevery_app in H1.
  auto. inversion H. auto. Qed.

Theorem well_formed_step : ∀ c v, well_formed c → c ⇓ v → well_formed v.
intros. induction H0. apply well_formed_inf in H. apply IHstep in H.

Example simple : (step (⟨nil⟩ close (:λ0 @ :λ0) 0) (⟨nil, 0 ↦ {close (:λ0) 0,
0}⟩ close (:λ0) 0)).
apply App with 0 nil 0 0.
unfold fresh. simpl.  auto.
apply Abs.
rewrite <- app_nil_l with (prod nat cell) (cons (0↦{close (:λ0) 0, 0}) nil).
apply Id.
apply zero.
apply Abs.
Qed.

*)


Require Import Program.Equality.
Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import Language
               Infra
               SubDis.

(* -------- properties of typing -------- *)
Lemma check_sub : forall G e m A,
  has_type G e m A -> forall B,
  sub A B ->
  has_type G e chk B.
Proof.
  induction 1; intros; eauto.
Qed.

Lemma chk_inf_sub: forall G e A,
  has_type G e chk A -> exists B,
  has_type G e inf B /\ sub B A.
Proof.
  introv Typ. inductions Typ.
  - exists*.
Qed.

Lemma val_chk_inf_sub: forall G e A,
  value e ->
  has_type G e chk A -> exists B,
  has_type G e inf B /\ sub B A.
Proof.
  introv Val Typ. inductions Typ.
  - exists*.
Qed.
(* ---------------- *)

Lemma genv_progress: forall A,
  toplike A -> exists v,
  genv A v.
Proof.
  introv Ht. inductions Ht; eauto.
  - destruct* IHHt1. destruct* IHHt2.
  - destruct* IHHt.
  - destruct* IHHt.
Qed.

Lemma genv_unique: forall A v1,
  genv A v1 -> forall v2,
  genv A v2 ->
  v1 = v2.
Proof.
  introv Hg1. inductions Hg1; introv Hg2; eauto.
  - inverts* Hg2.
  - inverts* Hg2.
    forwards~: IHHg1 H2. subst*.
  - inverts* Hg2.
    forwards~: IHHg1_1 H1. forwards~: IHHg1_2 H3. subst*.
  - inverts* Hg2. forwards~: IHHg1 H2. subst*.
Qed.

Lemma casting_top_normal : forall (v v': exp),
    casting v top v' -> v' = unit.
Proof.
  intros v v' H.
  remember top.
  induction H;
    try solve [inverts* Heqt].
Qed.

Lemma genv_casting_eq: forall A v1,
  toplike A -> forall v2,
  casting v1 A v2 -> forall v3,
  genv A v3 ->
  v2 = v3.
Proof.
  introv TL Red. inductions Red; introv Hg.
  - inverts* Hg.
  - inverts* Hg.
  - eapply IHRed; eauto.
  - eapply IHRed; eauto.
  - inverts* Hg. inverts* TL.
    forwards~: IHRed1 H2 H1. forwards~: IHRed2 H4 H3. subst*.
  - inverts* Hg. inverts* TL.
    forwards~: IHRed H0 H2. subst*.
  - inverts* TL.
  - eapply genv_unique; eauto.
Qed.

Lemma casting_toplike: forall A,
  toplike A -> forall (v1 v2 v1' v2' : exp),
  casting v1 A v1' ->
  casting v2 A v2' ->
  v1' = v2'.
Proof.
  introv TL R1 R2.
  forwards~ (v'&Hg): genv_progress TL.
  forwards~: genv_casting_eq TL R1 Hg.
  forwards~: genv_casting_eq TL R2 Hg.
  subst*.
Qed.

(* principal types for values *)
Fixpoint principal_type (v:exp) : typ :=
  match v with
  | unit => top
  | lit i5 => int
  | box e1 (ann (lam bl e) (arr A B)) => arr A B
  | box e1 (ann (lam wh e) (arr (rcd l A) B)) => arr A B
  | merge v1 v2 => and (principal_type v1) (principal_type v2)
  | rec l v1 => rcd l (principal_type v1)
  | _ => top
  end.

Lemma principal_type_disjoint: forall v,
  value v -> forall G A B,
  has_type G v inf A ->
  disjoint A B ->
  disjoint (principal_type v) B.
Proof.
  introv Val.
  inductions Val; introv Typ Dis; try solve [inverts* Typ].
  - simpl.
    inverts* Typ.
    + eapply dis_and_inv in Dis. destruct* Dis.
      forwards~: IHVal1 H1 H. forwards~: IHVal2 H2 H0.
      eapply dis_to_inter; eauto.
    + eapply dis_and_inv in Dis. destruct* Dis.
      forwards~: IHVal1 H1 H. forwards~: IHVal2 H2 H0.
      eapply dis_to_inter; eauto.
  - simpl.
    inverts* Typ.
    inductions B.
    + unfold disjoint. intros Hc. eapply costs_int_rcd.
      eapply costs_sym. eauto.
    + unfold disjoint. intros Hc. eapply costs_top_rcd.
      eapply costs_sym. eauto.
    + apply dis_sym in Dis.
      apply dis_and_inv in Dis. destruct* Dis.
      eapply dis_sym in H.
      eapply dis_sym in H0.
      forwards~: IHB1 H H1.
      forwards~: IHB2 H0 H1.
      eapply dis_sym in H2.
      eapply dis_sym in H3.
      eapply dis_sym; eauto.
      eapply dis_to_inter; eauto.
    + destruct* (x == n).
      {
        subst*. eapply disjoint_rcd_build.
        eapply IHVal; eauto. eapply disjoint_rcd_inv. eauto.
      }
      {
        unfold disjoint. intros Hc. eapply costs_rcd_rcd_neq. eauto. eauto.
      }
    + unfold disjoint. intros Hc. eapply costs_arr_rcd. eauto.
  - simpl. inverts* Typ. inverts* H3.
    eapply dis_domain_type. eauto.
  - simpl. inverts* Typ. inverts* H3.
    + eapply dis_domain_type. eauto.
    + eapply dis_domain_type. eauto.
Qed.

Lemma principal_types_disjoint: forall v1 A v2 B,
  value v1 -> forall G,
  has_type G v1 inf A ->
  value v2 -> forall F,
  has_type F v2 inf B ->
  disjoint A B ->
  disjoint (principal_type v1) (principal_type v2).
Proof.
  introv Val1 Typ1 Val2 Typ2 Dis.
  forwards* D1: principal_type_disjoint Typ1 Dis.
  apply dis_sym in D1.
  forwards* D2: principal_type_disjoint Typ2 D1.
  apply~ dis_sym.
Qed.

Lemma principal_type_sub: forall v A,
  value v -> forall G,
  has_type G v inf A ->
  sub (principal_type v) A.
Proof.
  intros v A Val G H.
  inductions H; inverts Val; simpl.
  - eauto.
  - eauto.
  - assert (S1: sub (and (principal_type e1) (principal_type e2)) A) by (econstructor; eauto).
    assert (S2: sub (and (principal_type e1) (principal_type e2)) B) by (econstructor; eauto).
    forwards*: sand S1 S2.
  - assert (S1: sub (and (principal_type v1) (principal_type v2)) A) by (econstructor; eauto).
    assert (S2: sub (and (principal_type v1) (principal_type v2)) B) by (econstructor; eauto).
    forwards*: sand S1 S2.
  - inverts H0. inverts H4. inverts H0.
    inverts H8. eauto.
  - inverts H0. inverts H4. inverts H0.
    inverts H8. eauto.
  - eauto.
Qed.

Definition old_dis A B :=
  forall C, sub A C -> sub B C -> toplike C.

Lemma dis_old_spec: forall A B C,
  disjoint A B ->
  sub A C ->
  sub B C ->
  toplike C.
Proof.
  intros A B C. indTypSize (size_typ A + size_typ B + size_typ C).
  lets Sub: H0.
  inverts* H0.
  - eapply dis_sym in H.
    forwards~: dis_super H1 H.
    exfalso. unfold disjoint in H0.
    eapply H0. unfold cost_spec. exists*.
  - forwards~ (C1&C2): and_inversion H1.
    forwards~: IH H H2 C1. elia.
    forwards~: IH H H3 C2. elia.
  - forwards~: IH H2 H1. elia.
    forwards~ (?&?): dis_and_inv H.
  - forwards~: IH H2 H1. elia.
    forwards~ (?&?): dis_and_inv H.
  - inductions B.
    + inverts* H1.
    + inverts* H1.
    + eapply dis_sym in H.
      forwards~ (?&?): dis_and_inv H.
      eapply dis_sym in H0.
      eapply dis_sym in H3.
      inverts H1.

      forwards~: IH H0 Sub H7. elia.
      forwards~: IH H3 Sub H7. elia.
    + inverts* H1.
      forwards~: disjoint_rcd_inv H.
      forwards~: IH H0 H2 H3. elia.
    + inverts* H1.
  - inductions B.
    + inverts* H1.
    + inverts* H1.
    + eapply dis_sym in H.
      forwards~ (?&?): dis_and_inv H.
      eapply dis_sym in H0.
      eapply dis_sym in H4.
      inverts H1.

      forwards~: IH H0 Sub H8. elia.
      forwards~: IH H4 Sub H8. elia.
    + inverts* H1.
    + inverts* H1.
      forwards~: disjoint_arr_inv H.
      forwards~: IH H0 H3 H8. elia.
Qed.

Lemma old_dis_complete: forall A B,
  disjoint A B ->
  old_dis A B.
Proof.
  introv Dis. unfold old_dis. introv S1 S2.
  eapply dis_old_spec; eauto.
Qed.

Lemma gord_not_tl: forall A,
  gord A -> ~ toplike A.
Proof.
  introv H Ht. inductions H; try solve [inverts* Ht].
Qed.

Lemma old_dis_sound: forall A B,
  old_dis A B ->
  disjoint A B.
Proof.
  introv Ho. unfold old_dis in *. unfold disjoint. introv Hc.
  unfold cost_spec in *.
  destruct* Hc. destruct* H. destruct* H0.
  forwards~: Ho H0 H1.
  eapply gord_not_tl; eauto.
Qed.

Lemma sub_casting: forall v v' A,
  value v ->
  casting v A v' ->
  sub (principal_type v) A.
Proof.
  introv Val Red.
  inductions Red.
  - simpl. eauto.
  - simpl. eauto.
  - simpl. inverts* Val.
  - simpl. inverts* Val.
  - simpl. eauto.
  - simpl. inverts* Val.
  - inverts H1.
    + simpl. eauto.
    + simpl. eauto.
  - inverts H1.
    + simpl. eauto.
    + simpl. eauto.
Qed.

Lemma disjoint_val_consistent: forall A B v1 v2 G F,
  disjoint A B ->
  value v1 ->
  value v2 ->
  has_type G v1 inf A ->
  has_type F v2 inf B ->
  consistencySpec v1 v2.
Proof.
  intros A B v1 v2 G F Dis Val1 Val2 Typ1 Typ2.
  unfold consistencySpec.
  introv Red1 Red2.
  forwards* Sub1': sub_casting Red1.
  forwards* Sub2': sub_casting Red2.
  forwards* Dis': principal_types_disjoint Typ1 Typ2.
  assert (Top: toplike A0). {
    eapply dis_old_spec; eauto.
  }
  forwards*: casting_toplike Top Red1 Red2.
Qed.

Lemma value_closed : forall G e m A,
  has_type G e m A ->
  value e -> forall F,
  has_type F e m A.
Proof.
  induction 1; intros Val K; eauto; try solve [inverts* Val].
  - (* merge *)
    inverts* Val. eapply tcon; try eassumption.
    eapply IHhas_type1; eassumption.
    eapply IHhas_type2; eassumption.
    eapply disjoint_val_consistent.
    eapply H1. eauto. eauto. eauto. eauto.
Qed.

Lemma casting_unique_aux: forall (v v1 v2 : exp) (A: typ),
  value v ->
  (exists G B, has_type G v inf B) ->
  casting v A v1 ->
  casting v A v2 ->
  v1 = v2.
Proof.
  intros v v1 v2 A Val H R1 R2.
  gen v2.
  lets R1': R1.
  induction R1; introv R2.
  - forwards~: casting_toplike R1' R2.
  - inverts* R2.
  - (* mergel *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2.
    + forwards~: casting_toplike R1' R2'.
    + inverts* H'. inverts* H1.
    + inverts* H'. inverts* H1.
      forwards~ Cons: disjoint_val_consistent H11 H3 H4 H7 H9.
      unfold consistencySpec in Cons.
      eapply Cons; try eassumption.
    + inverts* H0.
  - (* merger *)
    lets [B H']: H.
    lets R2': R2.
    inverts Val.
    inverts* R2.
    + forwards~: casting_toplike R1' R2'.
    + inverts* H'. inverts* H1.
      * forwards~: disjoint_val_consistent H11 H3 H4 H7 H9.
      unfold consistencySpec in H1.
        forwards~: H1 H5 R1.
      * unfold consistencySpec in H13.
        forwards~: H13 H5 R1.
    + inverts* H'. inverts* H1.
    + inverts* H0.
  - (* and *)
    inverts~ R2.
    + inverts* H1.
    + inverts* H1.
    + forwards*: IHR1_1.
      forwards*: IHR1_2.
      congruence.
  - (* rcd *)
    inverts* R2.
    + inverts* Val. destruct* H. destruct* H. inverts* H. forwards*: IHR1. subst*.
  - inverts* R2.
  - inverts H2.
    + forwards~: genv_casting_eq R2 H5.
    + forwards~: genv_casting_eq R2 H5.
Qed.

Lemma casting_unique: forall (v v1 v2 : exp) (G A B: typ),
  value v ->
  has_type G v inf B ->
  casting v A v1 ->
  casting v A v2 ->
  v1 = v2.
Proof.
  introv Val H R1 R2.
  eapply casting_unique_aux; eauto.
Qed.

Lemma gen_step_unique: forall e m A G,
  has_type G e m A -> forall v e1 e2,
  has_type top v inf G ->
  step v e e1 ->
  step v e e2 ->
  e1 = e2.
Proof.
  intros e m A G H.
  induction H; introv Typv Red1 Red2.
  - inverts* Red1.
  - inverts* Red1.
  - inverts* Red1. inverts* Red2.
  - inverts Red1; inverts Red2.
    + assert (e' = e'0). {
      eapply IHhas_type2; try eapply H7; try eapply H6.
      econstructor; try eassumption; try eauto.
      eapply value_closed; try eassumption.
      unfold disjoint. eapply costs_top_any.
    }
    subst*.
    + exfalso. forwards~: step_not_value H9.
    + exfalso. forwards~: step_not_value H7.
    + forwards~: IHhas_type1 Typv H7 H8. subst*.
  - exfalso. forwards~: step_not_value Red1.
  - inverts Red1; inverts Red2; try solve [inverts H; inverts H0]; try solve [inverts H6]; try solve [inverts H8].
    + forwards~(B&TypI&?): val_chk_inf_sub H.
      forwards~: casting_unique TypI H4 H7.
    + exfalso. forwards~: step_not_value H7.
    + exfalso. forwards~: step_not_value H4.
    + forwards~: IHhas_type Typv H5 H4. subst*.
  - inverts Red1; inverts Red2.
    + inverts* H12.
    + inverts* H9.
    + inverts* H9.
    + inverts* H10.
    + inverts* H7.
    + inverts* H7.
    + inverts* H10.
    + inverts* H7.
    + eauto.
  - inverts Red1; inverts Red2.
    + inverts H3.
      * inverts H. inverts H9. inverts H11. inverts H.
        inverts H14. inverts H10. inverts H20.
        forwards~(D&TypI&?): val_chk_inf_sub H0.
        forwards~: casting_unique TypI H4 H16.
        subst*.
      * inverts H. inverts H9. inverts H11. inverts H.
        inverts H14. inverts H10. inverts H20.
        forwards~(D&TypI&?): val_chk_inf_sub H0.
        forwards~: casting_unique TypI H4 H16.
        subst*.
    + inverts H3; exfalso; forwards~: step_not_value H11.
    + exfalso. forwards~: step_not_value H9.
    + inverts H3; exfalso; forwards~: step_not_value H5.
    + forwards~: IHhas_type1 Typv H5 H6. subst*.
    + exfalso. forwards~: step_not_value H5.
    + exfalso. forwards~: step_not_value H4.
    + exfalso. forwards~: step_not_value H7.
    + forwards~: IHhas_type2 Typv H4 H5. subst*.
  - inverts Red1; inverts Red2.
    + eauto.
    + exfalso. forwards~: step_not_value H4.
    + exfalso. forwards~: step_not_value H6.
    + exfalso. forwards~: step_not_value H3.
    + forwards~: step_env H3.
      forwards~: value_closed H top.
      forwards~: IHhas_type2 H3 H4. subst*.
    + forwards~: step_env H3.
      exfalso. forwards~: step_not_value H6.
    + exfalso. forwards~: step_not_value H4.
    + forwards~: step_env H3.
      exfalso. forwards~: step_not_value H4.
    + forwards~: IHhas_type1 H4 H5. subst*.
  - inverts* Red1; inverts* Red2.
  - inverts Red1; inverts Red2.
    forwards~: IHhas_type Typv H4 H5. subst*.
  - inverts Red1; inverts Red2.
    + eauto.
    + exfalso. forwards~: step_not_value H6.
    + exfalso. forwards~: step_not_value H4.
    + forwards~: IHhas_type Typv H4 H5. subst*.
Qed.

Theorem step_unique: forall e m A,
  has_type top e m A -> forall e1 e2,
  step unit e e1 ->
  step unit e e2 ->
  e1 = e2.
Proof.
  introv Typ H1 H2.
  forwards~: gen_step_unique Typ H1 H2.
Qed.


(** * General setting for behavioural equivalences *)

Require Export Functions.
Require Export Reductions.
Set Implicit Arguments.

Section Global.

  Variable A: Type.

  Section Sim.

    Variables X Y: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.

    (** More or less generic evolution predicates (Definitions 1.2)  *)
    Definition evolve_1 l R S := diagram (TX l) R (Weak TY l) S.
    Definition evolve_t   R S := evolve_1 (T A) R S.
    Definition evolve_a   R S := forall a, evolve_1 (L a) R S .
    Definition evolve     R S := forall l, evolve_1 l R S.

    (** (Silent) simulation, expansion (Definitions 1.3) *)
    Definition simulation_t R := evolve_t R R.
    Definition simulation   R := evolve   R R.

    (** (Relaxed) expansion  (on one side only) *)
    Definition expansion1   R := diagram_r TX R (EWeak TY) R.
    Definition wexpansion1  R := diagram_r TX R (REWeak TY) R.

    Variable F: function X Y.

    (** Monotonicity: Definition 1.5 *)
    Record monotonic: Prop := mkmon {
      mon_m:> increasing F;
      mon_t:  forall R S, evolve_t R S -> incl R S -> evolve_t (F R) (F S);
      mon_a:  forall R S, evolve   R S -> incl R S -> evolve_a (F R) (F S)
    }.
    (** Weak monotonicity: Definition 2.1 *)
    Record wmonotonic: Prop := mkwmon {
      wmon_m:> increasing F;
      wmon_t:  forall R, simulation_t R -> simulation_t (F R);
      wmon_a:  forall R S, simulation_t R -> simulation_t S -> evolve_a R S -> incl R S -> evolve_a (F R) (F S)
    }.

    (** Controlled relations: Definition 3.1 *)
    Variable B: relation X.
    Record controlled: Prop := mkctrl {
      ctrl_t:  forall R, evolve_t R (comp (star B) R) -> simulation_t (comp (star B) R);
      ctrl_a:  forall R S, evolve_t R (comp (star B) R) -> simulation_t S ->
	                  evolve_a R S -> incl R S -> evolve_a (comp (star B) R) (comp (star B) S)
    }.
    (** Lemma 1.4 (1) *)
    Lemma weak_strong_t: forall R, simulation_t R -> diagram (Weak TX (T A)) R (Weak TY (T A)) R.
    Proof.
      intros R HR; simpl; apply diagram_reverse; apply diagram_star; apply diagram_reverse; exact HR.
    Qed.
    Lemma weak_strong: forall R, simulation R -> diagram_r (Weak TX) R (Weak TY) R.
    Proof.
      intros R HR; generalize (weak_strong_t (HR (T A)));
	intros Ht l; destruct l as [ | a ]; auto.
      intros x x' y Hxx' xRy; destruct Hxx' as [ x1 Hxx1 Hx1x' ]; destruct Hx1x' as [ x2 Hx1x2 Hx2x' ].
      destruct (Ht _ _ _ Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
      destruct (HR _ _ _ _ Hx1x2 x1Ry1) as [ y2 Hy1y2 x2Ry2 ].
      destruct (Ht _ _ _ Hx2x' x2Ry2) as [ y' Hy2y' x'Ry' ].
      exists y'; auto.
      apply taus_weak with y1; auto.
      apply weak_taus with y2; auto.
    Qed.

    (** Lemma 1.4 (2) (splitted into several practical results) *)
    Lemma union2_evolve: forall l R R' S, evolve_1 l R S -> evolve_1 l R' S -> evolve_1 l (union2 R R') S.
    Proof.
      intros l R R' S HR HR' x x' y Hxx' xRy; destruct xRy as [ xRy | xRy ].
      destruct (HR _ _ _ Hxx' xRy) as [ y' ]; exists y'; auto.
      destruct (HR' _ _ _ Hxx' xRy) as [ y' ]; exists y'; auto.
    Qed.
    Lemma union2_evolve_left: forall l R S S', evolve_1 l R S -> evolve_1 l R (union2 S S').
    Proof.
      intros l R S S' H x x' y Hxx' xRy; destruct (H _ _ _ Hxx' xRy) as [ y' ];
	exists y'; auto; left; auto.
    Qed.
    Lemma union2_evolve_right: forall l R S S', evolve_1 l R S' -> evolve_1 l R (union2 S S').
    Proof.
      intros l R S S' H x x' y Hxx' xRy; destruct (H _ _ _ Hxx' xRy) as [ y' ];
	exists y'; auto; right; auto.
    Qed.
    Lemma union_evolve: forall l I R S,
      (forall i:I, evolve_1 l (R i) S) -> evolve_1 l (union R) S.
    Proof.
      intros l I R S H x x' y Hxx' xRy; destruct xRy as [ i xRy ].
      destruct (H i _ _ _ Hxx' xRy) as [ y' ]; exists y'; auto.
    Qed.
    Lemma evolve_union: forall l J R S,
      (exists j:J, evolve_1 l R (S j)) -> evolve_1 l R (union S).
    Proof.
      intros l J R S H x x' y Hxx' xRy.
      destruct H as [ j Hj ]; destruct (Hj _ _ _ Hxx' xRy) as [ y' ].
      exists y'; auto; exists j; auto.
    Qed.

    (** Evolutions behave like functional arrows (contra/co-variance) *)
    Lemma incl_evolve: forall l R R' S, incl R R' -> evolve_1 l R' S -> evolve_1 l R S.
    Proof.
      intros l R R' S HRR' HR'S x x' y Hxx' xRy.
      destruct (HR'S _ _ _ Hxx' (HRR' _ _ xRy)) as [ y' ]; exists y'; auto.
    Qed.
    Lemma evolve_incl: forall l S R S', incl S S' -> evolve_1 l R S -> evolve_1 l R S'.
    Proof.
      intros l S R S' HSS' HRS x x' y Hxx' xRy.
      destruct (HRS _ _ _ Hxx' xRy) as [ y' ]; exists y'; auto.
    Qed.

    (** (Silent) simulations are insensitive to extensional equality *)
    Lemma simulation_eeq: forall R S, eeq R S -> simulation R -> simulation S.
    Proof.
      intros R S HRS H l.
      apply evolve_incl with R.
      apply (proj1 HRS).
      apply incl_evolve with R.
      apply (proj2 HRS).
      apply H.
    Qed.
    Lemma simulation_t_eeq: forall R S, eeq R S -> simulation_t R -> simulation_t S.
    Proof.
      intros R S HRS H; unfold simulation_t, evolve_t.
      apply evolve_incl with R.
      apply (proj1 HRS).
      apply incl_evolve with R.
      apply (proj2 HRS).
      apply H.
    Qed.

  End Sim.

  Section Bi.

    Variables X Y: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.

    (** Quantifications on both sides of a relation *)
    Definition bisimulation R := simulation  TX TY R /\ simulation TY TX (trans R).
    Definition expansion    R := expansion1  TX TY R /\ simulation TY TX (trans R).
    Definition wexpansion   R := wexpansion1 TX TY R /\ simulation TY TX (trans R).

    (** Definition of the co-inductive relations as `greatest relations such that' *)
    Definition bisim   := union_st bisimulation.
    Definition expand  := union_st expansion.
    Definition wexpand := union_st wexpansion.

    (** Validity of previous definitions *)
    Lemma bisimulation_bisim: bisimulation bisim.
    Proof.
      split; intros l x x' y Hxx' xRy; destruct xRy as [ R HR xRy ];
      [ destruct (proj1 HR _ _ _ _ Hxx' xRy) as [ y' ]
      | destruct (proj2 HR _ _ _ _ Hxx' xRy) as [ y' ] ];
      exists y'; auto; exists R; auto.
    Qed.
    Lemma expansion_expand: expansion expand.
    Proof.
      split; intros l x x' y Hxx' xRy; destruct xRy as [ R HR xRy ];
      [ destruct (proj1 HR _ _ _ _ Hxx' xRy) as [ y' ]
      | destruct (proj2 HR _ _ _ _ Hxx' xRy) as [ y' ] ];
      exists y'; auto; exists R; auto.
    Qed.
    Lemma wexpansion_wexpand: wexpansion wexpand.
    Proof.
      split; intros l x x' y Hxx' xRy; destruct xRy as [ R HR xRy ];
      [ destruct (proj1 HR _ _ _ _ Hxx' xRy) as [ y' ]
      | destruct (proj2 HR _ _ _ _ Hxx' xRy) as [ y' ] ];
      exists y'; auto; exists R; auto.
    Qed.

    (** Inclusions *)
    Lemma expand_wexpand: incl expand wexpand.
    Proof.
      intros P Q H; destruct H as [ R H H' ]; exists R; auto; split.
      intros l x x' y Hxx' xRy; destruct (proj1 H _ _ _ _ Hxx' xRy) as [ y' Hyy' x'Ry' ]; exists y'; auto.
      destruct l; simpl in Hyy'; intuition; exists y'; auto.
      exact (proj2 H).
    Qed.
    Lemma wexpand_bisim: incl wexpand bisim.
    Proof.
      intros P Q H; destruct H as [ R H H' ]; exists R; auto; split.
      intros l x x' y Hxx' xRy; destruct (proj1 H _ _ _ _ Hxx' xRy) as [ y' Hyy' x'Ry' ]; exists y'; auto.
      destruct l; simpl in Hyy'.
      celim Hyy'; intro Hyy'; try destruct Hyy'; auto.
      exists y; auto.
      exact (proj2 H).
    Qed.

  End Bi.

  (** * Composition of simulation, expansion1, wexpansion1 relations *)
  Section Composition.

    Variables X Y Z: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.
    Variable TZ: reduction_t A Z.

    Variable R: relation2 X Y.
    Variable S: relation2 Y Z.

    Lemma simulation_comp: simulation TX TY R -> simulation TY TZ S -> simulation TX TZ (comp R S).
    Proof.
      intros HR HS l x x' y Hxx' xRy; destruct xRy as [ t xRt tRy ].
      destruct (HR _ _ _ _ Hxx' xRt) as [ t' Htt' x'Rt' ].
      destruct (weak_strong HS _ _ _ _ Htt' tRy) as [ y' Hyy' t'Ry' ].
      exists y'; auto; exists t'; auto.
    Qed.

    Lemma expansion1_comp: expansion1 TX TY R -> expansion1 TY TZ S -> expansion1 TX TZ (comp R S).
    Proof.
      intros HR HS l x x' y Hxx' xRy; destruct xRy as [ t xRt tRy ].
      destruct (HR _ _ _ _ Hxx' xRt) as [ t' Htt' x'Rt' ]; destruct l.
      celim Htt'; intro Htt'.
      destruct Htt'; exists y; [ left | exists t ]; auto.
      destruct (HS _ _ _ _ Htt' tRy) as [ y' Hyy' t'Ry' ];
	exists y'; auto; exists t'; auto.
      destruct (HS _ _ _ _ Htt' tRy) as [ y' Hyy' t'Ry' ];
	exists y'; auto; exists t'; auto.
    Qed.

    Let wexpansion1_t: wexpansion1 TY TZ S ->
      forall x x' y, star (TY (T _)) x x' -> S x y -> exists2 y', star (TZ (T _)) y y' & S x' y'.
    Proof.
      intros H x x' y Hxx'; cgen y; induction Hxx' as [ x | x1 x x' Hxx1 Hx1x' IH ]; intros y xRy.
      exists y; auto.
      destruct (H _ _ _ _ Hxx1 xRy) as [ y1 Hyy1 x1Ry1 ].
      destruct (IH _ x1Ry1) as [ y' Hy1y' x'Ry' ].
      exists y'; auto.
      celim Hyy1; intro Hyy1.
      destruct Hyy1; auto.
      apply S_star with y1; auto.
    Qed.

    Lemma wexpansion1_comp: wexpansion1 TX TY R -> wexpansion1 TY TZ S -> wexpansion1 TX TZ (comp R S).
    Proof.
      intros HR HS l x x' y Hxx' xRy; destruct xRy as [ t xRt tRy ].
      destruct (HR _ _ _ _ Hxx' xRt) as [ t' Htt' x'Rt' ]; destruct l.
      celim Htt'; intro Htt'.
      destruct Htt'; exists y; [ left | exists t ]; auto.
      destruct (HS _ _ _ _ Htt' tRy) as [ y' Hyy' t'Ry' ];
	exists y'; auto; exists t'; auto.
      destruct Htt' as [ t1 Htt1 Ht1t' ].
      destruct (HS _ _ _ _ Htt1 tRy) as [ y1 Hyy1 t1Ry1 ].
      destruct (wexpansion1_t HS Ht1t' t1Ry1) as [ y' Hy1y' t'Ry' ].
      exists y'.
      destruct Hyy1 as [ y2 ]; exists y2; auto; apply star_trans with y1; auto.
      exists t'; auto.
    Qed.

  End Composition.

  (** * Composition of bisimulation, expansion, wexpansion relations *)
  Section BiComposition.

    Variables X Y Z: Type.
    Variable TX: reduction_t A X.
    Variable TY: reduction_t A Y.
    Variable TZ: reduction_t A Z.

    Variable R: relation2 X Y.
    Variable S: relation2 Y Z.

    Lemma bisimulation_comp: bisimulation TX TY R -> bisimulation TY TZ S -> bisimulation TX TZ (comp R S).
    Proof.
      unfold bisimulation; intros HR HS; split.
      apply simulation_comp with TY; intuition.
      eapply simulation_eeq; try (apply eeq_sym; apply inv_comp).
      apply simulation_comp with TY; intuition.
    Qed.

    Lemma expansion_comp: expansion TX TY R -> expansion TY TZ S -> expansion TX TZ (comp R S).
    Proof.
      unfold expansion; intros HR HS; split.
      apply expansion1_comp with TY; intuition.
      eapply simulation_eeq; try (apply eeq_sym; apply inv_comp).
      apply simulation_comp with TY; intuition.
    Qed.

    Lemma wexpansion_comp: wexpansion TX TY R -> wexpansion TY TZ S -> wexpansion TX TZ (comp R S).
    Proof.
      unfold wexpansion; intros HR HS; split.
      apply wexpansion1_comp with TY; intuition.
      eapply simulation_eeq; try (apply eeq_sym; apply inv_comp).
      apply simulation_comp with TY; intuition.
    Qed.

  End BiComposition.

  (** * Bisimilarity is an equivalence relation, Expansion and Weak expansion are preorders *)
  Section Properties.

    Variable X: Type.
    Variable TX: reduction_t A X.

    (** Symmetry of Bisimilarity *)
    Lemma bisim_sym: symmetric (bisim TX TX).
    Proof.
      intros x y H; destruct H as [ R HR H ].
      exists (trans R); auto.
      celim HR; intro HR; split; auto.
    Qed.

    (** Reflexivity of Bisimilarity *)
    Lemma bisim_refl: reflexive (bisim TX TX).
    Proof.
      intro u; exists (eq (A:=X)); auto.
      split; intros l x x' y Hxx' xRy; exists x'; destruct xRy; auto.
    Qed.

    (** Transitivity of Bisimilarity *)
    Lemma bisim_trans: transitive (bisim TX TX).
    Proof.
      intros y x z XY YZ.
      destruct XY as [ R HR XY ].
      destruct YZ as [ S HS YZ ].
      exists (comp R S).
      apply bisimulation_comp with TX; auto.
      exists y; auto.
    Qed.

    (** Definition of Controlled Bisimulations *)
    Definition bicontrolled R := controlled TX TX R /\ incl R (bisim TX TX).

    (** Reflexivity of Expansion *)
    Lemma expand_refl: reflexive (expand TX TX).
    Proof.
      intro u; exists (eq (A:=X)); auto.
      split; intros l x x' y Hxx' xRy; exists x'; destruct xRy; auto.
      destruct l; auto; right; auto.
    Qed.

    (** Transitivity of Expansion *)
    Lemma expand_trans: transitive (expand TX TX).
    Proof.
      intros y x z XY YZ.
      destruct XY as [ R HR XY ].
      destruct YZ as [ S HS YZ ].
      exists (comp R S).
      apply expansion_comp with TX; auto.
      exists y; auto.
    Qed.

    (** Reflexivity of Weak Expansion *)
    Lemma wexpand_refl: reflexive (wexpand TX TX).
    Proof.
      intro u; exists (eq (A:=X)); auto.
      split; intros l x x' y Hxx' xRy; exists x'; destruct xRy; auto.
      destruct l; [ right | exists x' ]; auto.
    Qed.

    (** Transitivity of Weak Expansion *)
    Lemma wexpand_trans: transitive (wexpand TX TX).
    Proof.
      intros y x z XY YZ.
      destruct XY as [ R HR XY ].
      destruct YZ as [ S HS YZ ].
      exists (comp R S).
      apply wexpansion_comp with TX; auto.
      exists y; auto.
    Qed.

  End Properties.

End Global.

Ltac union_evolve n := unfold UIter, simulation_t, evolve_t; apply union_evolve; intro n; apply evolve_union.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Representation of interference graphs for register allocation. *)

Require Import Coqlib.
Require Import FSets.
Require Import FSetAVL.
Require Import Maps.
Require Import Ordered.
Require Import Registers.
Require Import Locations.

(** Interference graphs are undirected graphs with two kinds of nodes:
- RTL pseudo-registers;
- Machine registers.

and four kind of edges:
- Conflict edges between two pseudo-registers.
  (Meaning: these two pseudo-registers must not be assigned the same
   location.)
- Conflict edges between a pseudo-register and a machine register
  (Meaning: this pseudo-register must not be assigned this machine
   register.)
- Preference edges between two pseudo-registers.
  (Meaning: the generated code would be more efficient if those two
   pseudo-registers were assigned the same location, but if this is not
   possible, the generated code will still be correct.)
- Preference edges between a pseudo-register and a machine register
  (Meaning: the generated code would be more efficient if this
   pseudo-register was assigned this machine register, but if this is not
   possible, the generated code will still be correct.)

A graph is represented by four finite sets of edges (one of each kind
above).  An edge is represented by a pair of two pseudo-registers or
a pair (pseudo-register, machine register).
In the case of two pseudo-registers ([r1], [r2]), we adopt the convention
that [r1] <= [r2], so as to reflect the undirected nature of the edge.
*)

Module OrderedReg <: OrderedType with Definition t := reg := OrderedPositive.
Module OrderedRegReg := OrderedPair(OrderedReg)(OrderedReg).
Module OrderedMreg := OrderedIndexed(IndexedMreg).
Module OrderedRegMreg := OrderedPair(OrderedReg)(OrderedMreg).

Module SetRegReg := FSetAVL.Make(OrderedRegReg).
Module SetRegMreg := FSetAVL.Make(OrderedRegMreg).

Record graph: Type := mkgraph {
  interf_reg_reg: SetRegReg.t;
  interf_reg_mreg: SetRegMreg.t;
  pref_reg_reg: SetRegReg.t;
  pref_reg_mreg: SetRegMreg.t
}.

Definition empty_graph :=
  mkgraph SetRegReg.empty SetRegMreg.empty
          SetRegReg.empty SetRegMreg.empty.

(** The following functions add a new edge (if not already present)
  to the given graph. *)

Definition ordered_pair (x y: reg) :=
  if plt x y then (x, y) else (y, x).

Definition add_interf (x y: reg) (g: graph) :=
  mkgraph (SetRegReg.add (ordered_pair x y) g.(interf_reg_reg))
          g.(interf_reg_mreg)
          g.(pref_reg_reg)
          g.(pref_reg_mreg).

Definition add_interf_mreg  (x: reg) (y: mreg) (g: graph) :=
  mkgraph g.(interf_reg_reg)
          (SetRegMreg.add (x, y) g.(interf_reg_mreg))
          g.(pref_reg_reg)
          g.(pref_reg_mreg).

Definition add_pref (x y: reg) (g: graph) :=
  mkgraph g.(interf_reg_reg)
          g.(interf_reg_mreg)
          (SetRegReg.add (ordered_pair x y) g.(pref_reg_reg))
          g.(pref_reg_mreg).

Definition add_pref_mreg  (x: reg) (y: mreg) (g: graph) :=
  mkgraph g.(interf_reg_reg)
          g.(interf_reg_mreg)
          g.(pref_reg_reg)
          (SetRegMreg.add (x, y) g.(pref_reg_mreg)).

(** [interfere x y g] holds iff there is a conflict edge in [g]
  between the two pseudo-registers [x] and [y]. *)

Definition interfere (x y: reg) (g: graph) : Prop :=
  SetRegReg.In (ordered_pair x y) g.(interf_reg_reg).

(** [interfere_mreg x y g] holds iff there is a conflict edge in [g]
  between the pseudo-register [x] and the machine register [y]. *)

Definition interfere_mreg (x: reg) (y: mreg) (g: graph) : Prop :=
  SetRegMreg.In (x, y) g.(interf_reg_mreg).

Lemma ordered_pair_charact:
  forall x y,
  ordered_pair x y = (x, y) \/ ordered_pair x y = (y, x).
Proof.
  unfold ordered_pair; intros.
  case (plt x y); intro; tauto.
Qed.

Lemma ordered_pair_sym:
  forall x y, ordered_pair y x = ordered_pair x y.
Proof.
  unfold ordered_pair; intros.
  case (plt x y); intro.
  case (plt y x); intro.
  unfold Plt in *; omegaContradiction.
  auto.
  case (plt y x); intro.
  auto.
  assert (Zpos x = Zpos y).  unfold Plt in *. omega.
  congruence.
Qed.

Lemma interfere_sym:
  forall x y g, interfere x y g -> interfere y x g.
Proof.
  unfold interfere; intros.
  rewrite ordered_pair_sym. auto.
Qed.

(** [graph_incl g1 g2] holds if [g2] contains all the conflict edges of [g1]
  and possibly more. *)

Definition graph_incl (g1 g2: graph) : Prop :=
  (forall x y, interfere x y g1 -> interfere x y g2) /\
  (forall x y, interfere_mreg x y g1 -> interfere_mreg x y g2).

Lemma graph_incl_trans:
  forall g1 g2 g3, graph_incl g1 g2 -> graph_incl g2 g3 -> graph_incl g1 g3.
Proof.
  unfold graph_incl; intros.
  elim H0; elim H; intros.
  split; eauto.
Qed.

(** We show that the [add_] functions correctly record the desired
  conflicts, and preserve whatever conflict edges were already present. *)

Lemma add_interf_correct:
  forall x y g,
  interfere x y (add_interf x y g).
Proof.
  intros. unfold interfere, add_interf; simpl.
  apply SetRegReg.add_1. auto.
Qed.

Lemma add_interf_incl:
  forall a b g,  graph_incl g (add_interf a b g).
Proof.
  intros. split; intros.
  unfold add_interf, interfere; simpl.
  apply SetRegReg.add_2. exact H.
  exact H.
Qed.

Lemma add_interf_mreg_correct:
  forall x y g,
  interfere_mreg x y (add_interf_mreg x y g).
Proof.
  intros. unfold interfere_mreg, add_interf_mreg; simpl.
  apply SetRegMreg.add_1. auto.
Qed.

Lemma add_interf_mreg_incl:
  forall a b g,  graph_incl g (add_interf_mreg a b g).
Proof.
  intros. split; intros.
  exact H.
  unfold add_interf_mreg, interfere_mreg; simpl.
  apply SetRegMreg.add_2. exact H.
Qed.

Lemma add_pref_incl:
  forall a b g,  graph_incl g (add_pref a b g).
Proof.
  intros. split; intros.
  exact H.
  exact H.
Qed.

Lemma add_pref_mreg_incl:
  forall a b g,  graph_incl g (add_pref_mreg a b g).
Proof.
  intros. split; intros.
  exact H.
  exact H.
Qed.

(** [all_interf_regs g] returns the set of pseudo-registers that
  are nodes of [g]. *)

Definition add_intf2 (r1r2: reg * reg) (u: Regset.t) : Regset.t :=
  Regset.add (fst r1r2) (Regset.add (snd r1r2) u).
Definition add_intf1 (r1m2: reg * mreg) (u: Regset.t) : Regset.t :=
  Regset.add (fst r1m2) u.

Definition all_interf_regs (g: graph) : Regset.t :=
  let s1 := SetRegMreg.fold add_intf1 g.(interf_reg_mreg) Regset.empty in
  let s2 := SetRegMreg.fold add_intf1 g.(pref_reg_mreg) s1 in
  let s3 := SetRegReg.fold add_intf2 g.(interf_reg_reg) s2 in
  SetRegReg.fold add_intf2 g.(pref_reg_reg) s3.

Lemma in_setregreg_fold:
  forall g r1 r2 u,
  SetRegReg.In (r1, r2) g \/ Regset.In r1 u /\ Regset.In r2 u ->
  Regset.In r1 (SetRegReg.fold add_intf2 g u) /\
  Regset.In r2 (SetRegReg.fold add_intf2 g u).
Proof.
  set (add_intf2' := fun u r1r2 => add_intf2 r1r2 u).
  assert (forall l r1 r2 u,
    InA OrderedRegReg.eq (r1,r2) l \/ Regset.In r1 u /\ Regset.In r2 u ->
    Regset.In r1 (List.fold_left add_intf2' l u) /\
    Regset.In r2 (List.fold_left add_intf2' l u)).
  induction l; intros; simpl.
  elim H; intro. inversion H0. auto.
  apply IHl. destruct a as [a1 a2].
  elim H; intro. inversion H0; subst.
  red in H2. simpl in H2. destruct H2. subst r1 r2.
  right; unfold add_intf2', add_intf2; simpl; split.
  apply Regset.add_1. auto.
  apply Regset.add_2. apply Regset.add_1. auto.
  tauto.
  right; unfold add_intf2', add_intf2; simpl; split;
  apply Regset.add_2; apply Regset.add_2; tauto.

  intros. rewrite SetRegReg.fold_1. apply H.
  intuition.
Qed.

Lemma in_setregreg_fold':
  forall g r u,
  Regset.In r u ->
  Regset.In r (SetRegReg.fold add_intf2 g u).
Proof.
  intros. exploit in_setregreg_fold. eauto.
  intros [A B]. eauto.
Qed.

Lemma in_setregmreg_fold:
  forall g r1 mr2 u,
  SetRegMreg.In (r1, mr2) g \/ Regset.In r1 u ->
  Regset.In r1 (SetRegMreg.fold add_intf1 g u).
Proof.
  set (add_intf1' := fun u r1mr2 => add_intf1 r1mr2 u).
  assert (forall l r1 mr2 u,
    InA OrderedRegMreg.eq (r1,mr2) l \/ Regset.In r1 u ->
    Regset.In r1 (List.fold_left add_intf1' l u)).
  induction l; intros; simpl.
  elim H; intro. inversion H0. auto.
  apply IHl with mr2. destruct a as [a1 a2].
  elim H; intro. inversion H0; subst.
  red in H2. simpl in H2. destruct H2. subst r1 mr2.
  right; unfold add_intf1', add_intf1; simpl.
  apply Regset.add_1; auto.
  tauto.
  right; unfold add_intf1', add_intf1; simpl.
  apply Regset.add_2; auto.

  intros. rewrite SetRegMreg.fold_1. apply H with mr2.
  intuition.
Qed.

Lemma all_interf_regs_correct_1:
  forall r1 r2 g,
  SetRegReg.In (r1, r2) g.(interf_reg_reg) ->
  Regset.In r1 (all_interf_regs g) /\
  Regset.In r2 (all_interf_regs g).
Proof.
  intros. unfold all_interf_regs.
  apply in_setregreg_fold. right.
  apply in_setregreg_fold. tauto.
Qed.

Lemma all_interf_regs_correct_2:
  forall r1 mr2 g,
  SetRegMreg.In (r1, mr2) g.(interf_reg_mreg) ->
  Regset.In r1 (all_interf_regs g).
Proof.
  intros. unfold all_interf_regs.
  apply in_setregreg_fold'. apply in_setregreg_fold'.
  apply in_setregmreg_fold with mr2. right.
  apply in_setregmreg_fold with mr2. eauto.
Qed.


(** proofs that the statements of the axioms are propositions *)

Require Import UniMath.Foundations.PartD.

Lemma isaprop_univalenceStatement : isaprop univalenceStatement.
Proof.
  unfold univalenceStatement.
  apply impred_isaprop; intro X;
  apply impred_isaprop; intro Y.
  apply isapropisweq.
Defined.

Lemma isaprop_funextemptyStatement : isaprop funextemptyStatement.
Proof.
  unfold funextemptyStatement.
  apply impred_isaprop; intro X;
  apply impred_isaprop; intro f;
  apply impred_isaprop; intro g.
  generalize g; clear g.
  generalize f; clear f.
  change (isaset (X → ∅)).
  apply impred_isaset; intro x.
  apply isasetempty.
Defined.

Lemma isaprop_isweqtoforallpathsStatement : isaprop isweqtoforallpathsStatement.
Proof.
  unfold isweqtoforallpathsStatement.
  apply impred_isaprop; intro T;
  apply impred_isaprop; intro P;
  apply impred_isaprop; intro f;
  apply impred_isaprop; intro g.
  apply isapropisweq.
Defined.

Lemma isaprop_propositionalUnivalenceStatement : isaprop propositionalUnivalenceStatement.
Proof.
  unfold propositionalUnivalenceStatement.
  apply impred_isaprop; intro P;
  apply impred_isaprop; intro Q;
  apply impred_isaprop; intro i;
  apply impred_isaprop; intro j;
  apply impred_isaprop; intros _;
  apply impred_isaprop; intros _.
  apply (isofhlevelweqb 1 (univalence P Q)).
  fold isaprop.
  apply isapropweqtoprop.
  exact j.
Defined.

Lemma isaprop_funcontrStatement : isaprop funcontrStatement.
Proof.
  unfold funcontrStatement.
  apply impred_isaprop; intro X;
  apply impred_isaprop; intro P;
  apply impred_isaprop; intros _.
  apply isapropiscontr.
Defined.

Lemma isaprop_funextcontrStatement : isaprop funextcontrStatement.
Proof.
  unfold funextcontrStatement.
  apply impred_isaprop; intro T;
  apply impred_isaprop; intro P;
  apply impred_isaprop; intro g.
  apply isapropiscontr.
Defined.

(* end *)