(** * Equational reasoning for Riesz spaces restricted to terms in negative normal form *)

Require Import CMorphisms.

Require Import EqNat.
Require Import PeanoNat.
Require Import Lra.

Require Import Rpos.
Require Import RL.hr.term.

Local Open Scope R_scope.

(** ** Basic definitions needed for equational reasoning *)
(** Context *)
Inductive context : Type :=
| RS_hole : context
| RS_cohole : context
| RS_TC : term -> context
| RS_varC : term.V -> context
| RS_covarC : term.V -> context
| RS_zeroC : context
| RS_minC : context -> context -> context
| RS_maxC : context -> context -> context
| RS_plusC : context -> context -> context
| RS_mulC : Rpos -> context -> context.

Fixpoint evalContext (c : context) (t : term) : term :=
  match c with
  | RS_hole => t
  | RS_cohole => -S t
  | RS_TC t' => t'
  | RS_varC n => RS_var n
  | RS_covarC n => RS_covar n
  | RS_zeroC => RS_zero
  | RS_minC c1 c2 => RS_min (evalContext c1 t) (evalContext c2 t)
  | RS_maxC c1 c2 => RS_max (evalContext c1 t) (evalContext c2 t)
  | RS_plusC c1 c2 => RS_plus (evalContext c1 t) (evalContext c2 t)
  | RS_mulC x c => RS_mul x (evalContext c t)
  end.

Fixpoint minusC c :=
  match c with
  | RS_hole => RS_cohole
  | RS_cohole => RS_hole
  | RS_TC t => RS_TC (-S t)
  | RS_varC n => RS_covarC n
  | RS_covarC n => RS_varC n
  | RS_zeroC => RS_zeroC
  | RS_plusC c1 c2 => RS_plusC (minusC c1) (minusC c2)
  | RS_mulC r c1 => RS_mulC r (minusC c1)
  | RS_maxC c1 c2 => RS_minC (minusC c1) (minusC c2)
  | RS_minC c1 c2 => RS_maxC (minusC c1) (minusC c2)
  end.

(** ** Equational Reasoning *)
Inductive eqMALG : term -> term -> Type :=
(** equational rules *)
| refl t : eqMALG t t
| trans t1 t2 t3 : eqMALG t1 t2 -> eqMALG t2 t3 -> eqMALG t1 t3
| ctxt c t1 t2 : eqMALG t1 t2 -> eqMALG (evalContext c t1) (evalContext c t2)
| sym t1 t2 : eqMALG t1 t2 -> eqMALG t2 t1
| subs_r t1 t2 n t : eqMALG t1 t2 -> eqMALG (subs t1 n t) (subs t2 n t)
(** vector space axioms *)
| asso_plus t1 t2 t3 : eqMALG (t1 +S (t2 +S t3)) ((t1 +S t2) +S t3)
| commu_plus t1 t2 : eqMALG (t1 +S t2) (t2 +S t1)
| neutral_plus t : eqMALG (t +S RS_zero) t
| opp_plus t : eqMALG (t -S t) RS_zero
| minus_ax a b t (Hlt: (projT1 b < projT1 a)%R) : eqMALG ((a *S t) +S (b *S (-S t))) ((minus_pos Hlt) *S t)
| mul_1 t  : eqMALG (One *S t) t
| mul_assoc x y t : eqMALG (x *S (y *S t)) ((time_pos x y) *S t)
| mul_distri_term x t1 t2 : eqMALG (x *S (t1 +S t2)) ((x *S t1) +S (x *S t2))
| mul_distri_coeff x y t : eqMALG ((plus_pos x y) *S t) ((x *S t) +S (y *S t))
| mul_minus x t : eqMALG (x *S (-S t)) (-S (x *S t))
(** lattice axioms *)
| asso_max t1 t2 t3 : eqMALG (t1 \/S (t2 \/S t3)) ((t1 \/S t2) \/S t3)
| commu_max t1 t2 : eqMALG (t1 \/S t2) (t2 \/S t1)
| abso_max t1 t2 : eqMALG (t1 \/S (t1 /\S t2)) t1
| asso_min t1 t2 t3 : eqMALG (t1 /\S (t2 /\S t3)) ((t1 /\S t2) /\S t3)
| commu_min t1 t2 : eqMALG (t1 /\S t2) (t2 /\S t1)
| abso_min t1 t2 : eqMALG (t1 /\S (t1 \/S t2)) t1
(** compability axiom *)
| compa_plus_ax t1 t2 t3 : eqMALG (((t1 /\S t2) +S t3) /\S (t2 +S t3)) ((t1 /\S t2) +S t3)
| compa_mul_ax r t : eqMALG (RS_zero /\S (r *S (t \/S RS_zero))) RS_zero.

Notation "A === B" := (eqMALG A B) (at level 90, no associativity).
Notation "A <== B" := (eqMALG (A /\S B) A) (at level 90, no associativity).

(** *** === is an equivalence relation **)

Instance eqMALG_Equivalence : Equivalence eqMALG | 10 := {
  Equivalence_Reflexive := refl ;
  Equivalence_Symmetric := sym ;
  Equivalence_Transitive := trans }.

(** *** Proofs of a equalities *)

Hint Constructors eqMALG : core.

Lemma cong_S : forall A B, A = B -> A === B.
Proof.
  intros A B eq.
  subst.
  reflexivity.
Qed.
Hint Resolve cong_S : core.

Lemma plus_left : forall A B C, A === C -> A +S B === C +S B.
Proof.
  intros A B C eq.
  apply (@ctxt (RS_plusC RS_hole (RS_TC B))).
  apply eq.
Qed.

Lemma plus_right : forall A B C, B === C -> A +S B === A +S C.
Proof.
  intros A B C eq.
  apply (@ctxt (RS_plusC (RS_TC A) RS_hole)).
  apply eq.
Qed.

Lemma plus_cong : forall A B C D, A === B -> C === D -> A +S C === B +S D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A +S D); [apply plus_right | apply plus_left]; assumption.
Qed.

Global Instance plus_cong_instance : Proper (eqMALG ==> eqMALG ==> eqMALG) RS_plus | 10.
Proof. repeat intro; now apply plus_cong. Qed.

Lemma max_left : forall A B C, A === C -> A \/S B === C \/S B.
Proof.
  intros A B C eq.
  apply (@ctxt (RS_maxC RS_hole (RS_TC B))).
  apply eq.
Qed.

Lemma max_right : forall A B C, B === C -> A \/S B === A \/S C.
Proof.
  intros A B C eq.
  apply (@ctxt (RS_maxC (RS_TC A) RS_hole)).
  apply eq.
Qed.

Lemma max_cong : forall A B C D, A === B -> C === D -> A \/S C === B \/S D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A \/S D); [apply max_right | apply max_left]; assumption.
Qed.

Global Instance max_cong_instance : Proper (eqMALG ==> eqMALG ==> eqMALG) RS_max | 10.
Proof. repeat intro; now apply max_cong. Qed.

Lemma min_left : forall A B C, A === C -> A /\S B === C /\S B.
Proof.
  intros A B C eq.
  apply (@ctxt (RS_minC RS_hole (RS_TC B))).
  apply eq.
Qed.

Lemma min_right : forall A B C, B === C -> A /\S B === A /\S C.
Proof.
  intros A B C eq.
  apply (@ctxt (RS_minC (RS_TC A) RS_hole)).
  apply eq.
Qed.

Lemma mul_left : forall x y A , x = y -> RS_mul x A === RS_mul y A.
Proof.
  intros x y A eq.
  rewrite eq.
  auto.
Qed.

Lemma min_cong : forall A B C D, A === B -> C === D -> A /\S C === B /\S D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A /\S D); [apply min_right | apply min_left]; assumption.
Qed.

Global Instance min_cong_instance : Proper (eqMALG ==> eqMALG ==> eqMALG) RS_min | 10.
Proof. repeat intro; now apply min_cong. Qed.

Lemma mul_right : forall x A B , A === B -> x *S A === x *S B.
Proof.
  intros x A B eq.
  apply (@ctxt (RS_mulC x RS_hole)).
  apply eq.
Qed.

Global Instance mul_right_instance x : Proper (eqMALG ==> eqMALG) (RS_mul x) | 10.
Proof. repeat intro; now apply mul_right. Qed.

Lemma minus_cong : forall A B , A === B -> -S A === -S B.
Proof.
  intros A B eq.
  apply (@ctxt RS_cohole).
  assumption.
Qed.

Global Instance minus_cong_instance : Proper (eqMALG ==> eqMALG) RS_minus | 10.
Proof. repeat intro; now apply minus_cong. Qed.

Hint Resolve plus_left plus_right max_left max_right min_left min_right minus_cong mul_left mul_right : core.

Lemma evalContext_cong : forall c t1 t2, t1 === t2 -> evalContext c t1 === evalContext c t2.
Proof.
  induction c; simpl; auto.
  all:intros t1 t2 eq; specialize (IHc1 t1 t2 eq); specialize (IHc2 t1 t2 eq).
  - etransitivity; [apply (@ctxt (RS_minC RS_hole (RS_TC (evalContext c2 t1)))); apply IHc1 |]; simpl.
    apply (@ctxt (RS_minC (RS_TC (evalContext c1 t2)) RS_hole)); apply IHc2.
  - etransitivity; [apply (@ctxt (RS_maxC RS_hole (RS_TC (evalContext c2 t1)))); apply IHc1 |]; simpl.
    apply (@ctxt (RS_maxC (RS_TC (evalContext c1 t2)) RS_hole)); apply IHc2.
  - etransitivity; [apply (@ctxt (RS_plusC RS_hole (RS_TC (evalContext c2 t1)))); apply IHc1 |]; simpl.
    apply (@ctxt (RS_plusC (RS_TC (evalContext c1 t2)) RS_hole)); apply IHc2.
Qed.

Global Instance evalContext_cong_instance c : Proper (eqMALG ==> eqMALG) (evalContext c) | 10.
Proof. repeat intro; now apply evalContext_cong. Qed.

Lemma leq_compa_plus : forall A B C, (A /\S B) +S C <== B +S C.
Proof.
  intros A B C.
  auto.
Qed.

Hint Resolve leq_compa_plus : MGA_solver.

Lemma minus_distri : forall A B, -S (A +S B) === (-S A) +S (-S B).
Proof.
  intros A B.
  auto.
Qed.

Hint Resolve minus_distri : MGA_solver.

Lemma minus_zero : RS_zero === -S RS_zero.
Proof.
  auto.
Qed.

Lemma minus_minus : forall A , -S (-S A) = A.
Proof with auto.
  induction A; simpl; try rewrite IHA; try rewrite IHA1; try rewrite IHA2...
Qed.

Hint Resolve minus_zero : MGA_solver.
Hint Resolve minus_minus : MGA_solver.

Lemma leq_antisym : forall A B, A <== B -> B <== A -> A === B.
Proof with auto.
  intros A B eq1 eq2.
  apply trans with (B /\S A)...
  apply trans with (A /\S B)...
Qed.

Lemma leq_cong_l : forall A A' B, A === A' -> A' <== B -> A <== B.
Proof with auto.
  intros A A' B eq leq.
  apply trans with (A' /\S B)...
  apply trans with A'...
Qed.

Lemma leq_cong_r : forall A B B', B === B' -> A <== B' -> A <== B.
Proof with auto.
  intros A B B' eq leq.
  apply trans with (A /\S B')...
Qed.

Lemma leq_trans : forall A B C, A <== B -> B <== C -> A <== C.
Proof with auto.
  intros A B C leq1 leq2.
  apply trans with ((A /\S B) /\S C)...
  apply trans with (A /\S (B /\S C))...
  apply trans with (A /\S B)...
Qed.

Lemma leq_plus : forall A B C, A <== B -> (A +S C) <== (B +S C).
Proof with auto.
  intros A B C leq.
  apply leq_cong_l with ((A /\S B) +S C)...
Qed.

Hint Resolve leq_plus : MGA_solver.

Lemma min_max : forall A B , (A /\S B) === A -> (A \/S B) === B.
Proof with auto.
  intros A B eq.
  apply trans with ((A /\S B) \/S B)...
  apply trans with ((B /\S A) \/S B)...
  apply trans with (B \/S (B /\S A))...
Qed.

Lemma max_min : forall A B , (A \/S B) === A -> (A /\S B) === B.
Proof with auto.
  intros A B eq.
  apply trans with ((A \/S B) /\S B)...
  apply trans with ((B \/S A) /\S B)...
  apply trans with (B /\S (B \/S A))...
Qed.

Hint Resolve max_min min_max : MGA_solver.

Lemma leq_refl_cong : forall A B, ((A /\S A) /\S B) === A /\S B.
Proof with auto.
  intros A B.
  apply trans with (A /\S (A /\S B))...
  apply max_min.
  apply abso_max.
Qed.

Lemma leq_refl : forall A , A /\S A === A.
Proof with auto.
  intro A.
  apply trans with (A /\S (A /\S (A \/S A)))...
  apply trans with ((A /\S A) /\S (A \/S A))...
  apply trans with (A /\S (A \/S A)); auto using leq_refl_cong.
Qed.

Hint Resolve leq_refl : MGA_solver.

Lemma leq_min : forall A B C, A <== B -> A <== C -> A <== (B /\S C).
Proof with auto.
  intros A B C leq1 leq2.
  apply trans with ((A /\S B) /\S C)...
  apply trans with (A /\S C)...
Qed.

Lemma leq_max : forall A B , A <== (A \/S B).
Proof with auto.
  intros A B.
  auto.
Qed.

Lemma min_leq : forall A B, (A /\S B) <== A.
Proof with auto with *.
  intros A B.
  apply trans with (A /\S (A /\S B))...
Qed.

Lemma max_leq : forall A B C, A <== C -> B <== C -> (A \/S B) <== C.
Proof with auto with *.
  intros A B C leq1 leq2.
  apply trans with (C /\S (A \/S B))...
  apply max_min.
  apply trans with ((A \/S B) \/S C)...
  apply trans with (A \/S (B \/S C))...
  apply trans with (A \/S C)...
Qed.

Hint Resolve leq_max min_leq min_leq max_leq : MGA_solver.

Lemma leq_plus_left : forall A B C, A <== B -S C -> A +S C <== B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_r with (B +S (-S C) +S C)...
  apply trans with (B +S ((-S C) +S C))...
  apply trans with (B +S (C -S C))...
  apply trans with (B +S RS_zero)...
Qed.

Lemma leq_plus_right : forall A B C, A -S B <== C -> A <== C +S B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_l with ( A -S B +S B)...
  apply trans with (A +S RS_zero)...
  apply trans with (A +S (B -S B))...
  apply trans with (A +S ((-S B) +S B))...
Qed.

Lemma leq_minus_left : forall A B C, A <== B +S C -> A -S C <== B.
Proof with auto.
  intros A B C leq.
  apply leq_plus_left...
  apply trans with (A /\S (B +S C)); auto using minus_minus.
Qed.

Lemma leq_minus_right : forall A B C , A +S C <== B -> A <== B -S C.
Proof with auto.
  intros A B C leq.
  apply leq_plus_right.
  apply trans with ((A +S C) /\S B); auto using minus_minus.
  apply trans with (A +S C); auto using minus_minus.
Qed.

Lemma max_plus : forall A B C, ((A \/S B) +S C) === (A +S C) \/S (B +S C).
Proof with auto.
  intros A B C.
  apply leq_antisym.
  - apply leq_plus_left.
    apply max_leq.
    + apply leq_minus_right...
    + apply leq_minus_right...
      apply trans with ((B +S C) /\S ((B +S C) \/S (A +S C)))...
  - apply max_leq; auto using leq_plus.
    apply leq_plus_right.
    apply leq_cong_l with B.
      * apply trans with (B +S (C -S C))...
        apply trans with (B +S RS_zero)...
      * apply leq_cong_r with (B \/S A)...
Qed.

Hint Resolve max_plus : MGA_solver.

Lemma minus_reverse_leq : forall A B, B <== A -> (-S A) <== (-S B).
Proof with auto.
  intros A B leq.
  apply leq_cong_r with (-S B +S RS_zero)...
  apply leq_cong_r with (RS_zero -S B)...
  apply leq_minus_right.
  apply leq_cong_l with (B -S A)...
  apply leq_minus_left.
  apply leq_cong_r with (A +S RS_zero)...
  apply leq_cong_r with A...
Qed.

Hint Resolve minus_reverse_leq : MGA_solver.

Lemma minus_min_max : forall A B, -S (A /\S B) === (-S A) \/S (-S B).
Proof with auto with MGA_solver.
  intros A B.
  apply leq_antisym.
  - apply leq_cong_r with (-S (-S ((-S A) \/S (-S B))))...
    apply minus_reverse_leq.
    apply leq_min.
    + apply leq_cong_r with (-S (-S A))...
    + apply leq_cong_r with (-S (-S B))...
      apply leq_cong_l with (-S (-S B \/S -S A))...
  - apply max_leq.
    + apply minus_reverse_leq...
    + apply leq_cong_r with (-S (B /\S A))...
Qed.

Lemma min_leq_max : forall A B, A /\S B <== A \/S B.
Proof with auto with MGA_solver.
  intros A B.
  apply leq_trans with A...
Qed.

Hint Resolve minus_min_max min_leq_max : MGA_solver.

Lemma minus_inj : forall A B, -S A === -S B -> A === B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (-S (-S A))...
  apply trans with (-S (-S B))...
Qed.

Lemma leq_plus_cong : forall A B C D, A <== B -> C <== D -> A +S C <== B +S D.
Proof with auto with MGA_solver.
  intros A B C D leq1 leq2.
  apply leq_trans with (B +S C)...
  apply leq_cong_l with (C +S B)...
  apply leq_cong_r with (D +S B)...
Qed.

Hint Resolve leq_plus_cong : MGA_solver.

Lemma cond_leq : forall A B, RS_zero <== (A -S B) -> B <== A.
Proof with auto with MGA_solver.
  intros A B Hleq.
  apply leq_cong_r with ((A -S B) +S B).
  { apply trans with (A +S RS_zero)...
    apply trans with (A +S (B -S B))...
    apply trans with (A +S ((-S B) +S B))... }
  apply leq_cong_l with (RS_zero +S B)...
  apply trans with (B +S RS_zero)...
Qed.

Lemma cond_leq_inv : forall A B, B <== A -> RS_zero <== (A -S B).
Proof with auto with MGA_solver.
  intros A B Hleq.
  apply leq_cong_l with (B -S B)...
Qed.

Lemma eq_minus : forall A B, A === B -> A -S B === RS_zero.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (B -S B)...
Qed.

Hint Resolve eq_minus : MGA_solver.

Lemma minus_eq : forall A B, A -S B === RS_zero -> A === B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (A +S RS_zero)...
  apply trans with (A +S (B -S B))...
  apply trans with (A +S ((-S B) +S B))...
  apply trans with (A -S B +S B)...
  apply trans with (RS_zero +S B)...
  apply trans with (B +S RS_zero)...
Qed.

Lemma mul_compa : forall (r : Rpos) A B, A <== B -> (r *S A) <== (r *S B).
Proof with auto with MGA_solver.
  intros r A B HleqAB.
  apply cond_leq.
  apply leq_cong_r with ((r *S ((B -S A) \/S RS_zero))).
  { apply trans with ((r *S B) +S (r *S (-S A)))...
    apply trans with (r *S (B -S A))...
    apply mul_right.
    apply sym.
    apply trans with (RS_zero \/S (B -S A))...
    apply min_max.
    apply cond_leq_inv...
  }
  apply compa_mul_ax...
Qed.

Hint Resolve mul_compa : MGA_solver.

Lemma mul_0 :  forall r, r *S RS_zero === RS_zero.
Proof with auto with MGA_solver.
  intro r.
  transitivity (r *S (RS_zero +S RS_zero))...
  transitivity (r *S RS_zero +S r *S RS_zero)...
  transitivity (r *S RS_zero +S r *S (-S RS_zero))...
  transitivity (r *S RS_zero +S (-S (r *S RS_zero)))...
Qed.

Hint Resolve mul_0 : MGA_solver.

Lemma no_div_zero : forall r A, r *S A === RS_zero -> A === RS_zero.
Proof with auto with MGA_solver.
  intros r A eq.
  transitivity (One *S A)...
  transitivity ((time_pos (inv_pos r) r) *S A)...
  { apply mul_left.
    apply Rpos_eq; destruct r; simpl. clear eq; apply R_blt_lt in e.
    rewrite Rinv_l...
    nra. }
  apply trans with ((inv_pos r) *S (r *S A))...
  apply trans with ((inv_pos r) *S RS_zero)...
Qed.

Lemma mul_distri_minus : forall k A B, (k *S A) -S (k *S B) === k *S (A -S B).
Proof with auto with MGA_solver.
  intros k A B.
  apply trans with ((k *S A) +S (k *S (-S B)))...
Qed.

Lemma minus_max_min : forall A B, -S (A \/S B) === (-S A) /\S (-S B).
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (-S (A \/S (-S (-S B))))...
  apply trans with (-S ((-S (-S A)) \/S (-S (-S B))))...
  apply trans with (-S (-S ((-S A) /\S (-S B))))...
Qed.

Hint Resolve mul_distri_minus minus_max_min : MGA_solver.

Lemma zero_leq_pos : forall A , RS_zero <== pos A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_r with (RS_zero \/S A)...
Qed.

Lemma zero_leq_neg : forall A , RS_zero <== neg A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_r with (RS_zero \/S (-S A))...
Qed.

Hint Resolve zero_leq_pos zero_leq_neg : MGA_solver.

Lemma eq_minus_right : forall A B C, A +S C === B -> A === B -S C.
Proof with auto with MGA_solver.
  intros A B C eq.
  apply trans with (A +S RS_zero)...
  apply trans with (A +S (C -S C))...
  apply trans with ((A +S C) -S C)...
Qed.

Lemma eq_plus_right : forall A B C, A -S C === B -> A === B +S C.
Proof with auto with MGA_solver.
  intros A B C eq.
  apply trans with (A +S RS_zero)...
  apply trans with (A +S (C -S C))...
  apply trans with (A +S ((-S C) +S C))...
  apply trans with ((A -S C) +S C)...
Qed.

Lemma decomp_pos_neg : forall A, A === (pos A) -S (neg A).
Proof with auto with MGA_solver.
  intros A.
  apply eq_minus_right.
  apply trans with (A \/S (A -S A))...
  apply trans with ((A +S RS_zero) \/S (A -S A))...
  apply trans with ((RS_zero +S A) \/S (A -S A))...
  apply trans with ((A -S A) \/S (RS_zero +S A))...
  apply trans with (((-S A) +S A) \/S (RS_zero +S A))...
  apply trans with (neg A +S A)...
Qed.

Hint Resolve decomp_pos_neg : MGA_solver.

Lemma pos_neg : forall A, pos A === A +S (neg A).
Proof.
  intros A.
  apply trans with ((pos A -S neg A) +S neg A); auto using eq_plus_right with MGA_solver.
Qed.

Lemma neg_pos : forall A , neg A === (pos A) -S A.
Proof with auto with MGA_solver.
  intros A.
  apply eq_minus_right...
  apply trans with (A +S neg A); auto using eq_plus_right with MGA_solver.
Qed.

Hint Resolve pos_neg neg_pos : MGA_solver.

Lemma min_plus : forall A B C, (A /\S B) +S C === (A +S C) /\S (B +S C).
Proof with auto with MGA_solver.
  intros A B C.
  apply trans with (-S (-S ((A +S C) /\S (B +S C))))...
  apply trans with (-S ((-S (A +S C)) \/S (-S (B +S C))))...
  apply trans with (-S (((-S A) -S C) \/S ((-S (B +S C)))))...
  apply trans with (-S (((-S A) -S C) \/S (((-S B) -S C))))...
  apply trans with (-S (((-S A) \/S ((-S B))) -S C))...
  apply trans with ((-S (((-S A) \/S ((-S B))))) -S (-S C))...
  apply trans with ((-S (((-S A) \/S ((-S B))))) +S C)...
  apply trans with (((-S (-S A)) /\S ((-S (-S B)))) +S C)...
  apply trans with ((A /\S ((-S (-S B)))) +S C)...
Qed.

Hint Resolve min_plus : MGA_solver.

Lemma min_pos_neg : forall A, (pos A) /\S (neg A) === RS_zero.
Proof with auto with MGA_solver.
  intros A.
  apply trans with ((A +S (neg A)) /\S (neg A))...
  apply trans with ((A +S (neg A)) /\S (neg A +S RS_zero))...
  apply trans with ((A +S (neg A)) /\S (RS_zero +S neg A))...
  apply trans with ((A /\S RS_zero) +S neg A)...
  apply trans with ( (-S (-S (A /\S RS_zero))) +S neg A)...
  apply trans with ( (-S ((-S A) \/S (-S RS_zero))) +S neg A)...
  apply trans with ( (-S (neg A)) +S neg A)...
  apply trans with (neg A -S neg A)...
Qed.

Hint Resolve min_pos_neg : MGA_solver.

Lemma cond_zero_leq_max : forall A B,
    (A \/S B) === (pos A \/S pos B) -> RS_zero <== A \/S B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with ((A \/S B) /\S RS_zero)...
  apply max_min.
  apply trans with ((A \/S B) \/S (RS_zero \/S RS_zero))...
  apply trans with (A \/S (B \/S (RS_zero \/S RS_zero)))...
  apply trans with (A \/S (pos B \/S RS_zero))...
  apply trans with (A \/S (RS_zero \/S pos B))...
  apply trans with (pos A \/S pos B)...
Qed.

Lemma cond_eq_pos : forall A B,
    RS_zero <== A \/S B -> (A \/S B) === (pos A \/S pos B).
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (A \/S (RS_zero \/S pos B))...
  apply trans with (A \/S (pos B \/S RS_zero))...
  apply trans with (A \/S (B \/S (RS_zero \/S RS_zero)))...
  apply trans with ((A \/S B) \/S (RS_zero \/S RS_zero))...
  apply trans with (A \/S B \/S RS_zero)...
  apply trans with (RS_zero \/S (A \/S B))...
Qed.

Lemma max_pos : forall A B, A \/S B === (pos (A -S B)) +S B.
Proof with auto with MGA_solver.
  intros A B.
  apply trans with ((A +S RS_zero) \/S B)...
  apply trans with ((A +S (B -S B)) \/S B)...
  apply trans with ((A +S ((-S B) +S B)) \/S B)...
  apply trans with ((A +S (-S B) +S B) \/S B)...
  apply trans with ((A +S (-S B) +S B) \/S (B +S RS_zero))...
  apply trans with ((A +S (-S B) +S B) \/S (RS_zero +S B))...
Qed.

Hint Resolve max_pos : MGA_solver.

Lemma min_pos : forall A B, A /\S B === A -S (pos (A -S B)).
Proof with auto with MGA_solver.
  intros A B.
  apply eq_minus_right.
  apply trans with ((pos (A -S B)) +S (A /\S B))...
  apply sym.
  apply eq_plus_right.
  apply trans with (A +S ((-S A) \/S (-S B)))...
  apply trans with (((-S A) \/S (-S B)) +S A)...
  apply trans with (((-S A) +S A) \/S ((-S B) +S A))...
  apply trans with ((A -S A) \/S ((-S B) +S A))...
  apply trans with (RS_zero \/S ((-S B) +S A))...
  apply trans with (RS_zero \/S (A -S B))...
Qed.

Hint Resolve min_pos : MGA_solver.

Lemma min_max_plus : forall A B, (A \/S B) +S (A /\S B) === A +S B.
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (((pos (A -S B)) +S B) +S (A /\S B))...
  apply trans with (((pos (A -S B)) +S B) +S (A -S (pos (A -S B))))...
  apply trans with ((B +S (pos (A -S B))) +S (A -S (pos (A -S B))))...
  apply trans with (B +S ((pos (A -S B)) +S (A -S (pos (A -S B)))))...
  apply trans with (B +S ((pos (A -S B)) +S ((-S (pos (A -S B))) +S A)))...
  apply trans with (B +S ((pos (A -S B)) +S (-S (pos (A -S B))) +S A))...
  apply trans with (B +S (RS_zero +S A))...
  apply trans with (B +S (A +S RS_zero))...
  apply trans with (B +S A)...
Qed.

Hint Resolve min_max_plus : MGA_solver.

Lemma max_distri_min : forall A B C, (A /\S B) \/S C === (A \/S C) /\S (B \/S C).
Proof with auto with MGA_solver.
  intros A B C.
  remember ((A \/S C) /\S (B \/S C)) as m.
  apply leq_antisym.
  - apply leq_cong_r with (A \/S C /\S B \/S C)...
    apply leq_min.
    + apply max_leq.
      * apply leq_trans with A...
      * apply leq_cong_r with (C \/S A)...
    + apply max_leq...
      * apply leq_trans with B...
        apply leq_cong_l with (B /\S A)...
      * apply leq_cong_r with (C \/S B)...
  - apply leq_cong_r with ((A /\S B) -S ((-S C) +S ((A /\S B) /\S C)))...
    + apply trans with ((A /\S B) +S ((-S (-S C)) -S ((A /\S B) /\S C)))...
      apply trans with ((A /\S B) +S (C -S ((A /\S B) /\S C)))...
      apply trans with (((A /\S B) +S C) -S ((A /\S B) /\S C)); auto using eq_minus_right with MGA_solver.
    + apply leq_minus_right...
      apply leq_min...
      * apply leq_cong_l with ((m +S ((A /\S B) /\S C)) -S C)...
        ** apply trans with (m +S (((A /\S B) /\S C) -S C))...
        ** apply leq_cong_r with ((A +S C) -S C); auto using eq_minus_right with MGA_solver.
           apply leq_plus.
           apply leq_cong_r with ((A \/S C) +S (A /\S C))...
           apply leq_trans with (m +S (A /\S C))...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A /\S (B /\S C))...
               apply leq_cong_l with (A /\S (C /\S B))...
               apply leq_cong_l with (A /\S C /\S B)...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A \/S C /\S B \/S C)...
      * apply leq_cong_l with (m +S ((A /\S B /\S C) -S C))...
        apply leq_cong_l with ((m +S (A /\S B /\S C)) -S C)...
        apply leq_cong_r with (B +S RS_zero)...
        apply leq_cong_r with (B +S (C -S C))...
        apply leq_cong_r with ((B +S C) -S C)...
        apply leq_plus...
        apply leq_cong_r with ((B \/S C) +S (B /\S C))...
        apply leq_plus_cong...
        apply leq_cong_l with (A \/S C /\S B \/S C)...
        ** apply leq_cong_l with (B \/S C /\S A \/S C)...
        ** apply leq_cong_l with (A /\S (B /\S C))...
           apply leq_cong_l with ((B /\S C) /\S A)...
Qed.

Hint Resolve max_distri_min : MGA_solver.

Lemma min_distri_max : forall A B C, (A \/S B) /\S C === (A /\S C) \/S (B /\S C).
Proof with auto with MGA_solver.
  intros A B C.
  apply trans with (-S (-S (A \/S B /\S C)))...
  apply trans with (-S ((-S (A \/S B) \/S (-S C))))...
  apply trans with (-S (((-S A) /\S (-S B)) \/S (-S C)))...
  apply trans with (-S (((-S A) \/S (-S C)) /\S ((-S B) \/S (-S C))))...
  apply trans with ((-S ((-S A) \/S (-S C))) \/S (-S ((-S B) \/S (-S C))))...
  apply trans with (((-S (-S A)) /\S (-S (-S C))) \/S (-S ((-S B) \/S (-S C))))...
  apply trans with (((-S (-S A)) /\S (-S (-S C))) \/S ((-S (-S B)) /\S (-S (-S C))))...
  apply trans with ((A /\S (-S (-S C))) \/S ((-S (-S B)) /\S (-S (-S C))))...
  apply trans with ((A /\S C) \/S ((-S (-S B)) /\S (-S (-S C))))...
  apply trans with ((A /\S C) \/S (B /\S (-S (-S C))))...
Qed.

Hint Resolve min_distri_max : MGA_solver.

Lemma decomp_max_pos_neg : forall A B, A \/S B === ((pos A) \/S (pos B)) -S ((neg A) /\S (neg B)).
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (pos (A \/S B) -S (neg (A \/S B)))...
  apply trans with ((pos A \/S pos B) -S (neg (A \/S B))).
  - apply (@ctxt (RS_plusC RS_hole (minusC (RS_TC (neg (A \/S B)))))).
    apply trans with (A \/S B \/S (RS_zero \/S RS_zero))...
    apply trans with (A \/S (B \/S pos RS_zero))...
    apply trans with (A \/S (pos B \/S RS_zero))...
    apply trans with (A \/S (RS_zero \/S pos B))...
  - apply trans with ((pos A \/S pos B) -S (((-S A) /\S (-S B)) \/S RS_zero))...
Qed.

Hint Resolve decomp_max_pos_neg : MGA_solver.

Lemma cond_zero_leq_max_2 : forall A B, (neg A) /\S (neg B) === RS_zero -> RS_zero <== A \/S B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply cond_zero_leq_max...
  apply trans with ((pos A \/S pos B) +S RS_zero)...
  apply trans with ((pos A \/S pos B) -S RS_zero)...
  apply trans with ((pos A \/S pos B) -S (neg A /\S neg B))...
Qed.

Lemma cond_min_neg_eq_zero : forall A B, RS_zero <== A \/S B -> (neg A) /\S (neg B) === RS_zero.
Proof with auto with MGA_solver.
  intros A B leq.
  apply trans with (((pos A) \/S (pos B)) -S (A \/S B)); auto using eq_minus_right, cond_eq_pos with MGA_solver.
  apply eq_minus_right...
  apply trans with ((A \/S B) +S (neg A /\S neg B)); auto using eq_plus_right with MGA_solver.
Qed.

Lemma zero_leq_abs : forall A, RS_zero <== abs A.
Proof with auto with MGA_solver.
  intro A.
  apply cond_zero_leq_max_2.
  apply trans with ((neg A) /\S (pos A))...
  apply trans with ((pos A) /\S (neg A))...
Qed.

Hint Resolve zero_leq_abs : MGA_solver.

Lemma mul_distri_max_pos : forall r A B, r *S (A \/S B) === (r *S A) \/S (r *S B).
Proof with auto with MGA_solver.
  intros r A B.
  apply leq_antisym.
  - apply leq_cong_r with (r *S ((inv_pos r) *S ((r *S A) \/S (r *S B)))).
    { apply trans with ((time_pos r (inv_pos r)) *S (r *S A \/S r *S B))...
      replace (time_pos r (inv_pos r)) with One...
      destruct r; apply Rpos_eq; simpl.
      apply R_blt_lt in e; rewrite Rinv_r...
      nra. }
    apply mul_compa.
    apply max_leq.
    + apply leq_cong_l with ((inv_pos r) *S (r *S A)).
      { apply trans with ((time_pos (inv_pos r) r) *S A)...
        replace (time_pos (inv_pos r) r) with One.
        2:{ apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; try auto; try nra. }
        auto with MGA_solver; apply Rgt_not_eq; apply Hlt. }
      apply mul_compa; try apply Rlt_le; try auto with MGA_solver.
    + apply leq_cong_l with ((inv_pos r) *S (r *S B)).
      { apply trans with ((time_pos (inv_pos r) r) *S B)...
        replace (time_pos (inv_pos r) r) with One.
        2:{ apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; try auto; try nra. }
        symmetry; apply mul_1. }
      apply mul_compa.
      eapply leq_cong_r ; [ apply commu_max | apply leq_max].
  - apply max_leq; apply mul_compa...
    apply leq_cong_r with (B \/S A)...
Qed.

Lemma mul_distri_min_pos : forall r A B, r *S (A /\S B) === (r *S A) /\S (r *S B).
Proof with auto with MGA_solver.
  intros r A B.
  apply leq_antisym.
  - apply leq_min; apply mul_compa...
    apply leq_cong_l with (B /\S A)...
  - apply leq_cong_l with (r *S ((inv_pos r) *S ((r *S A) /\S (r *S B)))).
    { apply trans with ((time_pos r (inv_pos r)) *S (r *S A /\S r *S B))...
      replace (time_pos r (inv_pos r)) with One...
      apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_r; nra. }
    apply mul_compa...
    apply leq_min.
    + apply leq_cong_r with ((inv_pos r) *S (r *S A)).
      { apply trans with ((time_pos (inv_pos r) r) *S A)...
        replace (time_pos (inv_pos r) r) with One...
        apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; nra. }
      apply mul_compa; try apply Rlt_le; try auto with MGA_solver.
    + apply leq_cong_r with ((inv_pos r) *S (r *S B)).
      { apply trans with ((time_pos (inv_pos r) r) *S B)...
        replace (time_pos (inv_pos r) r) with One...
        apply Rpos_eq; destruct r; simpl; apply R_blt_lt in e; rewrite Rinv_l; nra. }
      apply mul_compa; try apply Rlt_le; try auto with MGA_solver.
      apply leq_cong_l with (r *S B /\S r *S A)...
Qed.
Hint Resolve mul_distri_max_pos : MGA_solver.
Hint Resolve mul_distri_min_pos : MGA_solver.

Require Import Lra.

Lemma mul_distri_min : forall A B, (plus_pos One One) *S (A /\S B) === ((plus_pos One One) *S A) /\S ((plus_pos One One) *S B).
Proof with auto with MGA_solver.
  intros A B.
  apply trans with (-S (-S ((plus_pos One One) *S (A /\S B))))...
  apply trans with (-S ((plus_pos One One) *S (-S (A /\S B))))...
  apply trans with (-S ((plus_pos One One) *S ((-S A) \/S (-S B))))...
  apply trans with (-S (((plus_pos One One) *S (-S A)) \/S ((plus_pos One One) *S (-S B))))...
  apply trans with (-S ((-S ((plus_pos One One) *S A)) \/S ((plus_pos One One) *S (-S B))))...
  apply trans with (-S ((-S ((plus_pos One One) *S A)) \/S (-S ((plus_pos One One) *S B))))...
  apply trans with (-S (-S (((plus_pos One One) *S A) /\S ((plus_pos One One) *S B))))...
Qed.

Hint Resolve mul_distri_min : MGA_solver.

Lemma mul_2 : forall A , (plus_pos One One) *S A === A +S A.
Proof with auto with MGA_solver.
  intros A.
  transitivity (One *S A +S One *S A)...
  transitivity (One *S A +S A)...
Qed.

Hint Resolve mul_2 : MGA_solver.

Lemma mean_prop : forall A B , A +S B <== (plus_pos One One) *S (A \/S B).
Proof with auto with MGA_solver.
  intros A B.
  apply leq_cong_r with (((plus_pos One One) *S A) \/S ((plus_pos One One) *S B))...
  apply leq_trans with (A +S (A \/S B))...
  { apply leq_cong_r with (A +S (B \/S A))... }
  apply leq_cong_r with ((plus_pos One One) *S (A \/S B))...
  apply leq_cong_r with ((A \/S B) +S (A \/S B))...
Qed.

Hint Resolve mean_prop : MGA_solver.

Lemma decomp_abs : forall A , abs A === pos A +S neg A.
Proof with auto with MGA_solver.
  intro A.
  apply trans with ((A +S RS_zero) \/S (-S A))...
  etransitivity.
  { apply (@ctxt (RS_maxC (RS_plusC (RS_TC A) RS_hole) (RS_TC (-S A)))).
    symmetry; apply (@opp_plus A). }
  simpl.
  apply trans with (((A +S A) -S A) \/S (-S A))...
  apply trans with (((A +S A) -S A) \/S ((-S A) +S RS_zero))...
  apply trans with (((A +S A) -S A) \/S (RS_zero -S A))...
  apply trans with (((A +S A) \/S RS_zero) -S A)...
  transitivity ((((plus_pos One One) *S A) \/S RS_zero) -S A)...
  transitivity ((((plus_pos One One) *S A) \/S (RS_zero +S RS_zero)) -S A)...
  transitivity ((((plus_pos One One) *S A) \/S ((plus_pos One One) *S RS_zero)) -S A)...
  apply trans with (((plus_pos One One) *S (pos A)) -S A)...
  apply trans with ((pos A +S pos A) -S A)...
  apply trans with (pos A +S (pos A -S A))...
Qed.

Hint Resolve decomp_abs : MGA_solver.

Lemma pos_leq_abs : forall A , pos A <== abs A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_l with (pos A +S RS_zero)...
  apply leq_cong_r with (pos A +S neg A)...
Qed.

Lemma neg_leq_abs : forall A , neg A <== abs A.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_l with (neg A +S RS_zero)...
  apply leq_cong_l with (RS_zero +S neg A)...
  apply leq_cong_r with (pos A +S neg A)...
Qed.

Hint Resolve pos_leq_abs neg_leq_abs : MGA_solver.

Lemma abs_eq_zero : forall A , abs A === RS_zero -> A === RS_zero.
Proof with auto with MGA_solver.
  intros A eq.
  apply trans with (pos A -S neg A)...
  apply trans with (pos A -S RS_zero)...
  - apply plus_right.
    apply minus_cong.
    apply leq_antisym...
    apply leq_trans with (abs A)...
    apply leq_cong_r with (abs A)...
  - apply trans with (pos A +S RS_zero)...
    apply trans with (pos A)...
    apply leq_antisym...
    apply leq_trans with (abs A)...
    apply leq_cong_r with (abs A)...
Qed.

Lemma min_minus_leq_zero : forall A , A /\S (-S A) <== RS_zero.
Proof with auto with MGA_solver.
  intro A.
  apply leq_cong_l with (-S (-S (A /\S (-S A))))...
  apply leq_cong_r with (-S RS_zero)...
  apply minus_reverse_leq.
  apply leq_cong_r with ((-S A) \/S (-S (-S A)))...
Qed.

Hint Resolve min_minus_leq_zero : MGA_solver.

Lemma two_eq_zero : forall A , (plus_pos One One) *S A === RS_zero -> A === RS_zero.
Proof with auto with MGA_solver.
  intros A eq.
  assert (A === -S A).
  - apply trans with ((-S A) +S RS_zero)...
    apply trans with (RS_zero -S A)...
    apply eq_minus_right...
    apply trans with ((plus_pos One One) *S A)...
  - apply abs_eq_zero.
    apply leq_antisym...
    apply leq_cong_l with (A /\S (-S A))...
    apply trans with (A \/S A)...
    apply trans with A...
    apply trans with (A /\S A)...
Qed.

Lemma inj_mul_two : forall A B, (plus_pos One One) *S A === (plus_pos One One) *S B -> A === B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply trans with (B +S RS_zero)...
  apply trans with (RS_zero +S B)...
  apply eq_plus_right.
  apply two_eq_zero...
  apply trans with (((plus_pos One One) *S A) +S ((plus_pos One One) *S (-S B)))...
  apply trans with (((plus_pos One One) *S A) -S ((plus_pos One One) *S B))...
Qed.

Lemma leq_div_2 : forall A B , (plus_pos One One) *S A <== (plus_pos One One) *S B -> A <== B.
Proof with auto with MGA_solver.
  intros A B eq.
  apply inj_mul_two...
  apply trans with (((plus_pos One One) *S A) /\S ((plus_pos One One) *S B))...
Qed.

Lemma neg_subdistri_plus : forall A B, neg (A +S B) <== (neg A) +S (neg B).
Proof with auto with MGA_solver.
  intros A B.
  apply max_leq...
  - apply leq_cong_l with ((-S A) +S (-S B))...
  - apply leq_cong_l with (RS_zero +S RS_zero)...
Qed.

Hint Resolve neg_subdistri_plus : MGA_solver.

Lemma Rpos_mul_neg : forall t A, t *S neg A === neg (t *S A).
Proof with auto with MGA_solver.
  intros t A.
  etransitivity; [ apply mul_distri_max_pos | ].
  auto using mul_0.
Qed.

Hint Resolve Rpos_mul_neg : MGA_solver.

Lemma mul_leq : forall t A B, A <== B -> t *S A <== t *S B.
Proof.
  auto with MGA_solver.
Qed.

Hint Resolve mul_leq : MGA_solver.

Lemma mul_leq_inv : forall t A B, t *S A <== t *S B -> A <== B.
Proof with auto with MGA_solver.
  intros t A B Hle.
  apply leq_cong_r with (One *S B); try auto.
  apply leq_cong_l with (One *S A); try auto.
  replace One with (time_pos (inv_pos t) t).
  2:{ destruct t; apply Rpos_eq; simpl; clear Hle; apply R_blt_lt in e; rewrite Rinv_l; nra. }
  eapply leq_cong_r; [ symmetry; apply mul_assoc | ].
  eapply leq_cong_l; [ symmetry; apply mul_assoc | ]...
Qed.

Lemma neg_leq_cond : forall A B, A <== B -> neg B <== neg A.
Proof with try assumption.
  intros A B Hleq.
  apply max_leq.
  - apply leq_trans with (-S A).
    + apply minus_reverse_leq...
    + apply leq_max.
  - auto with MGA_solver.
Qed.

Lemma max_idempotence : forall A, A \/S A === A.
Proof.
  intros A.
  apply min_max.
  apply leq_refl.
Qed.

Lemma eq_subs_minus : forall A B n, subs (-S A) n B = -S (subs A n B).
Proof with try reflexivity.
  induction A ; intros B v'; try (simpl; constructor; assumption); try (simpl; rewrite IHA1; rewrite IHA2; auto with MGA_solver; fail)...
  - simpl; case (term.V_eq v' v)...
  - simpl; case (term.V_eq v' v)...
    rewrite minus_minus...
  - simpl; rewrite IHA...
Qed.

Lemma leq_pos_max_mul_l : forall A B r,
    RS_zero <== (r *S A) \/S B ->
    RS_zero <== A \/S B.
Proof.
  intros A B [r Hpos];
    remember (existT (fun r : R => (0 <? r)%R = true) r Hpos) as t; intros Hleq.
  apply cond_min_neg_eq_zero in Hleq.
  apply cond_zero_leq_max_2.
  apply leq_antisym.
  - case (Rlt_dec 1 r); intros Hlt; [ | case (Rlt_dec r 1); intros Hnlt].
    + eapply leq_cong_r; [ symmetry; apply Hleq | ].
      apply leq_min.
      * apply leq_trans with (neg A); [ apply min_leq | ].
        apply leq_cong_l with (RS_zero +S neg A).
        { etransitivity; [ | apply commu_plus ].
         symmetry; apply neutral_plus. }
        apply leq_plus_left.
        change (1%R) with (projT1 One) in Hlt.
        replace r with (projT1 t) in Hlt by now rewrite Heqt.
        eapply leq_cong_r.
        { etransitivity.
          { apply (@ctxt (RS_plusC RS_hole (RS_TC (-S neg A)))).
            symmetry; apply Rpos_mul_neg. }
          simpl evalContext.
          etransitivity.
          { change ((-S (-S A)) /\S RS_zero) with (-S neg A).
            apply (@ctxt (RS_plusC (RS_TC (t *S neg A)) RS_cohole)).
            etransitivity; [ symmetry; apply mul_1 | ].
            reflexivity. }
          simpl.
          change (One *S ((-S (-S A)) /\S RS_zero)) with (-S (One *S neg A)).
          etransitivity; [apply (minus_ax _ _ _ Hlt) | ].
          reflexivity. }
        apply leq_cong_r with (minus_pos Hlt *S (pos (neg A))).
        { etransitivity.
          2:{ apply (@ctxt (RS_mulC (minus_pos Hlt) RS_hole)).
              symmetry; apply (commu_max (neg A)). }
          simpl.
          apply (@ctxt (RS_mulC (minus_pos Hlt) RS_hole)).
          symmetry.
          apply min_max.
          auto with MGA_solver. }
        apply compa_mul_ax.
      * eapply leq_cong_l; [apply commu_min | ].
        apply min_leq.
    + apply (@mul_leq_inv t).
      eapply leq_cong_l; [ apply mul_distri_min_pos | ].
      eapply leq_cong_r; [ apply mul_0 | ].
      eapply leq_cong_r; [ symmetry; apply Hleq | ].
      apply leq_cong_r with ((t *S neg A) /\S neg B); [auto with MGA_solver | ].
      apply leq_min; [apply min_leq | ].
      eapply leq_cong_l; [ apply commu_min | ].
      apply leq_trans with (t *S neg B) ; [ apply min_leq | ].
      eapply leq_cong_l; [ symmetry; apply neutral_plus | ].
      eapply leq_cong_l; [ apply commu_plus | ].
      apply leq_plus_left.
      apply leq_cong_r with ((One *S neg B) -S (t *S neg B)); [ auto | ].
      apply leq_cong_r with ((One *S neg B) +S (t *S (-S neg B))); [auto | ].
      change (1%R) with (projT1 One) in Hnlt.
      replace r with (projT1 t) in Hnlt by now rewrite Heqt.
      eapply leq_cong_r; [ apply (minus_ax _ _ _ Hnlt) | ].
      apply leq_cong_r with (minus_pos Hnlt *S (pos (neg B))).
      { transitivity (minus_pos Hnlt *S (RS_zero \/S neg B)) ; [ | auto].
        apply (@ctxt (RS_mulC (minus_pos Hnlt) RS_hole)).
        symmetry.
        apply min_max; auto with MGA_solver. }
      apply compa_mul_ax.
    + assert (t = One) as Heq.
      { apply Rpos_eq; rewrite Heqt;simpl; nra. }
      eapply leq_cong_r; [ symmetry; apply Hleq | ].
      rewrite Heq.
      eapply leq_cong_r ; [ | apply leq_refl ].
      auto.
  - apply leq_min; (eapply leq_cong_r ; [ apply commu_max | ]); apply leq_max.
Qed.

Lemma leq_pos_max_mul_l_inv : forall A B r,
    RS_zero <== A \/S B ->
    RS_zero <== (r *S A) \/S B.
Proof.
  intros A B r Hleq.
  apply leq_pos_max_mul_l with (inv_pos r).
  apply leq_cong_r with ((time_pos (inv_pos r) r) *S A \/S B); [ auto | ].
  rewrite inv_pos_l.
  apply leq_cong_r with (A \/S B); [ auto | ].
  apply Hleq.
Qed.

Lemma plus_pos_min : forall A B C, RS_zero <== A -> RS_zero <== B -> RS_zero <== C -> A +S B /\S C <== (A /\S C) +S (B /\S C).
Proof.
  intros A B C H1 H2 H3.
  apply leq_plus_right.
  apply leq_min.
  - apply leq_minus_left.
    eapply leq_cong_r; [ apply commu_plus | ].
    apply leq_plus_right.
    apply leq_min.
    + apply leq_minus_left.
      eapply leq_cong_r; [ apply commu_plus | ].
      apply min_leq.
    + apply leq_trans with (A +S B /\S C).
      * apply leq_minus_left.
        eapply leq_cong_l ; [ symmetry; apply neutral_plus | ].
        apply leq_plus_cong; try assumption.
        apply leq_refl.
      * eapply leq_cong_l; [ apply commu_min | ].
        apply min_leq.
  - apply leq_minus_left.
    eapply leq_cong_r; [apply commu_plus | ].
    apply leq_plus_right.
    apply leq_min.
    + apply leq_minus_left.
      eapply leq_cong_r; [ apply commu_plus | ].
      eapply leq_cong_l; [ symmetry; apply neutral_plus | ].
      apply leq_plus_cong; try assumption.
      eapply leq_cong_l; [ apply commu_min | ].
      apply min_leq.
    + apply leq_minus_left.
      eapply leq_cong_l ; [ symmetry; apply neutral_plus | ].
      apply leq_plus_cong; try assumption.
      eapply leq_cong_l; [ apply commu_min | ].
      apply min_leq.
Qed.


Require Import Lists.List.
Import ListNotations.
Require Import String.

Module Copland.

Module Term.

Definition Plc: Set := string.
Definition N_ID: Set := nat.
Definition Event_ID: Set := nat.
Definition ASP_ID: Set := string.
Definition TARG_ID: Set := string.
Definition Arg: Set := string.

Notation plc_dec := string_dec.

(** The structure of evidence. *)

Inductive ASP_PARAMS: Set :=
| asp_paramsC: ASP_ID -> (list Arg) -> Plc -> TARG_ID -> ASP_PARAMS.

Inductive FWD: Set :=
| COMP
| ENCR
| EXTD
| KILL
| KEEP.
Theorem FWD_dec : forall a1 a2 : FWD, {a1=a2}+{~a1=a2}.
Proof. repeat decide equality. Defined.

Inductive SP: Set :=
| ALL
| NONE.
Theorem SP_dec : forall a1 a2 : SP, {a1=a2}+{~a1=a2}.
Proof. repeat decide equality. Defined.

Inductive ASP: Set :=
| NULL: ASP
| CPY: ASP
| ASPC: SP -> FWD -> ASP_PARAMS -> ASP
| SIG: ASP
| HSH: ASP.
Theorem ASP_dec : forall a1 a2 : ASP, {a1=a2}+{~a1=a2}.
Proof. repeat decide equality. Defined.

Definition Split: Set := (SP * SP).

Inductive Term: Set :=
| asp: ASP -> Term
| att: Plc -> Term -> Term
| lseq: Term -> Term -> Term
| bseq: Split -> Term -> Term -> Term
| bpar: Split -> Term -> Term -> Term.

Theorem Term_dec : forall a1 a2 : Term, {a1=a2}+{~a1=a2}.
Proof. repeat decide equality. Defined.

End Term.

Module Evidence.

Import Term.

Inductive Evidence: Set :=
| mt: Evidence
| nn: N_ID -> Evidence
| uu: Plc -> FWD -> ASP_PARAMS -> Evidence -> Evidence
| ss: Evidence -> Evidence -> Evidence.
Theorem Evidence_dec : forall a1 a2 : Evidence, {a1=a2}+{~a1=a2}.
Proof. repeat decide equality. Defined.

(** Abstract definitions for signing and hashing parameters.
May instantiate these during compilation in the future. *)
Definition sig_params : ASP_PARAMS.
Admitted.
Definition hsh_params : ASP_PARAMS.
Admitted.

Definition enc_params : Plc -> ASP_PARAMS.
Admitted.
Definition sp_ev (sp:SP) (e:Evidence) : Evidence :=
    match sp with
    | ALL => e
    | NONE => mt
    end.

(** Helper function for evidence type reference semantics *)
Definition eval_asp t p e :=
  match t with
  | NULL => mt
  | CPY => e
  | ASPC sp fwd params =>
    match fwd with
    | KEEP => (sp_ev sp e)
    | KILL => mt
    | _ => uu p fwd params (sp_ev sp e)
    end
  | SIG => uu p EXTD sig_params e
  | HSH => uu p COMP hsh_params e
  (* | ENC q => uu p ENCR (enc_params q) e*)
  end.

Definition splitEv_T_l (sp:Split) (e:Evidence) : Evidence :=
match sp with
| (ALL,_) => e
|  _ => mt
end.

Definition splitEv_T_r (sp:Split) (e:Evidence) : Evidence :=
match sp with
| (_,ALL) => e
|  _ => mt
end.

(** Evidence Type denotational reference semantics.
    The evidence associated with a term, a place, and some initial evidence. *)

Fixpoint eval (t:Term) (p:Plc) (e:Evidence) : Evidence :=
  match t with
  | asp a => eval_asp a p e
  | att q t1 => eval t1 q e
  | lseq t1 t2 => eval t2 p (eval t1 p e)
  | bseq s t1 t2 => ss (eval t1 p (splitEv_T_l s e))
                      (eval t2 p (splitEv_T_r s e))
  | bpar s t1 t2 => ss (eval t1 p (splitEv_T_l s e))
                      (eval t2 p (splitEv_T_r s e))
  end.

End Evidence.

End Copland.


Require Import VST.floyd.proofauto.
Require Import VST.progs.loop_minus1.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition sum_Z : list Z -> Z := fold_right Z.add 0.

Definition sumarray_spec :=
 DECLARE _sumarray
  WITH a: val, sh : share, contents : list Z, size: Z
  PRE [ tptr tuint, tint ]
          PROP  (readable_share sh; 0 <= size <= Int.max_signed)
          PARAMS (a; Vint (Int.repr size))
          SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a)
  POST [ tuint ]
        PROP () RETURN (Vint (Int.repr (sum_Z contents)))
           SEP (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a).

Definition Gprog : funspecs := ltac:(with_library prog [sumarray_spec]).

Lemma sum_Z_app:
  forall a b, sum_Z (a++b) =  sum_Z a + sum_Z b.
Proof. intros. induction a; simpl; lia. Qed.

Lemma body_sumarray: semax_body Vprog Gprog f_sumarray sumarray_spec.
Proof.
  start_function.
  forward.
  forward_for_simple_bound
    (size - 1)
    (EX i: Z,
     PROP  ()
     LOCAL (temp _a a;
            temp _n (Vint (Int.repr size));
            temp _s (Vint (Int.repr (sum_Z (sublist 0 (i + 1) contents)))))
     SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a)).
  - entailer!!.
  - assert_PROP (Zlength contents = size) by (entailer!; list_solve).
    forward. forward. entailer!!. f_equal. f_equal.
    rewrite (sublist_split 0 (i + 1) (i + 1 + 1)) by lia.
    rewrite sum_Z_app. rewrite (sublist_one (i + 1)) by lia.
    simpl. autorewrite with sublist. reflexivity.
  - forward. entailer!!. autorewrite with sublist in *. reflexivity.
Qed.


Require Import FcEtt.imports.
Require Import FcEtt.tactics.
Require Import FcEtt.notations.
Require Import FcEtt.utils.

Require Import FcEtt.ett_ott.

Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_ind.
Require Import FcEtt.ext_wf.
Require Export FcEtt.ext_invert.
Require Export FcEtt.ext_weak.
Require Export FcEtt.ext_subst.
Require Import FcEtt.ett_roleing.

Require Import FcEtt.param.
Require Import FcEtt.ett_path.
Require Import FcEtt.ett_match.
Require Import FcEtt.ett_rename.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* --------------------------------------------------------- *)

(* Chain (multi-) substitutions *)

(*
   Give a context (G) and a list of pattern_args (args), we can create
   a multi-substitution as

       sub := zip (fst G) args

*)

(* TODO: generate this with ott?? *)
Definition pattern_arg_subst_tm : pattern_arg -> atom -> tm -> tm :=
 fun arg x b =>
  match arg with
  | p_Tm nu a => tm_subst_tm_tm a x b
  | p_Co _    => co_subst_co_tm g_Triv x b
  end.

Definition pattern_arg_subst_co : pattern_arg -> atom -> co -> co :=
 fun arg x b =>
  match arg with
  | p_Tm nu a => tm_subst_tm_co a x b
  | p_Co _    => co_subst_co_co g_Triv x b
  end.

(* This operation applies that substitution to an arbitrary tm *)
Definition cps_tm : tm -> list (atom * pattern_arg) -> tm :=
  fold_right (fun '(x,y) b => pattern_arg_subst_tm y x b).

Definition cps_co : co -> list (atom * pattern_arg) -> co :=
  fold_right (fun '(x,y) b => pattern_arg_subst_co y x b).

Definition cps_constraint phi sub :=
  match phi with
  | Eq a b A R => Eq (cps_tm a sub) (cps_tm b sub) (cps_tm A sub) R
  end.
Definition cps_sort (s : sort) sub :=
  match s with
  | Tm A   => Tm (cps_tm A sub)
  | Co phi => Co (cps_constraint phi sub)
  end.
Definition cps_context (G : context) su : context :=
  EnvImpl.map (fun so => cps_sort so su) G.

Definition cps_pattern_arg pa s :=
  match pa with
  | p_Tm nu a => p_Tm nu (cps_tm a s)
  | p_Co g    => p_Co (cps_co g s)
  end.

(* Predicates about these substitutions *)

Definition lc_sub (sub:list(atom*pattern_arg)) :=
  Forall (fun '(x,p) => lc_pattern_arg p) sub.

(* cps properties --- homemorphic over term forms *)

Lemma cps_a_CPi : forall phi C sub,
    cps_tm (a_CPi phi C) sub =
        (a_CPi (cps_constraint phi sub)
               (cps_tm C sub)).
Proof.
  intros. induction sub; destruct phi; simpl; auto.
  destruct a; simpl; rewrite IHsub.
  destruct p; simpl; auto.
Qed.

Lemma cps_a_Pi : forall nu A B sub,
   cps_tm (a_Pi nu A B) sub =
               a_Pi nu (cps_tm A sub)
                        (cps_tm B sub).
Proof.
  intros. induction sub; simpl; auto.
  destruct a; simpl. rewrite IHsub.
  destruct p; simpl; auto.
Qed.

Lemma cps_a_App : forall l nu a1 a2,
           cps_tm (a_App a1 nu a2) l =
           a_App (cps_tm a1 l) nu
                 (cps_tm a2 l).
Proof. intros. induction l. simpl; auto.
       destruct a; simpl. rewrite IHl.
       destruct p; simpl; auto.
Qed.

Lemma cps_a_CApp : forall l a g,
    cps_tm (a_CApp a g) l =
    a_CApp (cps_tm a l) (cps_co g l).
Proof. intros. induction l. simpl; auto. destruct a0; simpl.
       destruct p; rewrite IHl; auto.
Qed.

Lemma cps_g_Triv : forall s,
    cps_co g_Triv s = g_Triv.
Proof. induction s; try destruct p; simpl; auto.
destruct a. rewrite IHs. destruct p. simpl. auto. simpl. auto.
Qed.

Lemma cps_a_Bullet : forall s,
    cps_tm a_Bullet s = a_Bullet.
Proof. induction s; try destruct p; simpl; auto.
destruct a. rewrite IHs. destruct p. simpl. auto. simpl. auto.
Qed.

Lemma cps_tm_apply_pattern_args : forall pargs hd s,
   (cps_tm (apply_pattern_args hd pargs) s) =
      (apply_pattern_args
         (cps_tm hd s)
         (List.map (fun p => cps_pattern_arg p s) pargs)).
Proof.
  induction pargs;
  intros; simpl; auto.
  destruct a; try destruct nu; try destruct rho; simpl;
  rewrite IHpargs;
  try rewrite cps_a_App;
  try rewrite cps_a_CApp;
  try rewrite cps_a_Bullet;
  try rewrite cps_g_Triv;
  auto.
Qed.

(* ----------------------------------- *)

Lemma cps_tm_cons : forall nu a x s sub1,
  tm_subst_tm_tm a x (cps_tm s sub1) =
  cps_tm s ((x, p_Tm nu a) :: sub1).
Proof.
  intros. simpl. auto.
Qed.

Lemma cps_co_cons : forall g x s sub1,
  co_subst_co_tm g_Triv x (cps_tm s sub1) =
  cps_tm s ((x, p_Co g) :: sub1).
Proof.
  intros. simpl. auto.
Qed.

Lemma cps_nil : forall s,
  cps_tm s ∅ = s.
Proof.
  intros. auto.
Qed.

Lemma cps_sort_cons : forall a x s nu sub1,
  tm_subst_tm_sort a x (cps_sort s sub1) =
  cps_sort s ((x, p_Tm nu a) :: sub1).
Proof.
  intros. destruct s. simpl. auto. simpl.
  destruct phi. simpl. auto.
Qed.

Lemma cps_sort_cons_co : forall x s sub1,
  co_subst_co_sort g_Triv x (cps_sort s sub1) =
  cps_sort s ((x, p_Co g_Triv) :: sub1).
Proof.
  intros. destruct s. simpl. auto. simpl.
  destruct phi. simpl. auto.
Qed.

Lemma cps_sort_nil : forall s,
  cps_sort s ∅ = s.
Proof.
  destruct s. simpl. auto.
  destruct phi. simpl. auto.
Qed.

(* ----------------------------------- *)
(* Interaction with other functions *)

Lemma cps_open_tm_wrt_tm : forall C a sub,
    lc_sub sub ->
    cps_tm (open_tm_wrt_tm C a) sub
     = open_tm_wrt_tm (cps_tm C sub)
                      (cps_tm a sub).
Proof.
  induction sub. simpl. auto.
  move=> LC. inversion LC.
  simpl. destruct a0. destruct p; simpl.
  inversion H1.
  rewrite IHsub; auto.
  rewrite tm_subst_tm_tm_open_tm_wrt_tm; auto.
  inversion H1.
  rewrite IHsub; auto.
  rewrite co_subst_co_tm_open_tm_wrt_tm. auto.
  auto.
Qed.

Lemma cps_open_tm_wrt_co : forall C a sub,
    lc_sub sub ->
    cps_tm (open_tm_wrt_co C a) sub
     = open_tm_wrt_co (cps_tm C sub)
                      (cps_co a sub).
Proof.
  induction sub. simpl. auto.
  move=> LC. inversion LC.
  simpl. destruct a0. destruct p; simpl.
  inversion H1.
  rewrite IHsub; auto.
  rewrite tm_subst_tm_tm_open_tm_wrt_co; auto.
  inversion H1.
  rewrite IHsub; auto.
  rewrite co_subst_co_tm_open_tm_wrt_co. auto.
  auto.
Qed.

Lemma cps_close_tm_wrt_tm : forall C x sub,
    lc_sub sub ->
    x `notin` dom sub ->
    x `notin` fv_tm_tm_pattern_args_rng sub ->
    cps_tm (close_tm_wrt_tm x C) sub
     = close_tm_wrt_tm x (cps_tm C sub).
Proof.
  induction sub; intros; simpl; auto.
  destruct a. unfold fv_tm_tm_pattern_args_rng in *.
  destruct p; simpl in *; inversion H; subst; inversion H4; auto; subst.
  rewrite <- tm_subst_tm_tm_close_tm_wrt_tm; auto.
  rewrite IHsub; auto.
  rewrite <- co_subst_co_tm_close_tm_wrt_tm; auto.
  rewrite IHsub; auto.
Qed.

Lemma cps_tm_tm_subst_tm_tm: forall b a x sub,
    lc_sub sub ->
    x `notin` dom sub ->
    x `notin` fv_tm_tm_pattern_args_rng sub ->
    tm_subst_tm_tm (cps_tm a sub) x (cps_tm b sub)
    = cps_tm (tm_subst_tm_tm a x b) sub.
Proof.
  intros.
  rewrite (tm_subst_tm_tm_spec b a x).
  rewrite cps_open_tm_wrt_tm; auto.
  rewrite cps_close_tm_wrt_tm; auto.
  rewrite tm_subst_tm_tm_spec.
  auto.
Qed.

Lemma cps_tm_fresh_eq : forall a sub,
    domFresh sub (fv_tm_tm_tm a) ->
    domFresh sub (fv_co_co_tm a) ->
    cps_tm a sub = a.
Proof.
  induction sub; intros; simpl; auto.
  inversion H; subst.
  inversion H0; subst.
  destruct a0; destruct p; simpl in *.
  rewrite tm_subst_tm_tm_fresh_eq; auto.
  rewrite IHsub; auto.
  rewrite co_subst_co_tm_fresh_eq; auto.
  rewrite IHsub; auto.
Qed.

Lemma cps_co_fresh_eq : forall a sub,
    domFresh sub (fv_tm_tm_co a) ->
    domFresh sub (fv_co_co_co a) ->
    cps_co a sub = a.
Proof.
  induction sub; intros; simpl; auto.
  inversion H; subst.
  inversion H0; subst.
  destruct a0; destruct p; simpl in *.
  rewrite tm_subst_tm_co_fresh_eq; auto.
  rewrite IHsub; auto.
  rewrite co_subst_co_co_fresh_eq; auto.
  rewrite IHsub; auto.
Qed.

Lemma cps_subst_var : forall sub0 x nu a2,
    lc_sub sub0 ->
    x ∉ dom sub0 ->
    x ∉ fv_tm_tm_pattern_args_rng sub0 ->
    domFresh sub0 (fv_tm_tm_tm a2) ->
    domFresh sub0 (fv_co_co_tm a2) ->
    cps_tm (a_Var_f x) ((x, p_Tm nu a2) :: sub0) = a2.
Proof.
  intros.
  simpl.
  replace a2 with (cps_tm a2 sub0). 2 :
    rewrite cps_tm_fresh_eq; auto.
  rewrite cps_tm_tm_subst_tm_tm; auto.
  rewrite tm_subst_tm_tm_var.
  auto.
Qed.

Inductive wf_sub (G : context) : list (atom * pattern_arg) -> Prop :=
  | wf_sub_nil     : wf_sub G nil
  | wf_sub_cons_tm : forall x nu a2 sub0,
      wf_sub G sub0 ->
      lc_tm a2 ->
      x ∉ dom sub0 ->
      x ∉ dom G    ->
      (fv_tm_tm_tm a2) \u (fv_co_co_tm a2) [<=] dom G ->
      wf_sub G ((x,p_Tm nu a2)::sub0)
  | wf_sub_cons_co : forall x sub0,
      wf_sub G sub0 ->
      x ∉ dom sub0 ->
      x ∉ dom G    ->
      wf_sub G ((x,p_Co g_Triv)::sub0).

Hint Constructors wf_sub.

Lemma wf_sub_pattern_args :
  forall G sub, wf_sub G sub -> fv_tm_tm_pattern_args_rng sub [<=] dom G.
Proof.
  induction 1; unfold fv_tm_tm_pattern_args_rng in *; simpl; eauto.
  fsetdec.
  rewrite IHwf_sub. fsetdec.
  rewrite IHwf_sub. fsetdec.
Qed.

Lemma wf_sub_lc_sub : forall G sub,
    wf_sub G sub -> lc_sub sub.
Proof.
  induction 1; unfold lc_sub; eauto.
Qed.

Hint Resolve wf_sub_lc_sub.

Lemma wf_sub_domFresh : forall G s sub,
  s [<=] (dom G) -> wf_sub G sub -> domFresh sub s.
Proof.
  intros. induction H0.
  all: unfold domFresh in *.
  all: eauto.
Qed.

Lemma wf_cps_subst_var : forall sub0 x G nu a2,
    wf_sub G ((x, p_Tm nu a2) :: sub0) ->
    cps_tm (a_Var_f x) ((x, p_Tm nu a2) :: sub0) = a2.
Proof.
  intros.
  inversion H. subst.
  eapply cps_subst_var; eauto 1. eauto.
  move: (wf_sub_pattern_args H4) => h0.
  fsetdec.
  eapply wf_sub_domFresh; eauto.
  eapply wf_sub_domFresh; eauto.
Qed.

Lemma wf_cps_co_subst_var : forall sub0 x G g,
    wf_sub G ((x, p_Co g) :: sub0) ->
    cps_co (g_Var_f x) ((x, p_Co g) :: sub0) = g_Triv.
Proof.
  intros.
  inversion H. subst.
  generalize dependent sub0.
  induction sub0; intros; simpl.
  destruct (x == x) eqn:h. rewrite h; auto. contradiction.
  destruct a.
  inversion H3; subst; simpl in *.
  + rewrite tm_subst_tm_co_fresh_eq; eauto.
    rewrite cps_co_fresh_eq; eauto.
    eapply wf_sub_domFresh; simpl; eauto. fsetdec.
    simpl. eapply domFresh_singleton2. fsetdec.
  + rewrite (co_subst_co_co_fresh_eq _ _ a); eauto.
    rewrite cps_co_fresh_eq; eauto; simpl.
    eapply domFresh_empty.
    eapply domFresh_singleton2. auto.
Qed.

Lemma cps_pattern_fresh :  forall A pargs1 x p sub (G:list(atom*A)),
   x `notin` dom G ->
   fv_co_co_pattern_args (List.map (cps_pattern_arg^~ sub) pargs1) ⊂ empty ->
   fv_tm_tm_pattern_args (List.map (cps_pattern_arg^~ sub) pargs1) ⊂ dom G ->
   List.map (cps_pattern_arg^~ ((x, p) :: sub)) pargs1 =
   List.map (cps_pattern_arg^~ sub) pargs1.
Proof.
  intros A pargs0.
  induction pargs0; intros; simpl in *; auto.
  erewrite IHpargs0; eauto.
  destruct a; simpl in *; f_equal; f_equal.
  destruct p.
  simpl.
  rewrite tm_subst_tm_tm_fresh_eq; auto.
  simpl.
  rewrite co_subst_co_tm_fresh_eq; auto.
  fsetdec.
  destruct p.
  simpl.
  rewrite tm_subst_tm_co_fresh_eq; auto.
  simpl.
  rewrite co_subst_co_co_fresh_eq; auto.
  fsetdec.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Export Bool.

Set Implicit Arguments.
Unset Strict Implicit.

(*   Lemmas for boolean connectives, (crucially) including reflection. *)
(*   In the following NEGATION is taken as the standard form of a      *)
(* false condition : hypotheses should be of the form (negb b) rather  *)
(* than b = false or ~b, as much as possible.                          *)
(*   A few lemmas to facilitate the manipulation of large conditionals *)
(* conclude this file.                                                 *)

(* Negation lemmas. *)

Lemma negbI : forall b, b = false -> negb b. Proof. by case. Qed.
Lemma negbE : forall b, negb b -> b = false. Proof. by case. Qed.
Lemma negbIf : forall b : bool, b -> negb b = false. Proof. by case. Qed.
Lemma negbEf : forall b, negb b = false -> b. Proof. by case. Qed.
Lemma negbE2 : forall b, negb (negb b) -> b.  Proof. by case. Qed.

(* Prenex notations for wider connectives; WARNING: they associate to the   *)
(* right, because this is the natural orientation in most of the proof.     *)
(* This avoids bending backwards to adhere to the left-associative v8 infix *)
(* binary notation.                                                         *)

Inductive and3 (P Q R : Prop) : Prop :=
  And3 (_ : P) (_ : Q) (_ : R).

Notation "'and3b' b1 b2 b3" := (b1 && (b2 && b3))
  (at level 10, b1, b2, b3 at level 8).

Inductive and4 (P Q R S : Prop) : Prop :=
  And4 (_ : P) (_ : Q) (_ : R) (_ : S).

Notation "'and4b' b1 b2 b3 b4" := (b1 && (b2 && (b3 && b4)))
  (at level 10, b1, b2, b3, b4 at level 8).

Inductive and5 (P Q R S T : Prop) : Prop :=
  And5 (_ : P) (_ : Q) (_ : R) (_ : S) (_ : T).

Notation "'and5b' b1 b2 b3 b4 b5" := (b1 && (b2 && (b3 && (b4 && b5))))
  (at level 10, b1, b2, b3, b4, b5 at level 8).

Inductive or3 (P Q R : Prop) : Prop :=
  Or3_1 (_ : P) |  Or3_2 (_ : Q) |  Or3_3 (_ : R).

Notation "'or3b' b1 b2 b3" := (b1 || (b2 || b3))
  (at level 10, b1, b2, b3 at level 8).

Inductive or4 (P Q R S : Prop) : Prop :=
  Or4_1 (_ : P) |  Or4_2 (_ : Q) |  Or4_3 (_ : R) | Or4_4 (_ : S).

Notation "'or4b' b1 b2 b3 b4" := (b1 || (b2 || (b3 || b4)))
  (at level 10, b1, b2, b3, b4 at level 8).

Section ReflectConnectives.

Variable b1 b2 b3 b4 b5 : bool.

Lemma idPx : reflect b1 b1.
Proof. by case b1; constructor. Qed.

Lemma idPnx : reflect (negb b1) (negb b1).
Proof. by case b1; constructor. Qed.

Lemma negPx : reflect (~ b1) (negb b1).
Proof. by case b1; constructor; auto. Qed.

Lemma negPnx : reflect b1 (negb (negb b1)).
Proof. by case b1; constructor. Qed.

Lemma negPfx : reflect (b1 = false) (negb b1).
Proof. by case b1; constructor. Qed.

Lemma andPx : reflect (b1 /\ b2) (b1 && b2).
Proof. by case b1; case b2; constructor=> //; case. Qed.

Lemma and3Px : reflect (and3 b1 b2 b3) (and3b b1 b2 b3).
Proof. by case b1; case b2; case b3; constructor; try by case. Qed.

Lemma and4Px : reflect (and4 b1 b2 b3 b4) (and4b b1 b2 b3 b4).
Proof.
by case b1; case b2; case b3; case b4; constructor; try by case. Qed.

Lemma and5Px : reflect (and5 b1 b2 b3 b4 b5) (and5b b1 b2 b3 b4 b5).
Proof.
by case b1; case b2; case b3; case b4; case b5; constructor; try by case.
Qed.

Lemma orPx : reflect (b1 \/ b2) (b1 || b2).
Proof. by case b1; case b2; constructor; auto; case. Qed.

Lemma or3Px : reflect (or3 b1 b2 b3) (or3b b1 b2 b3).
Proof.
case b1; first by constructor; constructor 1.
case b2; first by constructor; constructor 2.
case b3; first by constructor; constructor 3.
by constructor; case.
Qed.

Lemma or4Px : reflect (or4 b1 b2 b3 b4) (or4b b1 b2 b3 b4).
Proof.
case b1; first by constructor; constructor 1.
case b2; first by constructor; constructor 2.
case b3; first by constructor; constructor 3.
case b4; first by constructor; constructor 4.
by constructor; case.
Qed.

Lemma nandPx : reflect (negb b1 \/ negb b2) (negb (b1 && b2)).
Proof. case b1; case b2; constructor; auto; case; auto. Qed.

Lemma norPx : reflect (negb b1 /\ negb b2) (negb (b1 || b2)).
Proof. case b1; case b2; constructor; auto; case; auto. Qed.

End ReflectConnectives.

Notation idP := (idPx _).
Notation idPn := (idPnx _).
Notation negP := (negPx _).
Notation negPn := (negPnx _).
Notation negPf := (negPfx _).
Notation andP := (andPx _ _).
Notation and3P := (and3Px _ _ _).
Notation and4P := (and4Px _ _ _ _).
Notation and5P := (and5Px _ _ _ _ _).
Notation orP := (orPx _ _).
Notation or3P := (or3Px _ _ _).
Notation or4P := (or4Px _ _ _ _).
Notation nandP := (nandPx _ _).
Notation norP := (norPx _ _).

(* Shorter, more systematic names for the boolean connectives laws.       *)

Lemma andTb : forall b, true && b = b.      Proof. done. Qed.
Lemma andFb : forall b, false && b = false. Proof. done. Qed.
Lemma andbT : forall b, b && true = b.      Proof. by case. Qed.
Lemma andbF : forall b, b && false = false. Proof. by case. Qed.
Lemma andbb : forall b, b && b = b.         Proof. by case. Qed.

Lemma andbC : forall b1 b2, b1 && b2 = b2 && b1. Proof. by do 2 case. Qed.

Lemma andbA : forall b1 b2 b3, and3b b1 b2 b3 = b1 && b2 && b3.
Proof. by do 3 case. Qed.

Lemma andbCA : forall b1 b2 b3, and3b b1 b2 b3 = and3b b2 b1 b3.
Proof. by do 3 case. Qed.

Lemma orTb : forall b, true || b = true. Proof. done. Qed.
Lemma orFb : forall b, false || b = b.   Proof. done. Qed.
Lemma orbT : forall b, b || true = true. Proof. by case. Qed.
Lemma orbF : forall b, b || false = b.   Proof. by case. Qed.
Lemma orbb : forall b, b || b = b.       Proof. by case. Qed.

Lemma orbC : forall b1 b2, b1 || b2 = b2 || b1.
Proof. by do 2 case. Qed.

Lemma orbA : forall b1 b2 b3, or3b b1 b2 b3 = b1 || b2 || b3.
Proof. by do 3 case. Qed.

Lemma orbCA : forall b1 b2 b3, or3b b1 b2 b3 = or3b b2 b1 b3.
Proof. by do 3 case. Qed.

(* Finally, an alternative to xorb that behaves somewhat better wrt Simpl. *)

Definition addb (b : bool) : bool -> bool := if b then negb else fun b' => b'.
Notation "b1 +b b2" := (addb b1 b2) (at level 50).

Lemma addTb : forall b, true +b b = negb b. Proof. done. Qed.
Lemma addFb : forall b, false +b b = b. Proof. done. Qed.
Lemma addbT : forall b, b +b true = negb b. Proof. by case. Qed.
Lemma addbF : forall b, b +b false = b. Proof. by case. Qed.
Lemma addbb : forall b, b +b b = false. Proof. by case. Qed.

Lemma addbC : forall b1 b2, b1 +b b2 = b2 +b b1.
Proof. by do 2 case. Qed.

Lemma addbA : forall b1 b2 b3, b1 +b (b2 +b b3) = b1 +b b2 +b b3.
Proof. by do 3 case. Qed.

Lemma addbCA : forall b1 b2 b3, b1 +b (b2 +b b3) = b2 +b (b1 +b b3).
Proof. by do 3 case. Qed.

Lemma addb_inv : forall b1 b2, b1 +b (b1 +b b2) = b2.
Proof. by do 2 case. Qed.

Lemma addb_movell : forall b1 b2 b3, b1 +b b2 = b3 -> b2 = b1 +b b3.
Proof. by do 3 case. Qed.

Lemma addb_movelr : forall b1 b2 b3, b1 +b b2 = b3 -> b2 = b3 +b b1.
Proof. by do 3 case. Qed.

Lemma addb_moverl : forall b1 b2 b3, b1 +b b2 = b3 -> b1 = b2 +b b3.
Proof. by do 3 case. Qed.

Lemma addb_moverr : forall b1 b2 b3, b1 +b b2 = b3 -> b1 = b3 +b b2.
Proof. by do 3 case. Qed.

Lemma addbP : forall b1 b2, b1 +b b2 -> negb b1 = b2.
Proof. by do 2 case. Qed.

(* Resolution tactic for blindly weeding out common terms from boolean       *)
(* equalities. When faced with a goal of the form (andb/orb/addb b1 b2) = b2 *)
(* they will try to locate b1 in b2 and remove it. This can fail!            *)

Ltac BoolCongr :=
  match goal with
  | |- (?X1 && ?X2 = ?X3) => first
  [ symmetry; rewrite -1?(andbC X1) -?(andbCA X1); congr (andb X1); symmetry
  | case X1; [ rewrite ?andTb ?andbT | by rewrite /= ?andbF ] ]
  | |- (?X1 || ?X2 = ?X3) => first
  [ symmetry; rewrite -1?(orbC X1) -?(orbCA X1); congr (orb X1); symmetry
  | case X1; [ by rewrite /= ?orbT | rewrite ?orFb ?orbF ] ]
  | |- (?X1 +b ?X2 = ?X3) =>
    symmetry; rewrite -1?(addbC X1) -?(addbCA X1); congr (addb X1); symmetry
  | |- (negb ?X1 = ?X2) => congr negb
  end.

(* The following lemmas are mainly useful for ifs with large conditions : *)
(* they allow reasoning about the condition without repeating it inside   *)
(* the proof (the latter IS preferable when the condition is short).      *)
(* Usage :                                                                *)
(*   if the goal has the form (if cond then ...) = ...                    *)
(*     Apply cases_of_if; Move=> Dcond.                                   *)
(*   generates two subgoal, with the assumption Dcond : cond = true/false *)
(*     Rewrite if_same  eliminates redundant ifs                          *)
(*     Rewrite (fun_if f) moves a function f inside an if                 *)
(*     Rewrite if_arg moves an argument inside a function-valued if       *)

Lemma cases_of_if : forall A (b : bool) (v1 v2 v3 : A),
 (b -> v1 = v3) -> (b = false -> v2 = v3) -> (if b then v1 else v2) = v3.
Proof. move=> A [|]; auto. Qed.

Lemma if_same : forall A (b : bool) (v : A), (if b then v else v) = v.
Proof. by move=> A [|]. Qed.

Lemma fun_if : forall A B (f : A -> B) (b : bool) v1 v2,
  f (if b then v1 else v2) = (if b then f v1 else f v2).
Proof. by move=> A B f [|]. Qed.

Lemma if_arg : forall A x B (b : bool) (f1 f2 : A -> B),
  (if b then f1 else f2) x = (if b then f1 x else f2 x).
Proof. by move=> A x B [|]. Qed.

Unset Implicit Arguments.


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

Require Import tools language lklc lklc_lang.

Open Scope expr_scope.

Section reduction.
  Context { X : Set } {decX : decidable_set X} .

  Section pad.
    Context { Σ : Set } {σ : 𝕬[X→Σ]}.
    Context { α : X -> Prop}.

    Definition Σ' : Set := option Σ.

    Notation " ⋄ " := (None).

    Definition unpad : list Σ' -> list Σ :=
      flat_map (fun a => match a with Some a => [a] | _ => [] end).

    Definition σ' : 𝕬[X → Σ'] := fun x w => (α x -> exists u, w = ⋄::u) /\ σ x (unpad w).

    Definition unpad_lang : language Σ' -> language Σ :=
      fun L w => exists u, L u /\ w = unpad u.

    Global Instance unpad_lang_smaller : Proper (ssmaller ==> ssmaller) unpad_lang.
    Proof. intros L M E u (v&Iv&->);exists v;split;auto. Qed.
    Global Instance unpad_lang_equiv : Proper (sequiv ==> sequiv) unpad_lang.
    Proof.
      intros L M E;apply antisymmetry;apply unpad_lang_smaller;rewrite E;reflexivity.
    Qed.

    Lemma unpad_app u v : unpad (u++v) = unpad u ++ unpad v.
    Proof. induction u as [|[|]];simpl;congruence. Qed.

    Fixpoint more_pad (u v : list Σ') :=
      match u,v with
      | [],[] => True
      | ⋄::u,⋄::v | u,⋄::v => more_pad u v
      | Some a::u,Some b::v => a = b /\ more_pad u v
      | _,_ => False
      end.

    Lemma more_pad_extra_diamond u v : more_pad u v -> more_pad u (⋄::v).
    Proof.
      revert v; induction u as [|[a|] u];intros [|[b|] v];try (simpl;tauto).
      intro h;simpl;apply IHu,h.
    Qed.

    Reserved Notation " u ⊑ v " (at level 80).

    Inductive inf_words : relation (list Σ') :=
    | inf_w_refl u : u ⊑ u
    | inf_w_trans u v w : u ⊑ v -> v ⊑ w -> u ⊑ w
    | inf_w_app u1 u2 v1 v2 : u1 ⊑ v1 -> u2 ⊑ v2 -> (u1++u2) ⊑ (v1++v2)
    | inf_w_pad u : u ⊑ ⋄::u
    where " u ⊑ v " := (inf_words u v).
    Hint Constructors inf_words.

    Lemma inf_words_length u v : u ⊑ v -> #u <= #v.
    Proof. intros U;induction U;simpl;repeat rewrite app_length; lia. Qed.

    Global Instance preorder_inf_words : PreOrder inf_words.
    Proof. split;eauto. Qed.

    Global Instance app_inf_words : Proper (inf_words ==> inf_words ==> inf_words) (@app Σ').
    Proof. intros ? ? ? ? ?;eauto. Qed.
    Global Instance cons_inf_words a : Proper (inf_words ==> inf_words) (cons a).
    Proof. intros ? ? E;replace (cons a) with (app [a]) by reflexivity;auto. Qed.

    Lemma inf_words_more_pad u v : u ⊑ v <-> more_pad u v.
    Proof.
      split.
      - intro U;induction U.
        + induction u as [|[|]];simpl;auto.
        + clear U1 U2; revert u v IHU1 IHU2;induction w as [|[a|]].
          * intros [|[|]] [|[|]];simpl;try tauto.
          * intros [|[c|]] [|[b|]];simpl;try tauto.
            intros (->&I1) (->&I2);split;auto.
            apply (IHw _ _ I1 I2).
          * intros [|[c|]] [|[b|]];simpl;try tauto.
            -- apply IHw.
            -- intros (->&I1) I2.
               apply (IHw _ (Some b :: l0));auto.
               split;auto.
            -- intros I1 I2;eapply IHw;eauto.
            -- apply IHw.
        + clear U1 U2;revert u1 IHU1 u2 v2 IHU2.
          induction v1 as [|[a|]];intros [|[b|] v] ih w1 w2 E;
            try (simpl in *;tauto).
          * simpl in *.
            destruct ih as (->&ih).
            split;auto.

          * simpl;apply more_pad_extra_diamond;simpl in ih.
            rewrite <- (app_nil_l w1).
            apply IHv1;auto.
          * simpl in *.
            rewrite app_comm_cons.
            apply IHv1;auto.
          * simpl in *.
            apply IHv1;auto.
        + apply more_pad_extra_diamond.
          induction u as [|[|]];simpl;auto.
      - revert u;induction v as [|[a|] v];simpl;intros [|[b|] u];
          try tauto||auto.
        + intros (->&h).
          rewrite (IHv _ h);reflexivity.
        + intro h;apply IHv in h as ->;auto.
        + intro h;apply IHv in h as ->;auto.
        + intro h;apply IHv in h as ->;auto.
    Qed.

    Global Instance partialorder_inf_words : PartialOrder Logic.eq inf_words.
    Proof.
      intros u v;split;[intros ->;split;reflexivity|].
      unfold Basics.flip;intros (I1&I2).
      rewrite inf_words_more_pad in I1,I2; revert v I1 I2;
        induction u as [|[a|] u];intros [|[b|] v];simpl;try tauto.
      - intros (->&I1) (_&I2);f_equal;apply IHu;auto.
      - intros;f_equal;apply IHu;auto.
    Qed.

    Global Instance rev_inf_words : Proper (inf_words ==> inf_words) (@rev Σ').
    Proof.
      intros u v U;induction U.
      - reflexivity.
      - eauto.
      - repeat rewrite rev_app_distr;auto.
      - simpl;rewrite <- app_nil_r at 1.
        apply inf_w_app;auto.
    Qed.

    Lemma inf_words_unpad u v : u ⊑ v -> unpad u = unpad v.
    Proof.
      intros U;induction U.
      - reflexivity.
      - etransitivity;eassumption.
      - repeat rewrite unpad_app;congruence.
      - simpl;auto.
    Qed.

    Lemma inf_words_app_invert u1 u2 v :
      u1 ++ u2 ⊑ v -> exists v1 v2, v = v1 ++ v2 /\ u1 ⊑ v1 /\ u2 ⊑ v2.
    Proof.
      remember (u1++u2) as u;intro U;revert u1 u2 Hequ;induction U.
      - intros u1 u2 ->;exists u1,u2;auto.
      - intros u1 u2 ->.
        destruct (IHU1 u1 u2) as (v1&v2&->&I1&I2);auto.
        destruct (IHU2 v1 v2) as (w1&w2&->&I3&I4);auto.
        exists w1,w2;eauto.
      - intros w1 w2 E;apply Levi in E as (w&[(->&->)|(->&->)]).
        + destruct (IHU1 w1 w) as (t1&t2&->&I1&I2);auto.
          exists t1,(t2++v2);rewrite app_ass;repeat split;auto.
        + destruct (IHU2 w w2) as (t1&t2&->&I1&I2);auto.
          exists (v1++t1),t2;rewrite app_ass;repeat split;auto.
      - intros u1 u2 ->;exists (⋄::u1),u2;repeat split;auto.
    Qed.

    Lemma min_words u : (map Some (unpad u)) ⊑ u.
    Proof.
      induction u as [|[a|] u];simpl;auto.
      - rewrite IHu;reflexivity.
      - rewrite IHu;auto.
    Qed.

    Lemma unpad_cons_inf_words a w v :
      a :: w = unpad v -> exists v1 v2 : list (Σ'), v = v1 ++ [Some a] ++ v2 /\ [] ⊑ v1.
    Proof.
      induction v as [|[b|]].
      - discriminate.
      - intros E';inversion E' as [[EE E]];subst.
        exists [],v;simpl;auto.
      - intros ih;apply IHv in ih as (v1&v2&->&I).
        exists (⋄::v1),v2;split;auto.
        rewrite I;auto.
    Qed.

    Lemma lub_more_pad u v :
      unpad u = unpad v -> exists w, u ⊑ w /\ v ⊑ w /\ forall t, u ⊑ t -> v ⊑ t -> w ⊑ t.
    Proof.
      revert v;induction u as [|[a|]u].
      - intros v Ev;exists v;repeat split.
        + induction v as [|[a|]];simpl in *;try discriminate;auto.
          rewrite IHv;auto.
        + reflexivity.
        + intuition.
      - intros [|[b|]v];try discriminate.
        + intros E';inversion E' as [[E'' E]];subst;clear E'.
          apply IHu in E as (w&E1&E2&M);clear IHu.
          exists (Some b::w);repeat split;auto.
          * rewrite E1;auto.
          * rewrite E2;auto.
          * intros t;induction t as [|[a|]].
            -- repeat rewrite inf_words_more_pad;simpl;tauto.
            -- intros I1 I2;rewrite inf_words_more_pad in I1,I2.
               destruct I1 as (->&I1),I2 as (_&I2).
               rewrite <- inf_words_more_pad in I1,I2.
               rewrite (M t I1 I2);reflexivity.
            -- intros;rewrite IHt;auto;rewrite inf_words_more_pad in *;simpl;auto.
        + simpl;intro E'.
          destruct (unpad_cons_inf_words E') as (v1&v2&->&Iv1).
          repeat rewrite unpad_app in E'.
          rewrite <- (inf_words_unpad Iv1) in E';simpl in E'.
          inversion E' as [[E]];subst;clear E'.
          apply IHu in E as (w&E1&E2&M);clear IHu.
          exists (⋄::v1++Some a:: w);repeat split;auto.
          * rewrite <- Iv1,<-E1;simpl;auto.
          * rewrite <- E2;reflexivity.
          * intros t I1' I2.
            destruct (unpad_cons_inf_words (inf_words_unpad I1')) as (t1&t2&->&It1).
            destruct t1 as [|[b|]];simpl in *;
              try (rewrite inf_words_more_pad in *;simpl in *;tauto).
            cut (v1 ⊑ t1 /\ w ⊑ t2);[intros (->&->);auto|].
            cut (v1 ⊑ t1 /\ v2 ⊑ t2 /\ u ⊑ t2);[intros (->&(h1&h2));split;auto|].
            clear w E1 E2 M.
            repeat rewrite inf_words_more_pad in *;simpl in *.
            revert u v1 v2 t2 Iv1 It1 I1' I2;induction t1 as [|[b|] t1];simpl;
              try tauto.
            -- intros u [|[|] v1] v2 t2;simpl;try tauto.
            -- intros u [|[|] v1] v2 t2;simpl;try tauto.
               ++ intros I1 I2 I3 I4;apply IHt1;simpl;auto.
               ++ intros I1 I2 I3 I4;apply IHt1;simpl;auto.
      - simpl;intros [|[b|] v] E.
        + exists (⋄::u);repeat split;auto.
          clear IHu;simpl;auto.
          induction u as [|[|]];simpl in *;try discriminate||auto.
          rewrite IHu;auto.
        + apply IHu in E as (w&E1&E2&M);clear IHu.
          exists (⋄::w);repeat split.
          * rewrite E1;reflexivity.
          * rewrite <- E2;simpl;auto.
          * intros t I1 I2.
            destruct t as [|[|]];rewrite inf_words_more_pad in I1,I2;simpl in *;try tauto.
            rewrite <- inf_words_more_pad in I1,I2.
            rewrite (M _ I1 I2);reflexivity.
        + simpl in E.
          apply IHu in E as (w&E1&E2&M);clear IHu.
          exists (⋄::w);repeat split.
          * rewrite E1;reflexivity.
          * rewrite <- E2;reflexivity.
          * intros t I1 I2.
            destruct t as [|[|]];rewrite inf_words_more_pad in I1,I2;simpl in *;try tauto.
            rewrite <- inf_words_more_pad in I1,I2.
            rewrite (M _ I1 I2);reflexivity.
    Qed.

    Definition pad_closed (L : language Σ') := forall u v, L u -> u ⊑ v -> L v.

    Lemma pad_closed_rat e : one_free e = true -> pad_closed (⟦e⟧σ').
    Proof.
      induction e;rsimpl;
        discriminate
        ||(rewrite andb_true_iff;intros (ih1&ih2);apply IHe1 in ih1;apply IHe2 in ih2;
          clear IHe1 IHe2)
        ||(intros ih;apply IHe in ih;clear IHe)
        ||intros _ ;intros u v Iu L.
      - apply Iu.
      - destruct Iu as (h1&h2);split.
        + intros h;apply h1 in h as (u'&->).
          rewrite inf_words_more_pad in L.
          destruct v as [|[]];simpl in *;tauto||eauto.
        + rewrite <- (inf_words_unpad L);assumption.
      - destruct Iu as (u1&u2&I1&I2&->).
        apply inf_words_app_invert in L as (v1&v2&->&L1&L2).
        exists v1,v2;repeat split.
        + now eapply ih1,L1.
        + now eapply ih2,L2.
      - destruct Iu as (I1&I2);split.
        + now eapply ih1,L.
        + now eapply ih2,L.
      - destruct Iu as [Iu|Iu].
        + now left;eapply ih1,L.
        + now right;eapply ih2,L.
      - now eapply ih,rev_inf_words,L.
      - destruct Iu as (n&In);exists n;revert u v In L;induction n;simpl.
        + intros u' v (u&?&I&->&->) L;exists v,[];rewrite app_nil_r in *;repeat split.
          now eapply ih,L.
        + intros u v (u1&u2&I1&I2&->) L.
          apply inf_words_app_invert in L as (v1&v2&->&L1&L2).
          exists v1,v2;repeat split.
          * now eapply ih,L1.
          * now eapply IHn,L2.
    Qed.

    Open Scope lang.
    Lemma unpad_prod L M :
      unpad_lang (L ⋅ M) ≃ unpad_lang L⋅unpad_lang M.
    Proof.
      intros u;split.
      - intros (w&(u1&u2&I1&I2&->)&->).
        rewrite unpad_app.
        exists (unpad u1),(unpad u2);repeat split.
        + exists u1;tauto.
        + exists u2;tauto.
      - intros (w1&w2&(u1&I1&->)&(u2&I2&->)&->).
        rewrite <- unpad_app.
        exists (u1++u2);split;[exists u1,u2|];tauto.
    Qed.
    Lemma unpad_union L M :
      unpad_lang (L + M) ≃ unpad_lang L+unpad_lang M.
    Proof.
      intros u;split.
      - intros (w&[I|I]&->).
        + left;exists w;auto.
        + right;exists w;auto.
      - intros [(w&I&->)|(w&I&->)];exists w;split;[left| |right|];auto.
    Qed.
    Lemma unpad_inter L M :
      pad_closed L -> pad_closed M ->
      unpad_lang (L ∩ M) ≃ unpad_lang L ∩ unpad_lang M.
    Proof.
      intros P1 P2 u;split.
      - intros (w&(I1&I2)&->);split;exists w;auto.
      - intros ((u1&I1&->)&(u2&I2&E)).
        apply lub_more_pad in E as (w&Iw1&Iw2&Min).
        exists w;repeat split.
        + eapply P1;eauto.
        + eapply P2;eauto.
        + apply inf_words_unpad,Iw1.
    Qed.
    Lemma unpad_power L n : unpad_lang (L^{S n}) ≃ (unpad_lang L)^{S n}.
    Proof.
      induction n;rsimpl.
      - intros u;split.
        + intros (?&(w&?&Iw&->&->)&->).
          exists (unpad w),[];repeat rewrite app_nil_r;repeat split;auto.
          exists w;tauto.
        + intros (u'&?&(w&Iw&->)&->&->).
          exists w;split;[exists w,[]|];rewrite app_nil_r;repeat split;auto.
      - simpl in IHn;rewrite <- IHn;clear IHn.
        rewrite unpad_prod;reflexivity.
    Qed.

    Lemma unpad_iter L : unpad_lang (L⁺) ≃ (unpad_lang L)⁺.
    Proof.
      intros u;split.
      - intros (w&(n&Iw)&->).
        exists n;apply unpad_power;exists w;tauto.
      - intros (n&In).
        apply unpad_power in In as (w&Iw&->).
        exists w;split;[exists n|];auto.
    Qed.

    Lemma unpad_rev u : rev (unpad u) = unpad (rev u).
    Proof.
      induction u as [|[|]];simpl;try rewrite unpad_app;try rewrite IHu;
        try rewrite app_nil_r;simpl;auto.
    Qed.

    Lemma unpad_conv L : unpad_lang (L ¯) ≃ (unpad_lang L)¯.
    Proof.
      intros u;split.
      - intros (v&Iv&->).
        exists (rev v).
        rewrite unpad_rev;auto.
      - intros (v&Iv&E).
        exists (rev v).
        rewrite <-unpad_rev,<-E.
        unfold mirror;repeat rewrite rev_involutive;auto.
    Qed.

    Close Scope lang.

    Lemma σ'_spec e : one_free e = true -> ⟦e⟧σ ≃ unpad_lang (⟦e⟧σ').
    Proof.
      induction e;rsimpl;
        discriminate
        ||(rewrite andb_true_iff;intros (O1&O2);
          rewrite (IHe1 O1),(IHe2 O2);clear IHe1 IHe2)
        ||(intros ih;apply IHe in ih as ->;clear IHe)
        ||intros _ .
      - intros u;split.
        + intros F;exfalso;apply F.
        + intros (?&F&_);apply F.
      - intros u;rsimpl;split.
        + intros Iu;exists (⋄::map Some u).
          cut (u = unpad (⋄ :: map Some u));[intros E;split;[|assumption]|].
          * split;[|rewrite <-E;assumption].
            intros Ix;exists (map Some u);reflexivity.
          * clear;simpl;induction u;simpl;congruence.
        + intros (w&(_&Iw)&->);assumption.
      - symmetry;apply unpad_prod.
      - symmetry;apply unpad_inter;auto using pad_closed_rat.
      - symmetry;apply unpad_union.
      - symmetry;apply unpad_conv.
      - symmetry;apply unpad_iter.
    Qed.
  End pad.
  Hint Constructors inf_words.

  Proposition one_free_sem e f :
    one_free e = true -> one_free f = true ->
    e ≃ f <-> forall A, forall σ : 𝕬[X → A], (forall a, ~ [] ∊ σ a) -> ⟦e⟧σ≃⟦f⟧σ.
  Proof.
    intros Oe Of;split;[intros E A σ _;apply E|].
    intros hyp A σ.
    set (α := (fun _ : X => True)).
    rewrite (@σ'_spec _ _ α _ Oe),(@σ'_spec _ _ α _ Of).
    set (σ0 := @σ' _ σ α).
    cut (forall a : X, ~ σ0  a []).
    - intros h;apply hyp in h as ->;reflexivity.
    - intros a ((v&Iv)&_).
      + exact I.
      + discriminate.
  Qed.

  Proposition one_free_sem_inf e f :
    one_free e = true ->
    e ≲ f <-> forall A, forall σ : 𝕬[X → A], (forall a, ~ [] ∊ σ a) -> ⟦e⟧σ≲⟦f⟧σ.
  Proof.
    intros Oe;split;[intros E A σ _;apply E|].
    intros hyp A σ.
    set (α := (fun _ : X => True)).
    rewrite (@σ'_spec _ _ α _ Oe).
    intros u (w&Iw&->).
    apply hyp in Iw as Iw';[|intros a ((v&Iv)&_);simpl;unfold α;[tauto|discriminate]].
    set (σ'' := fun a w => σ a (unpad w)).
    cut (w∊ ⟦f⟧ σ'');
      [|eapply assign_monotone,Iw';[|reflexivity];intros a u (_&Iu);apply Iu].
    clear;revert w;induction f;simpl;intro w;rsimpl.
    - intros ->;reflexivity.
    - intros F;apply F.
    - tauto.
    - intros (u1&u2&I1&I2&->).
      rewrite unpad_app.
      exists (unpad u1),(unpad u2);repeat split;auto.
    - intros (I1&I2);split;auto.
    - intros [I|I];[left|right];auto.
    - unfold mirror.
      rewrite unpad_rev;apply IHf.
    - intros (n&In);exists n;revert w In;induction n.
      + intros w (u&?&Iu&->&->).
        rewrite unpad_app;exists (unpad u),[];repeat split;auto.
      + rsimpl;intros w (u1&u2&Iu1&Iu2&->);rewrite unpad_app.
        exists (unpad u1),(unpad u2);repeat split;auto.
        apply IHn,Iu2.
  Qed.

  Definition positive e : 𝐄 X := Σ (flat_map (fun nf => match nf with
                                                     | ([],Some f)=> [f]
                                                     | _ => []
                                                     end) (expand e)).
  Notation " ⦗ e ⦘ " := (positive e).

  Lemma one_free_positive e : one_free ⦗e⦘ = true.
  Proof.
    apply one_free_sum.
    unfold positive.
    intros f If;apply in_flat_map in If as (([]&[g|])&Ig&If);simpl in *;auto.
    destruct If as [->|F];auto.
    apply one_free_expand in Ig;auto.
  Qed.

  Lemma positive_inf e : ⦗e⦘ ≤ e.
  Proof.
    rewrite (expand_eq _ e) at 2.
    apply Σ_small;intros f If.
    apply in_flat_map in If as (([]&[g|])&Ig&If);simpl in If;try tauto.
    destruct If as [<-|F];try tauto.
    assert (I' : nf_to_term ([], Some g) ∈ (map (nf_to_term (X:=X)) (expand e)))
      by (apply in_map_iff;eauto).
    apply (Σ_big _ I');simpl.
    rewrite ax_seq_1;reflexivity.
  Qed.

  Lemma positive_spec e f :
    one_free e = true -> e ≲ f -> e ≲ ⦗f⦘.
  Proof.
    intros Oe Ie.
    apply (one_free_sem_inf _ Oe).
    intros Ξ σ hσ u Iu.
    cut (u <> []).
    - intros N;apply Ie in Iu.
      apply (𝐄_eq_equiv_lang (expand_eq _ f)) in Iu.
      apply sum_lang in Iu as (F&If&Iu).
      apply in_map_iff in If as ((B&g)&<-&Ig);destruct g as [g|];[destruct B|];simpl in *.
      + rsimpl in *;destruct Iu as (?&?&->&Iu&E).
        symmetry in E;simpl in E;subst.
        apply sum_lang;exists g;repeat split;auto.
        apply in_flat_map;exists ([],Some g);simpl;auto.
      + exfalso;rsimpl in Iu.
        destruct Iu as (?&?&((F&_)&E)&_).
        apply test_is_one_inv in E as (_&->).
        eapply hσ,F.
      + exfalso;apply test_is_one_inv in Iu as (_&->);tauto.
    - clear f Ie.
      revert u Iu;induction e;simpl in *;rsimpl in *;intros u.
      + discriminate.
      + intros Iu _;apply Iu.
      + intros Iu ->;eapply hσ,Iu.
      + apply andb_true_iff in Oe as (O1&O2).
        intros (u1&u2&I1&I2&->) E;apply app_eq_nil in E as (->&->).
        apply IHe1 in I1;auto.
      + apply andb_true_iff in Oe as (O1&O2).
        intros (I1&I2) ->.
        apply IHe1 in I1;auto.
      + apply andb_true_iff in Oe as (O1&O2).
        intros [I1|I2].
        * apply IHe1 in I1;auto.
        * apply IHe2 in I2;auto.
      + intros Iu ->.
        apply IHe in Iu;auto.
      + intros (n&u1&u2&Iu&_&E) ->.
        symmetry in E;apply app_eq_nil in E as (->&_).
        apply IHe in Iu;auto.
  Qed.

  Reserved Notation " ⟨ e ⟩ A " (at level 20).

  Fixpoint reduce A e :=
    match e with
    | 0 => 0
    | 1 => 1
    | 𝐄_var a => if inb a A then 𝐄_var a + 1 else 𝐄_var a
    | e+f => ⟨e⟩A + ⟨f⟩A
    | e⋅f => ⟨e⟩A ⋅ ⟨f⟩A
    | e∩f => ⟨e⟩A ∩ ⟨f⟩A
    | e⁺ => ⟨e⟩A ⁺
    | e ¯ => ⟨e⟩A ¯
    end
  where " ⟨ e ⟩ A " := (reduce A e).

  Lemma reduce_sup A e : e ≤ ⟨e⟩A.
  Proof.
    induction e.
    - reflexivity.
    - reflexivity.
    - simpl;destruct (inb x A);[apply plus_left|];reflexivity.
    - simpl;rewrite IHe1,IHe2 at 1;reflexivity.
    - simpl;rewrite IHe1,IHe2 at 1;reflexivity.
    - simpl;rewrite IHe1,IHe2 at 1;reflexivity.
    - simpl;rewrite IHe at 1;reflexivity.
    - simpl;rewrite IHe at 1;reflexivity.
  Qed.

  Lemma reduce_inf A e : test A ⋅ ⟨e⟩A ≤ e.
  Proof.
    induction e;simpl.
    - rewrite test_sub_id,ax_seq_1;reflexivity.
    - rewrite test_sub_id,ax_seq_1;reflexivity.
    - case_eq (inb x A).
      + rewrite inb_spec,ax_seq_plus,ax_1_seq.
        rewrite test_sub_id,ax_seq_1 at 1.
        intros Ia;apply plus_inf;[reflexivity|].
        rewrite (test_var Ia),inf_ax_inter_l;reflexivity.
      + rewrite test_sub_id,ax_seq_1 at 1;reflexivity.
    - rewrite test_dup,<-ax_seq_assoc.
      rewrite (ax_seq_assoc _ (⟨e1⟩A)),(test_seq _ (⟨e1⟩A)).
      repeat rewrite ax_seq_assoc.
      rewrite IHe1,<-ax_seq_assoc,IHe2.
      reflexivity.
    - rewrite test_inter,IHe1,IHe2;reflexivity.
    - rewrite ax_seq_plus,IHe1,IHe2;reflexivity.
    - rewrite test_seq,<-test_conv,<-ax_conv_seq,IHe;reflexivity.
    - rewrite <- IHe at 2.
      transitivity (0⁺+test A⋅(0+⟨e⟩A)⁺).
      + rewrite iter_0;repeat rewrite (ax_plus_com 0),ax_plus_0.
        reflexivity.
      + rewrite test_inter_1, <- ax_inter_1_iter,<- test_inter_1.
        rewrite (ax_plus_com 0),ax_plus_0;reflexivity.
  Qed.

  Lemma reduce_lang A e :
    forall 𝐀,forall σ τ: 𝕬[X→𝐀],
        (forall a, ~ σ a []) ->
        (forall a, a ∈ A -> τ a []) ->
        (forall a w, ~ a ∈ A \/ w <> [] -> σ a w <-> τ a w) ->
        ⟦⟨e⟩A⟧σ≃⟦⟨e⟩A⟧τ.
  Proof.
    intros ? ? ? h1 h2 E.
    apply antisymmetry;
      [apply assign_monotone;
       [intros a w Iw;destruct w;
        [case_eq (inb a A);[|rewrite <- not_true_iff_false];rewrite inb_spec;intros Ia;
         [apply h2,Ia|apply E,Iw;now left]
        |apply E,Iw;right;discriminate]
       |reflexivity]|].
    induction e;simpl;rsimpl.
    - reflexivity.
    - reflexivity.
    - case_eq (inb x A);[|rewrite <- not_true_iff_false];rewrite inb_spec;intros Ix;rsimpl.
      + intros w [Iw | ->];[|right;reflexivity].
        destruct w as [|a w].
        * right;reflexivity.
        * left;apply E,Iw;right;discriminate.
      + intros w Iw;apply E,Iw;left;intros Ix';apply Ix,Ix'.
    - rewrite IHe1,IHe2;reflexivity.
    - rewrite IHe1,IHe2;reflexivity.
    - rewrite IHe1,IHe2;reflexivity.
    - rewrite IHe;reflexivity.
    - rewrite IHe;reflexivity.
  Qed.

  Lemma reduce_spec A e f :
    one_free e = true -> test A ⋅ e ≲ ⟨ f ⟩ A -> e ≲ ⟨ f ⟩ A.
  Proof.
    intros O I.
    apply (one_free_sem_inf _ O).
    intros Ξ σ hσ u Iu.
    set (σ' := (fun a w => (a ∈ A /\ w = []) \/ σ a w) : 𝕬[X→Ξ]).
    cut (u ∊ ⟦⟨f⟩A⟧σ').
    - intros Iu';eapply reduce_lang,Iu'.
      + apply hσ.
      + intros a Ia;left;split;auto.
      + intros a w [Ia|N];split;intro Iw.
        * right;assumption.
        * destruct Iw as [(F&_)|Iw];tauto.
        * right;assumption.
        * destruct Iw as [(_&->)|Iw];tauto.
    - apply I;rsimpl;exists [],u.
      repeat split.
      + apply test_is_one;[|reflexivity].
        intros a Ia;left;tauto.
      + eapply assign_monotone,Iu;[|reflexivity].
        intros a w Iw;right;assumption.
  Qed.

  Proposition reduction_inf A f : test A ⋅ ⦗⟨f⟩A⦘ ≤ f.
  Proof.
    rewrite <- (reduce_inf A f) at 2.
    rewrite positive_inf;reflexivity.
  Qed.

  Proposition reduction_one_free A f : one_free ⦗⟨f⟩A⦘ = true.
  Proof. apply one_free_positive. Qed.

  Proposition reduction_spec A e f :
    one_free e = true -> test A ⋅ e ≲ f -> e ≲ ⦗⟨f⟩A⦘.
  Proof.
    intros O I.
    rewrite (𝐄_inf_incl_lang (reduce_sup A f)) in I.
    apply (positive_spec O).
    apply (reduce_spec O),I.
  Qed.

End reduction.

Notation " ⦗ e ⦘ " := (positive e).
Notation " ⟨ e ⟩ A " := (reduce A e) (at level 20).


(*
  Verificación Formal - Unam 2020-2
  Ciro Iván García López
  Proyecto 1. Session Type Systems Verification
*)
From Coq Require Import Lists.List.
Import ListNotations.
From PROYI Require Import  Defs_Proposition.
From PROYI Require Import  Defs_Process.

(*
Las siguientes definiciones son necesarias para poder hablar de inferencia, se encuentran sueltas a lo largo del parrafo 'Typing inference'.

Definición de Asignación.
*)
Inductive Assignment : Type := assig ( x : Name )( A : Proposition ) : Assignment.
Notation " x : A " := (assig x A )(at level 60).

(*
Nuevamente, por la LNR no todo es necesario distinguir aquellas asignaciones que si tienen sentido.
*)
Inductive Assig : Assignment -> Prop :=
  is_assig :  forall (x : Name)(A:Proposition), Process_Name x -> Assig ( x : A).

(*
Definición de una colección de asignaciones.
*)
Inductive Collect : list Assignment -> Prop := is_collect :forall L : list Assignment,
  (forall H : Assignment, (In H L) -> Assig H ) -> Collect L.

(*
Figura 1, reglas de inferencia.
*)
Reserved Notation "D ';;;'  F '!-' P ':::' G" (at level 60).
Inductive Inference : Prepro -> list Assignment -> list Assignment -> list Assignment -> Prop :=
  | idr : forall (D : list Assignment) (x y : Name) ( A : Proposition),
    Collect D -> Process_Name x -> Process_Name y ->
    ( D ;;; ( cons (x:A) nil ) !- ([x←→y]) ::: [ (y:A) ]  )

  | idl : forall (D : list Assignment)(x y : Name)(A : Proposition),
    Collect D -> Process_Name x -> Process_Name y ->
    ( D ;;; ( (cons (x:A) nil) ++ (cons (x:(A^⊥)) nil) )  !-  ([x←→y]) ::: []  )

  | repr : forall ( D : list Assignment ) ( x y : Name)( A : Proposition )( P : Prepro ),
    Collect D -> Process_Name y -> Process_Name x -> Process P ->
    ( D ;;; nil !- P ::: [ (y:A) ] ) ->
    ( D ;;; nil !- (x !· (Close y P) ) ::: [ (x:!A)  ] )

  | repl : forall ( D F G : list Assignment ) ( u x : Name)( A : Proposition)(P : Prepro ),
    Collect D -> Collect F -> Collect G -> Process_Name u -> Process_Name x -> Process P ->
    ( D ;;; ( (cons (u:A) nil) ++ F) !- P ::: G ) ->
    ( D ;;; ( (cons (x:!A) nil) ++ F) !- ({x \ u }P) ::: G)

  | conr : forall ( D F G : list Assignment ) ( u x : Name)( A : Proposition)(P : Prepro ),
    Collect D -> Collect G -> Collect F -> Process_Name u -> Process_Name x -> Process P ->
    ( D ;;; ( (cons (u:A) nil) ++ F) !- P ::: G ) ->
    ( D ;;; F !- ({x \ u }P) ::: ( ( cons (x: (? (A ^⊥) )) nil ) ++ G) )

  | conl : forall ( D : list Assignment ) ( y x : Name)( A : Proposition)(P : Prepro ),
    Collect D -> Process_Name y -> Process_Name x -> Process P ->
    ( D ;;; (cons (y:A) nil) !- P ::: nil ) ->
    ( D ;;; (cons (x:? A) nil) !- ( x !· (Close y P)) ::: nil)

  | recr : forall ( D F G: list Assignment ) ( y x : Name)( A B : Proposition)(P : Prepro ),
    Collect D -> Collect F -> Collect G -> Process_Name x -> Process_Name y -> Process P ->
    ( D ;;; ( (cons (y:A) nil) ++ F) !- P ::: ( (cons (x:B) nil) ++ G ) ) ->
    ( D ;;; F !- (x · (Close y P)) ::: ((cons (x:(A−∘B) ) nil) ++ G ) )

  | recl : forall ( D F G F' G': list Assignment ) ( y x : Name)( A B : Proposition)(P Q: Prepro ),
    Collect D -> Collect F -> Collect G -> Collect F' -> Collect G' -> Process_Name x -> Process_Name y -> Process P  -> Process Q ->
    ( D ;;; F !- P ::: ( (cons (y:A) nil) ++ G ) ) ->
    ( D ;;; ((cons (x:B) nil) ++ F') !- Q ::: G' ) ->
    ( D ;;; ((cons (x:(A−∘B) ) nil) ++ (F ++ F')) !- (ν (Close y (x « y »· (P↓Q)))) ::: ( G ++ G') )

  | reccr : forall ( D F G: list Assignment ) ( y x : Name)( A B : Proposition)(P : Prepro ),
    Collect D -> Collect F -> Collect G -> Process_Name x -> Process_Name y -> Process P ->
    ( D ;;; F !- P ::: ( (cons (x:B) (cons (y:A) nil) ) ++ G ) ) ->
    ( D ;;; F !- (x · (Close y P)) ::: ((cons (x:(A⅋B) ) nil) ++ G ) )

  | reccl  : forall ( D F G F' G': list Assignment ) ( y x : Name)( A B : Proposition)(P Q: Prepro ),
    Collect D -> Collect F -> Collect G -> Collect F' -> Collect G' -> Process_Name x -> Process_Name y -> Process P  -> Process Q ->
    ( D ;;; ( (cons (y:A) nil) ++ F ) !- P ::: G ) ->
    ( D ;;; ((cons (x:B) nil) ++ F') !- Q ::: G' ) ->
    ( D ;;; ((cons (x:(A⅋B) ) nil) ++ (F ++ F')) !- (ν (Close y (x « y »· (P↓Q)))) ::: ( G ++ G') )

  | senl : forall ( D F G: list Assignment ) ( y x : Name)( A B : Proposition)(P : Prepro ),
    Collect D -> Collect F -> Collect G -> Process_Name x -> Process_Name y -> Process P ->
    ( D ;;; ( (cons (x:B) (cons (y:A) nil) ) ++ F) !- P ::: G ) ->
    ( D ;;; ( (cons (x:(A⊗B) ) nil) ++ F) !- (x · (Close y P)) ::: G )

  | senr  : forall ( D F G F' G': list Assignment ) ( y x : Name)( A B : Proposition)(P Q: Prepro ),
    Collect D -> Collect F -> Collect G -> Collect F' -> Collect G' -> Process_Name x -> Process_Name y -> Process P  -> Process Q ->
    ( D ;;; F !- P ::: ( (cons (y:A) nil) ++ G) ) ->
    ( D ;;; F' !- Q ::: ( (cons (x:B) nil) ++ G') ) ->
    ( D ;;; (F ++ F') !- (ν (Close y (x « y »· (P↓Q)))) ::: ( (cons (x:(A⊗B)) nil) ++ G ++ G') )

  | absr : forall ( D F G: list Assignment )( x : Name) (P : Prepro ),
    Collect D -> Collect F -> Collect G -> Process_Name x -> Process P ->
    ( D ;;; F !- P ::: G ) ->
    ( D ;;; F !- (x ()· P) ::: ( (cons (x:⊥) nil) ++ G) )

  | absl : forall ( D : list Assignment)( x : Name),
    Collect D -> Process_Name x ->
    ( D ;;; (cons (x:⊥) nil ) !- (x «»·° ) ::: nil )

  | onel : forall ( D F G : list Assignment)( x : Name)( P : Prepro),
    Collect D -> Collect F -> Collect G ->  Process_Name x -> Process P ->
    ( D ;;; F !- P ::: G ) ->
    ( D ;;; (cons (x:¶) nil ++ F) !- (x ()· P ) ::: G )

  | oner : forall ( D : list Assignment)( x : Name),
    Collect D -> Process_Name x ->
    ( D ;;; nil !- (x «»·° ) ::: (cons (x:¶) nil ) )

  | copyl : forall ( D F G : list Assignment)( x u : Name)( P : Prepro)(A : Proposition),
    Collect D -> Collect F -> Collect G ->  Process_Name x -> Process_Name u -> Process P ->
    ( ( cons (u:A) nil ++ D ) ;;; ( cons (x:A) nil ++ F ) !- P ::: G ) ->
    ( ( cons (u:A) nil ++ D ) ;;; F !- (ν (Close x ( u « x »· P ))) ::: G )

  | copyr : forall ( D F G : list Assignment)( x u : Name)( P : Prepro)(A : Proposition),
    Collect D -> Collect F -> Collect G ->  Process_Name x -> Process_Name u -> Process P ->
    ( ( cons (u:A) nil ++ D ) ;;; F !- P ::: ( cons (x:(A^⊥)) nil ++ G) ) ->
    ( ( cons (u:A) nil ++ D ) ;;; F !- (ν (Close x ( u « x »· P ))) ::: G )

  | cutrep : forall ( D F G : list Assignment)( x u : Name)( P Q : Prepro )(A : Proposition),
    Collect D -> Collect F -> Collect G ->  Process_Name x -> Process_Name u -> Process P -> Process Q ->
    ( D ;;; nil !- P ::: ( cons (x:A) nil ) ) ->
    ( D ;;; (cons (u:A) nil ++ F) !- Q ::: G ) ->
    ( D ;;; F !- (ν Close u ( (u !· Close x P) ↓ Q)) ::: G )

  | cutcon : forall ( D F G : list Assignment)( x u : Name)( P Q : Prepro )(A : Proposition),
    Collect D -> Collect F -> Collect G ->  Process_Name x -> Process_Name u -> Process P -> Process Q ->
    ( D ;;; ( cons (x:(A^⊥)) nil ) !- P ::: nil ) ->
    ( D ;;; (cons (u:A) nil ++ F) !- Q ::: G ) ->
    ( D ;;; F !- (ν Close u ( (u !· Close x P) ↓ Q)) ::: G )

where "D ';;;'  F '!-' P ':::' G" := (Inference P D F G).
Hint Constructors Inference : core.

Check Inference_ind.