(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* **************************************************************************

          Buchberger : Division for Term

          Laurent Thery April 2001

  ************************************************************************** *)

From Coq Require Import Relation_Definitions List.
From Buchberger Require Import CoefStructure moreCoefStructure OrderStructure.
From Buchberger Require Import Monomials Term.

Set Default Proof Using "Type".

Section DivTerm.
Load hCoefStructure.
Load mCoefStructure.
Load hOrderStructure.
Load mOrderStructure.
Load hTerm.

Set Implicit Arguments.
Unset Strict Implicit.

Definition divTerm :
  Term A n ->
  forall (b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b), Term A n.
intros H; case H; intros b2 c2 H'; case H'; intros b3 c3; simpl in |- *.
intros nZb3; exact (divA b2 b3 nZb3, div_mon n c2 c3).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem eqT_divTerm_plusTerm :
 forall (a b c : Term A n) (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c),
 eqT a b ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZc) c) ->
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZc) c) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (plusTerm (A:=A) plusA (n:=n) a b) nZc)
   (plusTerm (A:=A) plusA (n:=n) (divTerm a nZc) (divTerm b nZc)).
Proof using minusA invA cs A1.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 nZc H' H'0 H'1; split; auto.
case H'1; intros H'3 H'4; clear H'1.
case H'0; intros H'2 H'5; clear H'0.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := divA
            (plusA (multA (divA a2 a0 nZc) a0) (multA (divA a1 a0 nZc) a0))
            a0 nZc); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := divA (multA (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)) a0) a0 nZc);
 auto.
apply divA_eqA_comp with (1 := cs); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := plusA (multA a0 (divA a2 a0 nZc)) (multA a0 (divA a1 a0 nZc)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA a0 (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := multA (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)) (divA a0 a0 nZc));
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := divA (multA a0 (plusA (divA a2 a0 nZc) (divA a1 a0 nZc))) a0 nZc);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with
    (y := multA (divA a0 a0 nZc) (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)));
 auto.
apply divA_multA_comp_r with (1 := cs); auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA (plusA (divA a2 a0 nZc) (divA a1 a0 nZc)) A1);
 auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply multA_eqA_comp with (1 := cs); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); auto.
apply divA_A1 with (1 := cs); auto.
apply multA_A1_r with (1 := cs); auto.
Qed.

Theorem divTerm_invTerm_l :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (invTerm (A:=A) invA (n:=n) b) nZa)
   (invTerm (A:=A) invA (n:=n) (divTerm b nZa)).
Proof using plusA minusA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros d c A0' c0 nZA2 H'0; split; auto.
case H'0; intros H'1 H'2; clear H'0.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := divA (invA (multA (divA d A0' nZA2) A0')) A0' nZA2);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := divA (multA (invA (divA d A0' nZA2)) A0') A0' nZA2);
 auto.
apply divA_eqA_comp with (1 := cs); auto.
apply (eqA_sym _ _ _ _ _ _ _ _ _ cs); apply multA_invA_com_l with (1 := cs);
 auto.
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA (invA (divA d A0' nZA2)) (divA A0' A0' nZA2));
 auto.
apply divA_multA_comp_l with (1 := cs).
apply
 (eqA_trans _ _ _ _ _ _ _ _ _ cs)
  with (y := multA (invA (divA d A0' nZA2)) A1); auto.
apply multA_eqA_comp with (1 := cs); auto.
apply divA_A1 with (1 := cs).
apply multA_A1_r with (1 := cs).
Qed.

Theorem divTerm_invTerm_r :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZia : ~ zeroP (A:=A) A0 eqA (n:=n) (invTerm (A:=A) invA (n:=n) a)),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm b nZia)
   (invTerm (A:=A) invA (n:=n) (divTerm b nZa)).
Proof using plusA minusA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
split; auto.
apply divA_invA_r with (1 := cs); auto.
Qed.

Theorem eqT_divTerm :
 forall (a b c d : Term A n) (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c)
   (nZd : ~ zeroP (A:=A) A0 eqA (n:=n) d),
 eqT a b -> eqT c d -> eqT (divTerm a nZc) (divTerm b nZd).
Proof.
intros a b c d; case a; case b; case c; case d; unfold eqT in |- *;
 simpl in |- *; auto.
intros A0' c0 d2 c2 H' c3 H'0 c4 H'1 H'2 H'3 H'4; rewrite H'3; rewrite H'4;
 auto.
Qed.

Theorem eqTerm_divTerm_comp :
 forall (a b c d : Term A n) (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c)
   (nZd : ~ zeroP (A:=A) A0 eqA (n:=n) d),
 eqTerm (A:=A) eqA (n:=n) a b ->
 eqTerm (A:=A) eqA (n:=n) c d ->
 eqTerm (A:=A) eqA (n:=n) (divTerm a nZc) (divTerm b nZd).
Proof using plusA multA minusA invA cs A1.
intros a b c d; case a; case b; case c; case d; simpl in |- *; auto.
intros A0' c0 d2 c2 d3 c3 d4 c4 nZd2 H'0 H'1 H'2.
case H'2; intros H'3 H'4; clear H'2.
case H'1; intros H'2 H'5; clear H'1.
split; auto.
rewrite H'5; rewrite H'4; auto.
Qed.

Local Hint Resolve eqTerm_divTerm_comp : core.

Theorem divTerm_multTerm_l :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (multTerm (A:=A) multA (n:=n) c b) nZa)
   (multTerm (A:=A) multA (n:=n) c (divTerm b nZa)).
Proof using plusA minusA invA cs A1.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros d c0 A0' c2 d2 c3 nZd2 H'0; case H'0; intros H'1 H'2; auto.
split; auto.
apply divA_multA_comp_l with (1 := cs).
rewrite H'2.
repeat rewrite mult_div_com.
rewrite mult_mon_assoc.
repeat rewrite mult_div_com; auto.
Qed.

Theorem divTerm_multTerm_r :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) (divTerm (multTerm (A:=A) multA (n:=n) b c) nZa)
   (multTerm (A:=A) multA (n:=n) (divTerm b nZa) c).
Proof using plusA minusA invA cs A1.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 nZa H'; split; auto.
apply divA_multA_comp_r with (1 := cs).
elim H'; intros H'0 H'1; rewrite H'1; clear H'.
rewrite mult_div_com; auto.
rewrite <- mult_mon_assoc.
rewrite (mult_mon_com n m1 m).
rewrite mult_mon_assoc.
rewrite mult_div_com; auto.
Qed.

Local Hint Resolve divTerm_multTerm_l divTerm_multTerm_r : core.

Theorem div_is_T1 :
 forall (a : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqTerm (A:=A) eqA (n:=n) (divTerm a nZa) (T1 A1 n).
Proof using plusA multA minusA invA cs.
intros a; case a; simpl in |- *; auto.
intros a0 m nZa; split; auto.
apply divA_A1 with (1 := cs).
unfold M1 in |- *; apply mult_div_id; auto.
Qed.

Local Hint Resolve div_is_T1 : core.

Theorem divTerm_nZ :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 ~ zeroP (A:=A) A0 eqA (n:=n) (divTerm a nZb).
Proof using plusA multA minusA invA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H nZb; apply divA_nZ with (1 := cs); auto.
Qed.

Theorem divTerm_eqT :
 forall a b c : Term A n,
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 forall nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c,
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZc) c) ->
 eqTerm (A:=A) eqA (n:=n) b (multTerm (A:=A) multA (n:=n) (divTerm b nZc) c).
Proof using plusA minusA invA cs A1.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a1 m1 a2 m2 a3 m3 H1 H2 H3 H4 H5; case H5; intros H6 H7; split; auto.
apply divA_is_multA with (1 := cs); auto.
unfold eqT in H1; simpl in H1; rewrite <- H1; auto.
Qed.

Let gb : mon n * bool -> bool.
intros H'; case H'; auto.
Defined.

Let gm : mon n * bool -> mon n.
intros H'; case H'; auto.
Defined.

Definition mk_clean :
  forall a b : mon n, {c : mon n * bool | c = div_mon_clean n a b}.
intros a b; exists (div_mon_clean n a b); auto.
Defined.

Definition divTerm_dec :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 {eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b)} +
 {~
  eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b)}.
intros a b; case a; case b; simpl in |- *; auto.
intros b2 c2 b3 c3.
intros Zp1 Zp2.
case (mk_clean c3 c2).
intros x; case x.
intros c b4; case b4.
intros H0; left; simpl in |- *; auto.
generalize (div_clean_dec1 n c3 c2); rewrite <- H0; simpl in |- *; auto.
intros H1; case H1; auto; intros H2 H3; split; auto.
apply divA_is_multA with (1 := cs); auto.
intros H0; right; red in |- *; intros dviP_H; inversion dviP_H.
generalize (div_clean_dec2 n c3 c2); simpl in |- *; auto.
intros H'; lapply H'; [ intros H'0; apply H'0; clear H' | clear H' ].
rewrite <- H1; auto.
rewrite <- H0; simpl in |- *; auto.
Defined.

Theorem zeroP_divTerm :
 forall a b : Term A n,
 zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 zeroP (A:=A) A0 eqA (n:=n) (divTerm a nZb).
Proof using plusA multA minusA invA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros d H' A0' H'0 H'1 nZd; auto.
apply (eqA_trans _ _ _ _ _ _ _ _ _ cs) with (y := divA A0 d nZd); auto.
apply divA_A0_l with (1 := cs).
Qed.

Theorem divTerm_on_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqT a b ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b).
Proof using plusA minusA invA cs A1.
intros a b; case a; case b; unfold eqT in |- *; simpl in |- *; auto.
intros d c A0' c0 H' H'0 H'1; rewrite <- H'1.
split; auto.
apply divA_is_multA with (1 := cs); auto.
rewrite mult_div_id; auto.
rewrite mult_mon_zero_l; auto.
Qed.

Theorem divTerm_on_eqT_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqT a b -> eqT (divTerm a nZb) (T1 A1 n).
Proof.
intros a b; case a; case b; unfold eqT in |- *; simpl in |- *; auto.
intros b2 c b3 c0 H' H'0 H'1; rewrite H'1; auto.
rewrite mult_div_id; auto.
Qed.

Theorem divTerm_on_plusM_minusM :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 T2M a = mult_mon n (div_mon n (T2M a) (T2M b)) (T2M b) ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b).
Proof using plusA minusA invA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
split; auto.
apply divA_is_multA with (1 := cs); auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition ppc : Term A n -> Term A n -> Term A n.
intros H; case H; intros b2 c2 H'; case H'; intros b3 c3; simpl in |- *;
 exact (A1, ppcm_mon n c2 c3).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem ppc_com :
 forall a b : Term A n, eqTerm (A:=A) eqA (n:=n) (ppc a b) (ppc b a).
Proof using plusA multA minusA invA divA cs A0.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0; split; auto.
apply ppcm_com; auto.
Qed.

Theorem divTerm_ppc :
 forall (a b c : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b)),
 eqTerm (A:=A) eqA (n:=n) c (multTerm (A:=A) multA (n:=n) (divTerm c nZa) a) ->
 eqTerm (A:=A) eqA (n:=n) c (multTerm (A:=A) multA (n:=n) (divTerm c nZb) b) ->
 eqTerm (A:=A) eqA (n:=n) c
   (multTerm (A:=A) multA (n:=n) (divTerm c nZppab) (ppc a b)).
Proof using plusA minusA invA cs.
intros a b c; case a; case b; case c; simpl in |- *; auto.
intros a0 m a1 m0 a2 m1 nZa nZb nZppab H H0; split; auto.
apply divA_is_multA with (1 := cs); auto.
apply ppcm_mom_is_ppcm; intuition.
Qed.

Theorem divTerm_ppcl :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (ppc a b)
   (multTerm (A:=A) multA (n:=n) (divTerm (ppc a b) nZa) a).
Proof using plusA minusA invA cs.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 nZa H; split; auto.
apply divA_is_multA with (1 := cs); auto.
apply ppcm_prop_l.
Qed.

Theorem divTerm_ppcr :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqTerm (A:=A) eqA (n:=n) (ppc a b)
   (multTerm (A:=A) multA (n:=n) (divTerm (ppc a b) nZb) b).
Proof using plusA minusA invA cs.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 H nZb; split; auto.
apply divA_is_multA with (1 := cs); auto.
apply ppcm_prop_r.
Qed.

Theorem ppc_nZ :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b).
Proof using plusA multA minusA invA divA cs.
intros a b; case a; case b; simpl in |- *; auto.
Qed.

Theorem divTerm_rew :
 forall (a b : Term A n) (nZ1 nZ2 : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 divTerm a nZ1 = divTerm a nZ2.
Proof using plusA multA minusA invA cs A1.
intros a b; case a; case b; simpl in |- *; auto.
intros a0 m a1 m0 nZ1 nZ2.
rewrite divA_rew with (1 := cs) (nZ2 := nZ2); auto.
Qed.

Inductive divP : Term A n -> Term A n -> Prop :=
 divTerm_def :
   forall a b : Term A n,
   ~ zeroP (A:=A) A0 eqA (n:=n) a ->
   forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
   eqTerm (A:=A) eqA (n:=n) a
     (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) ->
   divP a b.

Theorem divP_inv1 :
 forall a b : Term A n, divP a b -> ~ zeroP (A:=A) A0 eqA (n:=n) a.
Proof.
intros a b H; inversion H; auto.
Qed.

Theorem divP_inv2 :
 forall a b : Term A n, divP a b -> ~ zeroP (A:=A) A0 eqA (n:=n) b.
Proof.
intros a b H; inversion H; auto.
Qed.

Theorem divP_inv3 :
 forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 divP a b ->
 eqTerm (A:=A) eqA (n:=n) a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b).
Proof using plusA minusA invA cs A1.
intros a b nZb H; inversion H; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb0) b);
 auto.
Qed.

Local Hint Resolve divP_inv1 divP_inv2 divP_inv3 : core.

Theorem divP_plusTerm :
 forall a b c : Term A n,
 divP a c ->
 divP b c ->
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 divP (plusTerm (A:=A) plusA (n:=n) a b) c.
Proof using minusA invA cs A1.
intros a b c H' H'0; inversion H'0; inversion H'.
intros H'1 H'2; apply divTerm_def with (nZb := nZb0); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb0) c)
            (multTerm (A:=A) multA (n:=n) (divTerm b nZb0) c));
 auto.
apply eqTerm_plusTerm_comp with (1 := cs); auto.
apply multTerm_eqT; auto.
apply eqT_divTerm; auto.
apply (eqT_refl A n).
apply (eqT_refl A n).
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (plusTerm (A:=A) plusA (n:=n) (divTerm a nZb0) (divTerm b nZb0))
            c); auto.
apply multTerm_plusTerm_dist_l with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqT_divTerm_plusTerm; auto.
Qed.

Local Hint Resolve divP_plusTerm : core.

Theorem divP_invTerm_l :
 forall a b : Term A n, divP a b -> divP (invTerm (A:=A) invA (n:=n) a) b.
Proof using plusA minusA cs A1.
intros a b H'; inversion H'; auto.
apply divTerm_def with (nZb := nZb); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (invTerm (A:=A) invA (n:=n) (divTerm a nZb)) b);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_invTerm_l; auto.
Qed.

Local Hint Resolve divP_invTerm_l : core.

Theorem divP_invTerm_r :
 forall a b : Term A n, divP a b -> divP a (invTerm (A:=A) invA (n:=n) b).
Proof using plusA minusA cs A1.
intros a b H'; inversion H'.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (invTerm (A:=A) invA (n:=n) b));
 [ intros nZib | auto ].
apply divTerm_def with (nZb := nZib); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (invTerm (A:=A) invA (n:=n) (divTerm a nZb))
            (invTerm (A:=A) invA (n:=n) b)); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb)
               (invTerm (A:=A) invA (n:=n) b))); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (invTerm (A:=A) invA (n:=n)
               (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b)));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb) b);
 auto.
apply eqTerm_invTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com_r with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_invTerm_r; auto.
Qed.

Local Hint Resolve divTerm_nZ : core.
Local Hint Resolve divP_invTerm_r : core.

Theorem divTerm_multTerml :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (multTerm (A:=A) multA (n:=n) a b) a.
Proof using plusA minusA invA eqA_dec cs A1.
intros a b nZa nZb.
apply divTerm_def with (nZb := nZa); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZa) b) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) b) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) b a); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply div_is_T1; auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_multTerm_r; auto.
Qed.

Theorem divTerm_multTermr :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (multTerm (A:=A) multA (n:=n) a b) b.
Proof using plusA minusA invA eqA_dec cs A1.
intros a b nZa nZb.
apply divTerm_def with (nZb := nZb); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) a (divTerm b nZb)) b);
 auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_multTerm_l; auto.
Qed.

Local Hint Resolve divTerm_multTermr divTerm_multTerml : core.

Theorem divP_trans : transitive (Term A n) divP.
Proof using plusA minusA invA cs A1.
red in |- *; intros a b c H' H'0.
cut (~ zeroP (A:=A) A0 eqA (n:=n) c); [ intros nZc | auto ].
apply divTerm_def with (nZb := nZc); auto.
apply divP_inv1 with (b := b); auto.
2: apply divP_inv2 with (a := b); auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) b); [ intros nZb | auto ].
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) (divTerm a nZb) (divTerm b nZc)) c);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb)
            (multTerm (A:=A) multA (n:=n) (divTerm b nZc) c));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZb) b);
 auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
inversion H'0; inversion H'.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) nZc);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply divTerm_multTerm_l; auto.
apply eqTerm_divTerm_comp; auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (1 := H4);
 auto.
apply divP_inv2 with (a := a); auto.
Qed.

Local Hint Resolve divP_trans : core.

Theorem divP_nZero :
 forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 divP a b -> ~ zeroP (A:=A) A0 eqA (n:=n) (divTerm a nZb).
Proof using plusA minusA invA cs A1.
intros a b nZb H'; inversion H'; auto.
Qed.

Local Hint Resolve divP_nZero : core.

Theorem divP_eqTerm_comp :
 forall a b c : Term A n,
 divP a c -> eqTerm (A:=A) eqA (n:=n) a b -> divP b c.
Proof using plusA minusA invA cs A1.
intros a b c H' H'0.
cut (~ zeroP (A:=A) A0 eqA (n:=n) c); [ intros nZc | auto ].
apply divTerm_def with (nZb := nZc); auto.
apply nzeroP_comp_eqTerm with (1 := cs) (a := a); auto.
apply divP_inv1 with (b := c); auto.
2: apply divP_inv2 with (a := a); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZc) c);
 auto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := a); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_on_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> eqT a b -> divP a b.
Proof using plusA minusA invA cs A1.
intros a b H' nZb H'1; apply divTerm_def with (nZb := nZb); auto.
apply divTerm_on_eqT; auto.
Qed.

Theorem divP_on_eqT_eqT :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b,
 eqT a b -> eqT (divTerm a nZb) (T1 A1 n).
Proof.
intros a b H nZb H0; apply divTerm_on_eqT_eqT; auto.
Qed.

Local Hint Resolve divP_on_eqT divP_on_eqT_eqT : core.

Inductive ppcm (p q : Term A n) : Term A n -> Prop :=
    ppcm0 :
      forall s : Term A n,
      (forall r : Term A n, divP r p -> divP r q -> divP r s) ->
      divP s p -> divP s q -> ppcm p q s.

Local Hint Resolve ppcm0 : core.

Theorem ppc_is_ppcm :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> ppcm a b (ppc a b).
Proof using plusA minusA invA cs.
intros a b nZa nZb; apply ppcm0; auto.
intros r H'1 H'2; inversion H'1; inversion H'2.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b)); [ intros nZppab | auto ].
apply divTerm_def with (nZb := nZppab); auto.
apply divTerm_ppc with (nZa := nZa) (nZb := nZb); auto.
apply ppc_nZ; auto.
apply divTerm_def with (nZb := nZa); auto.
apply ppc_nZ; auto.
apply divTerm_ppcl; auto.
apply divTerm_def with (nZb := nZb); auto.
apply ppc_nZ; auto.
apply divTerm_ppcr; auto.
Qed.

Theorem ppc_multTerm_divP :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 divP (multTerm (A:=A) multA (n:=n) a b) (ppc a b).
Proof using plusA minusA invA eqA_dec cs.
intros a b H' H'0.
elim ppc_is_ppcm; auto.
Qed.

Local Hint Resolve ppc_multTerm_divP : core.

Theorem divP_comp :
 forall a b c d : Term A n,
 divP a c ->
 eqTerm (A:=A) eqA (n:=n) a b -> eqTerm (A:=A) eqA (n:=n) c d -> divP b d.
Proof using plusA minusA invA cs A1.
intros a b c d H'; generalize b d; elim H'.
intros a0 b0 nZa0 nZb0 H'2 b1 d0 H'3 H'4; auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) d0); [ intros nZd0 | auto ].
apply divTerm_def with (nZb := nZd0); auto.
red in |- *; intros nz1; absurd (zeroP (A:=A) A0 eqA (n:=n) a0); auto.
apply zeroP_comp_eqTerm with (1 := cs) (a := b1); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := a0); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a0 nZb0) b0);
 auto.
red in |- *; intros nz1; absurd (zeroP (A:=A) A0 eqA (n:=n) b0); auto.
apply zeroP_comp_eqTerm with (1 := cs) (a := d0); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_multTerm_l :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b) c -> divP c a.
Proof using plusA minusA invA eqA_dec cs A1.
intros a b c H' H'0 H'1.
apply divP_comp with (a := multTerm (A:=A) multA (n:=n) a b) (c := a); auto.
Qed.

Theorem divP_multTerm_r :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b) c -> divP c b.
Proof using plusA minusA invA eqA_dec cs A1.
intros a b c H' H'0 H'1.
apply divP_comp with (a := multTerm (A:=A) multA (n:=n) a b) (c := b); auto.
Qed.

Local Hint Resolve divP_multTerm_r divP_multTerm_l : core.

Theorem divP_ppcl :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (ppc a b) a.
Proof using plusA minusA invA cs.
intros a b H' H'0; try assumption.
lapply (ppc_is_ppcm a b);
 [ intros H'3; lapply H'3; clear H'3; [ intros H'4 | idtac ] | idtac ];
 auto; auto.
inversion H'4; auto.
Qed.

Theorem divP_ppcr :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP (ppc a b) b.
Proof using plusA minusA invA cs.
intros a b H' H'0; try assumption.
lapply (ppc_is_ppcm a b);
 [ intros H'3; lapply H'3; clear H'3; [ intros H'4 | idtac ] | idtac ];
 auto; auto.
inversion H'4; auto.
Qed.

Local Hint Resolve divP_ppcl divP_ppcr : core.

Theorem divTerm_compo :
 forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZc : ~ zeroP (A:=A) A0 eqA (n:=n) c),
 divP a b ->
 divP b c ->
 eqTerm (A:=A) eqA (n:=n) (divTerm a nZc)
   (multTerm (A:=A) multA (n:=n) (divTerm a nZb) (divTerm b nZc)).
Proof using plusA minusA invA cs A1.
intros a b c nZb nZc H'; inversion H'.
intros H'0; inversion H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) nZc);
 auto.
Qed.

Local Hint Resolve divTerm_compo : core.

Theorem divP_comp_ppc0 :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b))
   (p : list (Term A n)),
 eqTerm (A:=A) eqA (n:=n) b
   (multTerm (A:=A) multA (n:=n)
      (divTerm (multTerm (A:=A) multA (n:=n) a b) nZppab)
      (divTerm (ppc a b) nZa)).
Proof using plusA minusA invA eqA_dec cs.
intros a b nZa nZb nZppab p.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm a nZa) b);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a b) nZa);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem divP_comp_ppc1 :
 forall (a b : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
   (nZppab : ~ zeroP (A:=A) A0 eqA (n:=n) (ppc a b))
   (p : list (Term A n)),
 eqTerm (A:=A) eqA (n:=n) a
   (multTerm (A:=A) multA (n:=n)
      (divTerm (multTerm (A:=A) multA (n:=n) a b) nZppab)
      (divTerm (ppc a b) nZb)).
Proof using plusA minusA invA eqA_dec cs.
intros a b nZa nZb nZppab H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) a (divTerm b nZb));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a b) nZb);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Definition divP_dec :
 forall a b : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b -> {divP a b} + {~ divP a b}.
intros a b nZa nZb.
elim divTerm_dec with (a := a) (nZb := nZb); auto.
intros H'1; left; apply divTerm_def with (nZb := nZb); auto.
Defined.

Theorem divP_eqT :
 forall a b c : Term A n,
 eqT a b -> ~ zeroP (A:=A) A0 eqA (n:=n) b -> divP a c -> divP b c.
Proof using plusA minusA invA cs A1.
intros a b c H' nZb H'1; inversion H'1.
apply divTerm_def with (nZb := nZb0); auto.
apply divTerm_eqT with (a := a); auto.
Qed.

Theorem eqTerm_multTerm_imp_eqTerm :
 forall a b c : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) c ->
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) c a)
   (multTerm (A:=A) multA (n:=n) c b) -> eqTerm (A:=A) eqA (n:=n) a b.
Proof using plusA minusA invA divA cs A1.
intros a b c nZc H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) c a) nZc);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZc) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply
  (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
   with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZc) a);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) c b) nZc);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZc) b);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) b);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem multTerm_eqTerm_inv :
 forall a b c : Term A n,
 eqTerm (A:=A) eqA (n:=n) (multTerm (A:=A) multA (n:=n) a b)
   (multTerm (A:=A) multA (n:=n) a c) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> eqTerm (A:=A) eqA (n:=n) b c.
Proof using plusA minusA invA divA cs A1.
intros a b c H' H'1.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) b (divTerm a H'1));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) b a) H'1);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a b) H'1);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) c (divTerm a H'1));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) c a) H'1);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (multTerm (A:=A) multA (n:=n) a c) H'1);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) c (T1 A1 n));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem eqT_nzero_divP :
 forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 eqT a (multTerm (A:=A) multA (n:=n) (divTerm a nZb) b) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> divP a b.
Proof using plusA minusA invA eqA_dec cs A1.
intros a b nZb H'0 H'1; auto.
apply divP_eqT with (a := multTerm (A:=A) multA (n:=n) (divTerm a nZb) b);
 auto.
apply (eqT_sym A n); auto.
Qed.

Local Hint Resolve eqT_nzero_divP : core.

Theorem eqT_nzero_eqT_divP :
 forall (a b c : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b),
 eqT c (multTerm (A:=A) multA (n:=n) (divTerm c nZb) b) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> eqT a c -> divP a b.
Proof using plusA minusA invA eqA_dec cs A1.
intros a b c nZb H'0 H'1 H'2.
apply eqT_nzero_divP with (nZb := nZb); auto.
apply (eqT_trans A n) with (y := c); auto.
apply
 (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (divTerm c nZb) b);
 auto.
apply (eqT_sym A n); auto.
apply multTerm_eqT; auto.
apply eqT_divTerm; auto; apply (eqT_refl A n); auto.
apply (eqT_refl A n); auto.
Qed.

Local Hint Resolve eqT_nzero_eqT_divP : core.

End DivTerm.


From iris.prelude Require Export prelude.
From iris.bi Require Export bi.
From iris.proofmode Require Import base.
From iris.prelude Require Import options.
Import bi.

Inductive env (A : Type) : Type :=
  | Enil : env A
  | Esnoc : env A → ident → A → env A.
Global Arguments Enil {_}.
Global Arguments Esnoc {_} _ _ _.
Global Instance: Params (@Enil) 1 := {}.
Global Instance: Params (@Esnoc) 1 := {}.

Fixpoint env_lookup {A} (i : ident) (Γ : env A) : option A :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x => if ident_beq i j then Some x else env_lookup i Γ
  end.

Module env_notations.
  Notation "y ≫= f" := (pm_option_bind f y).
  Notation "x ← y ; z" := (y ≫= λ x, z).
  Notation "' x1 ← y ; z" := (y ≫= (λ x1, z)).
  Notation "Γ !! j" := (env_lookup j Γ).
End env_notations.
Import env_notations.

Local Open Scope lazy_bool_scope.

Inductive env_wf {A} : env A → Prop :=
  | Enil_wf : env_wf Enil
  | Esnoc_wf Γ i x : Γ !! i = None → env_wf Γ → env_wf (Esnoc Γ i x).

Fixpoint env_to_list {A} (E : env A) : list A :=
  match E with Enil => [] | Esnoc Γ _ x => x :: env_to_list Γ end.
Coercion env_to_list : env >-> list.
Global Instance: Params (@env_to_list) 1 := {}.

Fixpoint env_dom {A} (Γ : env A) : list ident :=
  match Γ with Enil => [] | Esnoc Γ i _ => i :: env_dom Γ end.

Fixpoint env_app {A} (Γapp : env A) (Γ : env A) : option (env A) :=
  match Γapp with
  | Enil => Some Γ
  | Esnoc Γapp i x =>
     Γ' ← env_app Γapp Γ;
     match Γ' !! i with None => Some (Esnoc Γ' i x) | Some _ => None end
  end.

Fixpoint env_replace {A} (i: ident) (Γi: env A) (Γ: env A) : option (env A) :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x =>
     if ident_beq i j then env_app Γi Γ else
     match Γi !! j with
     | None => Γ' ← env_replace i Γi Γ; Some (Esnoc Γ' j x)
     | Some _ => None
     end
  end.

Fixpoint env_delete {A} (i : ident) (Γ : env A) : env A :=
  match Γ with
  | Enil => Enil
  | Esnoc Γ j x => if ident_beq i j then Γ else Esnoc (env_delete i Γ) j x
  end.

Fixpoint env_lookup_delete {A} (i : ident) (Γ : env A) : option (A * env A) :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x =>
     if ident_beq i j then Some (x,Γ)
     else '(y,Γ') ← env_lookup_delete i Γ; Some (y, Esnoc Γ' j x)
  end.

Inductive env_Forall2 {A B} (P : A → B → Prop) : env A → env B → Prop :=
  | env_Forall2_nil : env_Forall2 P Enil Enil
  | env_Forall2_snoc Γ1 Γ2 i x y :
     env_Forall2 P Γ1 Γ2 → P x y → env_Forall2 P (Esnoc Γ1 i x) (Esnoc Γ2 i y).

Inductive env_subenv {A} : relation (env A) :=
  | env_subenv_nil : env_subenv Enil Enil
  | env_subenv_snoc Γ1 Γ2 i x :
     env_subenv Γ1 Γ2 → env_subenv (Esnoc Γ1 i x) (Esnoc Γ2 i x)
  | env_subenv_skip Γ1 Γ2 i y :
     env_subenv Γ1 Γ2 → env_subenv Γ1 (Esnoc Γ2 i y).

Section env.
Context {A : Type}.
Implicit Types Γ : env A.
Implicit Types i : ident.
Implicit Types x : A.
Local Hint Resolve Esnoc_wf Enil_wf : core.

Ltac simplify :=
  repeat match goal with
  | _ => progress simplify_eq/=
  | H : context [ident_beq ?s1 ?s2] |- _ => destruct (ident_beq_reflect s1 s2)
  | |- context [ident_beq ?s1 ?s2] => destruct (ident_beq_reflect s1 s2)
  | H : context [pm_option_bind _ ?x] |- _ => destruct x eqn:?
  | |- context [pm_option_bind _ ?x] => destruct x eqn:?
  | _ => case_match
  end.

Lemma env_lookup_perm Γ i x : Γ !! i = Some x → Γ ≡ₚ x :: env_delete i Γ.
Proof.
  induction Γ; intros; simplify; rewrite 1?Permutation_swap; f_equiv; eauto.
Qed.

Lemma env_lookup_snoc Γ i P : env_lookup i (Esnoc Γ i P) = Some P.
Proof. induction Γ; simplify; auto. Qed.
Lemma env_lookup_snoc_ne Γ i j P :
  i ≠ j → env_lookup i (Esnoc Γ j P) = env_lookup i Γ.
Proof. induction Γ=> ?; simplify; auto. Qed.

Lemma env_app_perm Γ Γapp Γ' :
  env_app Γapp Γ = Some Γ' → env_to_list Γ' ≡ₚ Γapp ++ Γ.
Proof. revert Γ'; induction Γapp; intros; simplify; f_equal; auto. Qed.
Lemma env_app_fresh Γ Γapp Γ' i :
  env_app Γapp Γ = Some Γ' → Γapp !! i = None → Γ !! i = None → Γ' !! i = None.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.
Lemma env_app_fresh_1 Γ Γapp Γ' i x :
  env_app Γapp Γ = Some Γ' → Γ' !! i = None → Γ !! i = None.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.
Lemma env_app_disjoint Γ Γapp Γ' i :
  env_app Γapp Γ = Some Γ' → Γapp !! i = None ∨ Γ !! i = None.
Proof.
  revert Γ'.
  induction Γapp; intros; simplify; naive_solver eauto using env_app_fresh_1.
Qed.
Lemma env_app_wf Γ Γapp Γ' : env_app Γapp Γ = Some Γ' → env_wf Γ → env_wf Γ'.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.

Lemma env_replace_fresh Γ Γj Γ' i j :
  env_replace j Γj Γ = Some Γ' →
  Γj !! i = None → env_delete j Γ !! i = None → Γ' !! i = None.
Proof. revert Γ'. induction Γ; intros; simplify; eauto using env_app_fresh. Qed.
Lemma env_replace_wf Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → env_wf (env_delete i Γ) → env_wf Γ'.
Proof.
  revert Γ'. induction Γ; intros ??; simplify; [|inversion_clear 1];
    eauto using env_app_wf, env_replace_fresh.
Qed.
Lemma env_replace_lookup Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → is_Some (Γ !! i).
Proof. revert Γ'. induction Γ; intros; simplify; eauto. Qed.
Lemma env_replace_perm Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → Γ' ≡ₚ Γi ++ env_delete i Γ.
Proof.
  revert Γ'. induction Γ as [|Γ IH j y]=>Γ' ?; simplify; auto using env_app_perm.
  rewrite -Permutation_middle -IH //.
Qed.

Lemma env_lookup_delete_correct Γ i :
  env_lookup_delete i Γ = (x ← Γ !! i; Some (x,env_delete i Γ)).
Proof. induction Γ; intros; simplify; eauto. Qed.
Lemma env_lookup_delete_Some Γ Γ' i x :
  env_lookup_delete i Γ = Some (x,Γ') ↔ Γ !! i = Some x ∧ Γ' = env_delete i Γ.
Proof. rewrite env_lookup_delete_correct; simplify; naive_solver. Qed.

Lemma env_lookup_env_delete Γ j : env_wf Γ → env_delete j Γ !! j = None.
Proof. induction 1; intros; simplify; eauto. Qed.
Lemma env_lookup_env_delete_ne Γ i j : i ≠ j → env_delete j Γ !! i = Γ !! i.
Proof. induction Γ; intros; simplify; eauto. Qed.
Lemma env_delete_fresh Γ i j : Γ !! i = None → env_delete j Γ !! i = None.
Proof. induction Γ; intros; simplify; eauto. Qed.

Lemma env_delete_wf Γ j : env_wf Γ → env_wf (env_delete j Γ).
Proof. induction 1; simplify; eauto using env_delete_fresh. Qed.

Global Instance env_Forall2_refl (P : relation A) :
  Reflexive P → Reflexive (env_Forall2 P).
Proof. intros ? Γ. induction Γ; constructor; auto. Qed.
Global Instance env_Forall2_sym (P : relation A) :
  Symmetric P → Symmetric (env_Forall2 P).
Proof. induction 2; constructor; auto. Qed.
Global Instance env_Forall2_trans (P : relation A) :
  Transitive P → Transitive (env_Forall2 P).
Proof.
  intros ? Γ1 Γ2 Γ3 HΓ; revert Γ3.
  induction HΓ; inversion_clear 1; constructor; eauto.
Qed.
Global Instance env_Forall2_antisymm (P Q : relation A) :
  AntiSymm P Q → AntiSymm (env_Forall2 P) (env_Forall2 Q).
Proof. induction 2; inversion_clear 1; constructor; auto. Qed.
Lemma env_Forall2_impl {B} (P Q : A → B → Prop) Γ Σ :
  env_Forall2 P Γ Σ → (∀ x y, P x y → Q x y) → env_Forall2 Q Γ Σ.
Proof. induction 1; constructor; eauto. Qed.

Global Instance Esnoc_proper (P : relation A) :
  Proper (env_Forall2 P ==> (=) ==> P ==> env_Forall2 P) Esnoc.
Proof. intros Γ1 Γ2 HΓ i ? <-; by constructor. Qed.
Global Instance env_to_list_proper (P : relation A) :
  Proper (env_Forall2 P ==> Forall2 P) env_to_list.
Proof. induction 1; constructor; auto. Qed.

Lemma env_Forall2_fresh {B} (P : A → B → Prop) Γ Σ i :
  env_Forall2 P Γ Σ → Γ !! i = None → Σ !! i = None.
Proof. by induction 1; simplify. Qed.
Lemma env_Forall2_wf {B} (P : A → B → Prop) Γ Σ :
  env_Forall2 P Γ Σ → env_wf Γ → env_wf Σ.
Proof. induction 1; inversion_clear 1; eauto using env_Forall2_fresh. Qed.

Lemma env_subenv_fresh Γ Σ i : env_subenv Γ Σ → Σ !! i = None → Γ !! i = None.
Proof. by induction 1; simplify. Qed.
Lemma env_subenv_wf Γ Σ : env_subenv Γ Σ → env_wf Σ → env_wf Γ.
Proof. induction 1; inversion_clear 1; eauto using env_subenv_fresh. Qed.
Global Instance env_to_list_subenv_proper :
  Proper (env_subenv ==> sublist) (@env_to_list A).
Proof. induction 1; simpl; constructor; auto. Qed.
End env.

Record envs (PROP : bi) := Envs {
  env_intuitionistic : env PROP;
  env_spatial : env PROP;
  env_counter : positive (** A counter to generate fresh hypothesis names *)
}.
Add Printing Constructor envs.
Global Arguments Envs {_} _ _ _.
Global Arguments env_intuitionistic {_} _.
Global Arguments env_spatial {_} _.
Global Arguments env_counter {_} _.

(** We now define the judgment [envs_entails Δ Q] for proof mode entailments.
This judgment expresses that [Q] can be proved under the proof mode environment
[Δ]. To improve performance and to encapsulate the internals of the proof mode
(i.e. to ensure that tactics like [intro] cannot accidentally unfold the
entailment), we seal off [envs_entails].

The way the the definitions below are setup involves some trickery so we can
implement the [iFresh] tactic, which increases the counter [env_counter], in
an efficient way. Concretely, we made sure that [envs_entails (Envs Γp Γs c) Q]
and [envs_entails (Envs Γp Γs c') Q] are convertible for any [c] and [c']. This
way, [iFresh] can simply be implemented by changing the goal from
[envs_entails (Envs Γp Γs c) Q] into [envs_entails (Envs Γp Γs (Pos_succ c)) Q]
using the tactic [change_no_check]. This way, the generated proof term
contains no additional steps for changing the counter.

We first define a version [pre_envs_entails] that takes the two contexts
[env_intuitionistic] and [env_spatial] as its arguments. We seal this definition
and then lift it to take the whole proof mode context [Δ : envs PROP]. This is
crucial to make sure that the counter [env_counter] is not part of the seal. *)
Record envs_wf' {PROP : bi} (Γp Γs : env PROP) := {
  env_intuitionistic_valid : env_wf Γp;
  env_spatial_valid : env_wf Γs;
  envs_disjoint i : Γp !! i = None ∨ Γs !! i = None
}.
Definition envs_wf {PROP : bi} (Δ : envs PROP) :=
  envs_wf' (env_intuitionistic Δ) (env_spatial Δ).

Notation env_and_persistently Γ := ([∧ list] P ∈ env_to_list Γ, <pers> P)%I.

Definition of_envs' {PROP : bi} (Γp Γs : env PROP) : PROP :=
  (⌜envs_wf' Γp Γs⌝ ∧ env_and_persistently Γp ∧ [∗] Γs)%I.
Global Instance: Params (@of_envs') 1 := {}.
Definition of_envs {PROP : bi} (Δ : envs PROP) : PROP :=
  of_envs' (env_intuitionistic Δ) (env_spatial Δ).
Global Instance: Params (@of_envs) 1 := {}.
Global Arguments of_envs : simpl never.

Local Definition pre_envs_entails_def {PROP : bi} (Γp Γs : env PROP) (Q : PROP) :=
  of_envs' Γp Γs ⊢ Q.
Local Definition pre_envs_entails_aux : seal (@pre_envs_entails_def).
Proof. by eexists. Qed.
Local Definition pre_envs_entails := pre_envs_entails_aux.(unseal).
Local Definition pre_envs_entails_unseal :
  @pre_envs_entails = @pre_envs_entails_def := pre_envs_entails_aux.(seal_eq).

Definition envs_entails {PROP : bi} (Δ : envs PROP) (Q : PROP) : Prop :=
  pre_envs_entails  PROP (env_intuitionistic Δ) (env_spatial Δ) Q.
Definition envs_entails_unseal :
  @envs_entails = λ PROP (Δ : envs PROP) Q, (of_envs Δ ⊢ Q).
Proof. by rewrite /envs_entails pre_envs_entails_unseal. Qed.
Global Arguments envs_entails {PROP} Δ Q%I.
Global Instance: Params (@envs_entails) 1 := {}.

Record envs_Forall2 {PROP : bi} (R : relation PROP) (Δ1 Δ2 : envs PROP) := {
  env_intuitionistic_Forall2 : env_Forall2 R (env_intuitionistic Δ1) (env_intuitionistic Δ2);
  env_spatial_Forall2 : env_Forall2 R (env_spatial Δ1) (env_spatial Δ2)
}.

Definition envs_dom {PROP} (Δ : envs PROP) : list ident :=
  env_dom (env_intuitionistic Δ) ++ env_dom (env_spatial Δ).

Definition envs_lookup {PROP} (i : ident) (Δ : envs PROP) : option (bool * PROP) :=
  let (Γp,Γs,n) := Δ in
  match env_lookup i Γp with
  | Some P => Some (true, P)
  | None => P ← env_lookup i Γs; Some (false, P)
  end.

Definition envs_delete {PROP} (remove_intuitionistic : bool)
    (i : ident) (p : bool) (Δ : envs PROP) : envs PROP :=
  let (Γp,Γs,n) := Δ in
  match p with
  | true => Envs (if remove_intuitionistic then env_delete i Γp else Γp) Γs n
  | false => Envs Γp (env_delete i Γs) n
  end.

Definition envs_lookup_delete {PROP} (remove_intuitionistic : bool)
    (i : ident) (Δ : envs PROP) : option (bool * PROP * envs PROP) :=
  let (Γp,Γs,n) := Δ in
  match env_lookup_delete i Γp with
  | Some (P,Γp') => Some (true, P, Envs (if remove_intuitionistic then Γp' else Γp) Γs n)
  | None => '(P,Γs') ← env_lookup_delete i Γs; Some (false, P, Envs Γp Γs' n)
  end.

Fixpoint envs_lookup_delete_list {PROP} (remove_intuitionistic : bool)
    (js : list ident) (Δ : envs PROP) : option (bool * list PROP * envs PROP) :=
  match js with
  | [] => Some (true, [], Δ)
  | j :: js =>
     '(p,P,Δ') ← envs_lookup_delete remove_intuitionistic j Δ;
     '(q,Ps,Δ'') ← envs_lookup_delete_list remove_intuitionistic js Δ';
     Some ((p:bool) &&& q, P :: Ps, Δ'')
  end.

Definition envs_snoc {PROP} (Δ : envs PROP)
    (p : bool) (j : ident) (P : PROP) : envs PROP :=
  let (Γp,Γs,n) := Δ in
  if p then Envs (Esnoc Γp j P) Γs n else Envs Γp (Esnoc Γs j P) n.

Definition envs_app {PROP : bi} (p : bool)
    (Γ : env PROP) (Δ : envs PROP) : option (envs PROP) :=
  let (Γp,Γs,n) := Δ in
  match p with
  | true => _ ← env_app Γ Γs; Γp' ← env_app Γ Γp; Some (Envs Γp' Γs n)
  | false => _ ← env_app Γ Γp; Γs' ← env_app Γ Γs; Some (Envs Γp Γs' n)
  end.

Definition envs_simple_replace {PROP : bi} (i : ident) (p : bool)
    (Γ : env PROP) (Δ : envs PROP) : option (envs PROP) :=
  let (Γp,Γs,n) := Δ in
  match p with
  | true => _ ← env_app Γ Γs; Γp' ← env_replace i Γ Γp; Some (Envs Γp' Γs n)
  | false => _ ← env_app Γ Γp; Γs' ← env_replace i Γ Γs; Some (Envs Γp Γs' n)
  end.

Definition envs_replace {PROP : bi} (i : ident) (p q : bool)
    (Γ : env PROP) (Δ : envs PROP) : option (envs PROP) :=
  if beq p q then envs_simple_replace i p Γ Δ
  else envs_app q Γ (envs_delete true i p Δ).

Definition env_spatial_is_nil {PROP} (Δ : envs PROP) : bool :=
  if env_spatial Δ is Enil then true else false.

Definition envs_clear_spatial {PROP} (Δ : envs PROP) : envs PROP :=
  Envs (env_intuitionistic Δ) Enil (env_counter Δ).

Definition envs_clear_intuitionistic {PROP} (Δ : envs PROP) : envs PROP :=
  Envs Enil (env_spatial Δ) (env_counter Δ).

Definition envs_incr_counter {PROP} (Δ : envs PROP) : envs PROP :=
  Envs (env_intuitionistic Δ) (env_spatial Δ) (Pos_succ (env_counter Δ)).

Fixpoint envs_split_go {PROP}
    (js : list ident) (Δ1 Δ2 : envs PROP) : option (envs PROP * envs PROP) :=
  match js with
  | [] => Some (Δ1, Δ2)
  | j :: js =>
     '(p,P,Δ1') ← envs_lookup_delete true j Δ1;
     if p : bool then envs_split_go js Δ1 Δ2 else
     envs_split_go js Δ1' (envs_snoc Δ2 false j P)
  end.
(* if [d = Right] then [result = (remaining hyps, hyps named js)] and
   if [d = Left] then [result = (hyps named js, remaining hyps)] *)
Definition envs_split {PROP} (d : direction)
    (js : list ident) (Δ : envs PROP) : option (envs PROP * envs PROP) :=
  '(Δ1,Δ2) ← envs_split_go js Δ (envs_clear_spatial Δ);
  if d is Right then Some (Δ1,Δ2) else Some (Δ2,Δ1).

Fixpoint env_to_prop_go {PROP : bi} (acc : PROP) (Γ : env PROP) : PROP :=
  match Γ with Enil => acc | Esnoc Γ _ P => env_to_prop_go (P ∗ acc)%I Γ end.
Definition env_to_prop {PROP : bi} (Γ : env PROP) : PROP :=
  match Γ with Enil => emp%I | Esnoc Γ _ P => env_to_prop_go P Γ end.

Fixpoint env_to_prop_and_go {PROP : bi} (acc : PROP) (Γ : env PROP) : PROP :=
  match Γ with Enil => acc | Esnoc Γ _ P => env_to_prop_and_go (P ∧ acc)%I Γ end.
Definition env_to_prop_and {PROP : bi} (Γ : env PROP) : PROP :=
  match Γ with Enil => True%I | Esnoc Γ _ P => env_to_prop_and_go P Γ end.

Section envs.
Context {PROP : bi}.
Implicit Types Γ Γp Γs : env PROP.
Implicit Types Δ : envs PROP.
Implicit Types P Q : PROP.

Lemma of_envs_eq Δ :
  of_envs Δ =
  (⌜envs_wf Δ⌝ ∧
    env_and_persistently (env_intuitionistic Δ) ∧
    [∗] env_spatial Δ)%I.
Proof. done. Qed.

Lemma of_envs'_alt Γp Γs :
  of_envs' Γp Γs ⊣⊢ ⌜envs_wf' Γp Γs⌝ ∧ □ [∧] Γp ∗ [∗] Γs.
Proof.
  rewrite /of_envs'. f_equiv.
  rewrite -persistent_and_affinely_sep_l. f_equiv.
  clear. induction Γp as [|Γp IH ? Q]; simpl.
  { apply (anti_symm (⊢)); last by apply True_intro. apply persistently_True. }
  rewrite IH persistently_and. done.
Qed.
Lemma of_envs_alt Δ :
  of_envs Δ ⊣⊢ ⌜envs_wf Δ⌝ ∧ □ [∧] env_intuitionistic Δ ∗ [∗] env_spatial Δ.
Proof. rewrite /of_envs of_envs'_alt //. Qed.

Global Instance envs_Forall2_refl (R : relation PROP) :
  Reflexive R → Reflexive (envs_Forall2 R).
Proof. by constructor. Qed.
Global Instance envs_Forall2_sym (R : relation PROP) :
  Symmetric R → Symmetric (envs_Forall2 R).
Proof. intros ??? [??]; by constructor. Qed.
Global Instance envs_Forall2_trans (R : relation PROP) :
  Transitive R → Transitive (envs_Forall2 R).
Proof. intros ??? [??] [??] [??]; constructor; etrans; eauto. Qed.
Global Instance envs_Forall2_antisymm (R R' : relation PROP) :
  AntiSymm R R' → AntiSymm (envs_Forall2 R) (envs_Forall2 R').
Proof. intros ??? [??] [??]; constructor; by eapply (anti_symm _). Qed.
Lemma envs_Forall2_impl (R R' : relation PROP) Δ1 Δ2 :
  envs_Forall2 R Δ1 Δ2 → (∀ P Q, R P Q → R' P Q) → envs_Forall2 R' Δ1 Δ2.
Proof. intros [??] ?; constructor; eauto using env_Forall2_impl. Qed.

Global Instance env_intuitionistic_mono :
  Proper (envs_Forall2 (⊢) ==> env_Forall2 (⊢)) (@env_intuitionistic PROP).
Proof. solve_proper. Qed.
Global Instance env_intuitionistic_flip_mono :
  Proper (flip (envs_Forall2 (⊢)) ==> flip (env_Forall2 (⊢))) (@env_intuitionistic PROP).
Proof. solve_proper. Qed.
Global Instance env_intuitionistic_proper :
  Proper (envs_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢)) (@env_intuitionistic PROP).
Proof. solve_proper. Qed.

Global Instance env_spatial_mono :
  Proper (envs_Forall2 (⊢) ==> env_Forall2 (⊢)) (@env_spatial PROP).
Proof. solve_proper. Qed.
Global Instance env_spatial_flip_mono :
  Proper (flip (envs_Forall2 (⊢)) ==> flip (env_Forall2 (⊢))) (@env_spatial PROP).
Proof. solve_proper. Qed.
Global Instance env_spatial_proper :
  Proper (envs_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢)) (@env_spatial PROP).
Proof. solve_proper. Qed.

Global Instance of_envs_mono' :
  Proper (env_Forall2 (⊢) ==> env_Forall2 (⊢) ==> (⊢)) (@of_envs' PROP).
Proof.
  intros Γp1 Γp2 Hp Γs1 Γs2 Hs; apply and_mono; simpl in *.
  - apply pure_mono=> -[???]. constructor;
      naive_solver eauto using env_Forall2_wf, env_Forall2_fresh.
  - f_equiv; [|by repeat f_equiv].
    induction Hp; simpl; repeat (done || f_equiv).
Qed.
Global Instance of_envs_proper' :
  Proper (env_Forall2 (⊣⊢) ==> env_Forall2 (⊣⊢) ==> (⊣⊢)) (@of_envs' PROP).
Proof.
  intros Γp1 Γp2 Hp Γs1 Γs2 Hs; apply (anti_symm (⊢)); apply of_envs_mono';
    eapply (env_Forall2_impl (⊣⊢)); by eauto using equiv_entails_1_1.
Qed.

Global Instance of_envs_mono : Proper (envs_Forall2 (⊢) ==> (⊢)) (@of_envs PROP).
Proof. solve_proper. Qed.
Global Instance of_envs_proper : Proper (envs_Forall2 (⊣⊢) ==> (⊣⊢)) (@of_envs PROP).
Proof. solve_proper. Qed.

Global Instance Envs_proper (R : relation PROP) :
  Proper (env_Forall2 R ==> env_Forall2 R ==> eq ==> envs_Forall2 R) (@Envs PROP).
Proof. by constructor. Qed.

Global Instance envs_entails_proper :
  Proper (envs_Forall2 (⊣⊢) ==> (⊣⊢) ==> iff) (@envs_entails PROP).
Proof. rewrite envs_entails_unseal. solve_proper. Qed.
Global Instance envs_entails_mono :
  Proper (flip (envs_Forall2 (⊢)) ==> (⊢) ==> impl) (@envs_entails PROP).
Proof. rewrite envs_entails_unseal=> Δ1 Δ2 ? P1 P2 <- <-. by f_equiv. Qed.
Global Instance envs_entails_flip_mono :
  Proper (envs_Forall2 (⊢) ==> flip (⊢) ==> flip impl) (@envs_entails PROP).
Proof. rewrite envs_entails_unseal=> Δ1 Δ2 ? P1 P2 <- <-. by f_equiv. Qed.

Lemma envs_delete_intuitionistic Δ i : envs_delete false i true Δ = Δ.
Proof. by destruct Δ. Qed.
Lemma envs_delete_spatial Δ i :
  envs_delete false i false Δ = envs_delete true i false Δ.
Proof. by destruct Δ. Qed.

Lemma envs_lookup_delete_Some Δ Δ' rp i p P :
  envs_lookup_delete rp i Δ = Some (p,P,Δ')
  ↔ envs_lookup i Δ = Some (p,P) ∧ Δ' = envs_delete rp i p Δ.
Proof.
  rewrite /envs_lookup /envs_delete /envs_lookup_delete.
  destruct Δ as [Γp Γs]; rewrite /= !env_lookup_delete_correct.
  destruct (Γp !! i), (Γs !! i); naive_solver.
Qed.

Lemma envs_lookup_sound' Δ rp i p P :
  envs_lookup i Δ = Some (p,P) →
  of_envs Δ ⊢ □?p P ∗ of_envs (envs_delete rp i p Δ).
Proof.
  rewrite /envs_lookup /envs_delete !of_envs_eq=>?.
  apply pure_elim_l=> Hwf.
  destruct Δ as [Γp Γs], (Γp !! i) eqn:Heqo; simplify_eq/=.
  - rewrite pure_True ?left_id; last (destruct Hwf, rp; constructor;
      naive_solver eauto using env_delete_wf, env_delete_fresh).
    rewrite -persistently_and_intuitionistically_sep_l assoc.
    apply and_mono; last done. apply and_intro.
    + rewrite (env_lookup_perm Γp) //= and_elim_l //.
    + destruct rp; last done.
      rewrite (env_lookup_perm Γp) //= and_elim_r //.
  - destruct (Γs !! i) eqn:?; simplify_eq/=.
    rewrite pure_True ?left_id; last (destruct Hwf; constructor;
      naive_solver eauto using env_delete_wf, env_delete_fresh).
    rewrite (env_lookup_perm Γs) //=.
    rewrite ![(P ∗ _)%I]comm.
    rewrite persistent_and_sep_assoc. done.
Qed.
Lemma envs_lookup_sound Δ i p P :
  envs_lookup i Δ = Some (p,P) →
  of_envs Δ ⊢ □?p P ∗ of_envs (envs_delete true i p Δ).
Proof. apply envs_lookup_sound'. Qed.
Lemma envs_lookup_intuitionistic_sound Δ i P :
  envs_lookup i Δ = Some (true,P) → of_envs Δ ⊢ □ P ∗ of_envs Δ.
Proof. intros ?%(envs_lookup_sound' _ false). by destruct Δ. Qed.
Lemma envs_lookup_sound_2 Δ i p P :
  envs_wf Δ → envs_lookup i Δ = Some (p,P) →
  □?p P ∗ of_envs (envs_delete true i p Δ) ⊢ of_envs Δ.
Proof.
  rewrite /envs_lookup !of_envs_eq=>Hwf ?.
  rewrite [⌜envs_wf Δ⌝%I]pure_True // left_id.
  destruct Δ as [Γp Γs], (Γp !! i) eqn:Heqo; simplify_eq/=.
  - rewrite -persistently_and_intuitionistically_sep_l.
    rewrite (env_lookup_perm Γp) //= [(⌜_⌝ ∧ _)%I]and_elim_r !assoc //.
  - destruct (Γs !! i) eqn:?; simplify_eq/=.
    rewrite (env_lookup_perm Γs) //=.
    rewrite [(⌜_⌝ ∧ _)%I]and_elim_r.
    rewrite (comm _ P) -persistent_and_sep_assoc.
    apply and_mono; first done. rewrite comm //.
Qed.

Lemma envs_lookup_split Δ i p P :
  envs_lookup i Δ = Some (p,P) → of_envs Δ ⊢ □?p P ∗ (□?p P -∗ of_envs Δ).
Proof.
  intros. apply pure_elim with (envs_wf Δ).
  { rewrite of_envs_eq. apply and_elim_l. }
  intros. rewrite {1}envs_lookup_sound//.
  apply sep_mono_r. apply wand_intro_l, envs_lookup_sound_2; done.
Qed.

Lemma envs_lookup_delete_sound Δ Δ' rp i p P :
  envs_lookup_delete rp i Δ = Some (p,P,Δ') → of_envs Δ ⊢ □?p P ∗ of_envs Δ'.
Proof. intros [? ->]%envs_lookup_delete_Some. by apply envs_lookup_sound'. Qed.

Lemma envs_lookup_delete_list_sound Δ Δ' rp js p Ps :
  envs_lookup_delete_list rp js Δ = Some (p,Ps,Δ') →
  of_envs Δ ⊢ □?p [∗] Ps ∗ of_envs Δ'.
Proof.
  revert Δ Δ' p Ps. induction js as [|j js IH]=> Δ Δ'' p Ps ?; simplify_eq/=.
  { by rewrite intuitionistically_emp left_id. }
  destruct (envs_lookup_delete rp j Δ) as [[[q1 P] Δ']|] eqn:Hj; simplify_eq/=.
  apply envs_lookup_delete_Some in Hj as [Hj ->].
  destruct (envs_lookup_delete_list _ js _) as [[[q2 Ps'] ?]|] eqn:?; simplify_eq/=.
  rewrite -intuitionistically_if_sep_2 -assoc.
  rewrite envs_lookup_sound' //; rewrite IH //.
  repeat apply sep_mono=>//; apply intuitionistically_if_flag_mono; by destruct q1.
Qed.

Lemma envs_lookup_delete_list_cons Δ Δ' Δ'' rp j js p1 p2 P Ps :
  envs_lookup_delete rp j Δ = Some (p1, P, Δ') →
  envs_lookup_delete_list rp js Δ' = Some (p2, Ps, Δ'') →
  envs_lookup_delete_list rp (j :: js) Δ = Some (p1 &&& p2, (P :: Ps), Δ'').
Proof. rewrite //= => -> //= -> //=. Qed.

Lemma envs_lookup_delete_list_nil Δ rp :
  envs_lookup_delete_list rp [] Δ = Some (true, [], Δ).
Proof. done. Qed.

Lemma envs_lookup_snoc Δ i p P :
  envs_lookup i Δ = None → envs_lookup i (envs_snoc Δ p i P) = Some (p, P).
Proof.
  rewrite /envs_lookup /envs_snoc=> ?.
  destruct Δ as [Γp Γs], p, (Γp !! i); simplify_eq; by rewrite env_lookup_snoc.
Qed.
Lemma envs_lookup_snoc_ne Δ i j p P :
  i ≠ j → envs_lookup i (envs_snoc Δ p j P) = envs_lookup i Δ.
Proof.
  rewrite /envs_lookup /envs_snoc=> ?.
  destruct Δ as [Γp Γs], p; simplify_eq; by rewrite env_lookup_snoc_ne.
Qed.

Lemma envs_snoc_sound Δ p i P :
  envs_lookup i Δ = None → of_envs Δ ⊢ □?p P -∗ of_envs (envs_snoc Δ p i P).
Proof.
  rewrite /envs_lookup /envs_snoc !of_envs_eq=> ?; apply pure_elim_l=> Hwf.
  destruct Δ as [Γp Γs], (Γp !! i) eqn:?, (Γs !! i) eqn:?; simplify_eq/=.
  apply wand_intro_l; destruct p; simpl.
  - apply and_intro; [apply pure_intro|].
    + destruct Hwf; constructor; simpl; eauto using Esnoc_wf.
      intros j; destruct (ident_beq_reflect j i); naive_solver.
    + rewrite -persistently_and_intuitionistically_sep_l assoc //.
  - apply and_intro; [apply pure_intro|].
    + destruct Hwf; constructor; simpl; eauto using Esnoc_wf.
      intros j; destruct (ident_beq_reflect j i); naive_solver.
    + rewrite (comm _ P) -persistent_and_sep_assoc.
      apply and_mono; first done. rewrite comm //.
Qed.

Lemma envs_app_sound Δ Δ' p Γ :
  envs_app p Γ Δ = Some Δ' →
  of_envs Δ ⊢ (if p then <affine> env_and_persistently Γ else [∗] Γ) -∗ of_envs Δ'.
Proof.
  rewrite !of_envs_eq /envs_app=> ?; apply pure_elim_l=> Hwf.
  destruct Δ as [Γp Γs], p; simplify_eq/=.
  - destruct (env_app Γ Γs) eqn:Happ,
      (env_app Γ Γp) as [Γp'|] eqn:Heqo; simplify_eq/=.
    apply wand_intro_l, and_intro; [apply pure_intro|].
    + destruct Hwf; constructor; simpl; eauto using env_app_wf.
      intros j. apply (env_app_disjoint _ _ _ j) in Happ.
      naive_solver eauto using env_app_fresh.
    + apply and_intro.
      * rewrite and_elim_l. rewrite (env_app_perm _ _ Γp') //.
        rewrite affinely_elim big_opL_app sep_and. done.
      * rewrite and_elim_r. rewrite sep_elim_r. done.
  - destruct (env_app Γ Γp) eqn:Happ,
      (env_app Γ Γs) as [Γs'|] eqn:?; simplify_eq/=.
    apply wand_intro_l, and_intro; [apply pure_intro|].
    + destruct Hwf; constructor; simpl; eauto using env_app_wf.
      intros j. apply (env_app_disjoint _ _ _ j) in Happ.
      naive_solver eauto using env_app_fresh.
    + rewrite (env_app_perm _ _ Γs') // big_opL_app. apply and_intro.
      * rewrite and_elim_l. rewrite sep_elim_r. done.
      * rewrite and_elim_r. done.
Qed.

Lemma envs_app_singleton_sound Δ Δ' p j Q :
  envs_app p (Esnoc Enil j Q) Δ = Some Δ' → of_envs Δ ⊢ □?p Q -∗ of_envs Δ'.
Proof. move=> /envs_app_sound. destruct p; by rewrite /= right_id. Qed.

Lemma envs_simple_replace_sound' Δ Δ' i p Γ :
  envs_simple_replace i p Γ Δ = Some Δ' →
  of_envs (envs_delete true i p Δ) ⊢
  (if p then <affine> env_and_persistently Γ else [∗] Γ) -∗ of_envs Δ'.
Proof.
  rewrite /envs_simple_replace /envs_delete !of_envs_eq=> ?.
  apply pure_elim_l=> Hwf. destruct Δ as [Γp Γs], p; simplify_eq/=.
  - destruct (env_app Γ Γs) eqn:Happ,
      (env_replace i Γ Γp) as [Γp'|] eqn:Heqo; simplify_eq/=.
    apply wand_intro_l, and_intro; [apply pure_intro|].
    + destruct Hwf; constructor; simpl; eauto using env_replace_wf.
      intros j. apply (env_app_disjoint _ _ _ j) in Happ.
      destruct (decide (i = j)); try naive_solver eauto using env_replace_fresh.
    + rewrite (env_replace_perm _ _ Γp') //.
      rewrite big_opL_app. apply and_intro; first apply and_intro.
      * rewrite and_elim_l affinely_elim sep_elim_l. done.
      * rewrite sep_elim_r and_elim_l //.
      * rewrite and_elim_r sep_elim_r //.
  - destruct (env_app Γ Γp) eqn:Happ,
      (env_replace i Γ Γs) as [Γs'|] eqn:?; simplify_eq/=.
    apply wand_intro_l, and_intro; [apply pure_intro|].
    + destruct Hwf; constructor; simpl; eauto using env_replace_wf.
      intros j. apply (env_app_disjoint _ _ _ j) in Happ.
      destruct (decide (i = j)); try naive_solver eauto using env_replace_fresh.
    + rewrite (env_replace_perm _ _ Γs') // big_opL_app.
      apply and_intro.
      * rewrite and_elim_l. rewrite sep_elim_r. done.
      * rewrite and_elim_r. done.
Qed.

Lemma envs_simple_replace_singleton_sound' Δ Δ' i p j Q :
  envs_simple_replace i p (Esnoc Enil j Q) Δ = Some Δ' →
  of_envs (envs_delete true i p Δ) ⊢ □?p Q -∗ of_envs Δ'.
Proof. move=> /envs_simple_replace_sound'. destruct p; by rewrite /= right_id. Qed.

Lemma envs_simple_replace_sound Δ Δ' i p P Γ :
  envs_lookup i Δ = Some (p,P) → envs_simple_replace i p Γ Δ = Some Δ' →
  of_envs Δ ⊢ □?p P ∗ ((if p then <affine> env_and_persistently Γ else [∗] Γ) -∗ of_envs Δ').
Proof. intros. by rewrite envs_lookup_sound// envs_simple_replace_sound'//. Qed.

Lemma envs_simple_replace_maybe_sound Δ Δ' i p P Γ :
  envs_lookup i Δ = Some (p,P) → envs_simple_replace i p Γ Δ = Some Δ' →
  of_envs Δ ⊢
  □?p P ∗ (((if p then <affine> env_and_persistently Γ else [∗] Γ) -∗ of_envs Δ') ∧
           (□?p P -∗ of_envs Δ)).
Proof.
  intros. apply pure_elim with (envs_wf Δ).
  { rewrite of_envs_eq. apply and_elim_l. }
  intros. rewrite {1}envs_lookup_sound//. apply sep_mono_r, and_intro.
  - rewrite envs_simple_replace_sound'//.
  - apply wand_intro_l, envs_lookup_sound_2; done.
Qed.

Lemma envs_simple_replace_singleton_sound Δ Δ' i p P j Q :
  envs_lookup i Δ = Some (p,P) →
  envs_simple_replace i p (Esnoc Enil j Q) Δ = Some Δ' →
  of_envs Δ ⊢ □?p P ∗ (□?p Q -∗ of_envs Δ').
Proof.
  intros. by rewrite envs_lookup_sound// envs_simple_replace_singleton_sound'//.
Qed.

Lemma envs_replace_sound' Δ Δ' i p q Γ :
  envs_replace i p q Γ Δ = Some Δ' →
  of_envs (envs_delete true i p Δ) ⊢
  (if q then <affine> env_and_persistently Γ else [∗] Γ) -∗ of_envs Δ'.
Proof.
  rewrite /envs_replace; destruct (beq _ _) eqn:Hpq.
  - apply eqb_prop in Hpq as ->. apply envs_simple_replace_sound'.
  - apply envs_app_sound.
Qed.

Lemma envs_replace_singleton_sound' Δ Δ' i p q j Q :
  envs_replace i p q (Esnoc Enil j Q) Δ = Some Δ' →
  of_envs (envs_delete true i p Δ) ⊢ □?q Q -∗ of_envs Δ'.
Proof. move=> /envs_replace_sound'. destruct q; by rewrite /= ?right_id. Qed.

Lemma envs_replace_sound Δ Δ' i p q P Γ :
  envs_lookup i Δ = Some (p,P) → envs_replace i p q Γ Δ = Some Δ' →
  of_envs Δ ⊢ □?p P ∗ ((if q then <affine> env_and_persistently Γ else [∗] Γ) -∗ of_envs Δ').
Proof. intros. by rewrite envs_lookup_sound// envs_replace_sound'//. Qed.

Lemma envs_replace_singleton_sound Δ Δ' i p q P j Q :
  envs_lookup i Δ = Some (p,P) →
  envs_replace i p q (Esnoc Enil j Q) Δ = Some Δ' →
  of_envs Δ ⊢ □?p P ∗ (□?q Q -∗ of_envs Δ').
Proof. intros. by rewrite envs_lookup_sound// envs_replace_singleton_sound'//. Qed.

Lemma envs_lookup_envs_clear_spatial Δ j :
  envs_lookup j (envs_clear_spatial Δ)
  = '(p,P) ← envs_lookup j Δ; if p : bool then Some (p,P) else None.
Proof.
  rewrite /envs_lookup /envs_clear_spatial.
  destruct Δ as [Γp Γs]; simpl; destruct (Γp !! j) eqn:?; simplify_eq/=; auto.
  by destruct (Γs !! j).
Qed.

Lemma envs_clear_spatial_sound Δ :
  of_envs Δ ⊢ of_envs (envs_clear_spatial Δ) ∗ [∗] env_spatial Δ.
Proof.
  rewrite !of_envs_eq /envs_clear_spatial /=. apply pure_elim_l=> Hwf.
  rewrite -persistent_and_sep_assoc. apply and_intro.
  - apply pure_intro. destruct Hwf; constructor; simpl; auto using Enil_wf.
  - rewrite -persistent_and_sep_assoc left_id. done.
Qed.

Lemma envs_clear_intuitionistic_sound Δ :
  of_envs Δ ⊢
  env_and_persistently (env_intuitionistic Δ) ∗ of_envs (envs_clear_intuitionistic Δ).
Proof.
  rewrite !of_envs_eq /envs_clear_spatial /=. apply pure_elim_l=> Hwf.
  rewrite persistent_and_sep_1.
  rewrite (pure_True); first by rewrite 2!left_id.
  destruct Hwf. constructor; simpl; auto using Enil_wf.
Qed.

Lemma env_spatial_is_nil_intuitionistically Δ :
  env_spatial_is_nil Δ = true → of_envs Δ ⊢ □ of_envs Δ.
Proof.
  intros. rewrite !of_envs_eq; destruct Δ as [? []]; simplify_eq/=.
  rewrite /bi_intuitionistically !persistently_and.
  rewrite persistently_pure persistent_persistently -persistently_emp_2.
  apply and_intro; last done. rewrite !and_elim_r. done.
Qed.

Lemma envs_lookup_envs_delete Δ i p P :
  envs_wf Δ →
  envs_lookup i Δ = Some (p,P) → envs_lookup i (envs_delete true i p Δ) = None.
Proof.
  rewrite /envs_lookup /envs_delete=> -[?? Hdisj] Hlookup.
  destruct Δ as [Γp Γs], p; simplify_eq/=.
  - rewrite env_lookup_env_delete //. revert Hlookup.
    destruct (Hdisj i) as [->| ->]; [|done]. by destruct (Γs !! _).
  - rewrite env_lookup_env_delete //. by destruct (Γp !! _).
Qed.
Lemma envs_lookup_envs_delete_ne Δ rp i j p :
  i ≠ j → envs_lookup i (envs_delete rp j p Δ) = envs_lookup i Δ.
Proof.
  rewrite /envs_lookup /envs_delete=> ?. destruct Δ as [Γp Γs],p; simplify_eq/=.
  - destruct rp=> //. by rewrite env_lookup_env_delete_ne.
  - destruct (Γp !! i); simplify_eq/=; by rewrite ?env_lookup_env_delete_ne.
Qed.

Lemma envs_incr_counter_equiv Δ : envs_Forall2 (⊣⊢) Δ (envs_incr_counter Δ).
Proof. done. Qed.
Lemma envs_incr_counter_sound Δ : of_envs (envs_incr_counter Δ) ⊣⊢ of_envs Δ.
Proof. by f_equiv. Qed.

Lemma envs_split_go_sound js Δ1 Δ2 Δ1' Δ2' :
  (∀ j P, envs_lookup j Δ1 = Some (false, P) → envs_lookup j Δ2 = None) →
  envs_split_go js Δ1 Δ2 = Some (Δ1',Δ2') →
  of_envs Δ1 ∗ of_envs Δ2 ⊢ of_envs Δ1' ∗ of_envs Δ2'.
Proof.
  revert Δ1 Δ2.
  induction js as [|j js IH]=> Δ1 Δ2 Hlookup HΔ; simplify_eq/=; [done|].
  apply pure_elim with (envs_wf Δ1)=> [|Hwf].
  { by rewrite !of_envs_eq !and_elim_l sep_elim_l. }
  destruct (envs_lookup_delete _ j Δ1)
    as [[[[] P] Δ1'']|] eqn:Hdel; simplify_eq/=; auto.
  apply envs_lookup_delete_Some in Hdel as [??]; subst.
  rewrite envs_lookup_sound //; rewrite /= (comm _ P) -assoc.
  rewrite -(IH _ _ _ HΔ); last first.
   { intros j' P'; destruct (decide (j = j')) as [->|].
     - by rewrite (envs_lookup_envs_delete _ _ _ P).
     - rewrite envs_lookup_envs_delete_ne // envs_lookup_snoc_ne //. eauto. }
  rewrite (envs_snoc_sound Δ2 false j P) /= ?wand_elim_r; eauto.
Qed.
Lemma envs_split_sound Δ d js Δ1 Δ2 :
  envs_split d js Δ = Some (Δ1,Δ2) → of_envs Δ ⊢ of_envs Δ1 ∗ of_envs Δ2.
Proof.
  rewrite /envs_split=> ?. rewrite -(idemp bi_and (of_envs Δ)).
  rewrite {2}envs_clear_spatial_sound.
  rewrite (env_spatial_is_nil_intuitionistically (envs_clear_spatial _)) //.
  rewrite -persistently_and_intuitionistically_sep_l.
  rewrite (and_elim_l (<pers> _)%I)
          persistently_and_intuitionistically_sep_r intuitionistically_elim.
  destruct (envs_split_go _ _) as [[Δ1' Δ2']|] eqn:HΔ; [|done].
  apply envs_split_go_sound in HΔ as ->; last first.
  { intros j P. by rewrite envs_lookup_envs_clear_spatial=> ->. }
  destruct d; simplify_eq/=; [|done]. by rewrite comm.
Qed.

Lemma env_to_prop_sound Γ : env_to_prop Γ ⊣⊢ [∗] Γ.
Proof.
  destruct Γ as [|Γ i P]; simpl; first done.
  revert P. induction Γ as [|Γ IH ? Q]=>P; simpl.
  - by rewrite right_id.
  - rewrite /= IH (comm _ Q _) assoc. done.
Qed.

Lemma env_to_prop_and_pers_sound Γ i P :
  □ env_to_prop_and (Esnoc Γ i P) ⊣⊢ <affine> env_and_persistently (Esnoc Γ i P).
Proof.
  revert P. induction Γ as [|Γ IH ? Q]=>P; simpl.
  - by rewrite right_id.
  - rewrite /= IH. clear IH. f_equiv. simpl.
    rewrite assoc. f_equiv.
    rewrite persistently_and comm. done.
Qed.
End envs.


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

Require Export Ring.
Require Import BinPos BinNat.
Import InitialRing.

Set Implicit Arguments.

Ltac Ncst t :=
  match isNcst t with
    true => t
  | _ => constr:NotConstant
  end.

Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).


Require Import Coq.omega.Omega.
Require Import Bedrock.Word Bedrock.SepIL Bedrock.IL Bedrock.Memory.

Fixpoint allocated (base : W) (offset len : nat) : HProp :=
  match len with
    | O => Emp
    | S len' => (Ex v, (match offset with
                          | O => base
                          | _ => base ^+ $ (offset)
                        end) =*> v) * allocated base (4+offset) len'
  end%Sep.

Notation "p =?> len" := (allocated p O len) (at level 39) : Sep_scope.

Theorem allocated_extensional : forall base offset len, HProp_extensional (allocated base offset len).
  destruct len; reflexivity.
Qed.

Hint Immediate allocated_extensional.

Lemma Himp_refl : forall p, p ===> p.
  intros; hnf; intros; hnf; intros.
  apply PropX.Imply_I.
  apply PropX.Env.
  simpl; auto.
Qed.

Lemma allocated_shift_base' : forall base base' len offset offset',
  base ^+ $ (offset) = base' ^+ $ (offset')
  -> allocated base offset len ===> allocated base' offset' len.
Proof.
  induction len; intros.

  apply Himp_refl.

  unfold allocated; fold allocated.
  match goal with
    | [ |- context[(?X =*> _)%Sep] ] =>
      assert (X = base ^+ natToW offset)
  end.
  destruct offset; auto.
  W_eq.
  rewrite H0; clear H0.

  match goal with
    | [ |- context[(?X =*> _)%Sep] ] =>
      match X with
        | context[offset'] => assert (X = base' ^+ natToW offset')
      end
  end.
  destruct offset'; auto.
  W_eq.
  rewrite H0; clear H0.

  match goal with
    | [ H : ?X = _ |- context[(?Y =*> _)%Sep] ] => change Y with X; rewrite H
  end.
  intro. apply himp_star_frame. apply himp_ex. reflexivity.
  eapply IHlen. repeat rewrite natToW_plus.
  repeat rewrite (wplus_comm (natToW 4)).
  repeat rewrite wplus_assoc.
  unfold natToW in *. rewrite H. reflexivity.
Qed.

Theorem allocated_shift_base : forall base base' len len' offset offset',
  base ^+ $ (offset) = base' ^+ $ (offset')
  -> len = len'
  -> allocated base offset len ===> allocated base' offset' len'.
  intros; subst; apply allocated_shift_base'; auto.
Qed.

Lemma split_empty : forall m, semp m
  -> split m m m.
  unfold semp; intros; subst.
  split.

  Lemma disjoint'_emp : forall addrs, disjoint' addrs (smem_emp' _) (smem_emp' _).
    induction addrs; simpl; intuition.
  Qed.
  apply disjoint'_emp.

  Lemma join'_emp : forall addrs, smem_emp' _ = join' addrs (smem_emp' _) (smem_emp' _).
    induction addrs; simpl; intuition.
    congruence.
  Qed.

  apply join'_emp.
Qed.

Theorem allocated_split : forall base len' len offset,
  (len' <= len)%nat
  -> allocated base offset len ===> allocated base offset len' * allocated base (offset + 4 * len') (len - len').
Proof.
  induction len'; inversion 1.
  { simpl. intro. unfold empB, starB.
    rewrite heq_star_emp_r. reflexivity. }
  { replace (offset + 4 * 0) with offset by omega.
    simpl minus.
    unfold allocated at 2. unfold empB, starB. intro. rewrite heq_star_emp_l. reflexivity. }
  { replace (S len' - S len') with 0 by omega. intro.
    unfold allocated at 3. unfold empB, starB. rewrite heq_star_emp_r. reflexivity. }
  { subst.
    replace (offset + 4 * S len') with ((4 + offset) + 4 * len') by omega.
    unfold allocated at 1 2; fold allocated.
    unfold empB, starB, exB. intro.
    rewrite heq_star_assoc.
    repeat rewrite heq_ex_star.
    apply himp_ex. intros.
    apply himp_star_frame. reflexivity.
    simpl minus. eapply IHlen'. omega. }
Qed.

Theorem allocated_join : forall base len' len offset,
  (len' <= len)%nat
  -> allocated base offset len' * allocated base (offset + 4 * len') (len - len') ===> allocated base offset len.
Proof.
  induction len'; inversion 1.
  { intro; unfold starB, empB; simpl. rewrite heq_star_emp_r. reflexivity. }
  { replace (offset + 4 * 0) with offset by omega.
    simpl minus.
    unfold allocated at 1. unfold empB, starB. intro. rewrite heq_star_emp_l. reflexivity. }
  { replace (S len' - S len') with 0 by omega. intro.
    unfold allocated at 3. unfold empB, starB. rewrite heq_star_emp_r. reflexivity. }
  { subst.
    replace (offset + 4 * S len') with ((4 + offset) + 4 * len') by omega.
    unfold allocated at 1 3; fold allocated.
    unfold empB, starB, exB. intro.
    rewrite heq_star_assoc.
    repeat rewrite heq_ex_star.
    apply himp_ex. intros.
    apply himp_star_frame. reflexivity.
    simpl minus. eapply IHlen'. omega. }
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-07-02

flat context closure (Sternagel & Middeldorp, RTA'08)
*)

Set Implicit Arguments.

From CoLoR Require Import ATrs NatUtil LogicUtil ListUtil SN EqUtil VecUtil
     RelUtil BoundNat.
From Coq Require Import Max.

(***********************************************************************)
(** flat context closure of a rule *)

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig). Notation terms := (vector term).
  Notation rule := (rule Sig). Notation rules := (rules Sig).

  Lemma flat_cont_aux : forall n i, i < n -> i + S (n - S i) = n.

  Proof. lia. Qed.

  Definition flat_cont_symb n (f : Sig) i (h : i < arity f) :=
    Cont f (flat_cont_aux h) (fresh n i) Hole (fresh (n+i) (arity f - S i)).

  Arguments flat_cont_symb _ [f i] _.

  Variables (some_symbol : Sig) (arity_some_symbol : arity some_symbol > 0)
            (n : nat).

  Definition one_flat_cont := flat_cont_symb n arity_some_symbol.

  Definition flat_conts_symb n f :=
    map (fun x => flat_cont_symb n (N_prf x)) (L (arity f)).

  Variables (Fs : list Sig) (Fs_ok : forall x : Sig, In x Fs).

  Definition flat_conts n := flat_map (flat_conts_symb n) Fs.

  Definition flat_cont_rule (a : rule) c :=
    let (l,r) := a in mkRule (fill c l) (fill c r).

  Definition is_root_preserving (a : rule) := let (l,r) := a in
    match l, r with
      | Fun f _, Fun g _ => beq_symb f g
      | _, _ => true
    end.

  Definition flat_rule n (a : rule) :=
    if is_root_preserving a then a :: nil
      else map (flat_cont_rule a) (flat_conts n).

  Definition flat_rules R := flat_map (flat_rule (S n)) R.

  Lemma root_preserving : forall R a,
    is_root_preserving a = true -> In a R -> In a (flat_rules R).

  Proof.
    intros. unfold flat_rules. rewrite in_flat_map. exists a. split_all.
    unfold flat_rule. rewrite H. simpl. auto.
  Qed.

(***********************************************************************)
(** main theorem for standard rewriting *)

  Section red.

    Variables (R : rules) (hyp : n >= maxvar_rules R).

    Lemma red_flat : red (flat_rules R) << red R.

    Proof.
      intros t u h. redtac. unfold flat_rules in lr. rewrite in_flat_map in lr.
      destruct lr as [[a b] [h1 h2]]. unfold flat_rule in h2. simpl in h2.
      destruct a. simpl in h2. split_all. inversion H. subst. apply red_rule.
      hyp.
      destruct b. simpl in h2. split_all. inversion H. subst. apply red_rule.
      hyp.
      revert h2. case_beq_symb Sig f f0; intro. simpl in h2. split_all.
      inversion H. subst. apply red_rule. hyp.
      rewrite in_map_iff in h2.
      destruct h2 as [d [h3 h4]]. unfold flat_cont_rule in h3. inversion h3.
      clear h3. subst. unfold flat_conts in h4. rewrite in_flat_map in h4.
      destruct h4 as [g [h5 h6]]. unfold flat_conts_symb in h6.
      rewrite in_map_iff in h6. destruct h6 as [x [h3 h4]]. subst.
      unfold flat_cont_symb. simpl. rewrite !Vmap_cast, !Vmap_app. simpl.
      set (v1 := Vmap (sub s) (fresh (S n) x)).
      set (v2 := Vmap (sub s) (fresh (S(n+x)) (arity g - S x))).
      set (e := flat_cont_aux x). set (d' := Cont g e v1 Hole v2).
      set (v' := Vmap (sub s) t0). set (v0' := Vmap (sub s) t1).
      change (red R (fill c (fill d' (sub s (Fun f t0))))
        (fill c (fill d' (sub s (Fun f0 t1))))). rewrite !fill_fill.
      apply red_rule. hyp.
    Qed.

    Definition red_flat_cont := Rof (red (flat_rules R)) (fill one_flat_cont).

    Lemma red_one_flat_cont_intro : red R << red_flat_cont.

    Proof.
      intros t u h. redtac. subst. unfold red_flat_cont, Rof.
      rewrite !fill_fill.
      case_eq (is_root_preserving (mkRule l r)); intros.
      apply red_rule. unfold flat_rules. rewrite in_flat_map.
      exists (mkRule l r). split_all. unfold flat_rule. rewrite H. simpl. auto.
      destruct l. discr. destruct r. discr.
      destruct (cont_case (comp one_flat_cont c)). discr.
      destruct H0 as [d [g [i [vi [j [vj [e]]]]]]]. rewrite !H0, <- !fill_fill.
      set (l := Fun f t). set (r := Fun f0 t0).
      apply context_closed_red.
      assert (m : maxvar_rule (mkRule l r) < S n). eapply maxvar_rules_elim.
      apply lr. lia.
      rewrite !fill_sub with (n:=n).
      set (s' := maxvar_union (S n) s (fsub n (Vapp vi vj))).
      apply hd_red_incl_red. apply hd_red_rule. unfold flat_rules.
      rewrite in_flat_map. exists (mkRule l r). split_all. unfold flat_rule.
      unfold l, r. rewrite H, in_map_iff. assert (h : i < arity g). lia.
      exists (flat_cont_symb (S n) h). split_all. simpl.
      gen (flat_cont_aux h). assert (arity g - S i = j). lia.
      rewrite H1.
      intro. assert (e0=e). apply eq_unique. subst. refl.
      unfold flat_conts. rewrite in_flat_map. exists g. split. apply Fs_ok.
      unfold flat_conts_symb. rewrite in_map_iff. exists (N_ h). split_all.
      apply In_L.
      trans (maxvar_rule (mkRule l r)). lia. apply le_max_r.
      trans (maxvar_rule (mkRule l r)). lia. apply le_max_l.
    Qed.

    Lemma rtc_red_one_flat_cont_intro : forall t u, red R # t u ->
      red (flat_rules R) # (fill one_flat_cont t) (fill one_flat_cont u).

    Proof.
      induction 1. apply rt_step. apply red_one_flat_cont_intro. hyp.
      apply rt_refl. apply rt_trans with (fill one_flat_cont y); hyp.
    Qed.

    Lemma WF_red_flat : WF (red R) <-> WF (red (flat_rules R)).

    Proof.
      split; intro.
      (* -> *)
      intro t. gen (H t). induction 1. apply SN_intro; intros. apply H1.
      apply red_flat. hyp.
      (* <- *)
      intro t. geneq H t (fill one_flat_cont t). induction 1. intros. subst.
      apply SN_intro; intros. apply H0 with (fill one_flat_cont y). 2: refl.
      apply red_one_flat_cont_intro. hyp.
    Qed.

  End red.

(***********************************************************************)
(** main theorem for rewriting modulo *)

  Section red_mod.

    Variables E R : rules.
    Variable hypE : n >= maxvar_rules E.
    Variable hypR : n >= maxvar_rules R.

    Lemma WF_red_mod_flat :
      WF (red_mod E R) <-> WF (red_mod (flat_rules E) (flat_rules R)).

    Proof.
      split; intro.
      (* -> *)
      intro t. gen (H t). induction 1. apply SN_intro; intros. apply H1.
      do 2 destruct H2. exists x0. split.
      (* rewrite red_flat in H2. hyp. *) eapply incl_elim.
      eapply rtc_incl. apply red_flat. hyp.
      apply red_flat. hyp.
      (* <- *)
      intro t. geneq H t (fill one_flat_cont t). induction 1. intros. subst.
      apply SN_intro; intros. apply H0 with (fill one_flat_cont y). 2: refl.
      do 2 destruct H1. exists (fill one_flat_cont x). split.
      apply rtc_red_one_flat_cont_intro; hyp.
      apply red_one_flat_cont_intro; hyp.
    Qed.

  End red_mod.

End S.

(***********************************************************************)
(** functorization *)

Module Type FlatCC.
  Parameter Sig : Signature.
  Parameter Fs : list Sig.
  Parameter Fs_ok : forall x : Sig, In x Fs.
  Parameter some_symbol : Sig.
  Parameter arity_some_symbol : arity some_symbol > 0.
End FlatCC.

Module FlatCCProps (Import F : FlatCC).

  Notation rules := (rules Sig).

  Section red_mod.

    Variables E R : rules.

    Let n := max (maxvar_rules E) (maxvar_rules R).

    Definition flat_mod_rules := flat_rules n Fs.

    Lemma WF_red_mod_flat :
      WF (red_mod E R) <-> WF (red_mod (flat_mod_rules E) (flat_mod_rules R)).

    Proof.
      eapply WF_red_mod_flat. apply arity_some_symbol. apply Fs_ok.
      apply le_max_l. apply le_max_r.
    Qed.

  End red_mod.

  Section red.

    Variable R : rules.

    Let n := maxvar_rules R.

    Definition flat_rules := flat_rules n Fs R.

    Lemma WF_red_flat : WF (red R) <-> WF (red flat_rules).

    Proof.
      eapply WF_red_flat. apply arity_some_symbol. apply Fs_ok. apply le_refl.
    Qed.

  End red.

  Ltac flat_cc :=
    match goal with
      | |- WF (red_mod _ _) => rewrite WF_red_mod_flat
      | |- WF (red _) => rewrite WF_red_flat
    end.

End FlatCCProps.


Record squash (A : Type) : Prop := sq { _ : A }.

Notation "∥ T ∥" := (squash T) (at level 10).
Arguments sq {_} _.

Lemma map_squash {A B} (f : A -> B) : ∥ A ∥ -> ∥ B ∥.
Proof.
  intros []; constructor; auto.
Qed.

Ltac sq :=
  repeat match goal with
  | H : ∥ _ ∥ |- _ => case H; clear H; intro H
  end; try eapply sq.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* In a connected graph, each vertex is bound by a path to each other.  *)
(* We define first a connected, then prove this property.               *)

(* The following notion is defined :                                    *)
(*      - Connected : defined upon a set of vertices and a set of arcs, *)
(*              constructors : C_isolated, C_leaf, C_edge, C_eq.        *)

Require Export Graphs.

Section CONNECTED.

Inductive Connected : V_set -> A_set -> Type :=
  | C_isolated : forall x : Vertex, Connected (V_single x) A_empty
  | C_leaf :
      forall (v : V_set) (a : A_set) (co : Connected v a) (x y : Vertex),
      v x ->
      ~ v y -> Connected (V_union (V_single y) v) (A_union (E_set x y) a)
  | C_edge :
      forall (v : V_set) (a : A_set) (co : Connected v a) (x y : Vertex),
      v x ->
      v y ->
      x <> y ->
      ~ a (A_ends x y) ->
      ~ a (A_ends y x) -> Connected v (A_union (E_set x y) a)
  | C_eq :
      forall (v v' : V_set) (a a' : A_set),
      v = v' -> a = a' -> Connected v a -> Connected v' a'.

Lemma Connected_not_empty :
 forall (v : V_set) (a : A_set), Connected v a -> v <> V_empty.
Proof.
        intros v a c; elim c; red; intros.
        elim (V_empty_nothing x); fold V_empty; rewrite <- H;
         apply V_in_single.
        elim (V_empty_nothing y); fold V_empty; rewrite <- H0;
         apply V_in_left; apply V_in_single.

        elim H; trivial.

        elim H; rewrite e; trivial.
Qed.

Lemma Connected_Isa_Graph :
 forall (v : V_set) (a : A_set), Connected v a -> Graph v a.
Proof.
        intros v a c; elim c; intros.
        apply G_eq with (v := V_union (V_single x) V_empty) (a := A_empty).
        rewrite V_union_commut; apply V_union_neutral.

        trivial.

        apply G_vertex.
        exact G_empty.

        compute. tauto.

        apply G_edge; intros.
        apply G_vertex; trivial.

        apply V_in_right; trivial.

        apply V_in_left; apply V_in_single.

        red; intros; elim n; rewrite <- H0; trivial.

        red; intros; elim n; apply (G_ina_inv2 _ _ H _ _ H0).

        red; intros; elim n; apply (G_ina_inv1 _ _ H _ _ H0).

        apply G_edge; trivial.

        apply G_eq with (v := v0) (a := a0); auto.
Qed.

Lemma C_v_dec :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 {v x} + {~ v x}.
Proof.
        intros; generalize (Connected_Isa_Graph v a c); intros g.
        apply (G_v_dec v a g x).
Qed.

Lemma C_a_dec :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Arc),
 {a x} + {~ a x}.
Proof.
        intros; generalize (Connected_Isa_Graph v a c); intros g.
        apply (G_a_dec v a g x).
Qed.

Lemma C_ina_inv1 :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 a (A_ends x y) -> v x.
Proof.
        intros; apply (G_ina_inv1 v a (Connected_Isa_Graph v a c) x y H).
Qed.

Lemma C_ina_inv2 :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 a (A_ends x y) -> v y.
Proof.
        intros; apply (G_ina_inv2 v a (Connected_Isa_Graph v a c) x y H).
Qed.

End CONNECTED.

Require Export Paths.

Section CONNECTED_BY_EDGES.

Remark V_included_union' : forall E F : V_set, V_included F (V_union E F).
Proof.
        intros; rewrite V_union_commut; apply V_included_union.
Qed.

Remark A_included_union' : forall E F : A_set, A_included F (A_union E F).
Proof.
        intros; rewrite A_union_commut; apply A_included_union.
Qed.

Lemma Connected_walk :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 v x -> v y -> {vl : V_list &  {el : E_list &  Walk v a x y vl el}}.
Proof.
        intros v a c; elim c; intros.
        split with V_nil; split with E_nil.
        inversion H.
        rewrite H1 in H0; inversion H0.
        apply W_null.
        apply V_in_single.

        case (V_union_single_dec _ _ _ n H0) as [e|v2];
         case (V_union_single_dec _ _ _ n H1) as [e0|v3].
        split with V_nil; split with E_nil.
        rewrite <- e; rewrite <- e0; apply W_null.
        apply V_in_left; apply V_in_single.

        elim (H x y0 v1 v3); intros.
        split with (x :: x1); elim p; intros.
        split with (E_ends y x :: x2); rewrite <- e; apply W_step.
        apply
         (Walk_subgraph v0 (V_union (V_single y) v0) a0
            (A_union (E_set x y) a0) x y0 x1 x2 p0).
        apply V_included_union'.

        apply A_included_union'.

        apply V_in_left; apply V_in_single.

        apply A_in_left; apply E_left.

        elim (H x0 x v2 v1); intros.
        split with (x1 ++ y0 :: V_nil); elim p; intros.
        split with (x2 ++ E_ends x y0 :: E_nil);
         apply Walk_append with (y := x).
        apply
         (Walk_subgraph _ (V_union (V_single y) v0) _
            (A_union (E_set x y) a0) _ _ _ _ p0).
        apply V_included_union'.

        apply A_included_union'.

        apply W_step.
        apply W_null.
        rewrite e0; apply V_in_left; apply V_in_single.

        apply V_in_right; trivial.
        rewrite e0; apply A_in_left; apply E_right.

        elim (H x0 y0 v2 v3); intros.
        split with x1; elim p; intros.
        split with x2;
         apply
          (Walk_subgraph _ (V_union (V_single y) v0) _
             (A_union (E_set x y) a0) _ _ _ _ p0).
        apply V_included_union'.

        apply A_included_union'.

        elim (H x0 y0 H0 H1); intros.
        split with x1; elim p; intros.
        split with x2;
         apply (Walk_subgraph _ v0 _ (A_union (E_set x y) a0) _ _ _ _ p0).
        unfold V_included, Included; auto.

        apply A_included_union'.

        elim (H x y); intros.
        split with x0; elim p; intros.
        split with x1; apply Walk_eq with (v := v0) (a := a0); auto.

        rewrite e; trivial.

        rewrite e; trivial.
Qed.

Lemma Connected_path :
 forall (v : V_set) (a : A_set) (g : Connected v a) (x y : Vertex),
 v x -> v y -> {vl : V_list &  {el : E_list &  Path v a x y vl el}}.
Proof.
        intros; elim (Connected_walk v a g x y H H0); intros.
        elim p; intros.
        apply (Walk_to_path v a x y x0 x1 p0).
Qed.

End CONNECTED_BY_EDGES.

Section INVERSION_CONNECTED.

Lemma C_minus_isolated :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 v x ->
 (forall y : Vertex, ~ a (A_ends x y)) -> v = V_single x /\ a = A_empty.
Proof.
        intros v a c; elim c; intros.
        inversion H; auto.

        case (V_union_single_dec _ _ _ n H0) as [e|v2].
        elim (H1 x); rewrite e; apply A_in_left; apply E_left.

        generalize (A_not_in_union _ _ _ H1); intros.
        generalize (H x0 v2 H2); intros; decompose [and] H3.
        elim (H1 y); rewrite H4 in v1; inversion v1; apply A_in_left;
         apply E_right.

        generalize (A_not_in_union _ _ _ H1); intros.
        generalize (H x0 H0 H2); intros; decompose [and] H3.
        rewrite H4 in v1; inversion v1; rewrite H4 in v2; inversion v2.
        elim n; rewrite <- H6; trivial.

        rewrite <- e; rewrite <- e0; apply H.
        rewrite e; trivial.

        rewrite e0; trivial.
Qed.

Lemma C_minus_isolated_left :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 v x -> (forall y : Vertex, ~ a (A_ends x y)) -> v = V_single x.
Proof.
        intros; elim (C_minus_isolated v a c x); auto.
Qed.

Lemma C_minus_isolated_right :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 v x -> (forall y : Vertex, ~ a (A_ends x y)) -> a = A_empty.
Proof.
        intros; elim (C_minus_isolated v a c x); auto.
Qed.

Lemma C_pendant_isolated :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y z : Vertex),
 ~ v y ->
 (forall t : Vertex, A_union (E_set x y) a (A_ends z t) -> t = y) ->
 forall t : Vertex, ~ a (A_ends z t).
Proof.
        intros; red; intros; elim H.
        generalize (H0 t); intros.
        rewrite <- H2.
        apply (C_ina_inv2 _ _ c _ _ H1).

        apply A_in_right; trivial.
Qed.

Lemma E_pendant_quasi_isolated :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 v y ->
 ~ a (A_ends y x) ->
 (forall z : Vertex, A_union (E_set x y) a (A_ends y z) -> z = x) ->
 v = V_single y.
Proof.
        intros; apply (C_minus_isolated_left _ _ c y H).
        red; intros; elim H0; rewrite <- (H1 y0).
        trivial.

        apply A_in_right; trivial.
Qed.

Lemma E_not_eq_traversal_pendant :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y x' y' : Vertex),
 v x ->
 v y ->
 x <> y ->
 ~ a (A_ends x y) ->
 ~ a (A_ends y x) ->
 v x' ->
 v y' ->
 (forall z : Vertex, A_union (E_set x y) a (A_ends y' z) -> z = x') ->
 E_set x y <> E_set x' y'.
Proof.
        intros; red; intros.
        generalize H6; rewrite H7; intros.
        generalize (E_eq_not_in' _ _ _ _ _ H2 H3 H7); intros.
        generalize (E_pendant_quasi_isolated _ _ c x' y' H5 H9 H8); intros.
        elim H1.
        rewrite H10 in H; inversion H.
        rewrite H10 in H0; inversion H0.
        rewrite <- H11; trivial.
Qed.

Lemma C_minus_pendant :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 v x ->
 v y ->
 (forall z : Vertex, a (A_ends y z) -> z = x) ->
 forall (v' : V_set) (a' : A_set),
 ~ v' y ->
 v = V_union (V_single y) v' ->
 ~ a' (A_ends x y) ->
 ~ a' (A_ends y x) -> a = A_union (E_set x y) a' -> Connected v' a'.
Proof.
        intros v a c; elim c; intros.
        elim (A_empty_nothing (A_ends x0 y)).
        fold A_empty; rewrite H6; apply A_in_left; apply E_right.

        case (V_union_single_dec _ _ _ n H1) as [e|v2].
        apply C_eq with (v := v0) (a := a0).
        apply (V_union_inversion (V_single y)).
        apply V_single_disjoint; trivial.

        rewrite e; apply V_single_disjoint; trivial.

        rewrite <- e in H4; trivial.

        generalize (H2 x); rewrite e; intros.
        apply (A_union_inversion (E_set x y)).
        apply E_set_disjoint; red; intros.
        elim n; apply (C_ina_inv2 _ _ co _ _ H9).

        elim n; apply (C_ina_inv1 _ _ co _ _ H9).

        rewrite e; rewrite H8.
        apply E_set_disjoint; trivial.

        apply A_in_left; apply E_left.

        fold A_union; rewrite H7; rewrite e; rewrite H8.
        trivial.

        apply A_in_left; apply E_left.

        trivial.

        case (V_union_single_dec _ _ _ n H0) as [e|v3].
        rewrite <- e in H2;
         generalize (C_pendant_isolated _ _ co x y y0 n H2);
         intros.
        generalize (C_minus_isolated _ _ co y0 v2 H8); intros.
        decompose [and] H9.
        apply C_eq with (v := V_single y) (a := A_empty).
        symmetry ; apply (V_union_single_single v' y y0).
        red; intros Heq; elim n; rewrite Heq; trivial.

        trivial.

        rewrite H10 in H4; trivial.

        apply (A_union_edge_edge a0 a' x0 y0).
        trivial.

        trivial.

        trivial.

        rewrite <- H7.
        rewrite H10 in v1; inversion v1.
        rewrite e; apply A_union_eq.
        apply E_set_eq.

        trivial.

        apply C_isolated.

        apply
         C_eq
          with
            (v := V_union (V_single y) (V_inter v0 v'))
            (a := A_union (E_set x y) (A_inter a0 a')).
        apply (V_union_single_inter y y0).
        trivial.

        red; intros Heq; elim n; rewrite Heq; trivial.

        trivial.

        apply (A_union_single_inter x y x0 y0).
        red; intros; elim n; apply (C_ina_inv2 _ _ co _ _ H8).

        red; intros; elim n; apply (C_ina_inv1 _ _ co _ _ H8).

        apply E_set_diff2.
        red; intros Heq; elim n; rewrite Heq; trivial.

        red; intros Heq; elim n; rewrite Heq; trivial.

        trivial.

        apply C_leaf.
        apply (H x0 y0 v3 v2).
        intros; apply (H2 z).
        apply A_in_right; trivial.

        red; intros Hi; elim H3; inversion Hi; trivial.

        symmetry ; rewrite V_inter_commut;
         apply (V_union_single_inter y0 y).
        trivial.

        red; intros Heq; elim n; rewrite <- Heq; trivial.

        auto.

        unfold A_inter.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        unfold A_inter.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        rewrite A_inter_commut; symmetry ;
         apply (A_union_single_inter x0 y0 x y).
        trivial.

        trivial.

        apply E_set_diff4; red; intros Heq; elim n; rewrite Heq;
         trivial.

        auto.

        apply V_in_inter.
        trivial.

        case (V_union_single_dec y0 x v') as [e|v4].
        trivial.

        rewrite <- H4; apply V_in_right; trivial.

        elim n; rewrite (H2 y).
        trivial.

        rewrite e; apply A_in_left; apply E_right.

        trivial.

        red; intros Hi; elim n; inversion Hi; trivial.

        generalize
         (E_not_eq_traversal_pendant _ _ co x y x0 y0 v1 v2 n n0 n1 H0 H1 H2);
         intros.
        apply C_eq with (v := v') (a := A_union (E_set x y) (A_inter a0 a')).
        trivial.

        apply (A_union_single_inter x y x0 y0); trivial.

        apply C_edge.
        apply (H x0 y0 H0 H1).
        intros; apply H2; apply A_in_right; trivial.

        trivial.

        trivial.

        unfold A_inter.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        unfold A_inter.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        rewrite A_inter_commut; symmetry ;
         apply (A_union_single_inter x0 y0 x y); auto.

        rewrite H4 in v1; inversion v1.
        elim H8; inversion H9.
        rewrite <- (H2 y).
        apply E_set_eq.

        rewrite H11; apply A_in_left; apply E_right.

        trivial.

        rewrite H4 in v2; inversion v2.
        elim H8; inversion H9.
        rewrite <- (H2 x).
        trivial.

        rewrite H11; apply A_in_left; apply E_left.

        trivial.

        trivial.

        apply A_not_inter; trivial.

        apply A_not_inter; trivial.

        apply (H x y).
        rewrite e; trivial.

        rewrite e; trivial.

        rewrite e0; trivial.

        trivial.

        rewrite e; trivial.

        trivial.

        trivial.

        rewrite e0; trivial.
Qed.

End INVERSION_CONNECTED.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Require Export SystemFR.Trees.
Require Export SystemFR.Syntax.
Require Export SystemFR.Tactics.

Require Export SystemFR.BaseType.
Require Export SystemFR.ErasedTermLemmas.
Require Export SystemFR.TypeErasure.
Require Export SystemFR.TypeErasureLemmas.

Lemma base_type_erase:
  forall X A B,
    base_type X A B ->
    base_type X (erase_type A) (erase_type B).
Proof.
  induction 1; repeat step || constructor;
    eauto with fv;
    eauto with erased.
Qed.