(* -*- mode: coq; mode: visual-line -*- *)
(** * Equivalences *)

Require Import
  Basics.Overture
  Basics.PathGroupoids
  Basics.Contractible
  Basics.Tactics.
Local Open Scope path_scope.

(** We now give many ways to construct equivalences.  In each case, we define an instance of the typeclass [IsEquiv] named [isequiv_X], followed by an element of the record type [Equiv] named [equiv_X].

   Whenever we need to assume, as a hypothesis, that a certain function is an equivalence, we do it by assuming separately a function and a proof of [IsEquiv].  This is more general than assuming an inhabitant of [Equiv], since the latter has an implicit coercion and an existing instance to give us the former automatically.  Moreover, implicit generalization makes it easy to assume a function and a proof of [IsEquiv]. *)

(** A word on naming: some of the lemmas about equivalences are analogues of those for paths in PathGroupoids.  We name them in an analogous way but adding [_equiv] in an appropriate place, e.g. instead of [moveR_M] we have [moveR_equiv_M].  *)

Generalizable Variables A B C f g.

(** The identity map is an equivalence. *)
Global Instance isequiv_idmap (A : Type) : IsEquiv idmap | 0 :=
  Build_IsEquiv A A idmap idmap (fun _ => 1) (fun _ => 1) (fun _ => 1).

Definition equiv_idmap (A : Type) : A <~> A := Build_Equiv A A idmap _.

Arguments equiv_idmap {A} , A.

Notation "1" := equiv_idmap : equiv_scope.

Global Instance reflexive_equiv : Reflexive Equiv | 0 := @equiv_idmap.

Arguments reflexive_equiv /.

(** The composition of equivalences is an equivalence. *)
Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g}
  : IsEquiv (compose g f) | 1000
  := Build_IsEquiv A C (compose g f)
    (compose f^-1 g^-1)
    (fun c => ap g (eisretr f (g^-1 c)) @ eisretr g c)
    (fun a => ap (f^-1) (eissect g (f a)) @ eissect f a)
    (fun a =>
      (whiskerL _ (eisadj g (f a))) @
      (ap_pp g _ _)^ @
      ap02 g
      ( (concat_A1p (eisretr f) (eissect g (f a)))^ @
        (ap_compose f^-1 f _ @@ eisadj f a) @
        (ap_pp f _ _)^
      ) @
      (ap_compose f g _)^
    ).

(* An alias of [isequiv_compose], with some arguments explicit; often convenient when type class search fails. *)
Definition isequiv_compose'
  {A B : Type} (f : A -> B) (_ : IsEquiv f)
  {C : Type} (g : B -> C) (_ : IsEquiv g)
  : IsEquiv (g o f)
  := isequiv_compose.

Definition equiv_compose {A B C : Type} (g : B -> C) (f : A -> B)
  `{IsEquiv B C g} `{IsEquiv A B f}
  : A <~> C
  := Build_Equiv A C (compose g f) _.

Definition equiv_compose' {A B C : Type} (g : B <~> C) (f : A <~> B)
  : A <~> C
  := equiv_compose g f.

Definition iff_equiv {A B : Type} (f : A <~> B)
  : A <-> B := (equiv_fun f, f^-1).

(** We put [g] and [f] in [equiv_scope] explcitly.  This is a partial work-around for https://coq.inria.fr/bugs/show_bug.cgi?id=3990, which is that implicitly bound scopes don't nest well. *)
Notation "g 'oE' f" := (equiv_compose' g%equiv f%equiv) : equiv_scope.

(* The TypeClass [Transitive] has a different order of parameters than [equiv_compose].  Thus in declaring the instance we have to switch the order of arguments. *)
Global Instance transitive_equiv : Transitive Equiv | 0 :=
  fun _ _ _ f g => equiv_compose g f.

Arguments transitive_equiv /.

Ltac change_apply_equiv_compose :=
  match goal with
  | [ |- context [ equiv_fun (?f oE ?g) ?x ] ] =>
    change ((f oE g) x) with (f (g x))
  end.

(** Anything homotopic to an equivalence is an equivalence. *)
Section IsEquivHomotopic.

  Context {A B : Type} (f : A -> B) {g : A -> B}.
  Context `{IsEquiv A B f}.
  Hypothesis h : f == g.

  Let sect := (fun b:B => (h (f^-1 b))^ @ eisretr f b).
  Let retr := (fun a:A => (ap f^-1 (h a))^ @ eissect f a).

  (* We prove the triangle identity with rewrite tactics.  Since we lose control over the proof term that way, we make the result opaque with "Qed". *)
  Let adj (a : A) : sect (g a) = ap g (retr a).
  Proof.
    unfold sect, retr.
    rewrite ap_pp. apply moveR_Vp.
    rewrite concat_p_pp, <- concat_Ap, concat_pp_p, <- concat_Ap.
    rewrite ap_V; apply moveL_Vp.
    rewrite <- ap_compose; rewrite (concat_A1p (eisretr f) (h a)).
    apply whiskerR, eisadj.
  Qed.

  (* This should not be an instance; it can cause the unifier to spin forever searching for functions to be homotopic to. *)
  Definition isequiv_homotopic : IsEquiv g
    := Build_IsEquiv _ _ g (f ^-1) sect retr adj.

  Definition equiv_homotopic : A <~> B
    := Build_Equiv _ _ g isequiv_homotopic.

End IsEquivHomotopic.

Definition isequiv_homotopic' {A B : Type} (f : A <~> B) {g : A -> B} (h : f == g)
  : IsEquiv g
  := isequiv_homotopic f h.

(** Transporting is an equivalence. *)
Section EquivTransport.

  Context {A : Type} (P : A -> Type) {x y : A} (p : x = y).

  Global Instance isequiv_transport : IsEquiv (transport P p) | 0
    := Build_IsEquiv (P x) (P y) (transport P p) (transport P p^)
    (transport_pV P p) (transport_Vp P p) (transport_pVp P p).

  Definition equiv_transport : P x <~> P y
    := Build_Equiv _ _ (transport P p) _.

End EquivTransport.

(** In all the above cases, we were able to directly construct all the structure of an equivalence.  However, as is evident, sometimes it is quite difficult to prove the adjoint law.

   The following adjointification theorem allows us to be lazy about this if we wish.  It says that if we have all the data of an (adjoint) equivalence except the triangle identity, then we can always obtain the triangle identity by modifying the datum [equiv_is_section] (or [equiv_is_retraction]).  The proof is the same as the standard categorical argument that any equivalence can be improved to an adjoint equivalence.

   As a stylistic matter, we try to avoid using adjointification in the library whenever possible, to preserve the homotopies specified by the user.  *)

Section Adjointify.

  Context {A B : Type} (f : A -> B) (g : B -> A).
  Context (isretr : f o g == idmap) (issect : g o f == idmap).

  (* This is the modified [eissect]. *)
  Let issect' := fun x =>
    ap g (ap f (issect x)^)  @  ap g (isretr (f x))  @  issect x.

  Local Definition is_adjoint' (a : A) : isretr (f a) = ap f (issect' a).
  Proof.
    unfold issect'.
    apply moveR_M1.
    repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose.
    rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)).
    repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1.
    rewrite concat_p_pp, <- ap_compose.
    rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))).
    rewrite concat_pV, concat_1p; reflexivity.
  Qed.

  (** We don't make this a typeclass instance, because we want to control when we are applying it. *)
  Definition isequiv_adjointify : IsEquiv f
    := Build_IsEquiv A B f g isretr issect' is_adjoint'.

  Definition equiv_adjointify : A <~> B
    := Build_Equiv A B f isequiv_adjointify.

End Adjointify.

Arguments isequiv_adjointify {A B}%type_scope (f g)%function_scope isretr issect.
Arguments equiv_adjointify {A B}%type_scope (f g)%function_scope isretr issect.

(** An involution is an endomap that is its own inverse. *)
Definition isequiv_involution {X : Type} (f : X -> X) (isinvol : f o f == idmap)
: IsEquiv f
  := isequiv_adjointify f f isinvol isinvol.

Definition equiv_involution {X : Type} (f : X -> X) (isinvol : f o f == idmap)
: X <~> X
  := equiv_adjointify f f isinvol isinvol.

(** Several lemmas useful for rewriting. *)
Definition moveR_equiv_M `{IsEquiv A B f} (x : A) (y : B) (p : x = f^-1 y)
  : (f x = y)
  := ap f p @ eisretr f y.

Definition moveR_equiv_M' `(f : A <~> B) (x : A) (y : B) (p : x = f^-1 y)
  : (f x = y)
  := moveR_equiv_M x y p.

Definition moveL_equiv_M `{IsEquiv A B f} (x : A) (y : B) (p : f^-1 y = x)
  : (y = f x)
  := (eisretr f y)^ @ ap f p.

Definition moveL_equiv_M' `(f : A <~> B) (x : A) (y : B) (p : f^-1 y = x)
  : (y = f x)
  := moveL_equiv_M x y p.

Definition moveR_equiv_V `{IsEquiv A B f} (x : B) (y : A) (p : x = f y)
  : (f^-1 x = y)
  := ap (f^-1) p @ eissect f y.

Definition moveR_equiv_V' `(f : A <~> B) (x : B) (y : A) (p : x = f y)
  : (f^-1 x = y)
  := moveR_equiv_V x y p.

Definition moveL_equiv_V `{IsEquiv A B f} (x : B) (y : A) (p : f y = x)
  : (y = f^-1 x)
  := (eissect f y)^ @ ap (f^-1) p.

Definition moveL_equiv_V' `(f : A <~> B) (x : B) (y : A) (p : f y = x)
  : (y = f^-1 x)
  := moveL_equiv_V x y p.

(** Equivalence preserves contractibility (which of course is trivial under univalence). *)
Lemma contr_equiv A {B} (f : A -> B) `{IsEquiv A B f} `{Contr A}
  : Contr B.
Proof.
  exists (f (center A)).
  intro y.
  apply moveR_equiv_M.
  apply contr.
Defined.

Definition contr_equiv' A {B} `(f : A <~> B) `{Contr A}
  : Contr B
  := contr_equiv A f.

(** Any two contractible types are equivalent. *)
Global Instance isequiv_contr_contr {A B : Type}
       `{Contr A} `{Contr B} (f : A -> B)
  : IsEquiv f
  := Build_IsEquiv _ _ f (fun _ => (center A))
                  (fun x => path_contr _ _)
                  (fun x => path_contr _ _)
                  (fun x => path_contr _ _).

Lemma equiv_contr_contr {A B : Type} `{Contr A} `{Contr B}
  : (A <~> B).
Proof.
  apply equiv_adjointify with (fun _ => center B) (fun _ => center A);
  intros ?; apply contr.
Defined.

(** The projection from the sum of a family of contractible types is an equivalence. *)
Global Instance isequiv_pr1 {A : Type} (P : A -> Type) `{forall x, Contr (P x)}
  : IsEquiv (@pr1 A P).
Proof.
  apply (Build_IsEquiv
           _ _ (@pr1 A P)
           (fun x => (x ; center (P x)))
           (fun x => 1)
           (fun xy => match xy with
                      | exist x y => ap (exist _ x) (contr _)
                      end)).
  intros [x y].
  rewrite <- ap_compose.
  symmetry; apply ap_const.
Defined.

Definition equiv_pr1 {A : Type} (P : A -> Type) `{forall x, Contr (P x)}
  : { x : A & P x } <~> A
  := Build_Equiv _ _ (@pr1 A P) _.

(** Assuming function extensionality, composing with an equivalence is itself an equivalence *)

Global Instance isequiv_precompose `{Funext} {A B C : Type}
  (f : A -> B) `{IsEquiv A B f}
  : IsEquiv (fun (g:B->C) => g o f) | 1000
  := isequiv_adjointify (fun (g:B->C) => g o f)
    (fun h => h o f^-1)
    (fun h => path_forall _ _ (fun x => ap h (eissect f x)))
    (fun g => path_forall _ _ (fun y => ap g (eisretr f y))).

Definition equiv_precompose `{Funext} {A B C : Type}
  (f : A -> B) `{IsEquiv A B f}
  : (B -> C) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:B->C) => g o f) _.

Definition equiv_precompose' `{Funext} {A B C : Type} (f : A <~> B)
  : (B -> C) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:B->C) => g o f) _.

Global Instance isequiv_postcompose `{Funext} {A B C : Type}
  (f : B -> C) `{IsEquiv B C f}
  : IsEquiv (fun (g:A->B) => f o g) | 1000
  := isequiv_adjointify (fun (g:A->B) => f o g)
    (fun h => f^-1 o h)
    (fun h => path_forall _ _ (fun x => eisretr f (h x)))
    (fun g => path_forall _ _ (fun y => eissect f (g y))).

Definition equiv_postcompose `{Funext} {A B C : Type}
  (f : B -> C) `{IsEquiv B C f}
  : (A -> B) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:A->B) => f o g) _.

Definition equiv_postcompose' `{Funext} {A B C : Type} (f : B <~> C)
  : (A -> B) <~> (A -> C)
  := Build_Equiv _ _ (fun (g:A->B) => f o g) _.

(** Conversely, if pre- or post-composing with a function is always an equivalence, then that function is also an equivalence.  It's convenient to know that we only need to assume the equivalence when the other type is the domain or the codomain. *)

Definition isequiv_isequiv_precompose {A B : Type} (f : A -> B)
  (precomp := (fun (C : Type) (h : B -> C) => h o f))
  (Aeq : IsEquiv (precomp A)) (Beq : IsEquiv (precomp B))
  : IsEquiv f.
Proof.
  assert (H : forall (C D : Type)
                     (Ceq : IsEquiv (precomp C)) (Deq : IsEquiv (precomp D))
                     (k : C -> D) (h : A -> C),
                k o (precomp C)^-1 h = (precomp D)^-1 (k o h)).
  { intros C D ? ? k h.
    transitivity ((precomp D)^-1 (k o (precomp C ((precomp C)^-1 h)))).
    - transitivity ((precomp D)^-1 (precomp D (k o ((precomp C)^-1 h)))).
      + rewrite (eissect (precomp D) _); reflexivity.
      + reflexivity.
    - rewrite (eisretr (precomp C) h); reflexivity. }
  refine (isequiv_adjointify f ((precomp A)^-1 idmap) _ _).
  - intros x.
    change ((f o (precomp A)^-1 idmap) x = idmap x).
    apply ap10.
    rewrite (H A B Aeq Beq).
    change ((precomp B)^-1 (precomp B idmap) = idmap).
    apply eissect.
  - intros x.
    change ((precomp A ((precomp A)^-1 idmap)) x = idmap x).
    apply ap10, eisretr.
Qed.

(*
Definition isequiv_isequiv_postcompose {A B : Type} (f : A -> B)
  (postcomp := (fun (C : Type) (h : C -> A) => f o h))
  (feq : forall C:Type, IsEquiv (postcomp C))
  : IsEquiv f.
(* TODO *)
*)

(** Equivalences between path spaces *)

(** If [f] is an equivalence, then so is [ap f].  We are lazy and use [adjointify]. *)
Global Instance isequiv_ap `{IsEquiv A B f} (x y : A)
  : IsEquiv (@ap A B f x y) | 1000
  := isequiv_adjointify (ap f)
  (fun q => (eissect f x)^  @  ap f^-1 q  @  eissect f y)
  (fun q =>
    ap_pp f _ _
    @ whiskerR (ap_pp f _ _) _
    @ ((ap_V f _ @ inverse2 (eisadj f _)^)
      @@ (ap_compose f^-1 f _)^
      @@ (eisadj f _)^)
    @ concat_pA1_p (eisretr f) _ _
    @ whiskerR (concat_Vp _) _
    @ concat_1p _)
  (fun p =>
    whiskerR (whiskerL _ (ap_compose f f^-1 _)^) _
    @ concat_pA1_p (eissect f) _ _
    @ whiskerR (concat_Vp _) _
    @ concat_1p _).

Definition equiv_ap `(f : A -> B) `{IsEquiv A B f} (x y : A)
  : (x = y) <~> (f x = f y)
  := Build_Equiv _ _ (ap f) _.

Global Arguments equiv_ap (A B)%type_scope f%function_scope _ _ _.

Definition equiv_ap' `(f : A <~> B) (x y : A)
  : (x = y) <~> (f x = f y)
  := equiv_ap f x y.

(* TODO: Is this really necessary? *)
Definition equiv_inj `(f : A -> B) `{IsEquiv A B f} {x y : A}
  : (f x = f y) -> (x = y)
  := (ap f)^-1.

(** The inverse of an equivalence is an equivalence. *)
Global Instance isequiv_inverse {A B : Type} (f : A -> B) {feq : IsEquiv f}
  : IsEquiv f^-1 | 10000.
Proof.
  refine (Build_IsEquiv B A f^-1 f (eissect f) (eisretr f) _).
  intro b.
  apply (equiv_inj (ap f)).
(* We will prove the equality as a composite of four paths, working right to left.
  The LHS remains [ap f (eissect f (f^-1 b))] throughout the process.
  Both sides of the equation are paths of type [f (f^-1 (f (f^-1 b))) = f (f^-1 b)]. *)
  refine (_ @ _ @ _ @ _); revgoals.
  1: apply ap_compose.
  1: symmetry; apply (ap_homotopic_id (eisretr f)).
  1: symmetry; apply concat_pp_V.
  1: symmetry; apply eisadj.
Defined.

(** If the goal is [IsEquiv _^-1], then use [isequiv_inverse]; otherwise, don't pretend worry about if the goal is an evar and we want to add a [^-1]. *)
#[export]
Hint Extern 0 (IsEquiv _^-1) => apply @isequiv_inverse : typeclass_instances.

(** [Equiv A B] is a symmetric relation. *)
Theorem equiv_inverse {A B : Type} : (A <~> B) -> (B <~> A).
Proof.
  intro e.
  exists (e^-1).
  apply isequiv_inverse.
Defined.

Notation "e ^-1" := (@equiv_inverse _ _ e) : equiv_scope.

Global Instance symmetric_equiv : Symmetric Equiv | 0 := @equiv_inverse.

Arguments symmetric_equiv /.

(** Inversion respects composition *)
Definition equiv_inverse_compose {A B C} (f : A <~> B) (g : B <~> C)
  : (g oE f)^-1 == f^-1 oE g^-1.
Proof.
  intros x; reflexivity.
Defined.

(** Inversion respects homotopies *)
Definition equiv_inverse_homotopy {A B} (f g : A <~> B) (p : f == g)
  : g^-1 == f^-1.
Proof.
  intros x; refine (_ @ _ @ _).
  1:symmetry; apply (eissect f).
  1:apply ap, p.
  apply ap, eisretr.
Defined.

Definition equiv_ap_inv `(f : A -> B) `{IsEquiv A B f} (x y : B)
  : (f^-1 x = f^-1 y) <~> (x = y)
  := (@equiv_ap B A f^-1 _ x y)^-1%equiv.

Definition equiv_ap_inv' `(f : A <~> B) (x y : B)
  : (f^-1 x = f^-1 y) <~> (x = y)
  := (equiv_ap' f^-1%equiv x y)^-1%equiv.

(** If [g \o f] and [f] are equivalences, so is [g].  This is not an Instance because it would require Coq to guess [f]. *)
Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C}
  `{IsEquiv A B f} `{IsEquiv A C (g o f)}
  : IsEquiv g
  := isequiv_homotopic (compose (compose g f) f^-1)
       (fun b => ap g (eisretr f b)).

Definition cancelR_equiv {A B C} (f : A -> B) {g : B -> C}
  `{IsEquiv A B f} `{IsEquiv A C (g o f)}
  : B <~> C
  := Build_Equiv B C g (cancelR_isequiv f).

(** If [g \o f] and [g] are equivalences, so is [f]. *)
Definition cancelL_isequiv {A B C} (g : B -> C) {f : A -> B}
  `{IsEquiv B C g} `{IsEquiv A C (g o f)}
  : IsEquiv f
  := isequiv_homotopic (compose g^-1 (compose g f))
       (fun a => eissect g (f a)).

Definition cancelL_equiv {A B C} (g : B -> C) {f : A -> B}
  `{IsEquiv B C g} `{IsEquiv A C (g o f)}
  : A <~> B
  := Build_Equiv _ _ f (cancelL_isequiv g).

(** Combining these with [isequiv_compose], we see that equivalences can be transported across commutative squares. *)
Definition isequiv_commsq {A B C D}
           (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D)
           (p : k o f == g o h)
           `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k}
: IsEquiv g.
Proof.
  refine (@cancelR_isequiv _ _ _ h g _ _).
  refine (isequiv_homotopic _ p).
Defined.

Definition isequiv_commsq' {A B C D}
           (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D)
           (p : g o h == k o f)
           `{IsEquiv _ _ g} `{IsEquiv _ _ h} `{IsEquiv _ _ k}
: IsEquiv f.
Proof.
  refine (@cancelL_isequiv _ _ _ k f _ _).
  refine (isequiv_homotopic _ p).
Defined.

(** Based homotopy spaces *)

Global Instance contr_basedhomotopy `{Funext}
       {A:Type} {B : A -> Type} (f : forall x, B x)
: Contr {g : forall x, B x & f == g }.
Proof.
  refine (contr_equiv' { g : forall x, B x & f = g } _).
  srapply equiv_adjointify; intros [g h].
  - exact (g; apD10 h).
  - exact (g; path_forall _ _ h).
  - apply ap, eisretr.
  - apply ap, eissect.
Defined.

Global Instance contr_basedhomotopy' `{Funext}
       {A:Type} {B : A -> Type} (f : forall x, B x)
: Contr {g : forall x, B x & g == f }.
Proof.
  refine (contr_equiv' { g : forall x, B x & g = f } _).
  srapply equiv_adjointify; intros [g h].
  - exact (g; apD10 h).
  - exact (g; path_forall _ _ h).
  - apply ap, eisretr.
  - apply ap, eissect.
Defined.

(** The function [equiv_ind] says that given an equivalence [f : A <~> B], and a hypothesis from [B], one may always assume that the hypothesis is in the image of [e].

In fibrational terms, if we have a fibration over [B] which has a section once pulled back along an equivalence [f : A <~> B], then it has a section over all of [B].  *)

Definition equiv_ind `{IsEquiv A B f} (P : B -> Type)
  : (forall x:A, P (f x)) -> forall y:B, P y
  := fun g y => transport P (eisretr f y) (g (f^-1 y)).

Arguments equiv_ind {A B} f {_} P _ _.

Definition equiv_ind_comp `{IsEquiv A B f} (P : B -> Type)
  (df : forall x:A, P (f x)) (x : A)
  : equiv_ind f P df (f x) = df x.
Proof.
  unfold equiv_ind.
  rewrite eisadj.
  rewrite <- transport_compose.
  exact (apD df (eissect f x)).
Defined.

(** Using [equiv_ind], we define a handy little tactic which introduces a variable and simultaneously substitutes it along an equivalence. *)

Ltac equiv_intro E x :=
  match goal with
    | |- forall y, @?Q y =>
      refine (equiv_ind E Q _); intros x
  end.

(** The same, but for several variables. *)

Tactic Notation "equiv_intros" constr(E) ident(x)
  := equiv_intro E x.
Tactic Notation "equiv_intros" constr(E) ident(x) ident(y)
  := equiv_intro E x; equiv_intro E y.
Tactic Notation "equiv_intros" constr(E) ident(x) ident(y) ident(z)
  := equiv_intro E x; equiv_intro E y; equiv_intro E z.

(** A lemma that combines equivalence induction with path induction.  If [e] is an equivalence from [a = b] to [X], then to prove [forall x, P x] it is enough to prove [forall p : a = b, P (e p)], and so by path induction it suffices to prove [P (e 1)]. The idiom for using this is to first [revert b X], which allows Coq to determine the family [P]. After using this, [b] will be replaced by [a] in the goal. *)
Definition equiv_path_ind {A} {a : A} {X : A -> Type}
           (e : forall (b : A), a = b <~> X b)
           (P : forall (b : A), X b -> Type)
           (r : P a (e a 1))
  : forall (b : A) (x : X b), P b x.
Proof.
  intro b.
  srapply (equiv_ind (e b)).
  intros [].
  exact r.
Defined.

(** [equiv_composeR'], a flipped version of [equiv_compose'], is (like [concatR]) most often useful partially applied, to give the “first half” of an equivalence one is constructing and leave the rest as a subgoal. One could similarly define [equiv_composeR] as a flip of [equiv_compose], but it doesn’t seem so useful since it doesn’t leave the remaining equivalence as a subgoal. *)
Definition equiv_composeR' {A B C} (f : A <~> B) (g : B <~> C)
  := equiv_compose' g f.

(* Shouldn't this become transitivity mid ? *)
Ltac equiv_via mid :=
  apply @equiv_composeR' with (B := mid).

(** It's often convenient when constructing a chain of equivalences to use [equiv_compose'], etc.  But when we treat an [Equiv] object constructed in that way as a function, via the coercion [equiv_fun], Coq sometimes needs a little help to realize that the result is the same as ordinary composition.  This tactic provides that help. *)
Ltac ev_equiv :=
  repeat match goal with
           | [ |- context[equiv_fun (equiv_compose' ?g ?f) ?a] ] =>
             change ((equiv_compose' g f) a) with (g (f a))
           | [ |- context[equiv_fun (equiv_compose ?g ?f) ?a] ] =>
             change ((equiv_compose g f) a) with (g (f a))
           | [ |- context[equiv_fun (equiv_inverse ?f) ?a] ] =>
             change ((equiv_inverse f) a) with (f^-1 a)
         end.

(** ** Building equivalences between nested sigma and record types *)

(** The following tactic [make_equiv] builds an equivalence between two types built out of arbitrarily nested sigma and record types, not necessarily right-associated, as long as they have all the same underyling components.  This is more general than [issig] in that it doesn't just prove equivalences between a single record type and a single right-nested tower of sigma types, but less powerful in that it can't deduce the latter nested tower of sigmas automatically: you have to have both sides of the equivalence known. *)

(* Perform [intros] repeatedly, recursively destructing all possibly-nested record types. *)
Ltac decomposing_intros :=
  let x := fresh in
  intros x; cbn in x;
  try match type of x with
  | ?a = ?b => fail 1           (** Don't destruct paths *)
  | forall y:?A, ?B => fail 1   (** Don't apply functions *)
  | _ => elim x; clear x
  end;
  try decomposing_intros.

(* A multi-success version of [assumption].  That is, like [assumption], but if there are multiple hypotheses that match the type of the goal, then after choosing the first one, if a later tactic fails we can backtrack and choose another one. *)
Ltac multi_assumption :=
  multimatch goal with
    (* If we wrote [ H : ?A |- ?A ] here instead, it would prevent Coq from choosing an assumption that would require instantiating evars, which it has to do in the contr_basedpaths case below. *)
    [ H : ?A |- _ ] => exact H
  end.

(* Build an element of a possibly-nested record type out of hypotheses in the context. *)
Ltac build_record :=
  cbn; multi_assumption + (unshelve econstructor; build_record).

(* Construct an equivalence between two possibly-nested record/sigma types that differ only by associativity and permutation of their components.  We could use [Build_Equiv] and directly construct [eisadj] by decomposing to reflexivity as well, but often with large nested types it seems to be faster to adjointify. *)
Ltac make_equiv :=
  simple notypeclasses refine (equiv_adjointify _ _ _ _);
    [ decomposing_intros; build_record
    | decomposing_intros; build_record
    | decomposing_intros; exact idpath
    | decomposing_intros; exact idpath ].

(** In case anyone ever needs it, here's the version that doesn't adjointify. It's not the default, because it can be slow. *)
Ltac make_equiv_without_adjointification :=
  simple notypeclasses refine (Build_Equiv _ _ _ _);
    [ decomposing_intros; build_record |
      simple notypeclasses refine (Build_IsEquiv _ _ _ _ _ _ _);
      [ decomposing_intros; build_record
      | decomposing_intros; exact idpath
      | decomposing_intros; exact idpath
      | decomposing_intros; exact idpath ] ].

(** Here are some examples of the use of this tactic that you can uncomment and explore. *)

(**
<<
Goal forall (A : Type) (B : A -> Type) (C : forall a:A, B a -> Type) (D : forall (a:A) (b:B a), C a b -> Type),
     { ab : {a : A & B a } & { c : C ab.1 ab.2 & D ab.1 ab.2 c } }
     <~> { a : A & { bc : { b : B a & C a b } & D a bc.1 bc.2 } }.
  intros A B C D.
  make_equiv.
  Undo.
  (** Here's the eventually successful proof script produced by [make_equiv], extracted from [Info 0 make_equiv] and prettified, so you can step through it and see how the tactic works. *)
  simple notypeclasses refine (equiv_adjointify _ _ _ _).
  - (** Here begins [decomposing_intros] *)
    intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros b; cbn in b.
    intros x; cbn in x.
    elim x; clear x.
    intros c; cbn in c.
    intros d; cbn in d.
    (** Here begins [build_record] *)
    cbn; unshelve econstructor.
    { cbn; exact a. }
    { cbn; unshelve econstructor.
      { cbn; unshelve econstructor.
        { cbn; exact b. }
        { cbn; exact c. } }
      { cbn; exact d. } }
  - intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros b; cbn in b.
    intros c; cbn in c.
    intros d; cbn in d.
    cbn; unshelve econstructor.
    { cbn; unshelve econstructor.
      { cbn; exact a. }
      { cbn; exact b. } }
    { cbn; unshelve econstructor.
      { cbn; exact c. }
      { cbn; exact d. } }
  - intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros b; cbn in b.
    intros c; cbn in c.
    intros d; cbn in d.
    cbn; exact idpath.
  - intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a; cbn in a.
    intros b; cbn in b.
    intros x; cbn in x.
    elim x; clear x.
    intros c; cbn in c.
    intros d; cbn in d.
    cbn; exact idpath.
Defined.
>>
*)

(** Here is an example illustrating the need for [multi_assumption] instead of just [assumption]. *)
(**
<<
Goal forall (A:Type) (R:A->A->Type),
    { x : A & { y : A & R x y } } <~> { xy : A * A & R (fst xy) (snd xy) }.
  intros A R.
  make_equiv.
  Undo.
  simple notypeclasses refine (equiv_adjointify _ _ _ _).
  - intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros x; cbn in x.
    elim x; clear x.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; unshelve econstructor.
    { cbn; unshelve econstructor.
      { (** [build_record] can't guess at this point that it needs to use [a1] instead of [a2], and in fact it tries [a2] first; but later on, [exact r] fails in that case, causing backtracking to this point and a re-try with [a1].  *)
        cbn; exact a1. }
      { cbn; exact a2. } }
    cbn; exact r.
  - intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; unshelve econstructor.
    { cbn; exact a1. }
    { cbn; unshelve econstructor.
      { cbn; exact a2. }
      { cbn; exact r. } }
  - intros x; cbn in x.
    elim x; clear x.
    intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; exact idpath.
  - intros x; cbn in x.
    elim x; clear x.
    intros a1; cbn in a1.
    intros x; cbn in x.
    elim x; clear x.
    intros a2; cbn in a2.
    intros r; cbn in r.
    cbn; exact idpath.
Defined.
>>
*)

(** Some "real-world" examples where [make_equiv] simplifies things a lot include the associativity/symmetry proofs in [Types/Sigma.v], [issig_pequiv'] in [Pointed/pEquiv.v], and [loop_susp_adjoint] in [Pointed/pSusp.v]. *)

(** Now we give a version of [make_equiv] that can also prove equivalences of nested sigma- and record types that involve contracting based path-spaces on either or both sides.  The basepoint and the path don't have to appear together, but can be in arbitrarily separated parts of the nested structure.  It does this by selectively applying path-induction to based paths appearing on both sides, if needed. *)

(** We start with a version of [decomposing_intros] that is willing to destruct paths, though as a second choice. *)
Ltac decomposing_intros_with_paths :=
  let x := fresh in
  intros x; cbn in x;
  multimatch type of x with
  | _ =>
    try match type of x with
        | (** Don't destruct paths at first *)
          ?a = ?b => fail 1
        | (** Don't apply functions at first *)
          forall y:?A, ?B => fail 1
        | _ => elim x; clear x
        end;
    try decomposing_intros_with_paths
  | ?a = ?b =>
    (** Destruct paths as a second choice.  But sometimes [destruct] isn't smart enough to generalize the other hypotheses that use the free endpoint, so we manually apply [paths_ind], or its right-handed version, instead. *)
    ((move x before b; (** Ensure that [b] and [x] come first in the [forall] goal resulting from [generalize dependent], so that [paths_ind] can apply to it. *)
      revert dependent b;
      assert_fails (move b at top); (** Check that [b] was actually reverted.  (If it's a section variable that the goal depends on, [generalize dependent b] will "succeed", but actually fail to generalize the goal over [b] (since that can't be done within the section) and not clear [b] from the context.)  *)
      refine (paths_ind _ _ _)) +
     (** Try the other endpoint too. *)
     (move x before a;
      revert dependent a;
      assert_fails (move a at top);
      refine (paths_ind_r _ _ _)));
    try decomposing_intros_with_paths
  end.

(** Going the other direction, we have to be willing to insert identity paths to fill in the based path-spaces that got destructed.  In fact [econstructor] is already willing to do that, since [idpath] is the constructor of [paths].  However, our previous [build_record] won't manage to get to the point of being able to apply [econstructor] to the necessary paths, since it'll get stuck earlier on trying to find the basepoint.  Thus, we give a version of [build_record] that is willing to create existential variables ("evars") for goals that it can't solve, in hopes that a later [idpath] (produced by [econstructor]) will determine them by unification.  Note that if there are other fields that depend on the basepoint that occur before the [idpath], the evar will -- and, indeed, must -- get instantiated by them instead.  This is why [multi_assumption], above, must be willing to instantiate evars. *)
Ltac build_record_with_evars :=
  (cbn; multi_assumption + (unshelve econstructor; build_record_with_evars)) +
  (** Create a fresh evar to solve this goal *)
  (match goal with
     |- ?G => let x := fresh in evar (x : G); exact x
   end; build_record_with_evars).

(** Now here's the improved version of [make_equiv]. *)
Ltac make_equiv_contr_basedpaths :=
  simple notypeclasses refine (equiv_adjointify _ _ _ _);
    (** [solve [ unshelve TAC ]] ensures that [TAC] succeeds without leaving any leftover evars. *)
    [ decomposing_intros_with_paths; solve [ unshelve build_record_with_evars ]
    | decomposing_intros_with_paths; solve [ unshelve build_record_with_evars ]
    | decomposing_intros_with_paths; exact idpath
    | decomposing_intros_with_paths; exact idpath ].

(** As before, we give some examples. *)

(**
<<
Section Examples.
  Context (A : Type) (B : A -> Type) (a0 : A).
  Goal { a : A & { b : B a & a = a0 } } <~> B a0.
  Proof.
    make_equiv_contr_basedpaths.
    Undo.
    simple notypeclasses refine (equiv_adjointify _ _ _ _).
    - (** Here begins [decomposing_intros_with_paths] *)
      intros x; cbn in x.
      elim x; clear x.
      intros a; cbn in a.
      intros x; cbn in x.
      elim x; clear x.
      intros b; cbn in b.
      intros p; cbn in p.
      (** [decomposing_intros] wouldn't be willing to destruct [p] here, because it's a path.  But [decomposing_intros_with_paths] will try it when all else fails. *)
      move p before a.
      generalize dependent a.
      not (move a at top).
      refine (paths_ind_r _ _ _).
      intros b; cbn in b.
      (** Here begins [build_record_with_evars] *)
      exact b.
    - (** Here begins [decomposing_intros_with_paths] *)
      intros b; cbn in b.
      (** Here begins [build_record_with_evars] *)
      cbn; unshelve econstructor.
      { let x := fresh in evar (x : A); exact x. }
      cbn; unshelve econstructor.
      { (** This instantiates the evar. *)
        exact b. }
      { cbn; unshelve econstructor. }
    - intros b; cbn in b.
      exact idpath.
    - intros x; cbn in x.
      elim x; clear x.
      intros a; cbn in a.
      intros x; cbn in x.
      elim x; clear x.
      intros b; cbn in b.
      intros p; cbn in p.
      move p before a.
      generalize dependent a.
      not (move a at top).
      refine (paths_ind_r _ _ _).
      intros b; cbn in b.
      exact idpath.
  Defined.
End Examples.
>>
*)

(** Some "real-world" examples where [make_equiv_contr_basedpaths] simplifies things a lot include [hfiber_compose] in [HFiber.v], [hfiber_pullback_along] in [Limits/Pullback.v], and [equiv_Ocodeleft2plus] in [BlakersMassey.v]. *)


(** * Global type definitions. *)

Require Import CoqLib.
Require Import String.
Require Import Ascii.
Require Import HexString.

(** Type definitions used in all part of the Hilecop-Cert project. *)

(** Defines the set of strictly positive natural numbers. *)

Definition natstar := { n : nat | n > 0 }.

(** Casts a natstar into a nat. *)

Definition natstar_to_nat (ns : natstar) := proj1_sig ns.
Coercion natstar_to_nat : natstar >-> nat.

(** Defines some natstar. *)

Definition onens := exist _ 1 (gt_Sn_O 0).
Definition twons := exist _ 2 (gt_Sn_O 1).
Definition threens := exist _ 3 (gt_Sn_O 2).
Definition fourns := exist _ 4 (gt_Sn_O 3).
Definition fivens := exist _ 5 (gt_Sn_O 4).
Definition sixns := exist _ 6 (gt_Sn_O 5).
Definition sevenns := exist _ 7 (gt_Sn_O 6).
Definition eightns := exist _ 8 (gt_Sn_O 7).
Definition ninens := exist _ 9 (gt_Sn_O 8).
Definition tenns := exist _ 10 (gt_Sn_O 9).

(** ** Properties on N  *)

Coercion N.to_nat : N >-> nat.
Coercion N.of_nat : nat >-> N.

Definition N_nleb_nle (n m : N) : ((n <=? m) = false <-> ~n <= m)%N.
  split.
  intros. intro. rewrite ((proj2 (N.leb_le n m)) H0) in H.
  inversion H.
  destruct (n <=? m)%N eqn: eq_le_bool.
  intro. elimtype False. apply H.
  apply ((proj1 (N.leb_le n m)) eq_le_bool).
  reflexivity.
Defined.

Definition N_le_dec (n m : N) : ({n <= m} + {~n <= m})%N.
  destruct (n <=? m)%N eqn: eq_le_bool.
  exact (left ((proj1 (N.leb_le n m)) eq_le_bool)).
  exact (right ((proj1 (N_nleb_nle n m)) eq_le_bool)).
Defined.

Definition N_nltb_nlt (n m : N) : ((n <? m) = false <-> ~n < m)%N.
  split.
  intros. intro. rewrite ((proj2 (N.ltb_lt n m)) H0) in H.
  inversion H.
  destruct (n <? m)%N eqn: eq_le_bool.
  intro. elimtype False. apply H.
  apply ((proj1 (N.ltb_lt n m)) eq_le_bool).
  reflexivity.
Defined.

Definition N_lt_dec (n m : N) : ({n < m} + {~n < m})%N.
  destruct (n <? m)%N eqn: eq_le_bool.
  exact (left ((proj1 (N.ltb_lt n m)) eq_le_bool)).
  exact (right ((proj1 (N_nltb_nlt n m)) eq_le_bool)).
Defined.

Lemma nlt_Npos_1 : forall p, (~Npos p < 1)%N.
  destruct p; inversion 1.
Defined.

Lemma N_lt_succ_lt_pred :
  forall i j,
    (Npos i < N.succ (Npos j))%N ->
    (N.pred (Npos i) < Npos j)%N.
  intros; lia.
Defined.

(** ** Definitions and Facts about strict orders and boolean functions *)

Section StrictOrders.

  Variable A : Type.
  Variable eqA : A -> A -> Prop.
  Variable decEqA : forall x y, {eqA x y} + {~eqA x y}.

  Variable rel : A -> A -> Prop.
  Variable decRel : forall x y, {rel x y} + {~rel x y}.

  (** Defines the type of relation that are a strict order
    over a type A.
   *)

  Inductive IsStrictOrder : Prop :=
    MkStrictOrder {
        rel_irrefl : forall a, ~rel a a;
        rel_trans : forall a b c, rel a b -> rel b c -> rel a c;

        (* Irreflexivity and transitivity entail anti-symmetry. *)
        (* rel_antisym : forall a b, rel a b -> ~rel b a; *)
      }.

  (** States that two elements of type A are comparable through
      the boolean relation [rel]. *)

  Definition AreComparable (x y : A) : Prop := rel x y \/ rel y x.

  (** States that [rel] is a strict total order over a type A, that is:
    - [rel] is a strict order over type A.
    - all elements of A that are different are comparable with [rel].
   *)

  Definition IsStrictTotalOrder :=
    IsStrictOrder /\ forall x y, ~eqA x y -> AreComparable x y.

  (** States that [rel] is a strict order over the elements of a list
      [l].  *)

  Inductive IsStrictOrderOverList (l : list A) (nodupl : NoDup l) : Prop :=
    MkStrictOrderOverList {
        reloverl_irrefl : forall a, In a l -> ~rel a a;
        reloverl_trans : forall a b c, In a l -> In b l -> In c l ->
                                       rel a b -> rel b c -> rel a c;

        (* Irreflexivity and transitivity entail anti-symmetry. *)
        (* reloverl_antisym : forall a b, In a l -> In b l -> brel a b = true -> brel b a = false; *)
      }.

  (** States that [rel] is a strict total order over the elements of list [l], that is:
      - [rel] is a strict order over the elements of [l]
      - all elements of [l] that are different are comparable with [rel].
   *)

  Definition IsStrictTotalOrderOverList (l : list A) (nodupl : NoDup l) :=
    IsStrictOrderOverList l nodupl /\ forall x y, ~eqA x y -> AreComparable x y.

End StrictOrders.

(** Defines the type of Petri net arcs. *)

Inductive ArcT : Type := basic | test | inhibitor.

(** Implements the equality between two arc_t values. *)

Definition arct_eqb (a a' : ArcT) : bool :=
  match a, a' with
  | basic, basic => true
  | test, test => true
  | inhibitor, inhibitor => true
  | _, _ => false
  end.

(** Cast from ArcT to nat. *)

Definition ArcT_in_nat (a : ArcT) :=
  match a with
  | basic => 0%N
  | test => 1%N
  | inhibitor => 2%N
  end.

Coercion ArcT_in_nat : ArcT >-> N.

(** Cast from ArcT to N. *)

Definition ArcT_in_N (a : ArcT) : N :=
  match a with
  | basic => 0
  | test => 1
  | inhibitor => 2
  end.

Coercion ArcT_in_N : ArcT >-> N.

(** Defines the type of Petri net transitions. *)

Inductive TransitionT : Type := not_temporal | temporal_a_b |
                                temporal_a_a | temporal_a_inf.

(** Cast from TransitionT to nat. *)

Definition TransitionT_in_nat (t : TransitionT) :=
  match t with
  | not_temporal => 0%N
  | temporal_a_b => 1%N
  | temporal_a_a => 2%N
  | temporal_a_inf => 3%N
  end.

Coercion TransitionT_in_nat : TransitionT >-> N.

(** Cast from TransitionT to N. *)

Definition TransitionT_in_N (t : TransitionT) : N :=
  match t with
  | not_temporal => 0
  | temporal_a_b => 1
  | temporal_a_a => 2
  | temporal_a_inf => 3
  end.

Coercion TransitionT_in_N : TransitionT >-> N.

(** Implements the equality between two transition_t values. *)

Definition transt_eqb (t t' : TransitionT) : bool :=
  match t, t' with
  | not_temporal, not_temporal => true
  | temporal_a_b, temporal_a_b => true
  | temporal_a_a, temporal_a_a => true
  | temporal_a_inf, temporal_a_inf => true
  | _, _ => false
  end.

(** Defines an option type able to return error messages. *)

Inductive optionE (A : Type) : Type :=
| Success : A -> optionE A
| Err : string -> optionE A.

Arguments Success {A} a.
Arguments Err {A}.

Definition Ret (A : Type) (x : A) := Success x.

Arguments Ret {A}.

Module ErrMonadNotations.

  Notation "[| x |]" := (Success x).

  Notation "x <- e1 ; e2" := (match e1 with
                              | Err msg => Err msg
                              | Success x => e2
                              end)
                               (right associativity, at level 200).

  Notation "'do' X <- A ; B" := (match A with
                                 | Err msg => Err msg
                                 | Success X => B
                                 end)
                                  (at level 200, X name, A at level 100, B at level 200).

  Notation "'do' '|(' x , y ')|' <- e1 ; e2" :=
    (do z <- e1; let '(x, y) := z in e2)
      (right associativity, at level 200).

  Notation "'do' '|(' x , y , z ')|' <- e1 ; e2" :=
    (do a <- e1; let '(x, y, z) := a in e2)
      (right associativity, at level 200).

  Definition f (n : nat) : optionE (nat * nat * nat) :=
    [| (0, 0, 0) |].

  Definition g (n : nat) : optionE (nat * nat) :=
    do |( x, y , z )| <- f n; [| (x, y) |].

End ErrMonadNotations.

(** Converts a nat into its hexadecimal string representation. Useful
    to display variable values in error messages.  *)

Notation "$$ n" := (of_nat n) (at level 0, only parsing).

(** ** Global definitions for bool *)

Definition nullb {A : Type} := fun _ : A => false.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

   (* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS                                      *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - DEFINITIONS                        *)
(* --------------------------------------------------------------------- *)

Section Useless.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

Definition useful (g: cfg _ _) (s: non_terminal + terminal): Prop:=
match s with
| inr t => True
| inl n => exists s: sentence, derives g [inl n] (map term_lift s)
end.

Definition useful_sf (g: cfg _ _)(l: _): Prop:=
forall s: _,
In s l -> useful g s.

Inductive g_use_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_use : forall left: non_terminal,
             forall right: sf,
             rules g left right ->
             useful g (inl left) ->
             useful_sf g right ->
             g_use_rules g left right.

Lemma g_use_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_use_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [ tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- intros left right H2.
  inversion H2.
  subst.
  destruct H1 as [_ H1].
  specialize (H1 left right H).
  destruct H1 as [H4 [H5 H6]].
  split.
  + exact H4.
  + split.
    * exact H5.
    * exact H6.
Qed.

Definition g_use (g: cfg _ _): cfg _ _:= {|
start_symbol:= start_symbol g;
rules:= g_use_rules g;
t_eqdec:= t_eqdec g;
nt_eqdec:= nt_eqdec g;
rules_finite:= g_use_finite g
|}.

Definition has_no_useless_symbols (g: cfg _ _): Prop:=
forall n: _, appears g (inl n) -> useful g (inl n).

Definition non_empty (g: cfg _ _): Prop:=
useful g (inl (start_symbol g)).

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - LEMMAS AND THEOREMS                *)
(* --------------------------------------------------------------------- *)

Lemma useful_exists:
forall g: cfg _ _,
forall n:non_terminal,
useful g (inl n) ->
exists (left : non_terminal) (right : sf),
rules g left right /\ (n = left \/ In (inl n) right).
Proof.
intros g n H1.
destruct H1 as [s H2].
apply exists_rule in H2.
destruct H2 as [H2 | H2].
- exists n, (map term_lift s).
  split.
  + exact H2.
  + left.
    reflexivity.
- destruct H2 as [right [H3 H4]].
  exists n, right.
  split.
  + exact H3.
  + left.
    reflexivity.
Qed.

Lemma useful_sf_sentence:
forall l: sf,
forall g: cfg _ _,
useful_sf g l -> exists s': sentence, derives g l (map term_lift s').
Proof.
intros l g H.
induction l.
- exists [].
  simpl.
  apply derives_refl.
- replace (a :: l) with ([a]++l) in H.
  + assert (H1: forall s: non_terminal + terminal, In s l -> useful g s).
      {
      intros s H1.
      specialize (H s).
      apply H.
      apply in_or_app.
      right.
      exact H1.
      }
    specialize (IHl H1).
    assert (H2: useful g a).
      {
      apply H.
      simpl.
      left.
      reflexivity.
      }
    unfold useful in H2.
    destruct a.
    * destruct IHl as [s' H3].
      destruct H2 as [s H2].
      exists (s ++ s').
      simpl.
      {
      rewrite map_app.
      change (inl n :: l) with ([inl n] ++ l).
      apply derives_combine.
      split.
      - exact H2.
      - exact H3.
      }
    * destruct IHl as [s2 H5].
      exists ([t] ++ s2).
      rewrite map_app.
      change (inr t :: l) with ([inr t] ++ l).
      apply derives_combine.
      {
      split.
      - simpl.
        constructor.
      - exact H5.
      }
  + simpl.
    reflexivity.
Qed.

Lemma use_step:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules g left right ->
(forall s: non_terminal + terminal, In s right -> useful g s) ->
useful g (inl left).
Proof.
intros g left right H1 H2.
unfold useful.
apply derives_rule with (s1:=[]) (s2:=[]) in H1.
simpl in H1.
rewrite app_nil_r in H1.
apply useful_sf_sentence in H2.
destruct H2 as [s' H3].
exists s'.
apply derives_trans with (s2:=right).
- exact H1.
- exact H3.
Qed.

Lemma useful_g_g_use:
forall g: cfg _ _,
forall n: non_terminal,
useful g (inl n) -> useful (g_use g) (inl n).
Proof.
intros g n H.
unfold useful in H.
destruct H as [x H].
unfold useful.
exists x.
apply derives_sflist in H.
apply derives_sflist.
destruct H as [l [H2 [H3 H4]]].
exists l.
split.
- assert (H5: length l >= 2 \/ length l < 2).
    {
    omega.
    }
  destruct H5 as [H5 | H5].
  + assert (H6:= H5).
    apply sflist_rules with (g:=g) in H5.
    destruct H5 as [H5 _].
    specialize (H5 H2).
    apply sflist_rules.
    * exact H6.
    * intros i H7.
      specialize (H5 i H7).
      destruct H5 as [left [right [s0 [s' [H10 [H11 H12]]]]]].
      exists left, right, s0, s'.
      {
      split.
      - exact H10.
      - split.
        + exact H11.
        + simpl.
          apply Lift_use.
          * exact H12.
          * unfold useful.
            assert (H20: derives g (s0 ++ inl left :: s') (map term_lift x)).
              {
              apply derives_sflist.
              rewrite <- (firstn_skipn i l) in H2.
              apply sflist_app_l in H2.
              exists (skipn i l).
              split.
              - exact H2.
              - split.
                + rewrite hd_skip.
                  exact H10.
                + rewrite last_skip.
                  * exact H4.
                  * omega.
              }
            assert (H21: exists s'': sentence, derives g [inl left] (map term_lift s'')).
              {
              apply derives_split in H20.
              destruct H20 as [s1' [s2' [H21 [_ H22]]]].
              replace (inl left :: s') with ([inl left] ++ s') in H22.
              - apply derives_split in H22.
                destruct H22 as [s1'0 [s2'0 [H31 [H32 _]]]].
                symmetry in H21.
                apply map_expand in H21.
                destruct H21 as [s1'' [s2'' [H40 [H41 H42]]]].
                rewrite <- H42 in H31.
                symmetry in H31.
                apply map_expand in H31.
                destruct H31 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H32.
                exists s1'''.
                exact H32.
              - simpl.
                reflexivity.
              }
            exact H21.
          * intros s1 H8.
            {
            destruct s1.
            - assert (H30: derives g (s0 ++ right ++ s') (map term_lift x)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H2.
                apply sflist_app_l in H2.
                exists (skipn (S i) l).
                split.
                - exact H2.
                - split.
                  + rewrite <- H11.
                    apply hd_skip.
                  + rewrite <- H4.
                    apply last_skip.
                    omega.
                }
              assert (H31: exists s'': sentence, derives g right (map term_lift s'')).
                {
                apply derives_split in H30.
                destruct H30 as [s1' [s2' [H35 [H36 H37]]]].
                apply derives_split in H37.
                destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                rewrite <- H43 in H38.
                symmetry in H38.
                apply map_expand in H38.
                destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H39.
                exists s1'''.
                exact H39.
                }
              assert (H32: exists s'': sentence, derives g [inl n0] (map term_lift s'')).
                {
                apply in_split in H8.
                destruct H8 as [l1 [l2 H60]].
                rewrite H60 in H31.
                destruct H31 as [s'' H61].
                apply derives_split in H61.
                destruct H61 as [s1' [s2' [H35 [H36 H37]]]].
                replace (inl n0 :: l2) with ([inl n0] ++ l2) in H37.
                - apply derives_split in H37.
                  destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                  symmetry in H35.
                  apply map_expand in H35.
                  destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                  rewrite <- H43 in H38.
                  symmetry in H38.
                  apply map_expand in H38.
                  destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                  rewrite <- H51 in H39.
                  exists s1'''.
                  exact H39.
                - simpl.
                  reflexivity.
                }
              exact H32.
            - simpl.
              auto.
          }
      }
  + destruct l as [|s0 l].
    * apply sflist_empty.
    * {
      destruct l as [|s1 l].
      - apply sflist_start.
      - replace (s0 :: s1 :: l) with ([s0] ++ [s1] ++ l) in H5.
        + repeat rewrite app_length in H5.
          simpl in H5.
          repeat apply lt_S_n in H5.
          apply lt_n_0 in H5.
          contradiction.
        + simpl.
          reflexivity.
      }
- split.
  + exact H3.
  + exact H4.
Qed.

Lemma useful_g_use:
forall g: cfg _ _,
forall n: non_terminal,
appears (g_use g) (inl n) -> useful (g_use g) (inl n).
Proof.
intros g n H.
inversion H.
clear H.
destruct H0 as [right [H1 H2]].
destruct H2 as [H2| H2].
- subst.
  simpl in H1.
  inversion H1.
  subst.
  apply useful_g_g_use.
  exact H0.
- simpl in H1.
  inversion H1.
  subst.
  apply useful_g_g_use.
  specialize (H3 (inl n)).
  apply H3.
  exact H2.
Qed.

Lemma sflist_g_use_g:
forall g: cfg _ _,
forall l: list sf,
sflist (g_use g) l -> sflist g l.
Proof.
intros g l H.
induction H.
- apply sflist_empty.
- apply sflist_start.
- apply sflist_step with (left:=left).
  exact IHsflist.
  exact H0.
  simpl in H1.
  inversion H1.
  exact H2.
Qed.

Lemma produces_g_use_g:
forall g: cfg _ _,
forall s: sentence,
produces (g_use g) s -> produces g s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
simpl in H2.
apply derives_sflist.
exists l.
split.
- apply sflist_g_use_g.
  exact H1.
- split.
  + exact H2.
  + exact H3.
Qed.

Lemma sflist_g_g_use:
forall g: cfg _ _,
forall l: list sf,
forall s: sentence,
sflist g l /\ last l [] = map term_lift s -> sflist (g_use g) l.
Proof.
intros g l s [H1 H2].
assert (H3: length l >= 2 \/ length l < 2).
  {
  omega.
  }
destruct H3 as [H3 | H3].
- assert (H3':=H3).
  apply sflist_rules with (g:=g) in H3.
  destruct H3 as [H3 _].
  specialize (H3 H1).
  apply sflist_rules.
  + exact H3'.
  + intros i H4.
    specialize (H3 i H4).
    destruct H3 as [left [right [s0 [s' [H5 [H6 H7]]]]]].
    exists left, right, s0, s'.
    split.
    * exact H5.
    * {
      split.
      - exact H6.
      - simpl.
        apply Lift_use.
        + exact H7.
        + unfold useful.
          assert (H20: derives g (s0 ++ inl left :: s') (map term_lift s)).
            {
            apply derives_sflist.
            rewrite <- (firstn_skipn i l) in H1.
            apply sflist_app_l in H1.
            exists (skipn i l).
            split.
            - exact H1.
            - split.
              + rewrite hd_skip.
                exact H5.
              + rewrite last_skip.
                * exact H2.
                * omega.
            }
          assert (H21: exists s'': sentence, derives g [inl left] (map term_lift s'')).
            {
            apply derives_split in H20.
            destruct H20 as [s1' [s2' [H21 [_ H22]]]].
            replace (inl left :: s') with ([inl left] ++ s') in H22.
            - apply derives_split in H22.
              destruct H22 as [s1'0 [s2'0 [H31 [H32 _]]]].
              symmetry in H21.
              apply map_expand in H21.
              destruct H21 as [s1'' [s2'' [H40 [H41 H42]]]].
              rewrite <- H42 in H31.
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [s1''' [s2''' [H50 [H51 H52]]]].
              rewrite <- H51 in H32.
              exists s1'''.
              exact H32.
            - simpl.
              reflexivity.
            }
          exact H21.
        + intros s1 H99.
          destruct s1.
          * assert (H30: derives g (s0 ++ right ++ s') (map term_lift s)).
              {
              apply derives_sflist.
              rewrite <- (firstn_skipn (S i) l) in H1.
              apply sflist_app_l in H1.
              exists (skipn (S i) l).
                split.
              - exact H1.
              - split.
                + rewrite <- H6.
                  apply hd_skip.
                + rewrite <- H2.
                  apply last_skip.
                  omega.
              }
            assert (H31: exists s'': sentence, derives g right (map term_lift s'')).
              {
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H35 [H36 H37]]]].
              apply derives_split in H37.
              destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
              symmetry in H35.
              apply map_expand in H35.
              destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
              rewrite <- H43 in H38.
              symmetry in H38.
              apply map_expand in H38.
              destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
              rewrite <- H51 in H39.
              exists s1'''.
              exact H39.
              }
            assert (H32: exists s'': sentence, derives g [inl n] (map term_lift s'')).
              {
              apply in_split in H99.
              destruct H99 as [l1 [l2 H60]].
              rewrite H60 in H31.
              destruct H31 as [s'' H61].
              apply derives_split in H61.
              destruct H61 as [s1' [s2' [H35 [H36 H37]]]].
              replace (inl n :: l2) with ([inl n] ++ l2) in H37.
              - apply derives_split in H37.
                destruct H37 as [s1'0 [s2'0 [H38 [H39 H40]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'' [s2'' [H41 [H42 H43]]]].
                rewrite <- H43 in H38.
                symmetry in H38.
                apply map_expand in H38.
                destruct H38 as [s1''' [s2''' [H50 [H51 H52]]]].
                rewrite <- H51 in H39.
                exists s1'''.
                exact H39.
              - simpl.
                reflexivity.
              }
            unfold useful.
            exact H32.
          * simpl.
            auto.
      }
- destruct l as [|s0 l].
  + apply sflist_empty.
  + destruct l as [|s1 l].
    * apply sflist_start.
    * {
      replace (s0 :: s1 :: l) with ([s0] ++ [s1] ++ l) in H3.
      - repeat rewrite app_length in H3.
        simpl in H3.
        repeat apply lt_S_n in H3.
        apply lt_n_0 in H3.
        contradiction.
      - simpl.
        reflexivity.
      }
Qed.

Lemma produces_g_g_use:
forall g: cfg _ _,
forall s: sentence,
produces g s -> produces (g_use g) s.
Proof.
unfold produces.
unfold generates.
intros g s H.
apply derives_sflist in H.
destruct H as [l [H1 [H2 H3]]].
apply derives_sflist.
exists l.
split.
- apply sflist_g_g_use with (s:=s).
  split.
  + exact H1.
  + exact H3.
- split.
  + exact H2.
  + exact H3.
Qed.

Theorem g_equiv_use:
forall g: cfg _ _,
non_empty g -> g_equiv (g_use g) g.
Proof.
unfold g_equiv.
intros g H' s.
split.
- apply produces_g_use_g.
- apply produces_g_g_use.
Qed.

Theorem g_use_correct:
forall g: cfg _ _,
non_empty g ->
g_equiv (g_use g) g /\
has_no_useless_symbols (g_use g).
Proof.
intros g H'.
split.
- apply g_equiv_use.
  exact H'.
- unfold has_no_useless_symbols.
  intros n H.
  inversion H.
  destruct H0 as [right [H1 H2]].
  simpl in H1.
  inversion H1.
  subst.
  destruct H2.
  + subst.
    apply useful_g_g_use in H3.
    exact H3.
  + specialize (H4 (inl n) H2).
    apply useful_g_g_use in H4.
    exact H4.
Qed.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - USELESS SYMBOLS - ALTERNATIVE DEFINITIONS            *)
(* --------------------------------------------------------------------- *)

Inductive useful2 (g: cfg non_terminal terminal): (non_terminal + terminal) -> Prop:=
| use_1: forall t: terminal,
         useful2 g (inr t)
| use_2: forall left: non_terminal,
         forall right: sf,
         rules g left right ->
         (forall s: non_terminal + terminal,
         In s right ->
         useful2 g s) ->
         useful2 g (inl left).

Fixpoint useful3 (g: cfg non_terminal terminal) (s: non_terminal + terminal): Prop:=
match s with
| inl n => False
| inr t => True
end.

End Useless.


Inductive Id (X:Set) : X -> X -> Prop :=
| refl : forall (x:X), Id X x x
.

Arguments Id {X} _ _.
Arguments refl {X} _.

Notation "x == y" := (Id x y) (at level 70, no associativity).

Lemma unit_singleton : forall (x:unit), x = tt.
Proof. intros []. reflexivity. Qed.

(*
Lemma Id_singleton : forall (X:Set) (x y:X) (p q: x == y), p = q.
Proof.
    intros X x y p q. destruct p.

Show.
*)


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rlt_irrefl.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2.
Proof.
  intros x y.
  intro hxy.
  unfold not.
  intro eq.
  subst y.
  generalize dependent hxy.
  apply Rlt_irrefl.
Qed.


Require Import GL4ip_PSGL4ip_calcs.
Require Import List.
Export ListNotations.

Require Import existsT.
Require Import PeanoNat.
Require Import Lia.

Set Implicit Arguments.

Parameter eq_dec_propvar : forall x y : V, {x = y}+{x <> y}.

Lemma In_dec : forall l (a : MPropF) , (In a l) + ((In a l) -> False).
Proof.
induction l.
- right. intro. destruct H.
- intro a0. pose (IHl a0). destruct s.
  * left. apply in_cons. assumption.
  * destruct (eq_dec_form a a0).
    + subst. left. apply in_eq.
    + right. intro. inversion H.
      { apply n. assumption. }
      { apply f. assumption. }
Qed.

(* Let us prove some lemmas about remove. *)

Lemma in_not_touched_remove : forall l1 (a0 a1 : MPropF),
        In a0 l1 -> a0 <> a1 -> In a0 (remove eq_dec_form a1 l1).
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form a1 a).
  * subst. apply IHl1. inversion H. exfalso. apply H0. auto. assumption. assumption.
  * inversion H. subst. apply in_eq. apply in_cons. apply IHl1. assumption. assumption.
Qed.

Lemma remove_dist_app {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
        forall (a : A) l1 l2, (@remove A eq_dec a (l1 ++ l2)) =
                              (@remove A eq_dec a l1) ++ (@remove A eq_dec a l2).
Proof.
intros a l1. induction l1.
- intro l2. rewrite app_nil_l. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec a a0).
  * apply IHl1.
  * simpl. rewrite IHl1. reflexivity.
Qed.

Lemma remove_not_in_anymore : forall l (A : MPropF),
          (In A (remove eq_dec_form A l)) -> False.
Proof.
induction l.
- intros. simpl in H. inversion H.
- intros. simpl in H. destruct (eq_dec_form A a). subst. apply IHl in H. assumption.
  inversion H. apply n. symmetry. assumption. apply IHl in H0. assumption.
Qed.

Lemma in_remove_in_init : forall l A B,
    In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l.
- intros. simpl. inversion H.
- intros. destruct (eq_dec_form A a). subst. apply in_eq. apply in_cons.
  pose (IHl A B). apply i. simpl in H. destruct (eq_dec_form B a).
  * subst. assumption.
  * inversion H. exfalso. apply n. symmetry. assumption. assumption.
Qed.

Lemma remove_preserv_NoDup : forall l (A : MPropF), NoDup l -> NoDup (remove eq_dec_form A l).
Proof.
induction l.
- intros. simpl. apply NoDup_nil.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply IHl. inversion H. assumption.
  * apply NoDup_cons. intro. apply in_remove_in_init in H0. inversion H. apply H3. assumption.
    apply IHl. inversion H. assumption.
Qed.

Lemma NoDup_destr_split : forall l1 l2 (A : MPropF), NoDup (l1 ++ A :: l2) -> NoDup (l1 ++ l2).
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_l in H. inversion H. assumption.
- intros. simpl. apply NoDup_cons. intro. inversion H. subst. apply H3. apply in_app_or in H0.
  destruct H0. apply in_or_app. left. assumption. apply in_or_app. right. apply in_cons.
  assumption. simpl in H. inversion H. subst. apply IHl1 with (A:=A). assumption.
Qed.

Lemma remove_le_length : forall l (A : MPropF), length (remove eq_dec_form A l) <= length l.
Proof.
induction l.
- intros. simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. apply le_S. apply IHl.
  * simpl. apply le_n_S. apply IHl.
Qed.

Lemma remove_In_smaller_length : forall l (A : MPropF),
                                 In A l -> length (remove eq_dec_form A l) < length l.
Proof.
induction l.
- intros. inversion H.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. unfold lt. apply le_n_S. apply remove_le_length.
  * simpl. apply Lt.lt_n_S. apply IHl. inversion H. subst. exfalso. apply n. auto.
    assumption.
Qed.

Lemma double_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a l, (@remove A eq_dec a (@remove A eq_dec a l)) = (@remove A eq_dec a l).
Proof.
intros a l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a a0).
  * subst. apply IHl.
  * simpl. destruct (eq_dec a a0).
    + exfalso. apply n. assumption.
    + rewrite IHl. reflexivity.
Qed.

Lemma permut_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) :
      forall a0 a1 l, (@remove A eq_dec a0 (@remove A eq_dec a1 l)) =
                      (@remove A eq_dec a1 (@remove A eq_dec a0 l)).
Proof.
intros a0 a1 l. induction l.
- simpl. reflexivity.
- simpl. destruct (eq_dec a1 a).
  * subst. simpl. destruct (eq_dec a0 a).
    + subst. reflexivity.
    + simpl. destruct (eq_dec a a). apply IHl. exfalso. apply n0. reflexivity.
  * simpl. destruct (eq_dec a0 a).
    + subst. assumption.
    + simpl. destruct (eq_dec a1 a). exfalso. apply n. assumption.
      rewrite IHl. reflexivity.
Qed.

Lemma In_remove_diff : forall l (A B : MPropF), In A (remove eq_dec_form B l) -> A <> B.
Proof.
induction l ; intros.
- intro. simpl in H. assumption.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply IHl. assumption.
  * inversion H.
    + subst. intro. apply n. symmetry. assumption.
    + apply IHl. assumption.
Qed.

(* Now we define remove_list and prove some lemmas about it. *)

Fixpoint remove_list (l1 l2: list MPropF) : list MPropF :=
match l1 with
  | [] => l2
  | h1 :: t1 => remove eq_dec_form h1 (remove_list t1 l2)
end.

Lemma remove_list_of_nil : forall (l : list MPropF), remove_list l nil = nil.
Proof.
induction l.
- simpl. reflexivity.
- simpl. rewrite IHl. simpl. reflexivity.
Qed.

Lemma app_remove_list : forall (l1 l2 l3 : list MPropF),
        remove_list (l1 ++ l2) l3 = remove_list l1 (remove_list l2 l3).
Proof.
induction l1.
- simpl. firstorder.
- induction l2.
  * intro l3. rewrite app_nil_r. simpl. reflexivity.
  * intro l3. simpl. pose (IHl1 (a0 :: l2) l3). simpl in e.
    rewrite e. reflexivity.
Qed.

Lemma remove_list_preserv_NoDup : forall l1 l2, NoDup l2 -> NoDup (remove_list l1 l2).
Proof.
induction l1.
- intros. simpl. assumption.
- intros. simpl. apply IHl1 in H. apply remove_preserv_NoDup with (A:=a) in H.
  assumption.
Qed.

Lemma remove_list_cont : forall l1 A, In A l1 -> (forall l2, In A (remove_list l1 l2) -> False).
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl in H0. apply remove_not_in_anymore in H0. assumption.
  * simpl in H0. pose (IHl1 A H1 l2). apply f. apply in_remove_in_init with (B:= a). assumption.
Qed.

Lemma remove_list_dist_app : forall (l1 l2 l3 : list MPropF),
        remove_list l1 (l2 ++ l3) = (remove_list l1 l2) ++ (remove_list l1 l3).
Proof.
induction l1.
- intros. simpl. reflexivity.
- simpl. intros. rewrite IHl1. simpl. rewrite remove_dist_app. reflexivity.
Qed.

Lemma permut_remove_remove_list : forall a (l1 l2 : list MPropF),
      remove eq_dec_form a (remove_list l1 l2) =
      remove_list l1 (remove eq_dec_form a l2).
Proof.
intros a l1. generalize dependent a. induction l1 ; simpl.
- reflexivity.
- intros. rewrite permut_remove. rewrite IHl1. reflexivity.
Qed.

Lemma swap_remove_list : forall (l1 l2 l3 : list MPropF),
      remove_list (l1 ++ l2) l3 = remove_list (l2 ++ l1) l3.
Proof.
induction l1.
- intros. rewrite app_nil_l. rewrite app_nil_r. reflexivity.
- induction l2.
  * rewrite app_nil_l. rewrite app_nil_r. reflexivity.
  * intro l3. simpl. rewrite IHl1. simpl. rewrite permut_remove.
    rewrite <- IHl2. simpl. rewrite IHl1. reflexivity.
Qed.

Lemma redund_remove_remove_list : forall a (l1 l2 : list MPropF),
      remove eq_dec_form a (remove_list (remove eq_dec_form a l1) l2) =
      remove eq_dec_form a (remove_list l1 l2).
Proof.
intro a. induction l1.
- intro l2. simpl. reflexivity.
- intro l2. simpl. destruct (eq_dec_form a a0).
  * rewrite IHl1. subst. rewrite double_remove. reflexivity.
  * simpl. rewrite permut_remove. rewrite IHl1. apply permut_remove.
Qed.

Lemma redund_remove : forall (l1 l2 l3 : list MPropF) a,
      remove eq_dec_form a (remove_list l1 (remove_list (remove eq_dec_form a l2) l3)) =
      remove eq_dec_form a (remove_list l1 (remove_list l2 l3)).
Proof.
intros. repeat rewrite <- app_remove_list. rewrite swap_remove_list.
rewrite app_remove_list. rewrite redund_remove_remove_list. rewrite <- app_remove_list.
rewrite swap_remove_list. reflexivity.
Qed.

Lemma redund_remove_list : forall (l1 l2 l3 : list MPropF),
      remove_list l1 (remove_list (remove_list l1 l2) l3) = remove_list l1 (remove_list l2 l3).
Proof.
induction l1 ; intros ; simpl.
- reflexivity.
- rewrite redund_remove. rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_in_single : forall l1 a, (In a l1) -> remove_list l1 [a] = nil.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a0 a0).
    apply remove_list_of_nil. exfalso. apply n. reflexivity.
  * apply IHl1 in H0. simpl. rewrite H0. simpl. reflexivity.
Qed.

Lemma not_removed_remove_list : forall l2 l1 A, In A l2 -> (In A l1 -> False) -> In A (remove_list l1 l2).
Proof.
induction l2.
- intros. inversion H.
- induction l1.
  * intros. simpl. assumption.
  * intros. simpl. pose (in_not_touched_remove (remove_list l1 (a :: l2))). pose (i A).
    pose (i0 a0). apply i1. apply IHl1. assumption. intro. apply H0. apply in_cons. assumption.
    clear i1. clear i0. clear i. destruct (eq_dec_form A a0). intro. apply H0. subst. apply in_eq.
    assumption.
Qed.

Lemma add_remove_list_preserve_NoDup : forall (l1 l2 : list MPropF),
            NoDup l1 -> NoDup l2 -> NoDup (l1 ++ (remove_list l1 l2)).
Proof.
induction l1.
- intros. rewrite app_nil_l. simpl. assumption.
- intros. simpl. apply NoDup_cons.
  * intro. apply in_app_or in H1. destruct H1. inversion H. apply H4. assumption.
    apply remove_not_in_anymore in H1. assumption.
  * rewrite permut_remove_remove_list. apply IHl1. inversion H. assumption.
    apply remove_preserv_NoDup. assumption.
Qed.

Lemma remove_list_is_in : forall l1 l2 A, In A l1 -> In A (l2 ++ (remove_list l2 l1)).
Proof.
intros. pose (In_dec l2 A). destruct s.
- apply in_or_app. left. assumption.
- apply in_or_app. right. apply not_removed_remove_list ; assumption.
Qed.

Lemma In_remove_same : forall l1 l2 (A : MPropF), In A l1 ->
                remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A).
    rewrite permut_remove_remove_list. reflexivity. exfalso. apply n. reflexivity.
  * simpl. pose (IHl1 l2 A H0). rewrite e. reflexivity.
Qed.

Lemma In_remove_length_same : forall l1 l2 (A : MPropF), In A l1 ->
                length (remove_list l1 (A :: l2)) = length (remove_list l1 l2).
Proof.
intros. rewrite In_remove_same. reflexivity. assumption.
Qed.

Lemma length_le_remove_list : forall (l1 l2 : list MPropF), length (remove_list l1 l2) <= length l2.
Proof.
induction l1.
- intros. auto.
- intros. simpl. rewrite permut_remove_remove_list. pose (IHl1 (remove eq_dec_form a l2)).
  apply Nat.le_trans with (m:=length (remove eq_dec_form a l2)). assumption.
  apply remove_le_length.
Qed.

Lemma remove_list_singl_id_or_nil : forall l (A : MPropF), remove_list l [A] = nil \/ remove_list l [A] = [A].
Proof.
induction l.
- intros. right. auto.
- intros. pose (IHl A). destruct o. left. simpl. rewrite H. auto.
  simpl. rewrite H. destruct (eq_dec_form A a).
  * subst. left. simpl. destruct (eq_dec_form a a). reflexivity. exfalso. apply n.
    reflexivity.
  * right. simpl. destruct (eq_dec_form a A). exfalso. apply n. symmetry. assumption.
    reflexivity.
Qed.

Lemma remove_list_non_empty_inter_smaller_length : forall l2 l1 (A : MPropF),
                                 In A l1 -> In A l2 -> length (remove_list l1 l2) < length l2.
Proof.
induction l2.
- intros. inversion H0.
- intros. simpl. destruct (eq_dec_form A a).
  * subst. rewrite In_remove_length_same. 2: assumption. unfold lt. apply le_n_S.
    apply length_le_remove_list.
  * inversion H0.
    + exfalso. apply n. symmetry. assumption.
    + assert (a :: l2 = [a] ++ l2). auto. rewrite H2. rewrite remove_list_dist_app.
      rewrite app_length. pose (remove_list_singl_id_or_nil l1 a). destruct o.
      rewrite H3. simpl. apply Nat.lt_lt_succ_r. apply IHl2 with (A:=A) ; assumption.
      rewrite H3. simpl. apply Lt.lt_n_S. apply IHl2 with (A:=A) ; assumption.
Qed.

Lemma remove_list_delete_head : forall l1 l2 l3 A, remove_list (l1 ++ A :: l2) (A :: l3) = remove_list (l1 ++ A :: l2) l3.
Proof.
induction l1 ; intros ; simpl.
- rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form A A). symmetry. apply permut_remove_remove_list.
  exfalso. apply n. reflexivity.
- rewrite IHl1. reflexivity.
Qed.

Lemma remove_list_delete_head_In : forall l1 l2 A, In A l1 -> remove_list l1 (A :: l2) = remove_list l1 l2.
Proof.
intros. pose (In_split A l1 H). destruct e. destruct H0. subst. apply remove_list_delete_head.
Qed.

Lemma remove_list_in_nil : forall l1 l2 l3 A,
        remove_list l1 (l2 ++ A :: l3) = nil ->
        (existsT2 l4 l5, l1 = l4 ++ A :: l5).
Proof.
induction l1.
- intros. simpl in H. destruct l2 ; inversion H.
- induction l2.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a A).
    + subst. exists []. exists l1. auto.
    + pose (IHl1 [] (remove eq_dec_form a l3)). simpl in s. apply s in H. destruct H. destruct s0.
      exists ([a] ++ x). exists x0. subst. auto.
  * intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
    + subst. pose (IHl2 l3 A). apply s. rewrite <- permut_remove_remove_list in H. simpl. assumption.
    + pose (IHl1 [] (remove eq_dec_form a (l2 ++ A :: l3)) a0). pose (s H). repeat destruct s0.
      subst. apply IHl2 with (l3:= l3). simpl. rewrite permut_remove_remove_list.
      rewrite remove_list_delete_head in H. assumption.
Qed.

Lemma remove_list_is_nil : forall l1 l2, (remove_list l1 l2 = nil <-> (forall A, (In A l2) -> (In A l1))).
Proof.
induction l1.
- intro l2. split.
  * intros. simpl in H. rewrite <- H. assumption.
  * intros. simpl. destruct l2.
    + reflexivity.
    + exfalso. pose (H m). assert (In m (m :: l2)). apply in_eq. apply i in H0. inversion H0.
- induction l2.
  * split.
    + intros. inversion H0.
    + intros. apply remove_list_of_nil.
  * split.
    + intros. simpl in H. rewrite permut_remove_remove_list in H. simpl in H. destruct (eq_dec_form a a0).
      subst. inversion H0. subst. apply in_eq. rewrite <- permut_remove_remove_list in H. simpl in IHl2.
      rewrite IHl2 in H. apply H in H1. destruct H1. subst. apply in_eq. apply in_cons. assumption.
      inversion H0. subst. apply in_cons. pose (remove_list_in_nil l1 [] (remove eq_dec_form a l2) A).
      simpl in s. apply s in H. destruct H. destruct s0. subst. apply in_or_app. right. apply in_eq.
      apply IHl2. 2: assumption. simpl. rewrite permut_remove_remove_list.
      pose (app_eq_nil (remove_list l1 [a0]) (remove_list l1 (remove eq_dec_form a l2))). simpl in a1.
      assert (H2: remove_list l1 [a0] ++ remove_list l1 (remove eq_dec_form a l2) = []).
      rewrite <- remove_list_dist_app. simpl. assumption. apply a1 in H2. destruct H2. assumption.
    + intros. simpl. rewrite permut_remove_remove_list. simpl. destruct (eq_dec_form a a0).
      { subst. rewrite <- permut_remove_remove_list. simpl in IHl2. rewrite IHl2. intros.
        pose (H A). apply i. apply in_cons. assumption. }
      { assert (H1: (forall A : MPropF, In A l2 -> In A (a :: l1))). intros. apply H.
        apply in_cons. assumption. apply IHl2 in H1.
        assert (H2: a0 :: remove eq_dec_form a l2 = [a0] ++ remove eq_dec_form a l2). auto.
        rewrite H2. rewrite remove_list_dist_app. clear H2. rewrite <- permut_remove_remove_list.
        simpl in H1. rewrite H1. rewrite app_nil_r. apply remove_list_in_single. pose (H a0).
        assert (H3: In a0 (a0 :: l2)). apply in_eq. apply i in H3. inversion H3. exfalso. apply n.
        assumption. assumption. }
Qed.

Lemma remove_delete_origin : forall l1 l2 (A B : MPropF), (A <> B) ->
            length (remove eq_dec_form A (l1 ++ B :: l2)) = S (length (remove eq_dec_form A (l1 ++ l2))).
Proof.
induction l1.
- intros. repeat rewrite app_nil_l. simpl. destruct (eq_dec_form A B). exfalso. apply H. assumption.
  simpl. reflexivity.
- intros. simpl. destruct (eq_dec_form A a).
  * apply IHl1. assumption.
  * simpl. apply eq_S. apply IHl1. assumption.
Qed.

Lemma keep_list_delete_head_not_origin : forall l1 l2 l3 A, ((In A l1) -> False) ->
                length (remove_list l1 (l2 ++ A :: l3)) = S (length (remove_list l1 (l2 ++ l3))).
Proof.
induction l1.
- intros. simpl. rewrite app_length. simpl. rewrite app_length. auto.
- intros. simpl. repeat rewrite remove_list_dist_app. assert (In A l1 -> False).
  intro. apply H. apply in_cons. assumption. assert (A :: l3 = [A] ++ l3).
  auto. rewrite H1. rewrite remove_list_dist_app. pose (remove_list_singl_id_or_nil l1 A).
  destruct o. exfalso. rewrite remove_list_is_nil in H2. apply H0. apply H2.
  apply in_eq. rewrite H2. apply remove_delete_origin. intro. apply H. subst. apply in_eq.
Qed.

Lemma keep_list_delete_head_not_In : forall l1 l2 A, ((In A l1) -> False) ->
                length (remove_list l1 (A :: l2)) = S (length (remove_list l1 l2)).
Proof.
intros. pose (@keep_list_delete_head_not_origin l1 [] l2 A H). repeat rewrite app_nil_l in e.
assumption.
Qed.

Lemma In_remove_In_list : forall (A B : MPropF) l, In A (remove eq_dec_form B l) -> In A l.
Proof.
induction l ; intros.
- simpl in H. destruct H.
- simpl in H. destruct (eq_dec_form B a).
  * subst. apply in_cons. apply IHl. assumption.
  * inversion H.
    + subst. apply in_eq.
    + apply in_cons. apply IHl. assumption.
Qed.

Lemma In_remove_list_In_list : forall (A : MPropF) l1 l2, In A (remove_list l1 l2) -> In A l2.
Proof.
intro A. induction l1 ; intros.
- simpl in H. assumption.
- simpl in H. apply In_remove_In_list in H. apply IHl1. assumption.
Qed.

Lemma In_remove_list_In_list_not_In_remove_list : forall (A : MPropF) l1 l2,
            In A (remove_list l1 l2) -> (In A l2 /\ ((In A l1) -> False)).
Proof.
intro A. induction l1 ; intros.
- simpl in H. split. assumption. intro. inversion H0.
- simpl in H. split. apply In_remove_In_list in H. apply IHl1. assumption. intro.
  inversion H0.
  * subst. apply remove_not_in_anymore in H. assumption.
  * apply In_remove_In_list in H. apply IHl1 in H. destruct H. apply H2. assumption.
Qed.

Lemma remove_list_incr_decr3 : forall (l3 l2 l1 : list MPropF),
              (incl l1 l2) ->
              length (remove_list l2 l3) <= length (remove_list l1 l3).
Proof.
induction l3 ; intros.
- repeat rewrite remove_list_of_nil. auto.
- destruct (In_dec l2 a).
  + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
    * rewrite remove_list_delete_head_In. 2: assumption. apply IHl3 ; auto.
    * rewrite keep_list_delete_head_not_In. 2: assumption. apply Nat.le_le_succ_r.
      apply IHl3. assumption.
  + repeat rewrite keep_list_delete_head_not_In. apply le_n_S. apply IHl3 ; auto.
    intro. apply f. apply H. assumption. assumption.
Qed.

Lemma remove_list_incr_decr1 : forall (l3 l1 l2: list MPropF),
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              length (remove_list l2 l3) < length (remove_list l1 l3).
Proof.
induction l3.
- intros. destruct H. destruct H. destruct H1. exfalso. inversion H1.
- intros. destruct H. destruct H. destruct H1. destruct (eq_dec_form a x).
  * subst. rewrite remove_list_delete_head_In. 2: assumption.
    rewrite keep_list_delete_head_not_In. 2: assumption. unfold lt.
    apply le_n_S. apply remove_list_incr_decr3. assumption.
  * inversion H1. exfalso. apply n ; assumption.
    assert (H4: exists A : MPropF, In A l2 /\ In A l3 /\ (In A l1 -> False)).
    exists x. auto. apply IHl3 in H4. 2 : assumption. unfold lt.
    destruct (In_dec l2 a).
    + rewrite remove_list_delete_head_In. 2: assumption. destruct (In_dec l1 a).
      { rewrite remove_list_delete_head_In. 2: assumption. apply H4. }
      { rewrite keep_list_delete_head_not_In. 2: assumption. apply le_n_S.
        unfold lt in H4. apply Le.le_Sn_le. assumption. }
    + rewrite keep_list_delete_head_not_In. 2: assumption. rewrite keep_list_delete_head_not_In.
      unfold lt in H4. apply le_n_S. assumption. intro. apply f. apply H0. assumption.
Qed.

Lemma remove_list_incr_decr2 : forall (l4 l3 l1 : list MPropF),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              length (remove_list l1 l4) <= length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. apply le_0_n.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (H2: In a l3). apply H1.
    apply in_eq. pose (in_split a l3 H2). repeat destruct e. destruct H3. rewrite H3.
    rewrite keep_list_delete_head_not_origin. 2: assumption. apply le_n_S. apply IHl4.
    inversion H. assumption. subst. apply NoDup_destr_split with (A:=a). assumption.
    inversion H. unfold incl. intros. subst. assert (H9 : In a0 (a :: l4)). apply in_cons.
    assumption. pose (H1 a0 H9). apply in_app_or in i. destruct i. apply in_or_app. left.
    assumption. inversion H3. subst. exfalso. apply H6. assumption. apply in_or_app. right.
    assumption.
Qed.

Lemma remove_list_incr_decr4 : forall (l4 l3 l1: list MPropF),
              (NoDup l4) ->
              (NoDup l3) ->
              (incl l4 l3) ->
              ((incl l3 l4) -> False) ->
              (exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False)) ->
              length (remove_list l1 l4) < length (remove_list l1 l3).
Proof.
induction l4.
- intros. rewrite remove_list_of_nil. simpl. destruct H3. destruct H3. destruct H4. pose (In_split x l3 H3).
  destruct e. destruct H6. subst. rewrite keep_list_delete_head_not_origin. 2: assumption.
  apply Nat.lt_0_succ.
- intros. destruct (In_dec l1 a).
  * rewrite remove_list_delete_head_In. 2: assumption. apply IHl4 ; try assumption.
    inversion H. assumption. unfold incl. intros. apply H1. apply in_cons. assumption.
    intro. apply H2. unfold incl. intros. apply in_cons. apply H4. assumption. destruct H3.
    destruct H3. destruct H4. exists x. repeat split ; try assumption. intro. apply H5.
    apply in_cons. assumption.
  * rewrite keep_list_delete_head_not_In. 2: assumption. assert (In a l3). apply H1.
    apply in_eq. pose (In_split a l3 H4). destruct e. destruct H5. subst.
    rewrite keep_list_delete_head_not_origin. 2 : assumption. apply Lt.lt_n_S.
    apply IHl4. inversion H. assumption. apply NoDup_destr_split with (A:=a). assumption.
    unfold incl. intros. pose (H1 a0). assert (In a0 (a :: l4)). apply in_cons. assumption.
    apply i in H6. apply in_app_or in H6. destruct H6. apply in_or_app. left. assumption.
    inversion H6. subst. inversion H. exfalso. apply H9. assumption. apply in_or_app. right.
    assumption. intro. apply H2. unfold incl. intros. apply in_app_or in H6. destruct H6.
    apply in_cons. apply H5. apply in_or_app. left. assumption. inversion H6. subst. apply in_eq.
    apply in_cons. apply H5. apply in_or_app. right. assumption.
    destruct H3. destruct H3. destruct H5. exists x1. repeat split ; try assumption.
    apply in_app_or in H3. destruct H3. apply in_or_app. left. assumption. inversion H3.
    subst. exfalso. apply H6. apply in_eq. apply in_or_app. right. assumption.
    intro. apply H6. apply in_cons. assumption.
Qed.

Lemma remove_list_incr_decr : forall (l1 l2 l3 l4 : list MPropF),
              (NoDup l4) ->
              (NoDup l3) ->
              (exists A, In A l2 /\ In A l3 /\ (In A l1 -> False)) ->
              (incl l1 l2) ->
              (incl l4 l3) ->
              length (remove_list l2 l4) < length (remove_list l1 l3).
Proof.
intros. unfold lt.
pose (remove_list_incr_decr2 l1 H H0 H3).
repeat destruct H1. destruct H4. destruct (In_dec l4 x).
- assert (H6: (exists A, In A l2 /\ In A l4 /\ (In A l1 -> False))).
  exists x. repeat split ; assumption. pose (@remove_list_incr_decr1 l4 l1 l2 H6 H2).
  unfold lt in l0. apply Nat.le_trans with (m:=length (remove_list l1 l4)) ; assumption.
- assert ((incl l3 l4) -> False). intros. apply f. apply H6. assumption.
  assert ((exists A, (In A l3) /\ ((In A l1) -> False) /\ ((In A l4) -> False))). exists x. auto.
  pose (@remove_list_incr_decr3 l4 l2 l1 H2). pose (@remove_list_incr_decr4 l4 l3 l1 H H0 H3 H6 H7).
  unfold lt in l5. apply le_n_S in l0.
  apply Nat.le_trans with (m:=S (length (remove_list l1 l4))) ; assumption.
Qed.

Lemma In_remove_list_remove_redund : forall l1 l2 a, In a l1 ->
                remove eq_dec_form a (remove_list l1 l2) = remove_list l1 l2.
Proof.
induction l1.
- intros. inversion H.
- intros. simpl. inversion H.
  * subst. rewrite double_remove. reflexivity.
  * pose (IHl1 l2 a0 H0). rewrite permut_remove. rewrite e. reflexivity.
Qed.

Lemma In_matters_remove_list : forall l1 l2, (incl l1 l2 /\ incl l2 l1) -> (forall l0,
                                    remove_list l1 l0 = remove_list l2 l0).
Proof.
induction l1.
- intros. destruct H. destruct l2. auto. unfold incl in H0. pose (H0 m). assert (In m (m :: l2)).
  apply in_eq. apply i in H1. inversion H1.
- intros. destruct H. simpl. pose (H a). assert (In a (a :: l1)). apply in_eq. apply i in H1.
  apply in_split in H1. destruct H1. destruct H1. subst. destruct (In_dec l1 a).
  * rewrite In_remove_list_remove_redund. 2: assumption. apply IHl1. split. intro. intro.
    apply H. apply in_cons. assumption. intro. intro. apply H0 in H1. inversion H1. subst.
    assumption. assumption.
  * rewrite swap_remove_list. simpl. rewrite <- redund_remove_remove_list with (l1:=(x0 ++ x)).
    pose (IHl1 (remove eq_dec_form a (x0 ++ x))). rewrite e.
    auto. split. intro. intro. apply in_not_touched_remove. assert (In a0 (a :: l1)). apply in_cons.
    assumption. apply H in H2. apply in_app_or in H2. destruct H2. apply in_or_app. right. assumption.
    inversion H2. subst. exfalso. apply f. assumption. apply in_or_app. left. assumption.
    intro. subst. apply f. assumption. intro. intro. pose (In_remove_diff (x0 ++ x) H1).
    pose (In_remove_In_list a0 a (x0 ++ x) H1). assert (In a0 (x ++ a :: x0)). apply in_app_or in i0.
    destruct i0. apply in_or_app. right. apply in_cons. assumption. apply in_or_app. left. assumption.
    apply H0 in H2. inversion H2. exfalso. apply n. symmetry. assumption. assumption.
Qed.


Require Import Coq.Bool.Bool.
Require Import Coq.Classes.RelationClasses.
Require Coq.Setoids.Setoid.

Set Implicit Arguments.
Set Strict Implicit.

Class RelDec (T : Type) (equ : T -> T -> Prop) : Type :=
{ rel_dec : T -> T -> bool }.

Arguments rel_dec {_} {equ} {_} _ _.
Arguments rel_dec _ _ _ !x !y.

Class RelDec_Correct T (equ : T -> T -> Prop) (ED : RelDec equ) : Prop :=
{ rel_dec_correct : forall x y : T, rel_dec x y = true <-> equ x y }.

Notation "a ?[ r  ]  b" := (@rel_dec _ r _ a b) (at level 30, b at next level).

Definition eq_dec {T : Type} {ED : RelDec (@eq T)} := rel_dec.

Section neg_rel_dec_correct.
  Context {T} {R:T -> T -> Prop} {RD:RelDec R} {RDC:RelDec_Correct RD}.

  Definition neg_rel_dec_correct : forall {x y}, ~R x y <-> rel_dec x y = false.
  Proof. intros x y. destruct (bool_dec (rel_dec x y) true) ; constructor ; intros ;
    repeat
      match goal with
      | [ |- ~ _ ] => unfold not ; intros
      | [ H1 : ?P, H2 : ~?P |- _ ] => specialize (H2 H1) ; contradiction
      | [ H1 : ?P = true, H2 : ?P = false |- _ ] => rewrite H1 in H2 ; discriminate
      | [ H1 : ?P <> true |- ?P = false ] => apply not_true_is_false ; exact H1
      | [ H1 : ?rel_dec ?a ?b = true, H2 : ~?R ?a ?b |- _ ] =>
          apply rel_dec_correct in H1
      | [ H1 : ?rel_dec ?a ?b = false, H2 : ?R ?a ?b |- _ ] =>
          apply rel_dec_correct in H2
      end.
  Qed.
End neg_rel_dec_correct.

Section rel_dec_p.
  Context {T} {R:T -> T -> Prop} {RD:RelDec R} {RDC:RelDec_Correct RD}.

  Definition rel_dec_p (x:T) (y:T) : {R x y} + {~R x y}.
  Proof. destruct (bool_dec (rel_dec x y) true) as [H | H].
    apply rel_dec_correct in H ; eauto.
    apply not_true_is_false in H ; apply neg_rel_dec_correct in H ; eauto.
  Qed.

  Definition neg_rel_dec_p (x:T) (y:T) : {~R x y} + {R x y}.
  Proof. destruct (rel_dec_p x y) ; [ right | left ] ; auto. Qed.
End rel_dec_p.

Section lemmas.
  Variable T : Type.
  Variable eqt : T -> T -> Prop.
  Variable r : RelDec eqt.
  Variable rc : RelDec_Correct r.

  Theorem rel_dec_eq_true : forall x y,
    eqt x y -> rel_dec x y = true.
  Proof.
    intros. eapply rel_dec_correct in H. assumption.
  Qed.

  Theorem rel_dec_neq_false : forall x y,
    ~eqt x y -> rel_dec x y = false.
  Proof.
    intros. remember (x ?[ eqt ] y).
    symmetry in Heqb.
    destruct b; try reflexivity.
    exfalso. eapply (@rel_dec_correct _ _ _ rc) in Heqb. auto.
  Qed.

  Theorem rel_dec_sym : Symmetric eqt -> forall x y,
    x ?[ eqt ] y = y ?[ eqt ] x.
  Proof.
    intros.
    remember (x ?[ eqt ] y); remember (y ?[ eqt ] x); intuition.
    destruct b; destruct b0; auto.
    { symmetry in Heqb; symmetry in Heqb0.
      eapply (@rel_dec_correct _ _ _ rc) in Heqb.
      symmetry in Heqb.
      eapply (@rel_dec_correct _ _ _ rc) in Heqb.
      congruence. }
    { symmetry in Heqb; symmetry in Heqb0.
      eapply (@rel_dec_correct _ _ _ rc) in Heqb0.
      symmetry in Heqb0.
      eapply (@rel_dec_correct _ _ _ rc) in Heqb0.
      congruence. }
  Qed.
End lemmas.

Section RelDec_from_dec.
  Context {T} (R : T -> T -> Prop).
  Variable (f : forall a b : T, {R a b} + {~R a b}).
  Definition RelDec_from_dec
  : RelDec R :=
  {| rel_dec := fun a b =>
                  match f a b with
                  | left _ => true
                  | right _ => false
                  end |}.

  Global Instance RelDec_Correct_eq_typ : RelDec_Correct RelDec_from_dec.
  Proof.
    constructor.
    intros.
    unfold rel_dec; simpl.
    destruct (f x y).
    - tauto.
    - split.
      + inversion 1.
      + intro. apply n in H. tauto.
  Qed.
End RelDec_from_dec.

(*
Section SumEq.
  Variable T : Type.
  Variable U : Type.

  Variable EDT : RelDec (@eq T).
  Variable EDU : RelDec (@eq U).

  (** Specialization for equality **)
  Global Instance RelDec_eq_sum : RelDec (@eq (T + U)) :=
  { rel_dec := fun x y =>
    match x , y with
      | inl x , inl y => eq_dec x y
      | inr x , inr y => eq_dec x y
      | _ , _ => false
    end }.

  Variable EDCT : RelDec_Correct EDT.
  Variable EDCU : RelDec_Correct EDU.

  Global Instance RelDec_Correct_eq_sum : RelDec_Correct RelDec_eq_sum.
  Proof.
    constructor; destruct x; destruct y; split; simpl in *; intros; try congruence;
      f_equal; try match goal with
                     | [ H : context [ eq_dec ?X ?Y ] |- _ ] =>
                       consider (eq_dec X Y)
                     | [ |- context [ eq_dec ?X ?Y ] ] =>
                       consider (eq_dec X Y)
                   end; auto; congruence.
  Qed.

End SumEq.
*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e384m2e128m2e96p2e32m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.arrival_sequence prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.task_arrival prosa.classic.model.arrival.basic.job.
Require Import prosa.classic.implementation.uni.jitter.task
               prosa.classic.implementation.uni.jitter.job.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq div.

Module ConcreteArrivalSequence.

  Import Job ArrivalSequence ConcreteTask ConcreteJob SporadicTaskset TaskArrival.

  Section PeriodicArrivals.

    Variable ts: concrete_taskset.

    (* At any time t, we release Some job of tsk if t is a multiple of the period,
       otherwise we release None. *)
    Definition add_job (arr_time: time) (tsk: concrete_task) :=
      if task_period tsk %| arr_time  then
        Some (Build_concrete_job (arr_time %/ task_period tsk) arr_time
                                 (task_cost tsk) (task_deadline tsk) tsk)
      else
        None.

    (* The arrival sequence at any time t is simply the partial map of add_job. *)
    Definition periodic_arrival_sequence (t: time) := pmap (add_job t) ts.

  End PeriodicArrivals.

  Section Proofs.

    (* Let ts be any concrete task set with valid parameters. *)
    Variable ts: concrete_taskset.

    (* Regarding the periodic arrival sequence built from ts, we prove that...*)
    Let arr_seq := periodic_arrival_sequence ts.

    (* ... arrival times are consistent, ... *)
    Theorem periodic_arrivals_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.
    Proof.
      move => j t ARRj.
      rewrite /arrives_at mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ... every job comes from the task set, ... *)
    Theorem periodic_arrivals_all_jobs_from_taskset:
      forall j,
        arrives_in arr_seq j ->
        job_task j \in ts.
    Proof.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ... job arrivals satisfy the sporadic task model, ... *)
    Theorem periodic_arrivals_are_sporadic:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Proof.
      move => j j' /eqP DIFF [arr ARR] [arr' ARR'] SAMEtsk LE.
      rewrite eqE /= /job_eqdef negb_and /= SAMEtsk eq_refl orbF in DIFF.
      rewrite 2!mem_pmap in ARR ARR'.
      move: ARR ARR' => /mapP [tsk_j INj SOMEj] /mapP [tsk_j' INj' SOMEj'].
      unfold add_job in SOMEj, SOMEj'; desf; simpl in *;
      move: Heq0 Heq => /dvdnP [k DIV] /dvdnP [k' DIV'].
      {
        rewrite DIV DIV' -mulSnr.
        rewrite leq_eqVlt in LE; move: LE => /orP [/eqP EQ | LESS].
        {
          exfalso; move: DIFF => /negP DIFF; apply DIFF.
          by subst; rewrite EQ !eq_refl.
        }
        subst; rewrite leq_mul2r; apply/orP; right.
        by rewrite ltn_mul2r in LESS; move: LESS => /andP [_ LT].
      }
    Qed.

    (* ... and the arrival sequence has no duplicate jobs. *)
    Theorem periodic_arrivals_is_a_set:
      arrival_sequence_is_a_set arr_seq.
    Proof.
      intros t.
      unfold arr_seq, periodic_arrival_sequence.
      apply (pmap_uniq) with (g := job_task); last by destruct ts.
      by unfold add_job, ocancel; intro tsk; desf.
    Qed.

    (* We also show that job costs are bounded by task costs... *)
    Theorem periodic_arrivals_job_cost_le_task_cost:
      forall j,
        arrives_in arr_seq j ->
        job_cost j <= task_cost (job_task j).
    Proof.
      intros j [t ARRj].
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP [tsk_j INj SOMEj].
      by unfold add_job in SOMEj; desf.
    Qed.

    (* ...and that job deadlines equal task deadlines. *)
    Theorem periodic_arrivals_job_deadline_eq_task_deadline:
      forall j,
        arrives_in arr_seq j ->
        job_deadline j = task_deadline (job_task j).
    Proof.
      intros j [t ARRj].
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP [tsk_j INj SOMEj].
      by unfold add_job in SOMEj; desf.
    Qed.

  End Proofs.

End ConcreteArrivalSequence.


Require Import Coq.Numbers.BinNums.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Spec.WeierstrassCurve Crypto.Curves.Weierstrass.Affine.
Require Import Crypto.Algebra.Field Crypto.Algebra.Hierarchy.
Require Import Crypto.Util.Decidable Crypto.Util.Tactics.DestructHead Crypto.Util.Tactics.BreakMatch.
Require Import Coq.PArith.BinPos.

Module W.
  Section W.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {a b:F}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "-" := Fsub. Local Infix "*" := Fmul.
    Local Notation "4" := (1+1+1+1). Local Notation "27" := (4*4 + 4+4 +1+1+1).

    Local Ltac Algebra_split :=
      repeat match goal with
             | |- Proper _ _ => cbv [Proper respectful]; intros
             | |- Equivalence _ => split; [intros ? | intros ??? | intros ????? ]
             | |- monoid => split
             | |- group => split
             | |- commutative_group => split
             | |- is_associative => split; intros ???
             | |- is_commutative => split; intros ??
             | |- is_left_inverse => split; intros ?
             | |- is_right_inverse => split; intros ?
             | |- is_left_identity => split; intros ?
             | |- is_right_identity => split; intros ?
             end.

    Global Instance commutative_group
           char_ge_3
           {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12%positive} (* FIXME: shouldn't need we need 4, not 12? *)
           {discriminant_nonzero:id(4*a*a*a + 27*b*b <> 0)}
      : commutative_group(eq:=W.eq(a:=a)(b:=b))(op:=W.add(char_ge_3:=char_ge_3))(id:=W.zero)(inv:=W.opp).
    Proof using Type.
      Time
        cbv [W.opp W.eq W.zero W.add W.coordinates proj1_sig];
          repeat match goal with
                 | _ => progress Algebra_split
                 | H: _ /\ _ |- _ => destruct H
                 | |- _ /\ _ => split
                 | _ => progress break_match
                 | _ => progress break_match_hyps
                 end; try contradiction; trivial.
      Time par: abstract (fsatz || (cbv [id] in *; fsatz)).
    Time Qed.
  End W.
End W.