(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    2006                     *)
(*************************************************************)

Unset Boxed Definitions.
Unset Boxed Values.

Require Export NArith.
Require Export Mylist.
Require Import Utils.

Set Implicit Arguments.

  (************************************************************)
  (*****         Type definitions for the CAD              ****)
  (************************************************************)

Section TYPES.

  (** Type of result of sign computations *)
  Definition Sign := option comparison.

  (**** Polynomials in Horner form, one var with coefs in C ****)

  (*The set of base coefficients *)
  Variable Rat :Set.
  Variable rmin : Rat -> Rat -> Rat.
  Variable req : Rat -> Rat -> bool.

  (*The set of coefficients*)
  Variable Coef:Set.

  (* Polys in one var over C*)
  Inductive Pol1(C:Set):Set:=
    |Pc : C -> Pol1 C
    |PX : Pol1 C -> positive -> C -> Pol1 C.

  Let Pol := Pol1 Coef.

  (* Here we can also define all the operators on Pols wich are not recursive
    in the number of variables *)

  (* Couple (degree * coefdom) for a polynomial *)
  Definition Pol_deg_coefdom :=
    let aux :=
      fix aux (deg:N) (P:Pol){struct P} : N * Coef :=
	match P with
	  | Pc a => (deg,a)
	  | PX P i p => aux (deg + Npos i)%N P
	end
	in aux N0.

(* Degree only *)
  Definition Pol_deg P := fst (Pol_deg_coefdom P).

(* Leading coef only *)
  Fixpoint Pol_dom(P:Pol) : Coef :=
   match P with
   | Pc p => p
   | PX P _ _ => Pol_dom P
   end.

(* Hack for division *)
  Definition Pol_coefdom_if_PC (c:Coef) (P:Pol) : Coef :=
   match P with
   | Pc p => p
   | PX P _ _ => c
   end.

  (************************************************************)
  (* Informations about a Pol to be computed once and for all *)
  (************************************************************)

  (* Info is (P, Pbar, dPbar, lowsign, signinfo) where :
     - P is a polynomial
     - Pbar is the square free part of P,
     - dPbar is the degree of Pbar (for later bern computations)
     - lowsign the sign of P in -inf
     - signinfo is the sign of P if it is known to be constant,
       and None else *)

  Definition build_Info := uple5 Pol Pol N Sign Sign.

  Definition mk_build_Info P Q n low sign_info : build_Info :=
    Five P Q n low sign_info.

  Definition Pol_of_build_Info (c:build_Info) := fst5 c.

  (************************************************************)
  (* ** Representation of algebraic points in n dimensions ** *)
  (************************************************************)

 (* This will be the information encoding bernstein coefs which are
  retained, in fact build_Info at the level below *)
  Variable berncoef : Set.

  (** encoding of algebraic numbers at this level,
      x := (a, b, P, Pbar, lb) : mkAlg
    - a < x < b
    - P is a polynomial such [P x = 0]
    - Pbar is the square free part of P.
    - lb is the list bernstein coefs of P over ]a b[.
    For each bern coef, we keep the polinfo because we will later
    have to compute signs of these coefs, so berncoef will be recursively
    instanciate with build_Info. *)

  Definition mkAlg := uple5 Rat Rat Pol Pol (list berncoef).

  (** Elements of R :
  either -infty : a least bound for the roots considered,
  or a rational point between two consecutive roots
  or a rational root
  or an algebraic root: mkAlg *)

  Inductive mkRpoint :Set:=
   | Minf     : Rat -> mkRpoint
   | Between  : Rat -> mkRpoint
   | Root     : Rat -> mkRpoint
   | Alg_root : mkAlg -> mkRpoint.

(***************************************************************)
(**                 Output of the procedure                   **)
(***************************************************************)

(* We build a labelled tree representing a cylindrical sample of points *)
(* For a CAD of polys with k variables, the tree is of depth k *)

(* - The inner nodes at depth i of the tree are labelled with real *)
(*points of type mkRpoints  of dim i : the dim is relevant in the *)
(* case of alg. points  for th encoding. *)

(* - Leaves of a tree of depth n are labbelled with elements of type *)
(*  (Pol*Sign) *)

(* a n-uple of mkRpoints of successive dimension from the root to a *)
(* leave has type path : if a leave (l,(P,s)) is at the position *)
(*p:path, then s is the sign of p at the point (p,l) *)

(* path encodes elements of R^{n-1}*)
  Variable path : Set.

(* the encoding of real points along the n-th coordinate of R^n *)
  Definition next_label := mkRpoint.

(* The encoding of elements of R^n *)
  Definition next_path := (path * next_label)%type.
  Definition build_next_path(p:path)(r:mkRpoint):=(p,r).

(* A zipper-like structure for update while building a new cad tree *)

(* mkCad builds the type of cylindrical sample (cs) trees of depth n -1, *)
(* given the type C to put in their leaves                          *)
  Variable mkCad:Set -> Set.

(* building cs tree of depth n *)
  Definition next_mkCad(C:Set):= mkCad (list (next_label * C)).

(* Given a cs tree of depth n-1, which leaves o type n and an update *)
(* function f : path -> C -> path which  compute an updated path an a *)
(* new value of type D, we build a new cs tree of depth n-1 with *)
(* leaves of type D and updated labels in the inner nodes *)

  Variable mkCad_map : forall C D : Set,
    (path -> C -> (path * D)) -> mkCad C -> mkCad D.

(* Same for the level n *)

  Definition next_mkCad_map(C D:Set)
(f:next_path -> C ->  (next_path *  D))
 (t:next_mkCad C) : next_mkCad D :=
 let aux(p : path)(leave : list (next_label * C)) :
   path*(list (next_label * D)):=
   let f_aux (p:path)(np:next_label*C):path*(next_label*D):=
     let (nlabel,c) := np in
     let (updated_npath,d):=f (p,nlabel) c in
       (fst updated_npath,(snd updated_npath,d)) in
   @two_fold path (next_label*C) (next_label * D) f_aux p leave in
   @mkCad_map (list (next_label * C)) (list (next_label * D)) aux t.

  (* Cad gathers what is needed from level n to build the cad at level n+1 *)

  Record Cad : Set := mk_cad {
    Pol_0                : Pol;
    Pol_1                : Pol;
    Pol_add              : Pol -> Pol -> Pol;
    Pol_mul_Rat          : Pol -> Rat -> Pol;
    Pol_mul              : Pol -> Pol -> Pol;
    Pol_sub              : Pol -> Pol -> Pol;
    Pol_opp              : Pol -> Pol;
    Pol_of_Rat           : Rat -> Pol;
    Pol_is_Rat           : Pol -> bool;
    Pol_zero_test        : Pol -> bool;
    Pol_base_cst_sign    : Pol -> option comparison;
    Pol_pow              : Pol -> N -> Pol;
    Pol_div_Rat          : Pol -> Rat -> Pol;
    Pol_div              : Pol -> Pol -> Pol;
    Pol_gcd_gcd_free     : Pol -> Pol -> Pol * Pol * Pol;
    Pol_square_free      : Pol -> Pol;
    path_refine          : next_path -> nat -> option next_path;
(*  cell_point_up_refine : mkcell_point_up -> nat -> option mkcell_point_up;*)
    Pol_low_bound        : Pol -> path -> Rat;
(*  Pol_low_bound        : Pol -> cell_point -> Rat;*)
    Pol_value_bound      : next_path -> Pol -> Rat * Rat;
(*  Pol_value_bound      : mkcell_point_up -> Pol -> Rat * Rat;*)
    Info_of_Pol          : Sign -> Pol -> build_Info;
    Pol_low_sign         :  path -> Pol -> Pol -> nat ->
      (path * (option comparison));
(*  Pol_low_sign         :
      cell_point -> Pol -> Pol -> nat -> (cell_point * (option comparison));*)
    Pol_sign_at          : build_Info -> next_path -> nat ->
      next_path * (Pol * Sign)%type;
(*  Pol_sign_at          :
      build_Info -> mkcell_point_up -> nat ->
      mkcell_point_up * (Pol * option comparison);*)
    Pol_cad : list Pol -> nat -> next_mkCad  (list (Pol * Sign))
(*  Pol_cad : list Pol -> nat -> mkCad_up (mkcell_point_up * (list (Pol * Sign)))*)
  }.

End TYPES.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Import Le Gt Minus Bool Setoid.
Set Implicit Arguments.
Require Import ZArith.
Require Import Bool.
Open Scope Z_scope.

Module Type T.

Inductive Loc : Type := Class {loc: Z}.
 Parameter Val: Loc -> Type.
 Parameter Loc_dec: forall i j: Loc, {i=j}+{i<>j}.

 Parameter EName: Type.
 Parameter EVal: EName -> Type.
 Parameter Exc_dec: forall i j: EName, {i=j}+{i<>j}.

 Inductive Empty_set : Type :=.

End T.


Require Export Coq.FSets.FMapInterface.
Require Import Fiat.Common.Wf.
Require Export Fiat.Common.FMapExtensions.
Require Export Fiat.Common.FMapExtensions.LiftRelationInstances.
Require Import Fiat.Common.

Module FMapExtensionsWf_fun (E: DecidableType) (Import M: WSfun E).
  Module LiftRelationInstancesExtensions := FMapExtensionsLiftRelationInstances_fun E M.
  Include LiftRelationInstancesExtensions.

  Section rel.
    Context {A} (eqb leb : A -> A -> bool).

    Let ltb x y := (leb x y && negb (eqb x y)).
    Let gtb := flip ltb.

    Context (well_founded_gt : well_founded gtb).
    Context (top : A) (top_top : forall x, leb x top)
            (top_eqb : forall x, leb top x -> eqb top x)
            (eqb_Equivalence : Equivalence eqb).
            (*eqb_bl : forall x y, eqb x y -> x = y)
            (eqb_lb : forall x y, x = y -> eqb x y*)

    Definition lift_leb := lift_brelation leb top.
    Definition lift_eqb := lift_brelation eqb top.
    Definition lift_ltb x y
      := lift_leb x y && negb (lift_eqb x y).

    Global Instance lift_ltb_Proper_Equal
      : Proper (@Equal _ ==> @Equal _ ==> eq) lift_ltb | 5.
    Proof.
      unfold lift_ltb.
      intros ?? H ?? H'.
      rewrite H, H'.
      reflexivity.
    Qed.

    Global Instance lift_ltb_Proper_lift_eqb
           {HR : Reflexive eqb}
           {Hsub : subrelation eqb leb}
           {leb_Proper : Proper (eqb ==> eqb ==> eq) leb}
           {eqb_Proper : Proper (eqb ==> eqb ==> eq) eqb}
      : Proper (lift_eqb ==> lift_eqb ==> eq) lift_ltb.
    Proof.
      unfold lift_ltb.
      intros ?? H ?? H'.
      rewrite H, H'.
      reflexivity.
    Qed.

    Global Instance lift_ltb_Irreflexive : Irreflexive lift_ltb | 5.
    Proof.
      unfold lift_ltb; intro x; hnf.
      rewrite (reflexivity (R:=lift_eqb) x).
      edestruct lift_leb; simpl; congruence.
    Qed.
    Lemma lift_ltb_Irreflexiveb : forall x y, lift_eqb x y -> lift_ltb x y = false.
    Proof.
      unfold is_true, lift_ltb; intros x y H; rewrite H.
      edestruct lift_leb; simpl; congruence.
    Qed.

    Lemma empty_ltb_nothing v : lift_ltb (empty _) v = false.
    Proof.
      unfold lift_ltb.
      apply not_true_iff_false, BoolFacts.not_andb_negb_iff.
      unfold lift_leb, lift_eqb.
      setoid_rewrite lift_brelation_iff.
      intros H k; specialize (H k).
      rewrite empty_o in *.
      edestruct find; [ | reflexivity ].
      apply top_eqb; assumption.
    Qed.

    Section wf.
      Let to_function (m : t A) : key -> A :=
        fun k => find_default top k m.
      Let keys_of (m : t A) : list key := List.map (@fst _ _) (elements m).

      Lemma is_finite_for_keys (m : t A) : is_finite_forA eqb top E.eq to_function (keys_of m) m.
      Proof.
        unfold is_finite_forA, is_finite_forA', keys_of, to_function, find_default.
        intro k.
        rewrite InA_alt.
        setoid_rewrite in_map_iff.
        intro H.
        destruct (find k m) eqn:Hfind; simpl; [ | reflexivity ].
        apply elements_iff_find in Hfind.
        rewrite InA_alt in Hfind.
        destruct Hfind as [kv [[? ?] ?]]; simpl in *; subst.
        exfalso; apply H.
        intuition eauto.
      Qed.

      Lemma well_founded_lift_gtb
            {leb_Reflexive : Reflexive leb}
            {leb_Proper : Proper (eqb ==> eqb ==> eq) leb}
            {eqb_Proper : Proper (eqb ==> eqb ==> eq) eqb}
        : well_founded (Basics.flip lift_ltb).
      Proof.
        intro a.
        eapply Acc_subrelation.
        { eapply function_relationA_of_Acc;
          [ .. | eexact well_founded_gt | | eapply is_finite_for_keys ];
          [ try exact _.. ];
          [ repeat match goal with
                               | [ |- is_true (?R ?x ?x) ] => reflexivity
                   | _ => progress unfold gtb, ltb, flip, impl in *
                   | _ => intro
                   | _ => progress subst
                   | _ => assumption
                   | [ H : is_true (eqb ?x ?y) |- _ ]
                     => rewrite H in *; clear x H
                   end..
          | | ].
          { simpl; unfold gtb, flip, ltb in *.
            intro x; rewrite top_top; simpl.
            destruct (eqb x top) eqn:Heqb; [ left | right; reflexivity ].
            fold_is_true.
            rewrite Heqb; reflexivity. }
          { unfold to_function, find_default.
            intros ???? H.
            rewrite !(find_o _ H).
            trivial. } }
        { unfold gtb, flip; intros x y _ H.
          unfold lift_ltb in H.
          apply andb_true_iff in H.
          destruct H as [H0 H1].
          unfold function_relation.
          split; [ clear H1 | clear H0 ].
          { unfold to_function, lift_leb, find_default, ltb in *.
            setoid_rewrite lift_brelation_iff in H0.
            intro k; specialize (H0 k).
            do 2 edestruct find;
              repeat match goal with
                     | _ => progress simpl in *
                     | _ => left; congruence
                     | _ => right; reflexivity
                     | [ |- context[eqb ?x ?y] ] => destruct (eqb x y) eqn:?
                     | [ H : context[?x = true] |- _ ] => change (is_true x) in H
                     | [ H : is_true ?x, H' : context[?x] |- _ ] => rewrite H in H'
                     | [ H : is_true ?x |- context[?x] ] => rewrite H
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite H in *; clear x H
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite <- H in *; clear y H
                     | [ H : context[eqb ?x ?x] |- _ ]
                     => replace (eqb x x) with true
                       in H
                       by (symmetry; change (is_true (eqb x x)); reflexivity)                     end. }
          { unfold lift_eqb, to_function, find_default in *.
            apply negb_true_iff in H1.
            rewrite lift_brelation_iff_false in H1.
            destruct H1 as [k H1]; exists k.
            do 2 edestruct find;
              repeat match goal with
                     | _ => progress simpl in *
                     | _ => progress subst
                     | _ => congruence
                     | _ => intro
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite H in *; clear x H
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite <- H in *; clear y H
                     | [ H : context[eqb ?x ?x] |- _ ]
                       => replace (eqb x x) with true
                         in H
                         by (symmetry; change (is_true (eqb x x)); reflexivity)
                   end. } }
      Qed.
    End wf.
  End rel.
End FMapExtensionsWf_fun.

Module FMapExtensionsWf (M: WS) := FMapExtensionsWf_fun M.E M.


From Ssreflect
Require Import ssreflect ssrfun ssrbool ssrnat eqtype choice seq fintype.
From MathComp
Require Import bigop  finfun finset generic_quotient perm tuple fingroup.

Require Import finmap finsfun finperm nominal nominal_signature.

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

Delimit Scope finperm_scope with fperm.
Local Open Scope finperm_scope.
Local Open Scope fset.
Local Open Scope quotient_scope.

Import Key.Exports.

Section Definitions.

Inductive data_sort := T.

Inductive cons := top | arrow | all.
Definition cons_nat (c : cons) :=
  match c with
    |top => 0
    |arrow => 1%nat
    |all => 2
  end.
Definition nat_cons (n : nat) :=
  match n with
    |0 => top
    |1 => arrow
    |_ => all
  end.
Lemma cons_natK : cancel cons_nat nat_cons.
Proof. by case. Qed.
Definition cons_eqMixin := CanEqMixin cons_natK.
Canonical cons_eqType := EqType cons cons_eqMixin.

Definition cons_arity (c : cons) :=
  match c with
    |top => unit_arity data_sort
    |arrow => pair_arity (data_arity T) (data_arity T)
    |all => pair_arity (binding_arity (data_arity T)) (data_arity T)
  end.

Definition cons_res (c : cons) := T.

Definition type := term cons_arity cons_res (data_arity T).
Definition Var (x : atom) := Atom cons_arity cons_res x.
Definition Top := @C _ _ cons_arity cons_res top (Unit cons_arity cons_res).
Definition Arrow t1 t2 := @C _ _ cons_arity cons_res arrow (Pair t1 t2).
Definition All x t1 t2 := @C _ _ cons_arity cons_res all (Pair (B x t1) t2).

Definition Var


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.CategoryTheory.DaggerCategories.Categories.
Require Import UniMath.CategoryTheory.DaggerCategories.Unitary.
Require Import UniMath.CategoryTheory.DaggerCategories.Univalence.
Require Import UniMath.CategoryTheory.DaggerCategories.Functors.
Require Import UniMath.CategoryTheory.DaggerCategories.Transformations.

Local Open Scope cat.

Local Lemma equality_on_objects_from_functor_equality
      {C D : category}
      (F G : functor_data C D)
      (p : ∏ c: C, F c = G c)
      (q : transportf (λ F : C → D, ∏ a b : C, C ⟦ a, b ⟧ → D ⟦ F a, F b ⟧)
   (funextsec (λ _ : C, D) (pr1 F) (pr1 G) (λ x : C, p x)) (pr2 F) = pr2 G)
  : ∏ c : C,
      toforallpaths (λ _ : C, D) F G
    (base_paths F G
       (total2_paths_f ((funextsec (λ _ : C, D) (pr1 F) (pr1 G) (λ x : C, p x)))
                       q)) c = p c.
Proof.
  intro c.
  rewrite base_total2_paths.
  now rewrite toforallpaths_funextsec.
Qed.

Local Definition functor_eq_eq_from_functor_ob_eq'
             (C C': category)
             (F G : functor C C') (p q : pr1 F = pr1 G)
             (H : (base_paths _ _  p) =
                    (base_paths _ _ q)) :
    p = q.
Proof.
  apply (invmaponpathsweq (total2_paths_equiv _ _ _ )); simpl.
  use total2_paths_f.
  + exact H.
  + apply uip.
    do 2 (apply impred_isaset ; intro).
    apply funspace_isaset.
    apply C'.
Defined.

Section DaggerFunctorCategories.

  Context {C D : category}
          (dagC : dagger C) (dagD : dagger D).

  Definition dagger_functor_disp_cat
    : disp_cat (functor_category C D)
    := disp_full_sub [C,D] (λ F, is_dagger_functor dagC dagD F).

  Definition dagger_functor_cat
    : category
    := total_category dagger_functor_disp_cat.

  Definition make_dagger_functor
             {F : functor C D}
             (dagF : is_dagger_functor dagC dagD F)
    : dagger_functor_cat
    := F ,, dagF.

  Definition make_dagger_transformation
             (F G : dagger_functor_cat)
             (α : nat_trans (pr1 F : functor _ _) (pr1 G : functor _ _))
    : dagger_functor_cat⟦F,G⟧
    := α ,, tt.

  Definition dagger_functor_cat_structure
    : dagger_structure dagger_functor_cat
    := λ F G α, make_dagger_transformation _ _ (dagger_adjoint (pr2 F) (pr2 G) (pr1 α)).

  Lemma dagger_transformation_equality
        {F G : functor C D}
        {dagF : is_dagger_functor dagC dagD F}
        {dagG : is_dagger_functor dagC dagD G}
        (α β : dagger_functor_cat⟦make_dagger_functor dagF , make_dagger_functor dagG⟧)
    : (∏ x : C, pr11 α x = pr11 β x) -> α = β.
  Proof.
    intro p.
    use subtypePath.
    { intro ; apply isapropunit. }
    apply (nat_trans_eq D).
    exact p.
  Qed.

  Lemma dagger_functor_cat_laws
    : dagger_laws dagger_functor_cat_structure.
  Proof.
    (*use make_dagger_laws*) repeat split ;
      (intro ; intros ; apply dagger_transformation_equality ; intro).
    - apply dagger_to_law_id.
    - apply dagger_to_law_comp.
    - apply dagger_to_law_idemp.
  Qed.

  Definition dagger_on_functor_cat : dagger dagger_functor_cat
    := _ ,, dagger_functor_cat_laws.

End DaggerFunctorCategories.

Section Univalence.

  Context {C D : category}
          {dagC : dagger C} {dagD : dagger D}
          {F G : functor C D}
          (dagF : is_dagger_functor dagC dagD F)
          (dagG : is_dagger_functor dagC dagD G).

  Local Definition unitary_functors_eq
    : UU
    := ∑ p : (∏ x : pr11 C, unitary dagD (F x) (G x)),
        ∏ (x y : C) (f : C⟦x,y⟧),
        #G f = (dagD _ _ (pr1 (p x))) · #F f · (pr1 (p y)).

  Local Definition functors_eq_data
    : UU
    := ∑ p : (∏ x : C, (pr11 F x) = (pr11 G x)),
        ∏ (x y : pr11 C) (f : (pr11 C)⟦x,y⟧),
        #G f = idtodaggermor dagD (! p x) · #F f · idtodaggermor dagD (p y).

  Definition unitary_functors_equiv_unitary
    : unitary_functors dagF dagG ≃ unitary (dagger_functor_cat_structure dagC dagD) (F,,dagF) (G,,dagG).
  Proof.
    use weq_iso.
    - intro α.
      exists (make_dagger_transformation dagC dagD _ _ (pr1 α : nat_trans (pr1 (F,,dagF)) (pr1 (G,,dagG)))).
      abstract (split ; apply dagger_transformation_equality ; intro c ; apply (pr2 α c)).
    - intro α.
      exists (pr11 α).
      abstract (
          intro c ;
          split ;
          [ exact (eqtohomot (base_paths _ _ (base_paths _ _ (pr12 α))) c)
          | exact (eqtohomot (base_paths _ _ (base_paths _ _ (pr22 α))) c) ]).
    - abstract (
          intro α ;
          use total2_paths_f ;
          [ use (nat_trans_eq (pr2 D)) ; intro ; apply idpath
          | use proofirrelevance ;
            apply impred_isaprop ; intro ;
            apply Isos.isaprop_is_inverse_in_precat]).
    - abstract (
          intro α ;
          use total2_paths_f ;
          [ apply dagger_transformation_equality ;
            intro ; apply idpath
          | apply isaprop_is_unitary]).
  Defined.

  Lemma unitary_functor_eq_to_unitary_functors_naturality
        (p : unitary_functors_eq)
    : is_nat_trans F G (λ c : pr11 C, pr1 (pr1 p c)).
  Proof.
    intros c1 c2 f.
    refine (_ @ maponpaths (compose _) (! pr2 p _ _ _)).
    refine (_ @ assoc' _ _ _).
    apply maponpaths_2.
    refine (_ @ assoc' _ _ _).
    refine (! id_left _ @ _).
    apply maponpaths_2, pathsinv0, (pr1 p).
  Qed.

  Definition unitary_functors_eq_to_unitary_functors
    : unitary_functors_eq -> unitary_functors dagF dagG.
  Proof.
    intros [p q].
    use tpair.
    - apply (make_nat_trans _ _ (λ c, pr1 (p c))).
      exact (unitary_functor_eq_to_unitary_functors_naturality (p,,q)).
    - abstract (intro ; apply p).
  Defined.

  Lemma unitary_functors_eq_from_unitary_functors_naturality
        (α : unitary_functors dagF dagG)
    : ∏ (x y : C) (f : C ⟦ x, y ⟧), # G f = dagD (F x) (G x) ((pr1 α) x) · # F f · (pr1 α) y.
  Proof.
    intros c1 c2 f.
    apply pathsinv0.
    refine (assoc' _ _ _ @ _).
    refine (maponpaths (compose _) (pr21 α _ _ _) @ _).
    refine (assoc _ _ _ @ _).
    refine (_ @ id_left _).
    apply maponpaths_2, (pr2 α).
  Qed.

  Definition unitary_functors_eq_from_unitary_functors
    : unitary_functors dagF dagG -> unitary_functors_eq.
  Proof.
    intros [α p].
    use tpair.
    + intro c.
      exists (α c).
      apply p.
    + exact (unitary_functors_eq_from_unitary_functors_naturality (α,,p)).
  Defined.

  Lemma unitary_functors_eq_equiv_unitary_functors_inv_law1
    :  ∏ x : unitary_functors_eq,
        unitary_functors_eq_from_unitary_functors (unitary_functors_eq_to_unitary_functors x) = x.
  Proof.
    intro.
    use total2_paths_f.
    - apply funextsec ; intro.
      apply unitary_eq, idpath.
    - repeat (apply funextsec ; intro).
      apply homset_property.
  Qed.

  Lemma unitary_functors_eq_equiv_unitary_functors_inv_law2
    :  ∏ y : unitary_functors dagF dagG,
        unitary_functors_eq_to_unitary_functors (unitary_functors_eq_from_unitary_functors y) = y.
  Proof.
    intro.
    use total2_paths_f.
    - use (nat_trans_eq (pr2 D)).
      intro ; apply idpath.
    - apply funextsec ; intro.
      apply Isos.isaprop_is_inverse_in_precat.
  Qed.

  Definition unitary_functors_eq_equiv_unitary_functors
    : unitary_functors_eq ≃ unitary_functors dagF dagG.
  Proof.
    use weq_iso.
    - exact unitary_functors_eq_to_unitary_functors.
    - exact unitary_functors_eq_from_unitary_functors.
    - exact unitary_functors_eq_equiv_unitary_functors_inv_law1.
    - exact unitary_functors_eq_equiv_unitary_functors_inv_law2.
  Defined.

  Definition functors_eq_data_to_unitary_functors_eq
             (u : is_univalent_dagger dagD)
    : functors_eq_data -> unitary_functors_eq.
  Proof.
    intro p.
    exists (λ c, idtodaggeriso dagD _ _ (pr1 p c)).
    intros x y f.
    refine (pr2 p x y f @ _).
    do 2 apply maponpaths_2.
    etrans.
    { apply (idtodaggeriso_is_dagger_of_idtodaggeriso dagD). }
    do 3 apply maponpaths.
    apply pathsinv0inv0.
  Defined.

  Definition functors_eq_data_from_unitary_functors_eq
             (u : is_univalent_dagger dagD)
    : unitary_functors_eq -> functors_eq_data.
  Proof.
    intros p.
    use tpair.
    - intro c ; apply u ; exact (pr1 p c).
    - intros x y f.
      refine (pr2 p x y f @ _).
      apply maponpaths_compose.
      + apply maponpaths_2.
        refine (_ @ ! idtodaggeriso_is_dagger_of_idtodaggeriso dagD _).
        do 2 apply maponpaths.
        etrans.
        * apply pathsinv0, (idtodaggeriso_daggerisotoid u).
        * apply maponpaths, pathsinv0, pathsinv0inv0.
      + apply pathsinv0, idtodaggermor_daggerisotoid.
  Defined.

  Lemma functors_eq_data_equiv_unitary_functors_eq_inv_law1
        (u : is_univalent_dagger dagD)
    :   ∏ x : functors_eq_data,
        functors_eq_data_from_unitary_functors_eq u (functors_eq_data_to_unitary_functors_eq u x) = x.
  Proof.
    intro p.
    use total2_paths_f.
    - apply funextsec ; intro.
      apply daggerisotoid_idtodaggeriso.
    - repeat (apply funextsec ; intro).
      apply homset_property.
  Qed.

  Lemma functors_eq_data_equiv_unitary_functors_eq_inv_law2
        (u : is_univalent_dagger dagD)
    :   ∏ y : unitary_functors_eq,
        functors_eq_data_to_unitary_functors_eq u (functors_eq_data_from_unitary_functors_eq u y) = y.
  Proof.
    intro p.
    use total2_paths_f.
    - apply funextsec ; intro.
      use total2_paths_f.
      + apply maponpaths, idtodaggeriso_daggerisotoid.
      + apply isaprop_is_unitary.
    - repeat (apply funextsec ; intro).
      apply homset_property.
  Qed.

  Definition functors_eq_data_equiv_unitary_functors_eq
             (u : is_univalent_dagger dagD)
    : functors_eq_data ≃ unitary_functors_eq.
  Proof.
    use weq_iso.
    - exact (functors_eq_data_to_unitary_functors_eq u).
    - exact (functors_eq_data_from_unitary_functors_eq u).
    - exact (functors_eq_data_equiv_unitary_functors_eq_inv_law1 u).
    - exact (functors_eq_data_equiv_unitary_functors_eq_inv_law2 u).
  Defined.

  Lemma transport_of_dagger_functor_map_is_pointwise
        (F0 G0 : pr11 C -> pr11 D)
        (F1 : ∏ a b : pr11 C, a --> b -> F0 a --> F0 b)
        (gamma : F0  = G0 )
        (a b : pr11 C) (f : a --> b) :
    transportf (fun x : pr11 C -> pr11 D =>
                  ∏ a0 b0 : pr11 C, a0 --> b0 -> x a0 --> x b0)
               gamma F1 a b f =
      Univalence.double_transport (toforallpaths (λ _ : pr11 C, pr11 D) F0 G0 gamma a)
                       (toforallpaths (λ _ : pr11 C, pr11 D) F0 G0 gamma b)
                       (F1 a b f).
  Proof.
    induction gamma.
    apply idpath.
  Qed.

  Lemma double_transport_idtodaggeriso (a a' b b' : pr111 D)
        (p : a = a') (q : b = b')  (f : a --> b) :
    Univalence.double_transport p q f = pr1 (idtodaggeriso dagD _ _ (! p)) · f · pr1 (idtodaggeriso dagD _ _ q).
  Proof.
    destruct p.
    destruct q.
    intermediate_path (identity _ · f).
    - apply pathsinv0; apply id_left.
    - apply pathsinv0; apply id_right.
  Qed.

  Definition equality_to_functors_eq_data
    : pr1 F = pr1 G -> functors_eq_data.
  Proof.
    intro p.
    exists (λ c, eqtohomot (base_paths _ _ p) c).
    abstract (
        intros x y f ;
        refine (! eqtohomot (eqtohomot (eqtohomot (fiber_paths p) x) y) f @ _) ;
        etrans ; [
          apply transport_of_dagger_functor_map_is_pointwise
        | apply double_transport_idtodaggeriso]
      ).
  Defined.

  Definition equality_from_functors_eq_data
    : functors_eq_data → pr1 F = pr1 G.
  Proof.
    intros [p q].
    use total2_paths_f.
    - apply funextsec ; intro ; apply p.
    - abstract(
          repeat (apply funextsec ; intro) ;
          rewrite transport_of_dagger_functor_map_is_pointwise ;
          rewrite double_transport_idtodaggeriso ;
          rewrite toforallpaths_funextsec ;
          exact (! q _ _ _)
        ).
  Defined.

  Lemma equality_equiv_functors_eq_data_inv_law1
    : ∏ x : pr1 F = pr1 G, equality_from_functors_eq_data (equality_to_functors_eq_data x) = x.
  Proof.
    intro.
    apply functor_eq_eq_from_functor_ob_eq'.
    refine (base_total2_paths _ @ _).
    apply (invmaponpathsweq (weqtoforallpaths _ _ _)).
    simpl.
    rewrite toforallpaths_funextsec.
    apply funextsec; intro ; apply idpath.
  Qed.

  Lemma equality_equiv_functors_eq_data_inv_law2
    : ∏ y : functors_eq_data, equality_to_functors_eq_data (equality_from_functors_eq_data y) = y.
  Proof.
    intros [p q].
    use total2_paths_f.
    - apply funextsec ; intro.
      apply equality_on_objects_from_functor_equality.
    - apply proofirrelevance.
      do 3 (apply impred_isaprop ; intro).
      apply homset_property.
  Qed.

  Definition equality_equiv_functors_eq_data
    : pr1 F = pr1 G ≃ functors_eq_data.
  Proof.
    use weq_iso.
    - exact equality_to_functors_eq_data.
    - exact equality_from_functors_eq_data.
    - exact equality_equiv_functors_eq_data_inv_law1.
    - exact equality_equiv_functors_eq_data_inv_law2.
  Defined.

  Local Definition id_pr1_to_pr11_id
    : F = G ≃ pr1 F = pr1 G.
  Proof.
    use subtypeInjectivity.
    intro.
    apply isaprop_is_functor.
    apply (pr2 D).
  Defined.

  Local Definition id_to_pr1_id
    : (F,,dagF) = (G,,dagG) ≃ F = G.
  Proof.
    use subtypeInjectivity.
    intro.
    apply isaprop_is_dagger_functor.
  Defined.

  Local Definition univalence_iso
             (u : is_univalent_dagger dagD)
    : (F,,dagF) = (G,,dagG) ≃  unitary (dagger_functor_cat_structure dagC dagD) (F,, dagF) (G,, dagG).
  Proof.
    refine (_ ∘ id_to_pr1_id)%weq.
    refine (_ ∘ id_pr1_to_pr11_id)%weq.
    refine (_ ∘ equality_equiv_functors_eq_data)%weq.
    refine (_ ∘ functors_eq_data_equiv_unitary_functors_eq u)%weq.
    refine (_ ∘ unitary_functors_eq_equiv_unitary_functors)%weq.
    exact unitary_functors_equiv_unitary.
  Defined.

End Univalence.

Lemma dagger_functor_cat_is_dagger_univalent
      {C D : category}
      (dagC : dagger C) (dagD : dagger D)
      (u : is_univalent_dagger dagD)
  : is_univalent_dagger (dagger_on_functor_cat dagC dagD).
Proof.
  intros F G.
  use weqhomot.
  - exact (univalence_iso (pr2 F) (pr2 G) u).
  - intro p.
    induction p.
    use subtypePath.
    { intro ; apply isaprop_is_unitary. }
    use subtypePath.
    { intro ; apply isapropunit. }
    apply (nat_trans_eq (pr2 D)).
    intro ; apply idpath.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

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

Print Assumptions square.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun.
From mathcomp Require Import choice seq path finset finfun fintype bigop.
From mathcomp Require Import bigenough.
From mathcomp Require Export finmap.

(* -------------------------------------------------------------------- *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope fset.
Local Open Scope fmap.

(* -------------------------------------------------------------------- *)
Lemma fnd_fmap0 (T : choiceType) (U : Type) x :
  ([fmap] : {fmap T -> U}).[?x] = None.
Proof. by rewrite not_fnd // in_fset0. Qed.

(* -------------------------------------------------------------------- *)
Lemma enum_fset0 (T : choiceType) :
  enum [finType of fset0] = [::] :> seq (@fset0 T).
Proof. by rewrite enumT unlock. Qed.

Lemma enum_fset1 (T : choiceType) (x : T) :
  enum [finType of [fset x]] = [:: [`fset11 x]].
Proof.
apply/perm_eq_small=> //; apply/uniq_perm_eq => //.
  by apply/enum_uniq.
case=> [y hy]; rewrite mem_seq1 mem_enum /in_mem /=.
by rewrite eqE /=; rewrite in_fset1 in hy.
Qed.

(* -------------------------------------------------------------------- *)
Section BigFSet.
Variable (R : Type) (idx : R) (op : Monoid.law idx).
Variable (I : choiceType).

Lemma big_fset0 (F : @fset0 I -> R) :
  \big[op/idx]_(i : fset0) F i = idx.
Proof. by rewrite /index_enum -enumT /= enum_fset0 big_nil. Qed.

Lemma big_fset1 (a : I) (F : [fset a] -> R) :
  \big[op/idx]_(i : [fset a]) F i = F (FSetSub (fset11 a)).
Proof. by rewrite /index_enum -enumT enum_fset1 big_seq1. Qed.
End BigFSet.

Section BigFSetIncl.
Variables (R : Type) (idx : R) (op : Monoid.com_law idx).
Variables (T : choiceType) (A B : {fset T}) (F : T -> R).

Lemma big_fset_incl :
    A `<=` B
  -> (forall x, x \in B -> x \notin A -> F x = idx)
  -> \big[op/idx]_(x : A) F (val x) = \big[op/idx]_(x : B) F (val x).
Proof.
move=> leAB Fid; rewrite [RHS](bigID (mem A \o val)) /=.
rewrite [X in op _ X]big1 => [|b /Fid ->//].
rewrite Monoid.mulm1 -[RHS]big_filter.
rewrite -[LHS](big_map _ xpredT) -[RHS](big_map _ xpredT).
apply/eq_big_perm/uniq_perm_eq.
+ rewrite map_inj_uniq; last by apply/val_inj.
  by rewrite /index_enum -enumT enum_uniq.
+ rewrite map_inj_uniq; [apply/filter_uniq | by apply/val_inj].
  by rewrite /index_enum -enumT enum_uniq.
move=> x; apply/mapP/mapP=> -[] => [a _ ->|b].
+ exists (fincl leAB a) => //; rewrite mem_filter /=.
  by rewrite fsvalP /= /index_enum -enumT mem_enum.
rewrite mem_filter => /andP[inA _] ->; exists [`inA] => //.
by rewrite /index_enum -enumT mem_enum.
Qed.
End BigFSetIncl.

Arguments big_fset_incl [R idx op T A B].

(* -------------------------------------------------------------------- *)
Module BigEnoughFSet.
Export BigEnough.

Definition big_rel_fsubset_class K : big_rel_class_of (@fsubset K).
Proof.
exists fsubset (fun G => \big[fsetU/fset0]_(g <- G) g)=> [|g s|g1 g2 j] //.
  by rewrite big_cons fsubsetUl.
by rewrite big_cons => h; rewrite fsubsetU // h orbT.
Qed.
Canonical big_enough_fset K := BigRelOf (big_rel_fsubset_class K).

Ltac fset_big_enough_trans :=
  match goal with
  | [leq : is_true (?A `<=` ?B) |- is_true (?X `<=` ?B)] =>
       apply: fsubset_trans leq; big_enough; olddone
  end.

Ltac done := do [fset_big_enough_trans|BigEnough.done].

Ltac pose_big_fset K i :=
  evar (i : {fset K}); suff : closed i; first do
    [move=> _; instantiate (1 := bigger_than (@fsubset K) _) in (Value of i)].
End BigEnoughFSet.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to the
   correctness of closure algorithms for context-free grammars, namely
   union, concatenation and Kleene star operations.

   More information can be found in the paper "Formalization of closure
   properties for context-free grammars", LSFA 2014.

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

Require Import Ascii.
Require Import String.
Require Import List.
Import ListNotations.

Open Scope char_scope.
Open Scope string_scope.
Open Scope list_scope.

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

Lemma map_expand:
forall (A B: Type) (f: A -> B) (l: list A) (s1 s2: list B),
s1 ++ s2 = map f l ->
exists s1' s2': list A,
l = s1' ++ s2' /\ map f s1' = s1 /\ map f s2' = s2.
Proof.
intros A B f l.
induction l.
- intros s1 s2 H.
  simpl in H.
  apply app_eq_nil in H.
  destruct H as [H1 H2].
  subst.
  exists [], [].
  auto.
- intros s1 s2 H.
  simpl in H.
  destruct s1.
  + simpl in H.
    destruct s2.
    * inversion H.
    * inversion H.
      exists [], (a::l). {
      split.
      - simpl.
        reflexivity.
      - split.
        + simpl.
          reflexivity.
        + simpl.
          reflexivity. }
  + destruct s2.
    * inversion H.
      exists (a::l), []. {
      split.
      - simpl.
        rewrite app_nil_r.
        reflexivity.
      - split.
        + simpl.
          rewrite <- H2.
          rewrite app_nil_r.
          reflexivity.
        + simpl.
          reflexivity. }
    * inversion H.
      specialize (IHl s1 (b0::s2)).
      specialize (IHl H2).
      destruct IHl as [s1' [s2' [H3 [H4 H5]]]].
      exists (a::s1').
      exists s2'. {
      split.
      - rewrite H3.
        simpl.
        reflexivity.
      - split.
        + simpl.
          rewrite H4.
          reflexivity.
        + rewrite H5.
          reflexivity. }
Qed.

Lemma cons_app:
forall (A: Type) (s: A) (l: list A),
s::l=[s]++l.
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma equal_app (A: Type) :
forall l1 l2 s1 s2 : list A,
l1 ++ l2 = s1 ++ s2 ->
(exists l, s1 = l1 ++ l /\ l2 = l ++ s2) \/ (exists l, l1 = s1 ++ l /\ s2 = l ++ l2).
Proof.
intros l1.
induction l1 as [|a l1 IH].
- intros l2 s1 s2 H.
  simpl in H.
  subst.
  simpl.
  left.
  exists s1.
  split.
  reflexivity.
  reflexivity.
- intros l2 s1 s2 H.
  simpl in H.
  destruct s1 as [|a' s1].
  + simpl in H.
    subst.
    simpl.
    right.
    exists (a::l1).
    split.
    * reflexivity.
    * simpl.
      reflexivity.
  + simpl in H.
    inversion H.
    subst a'.
    clear H.
    apply IH in H2.
    destruct H2 as [(l & ? & ?) | (l & ? & ?)].
    * subst.
      simpl.
      left.
      exists l. {
      split.
      - reflexivity.
      - reflexivity. }
    * right.
      exists l. {
      split.
      - rewrite H.
        simpl.
        reflexivity.
      - rewrite H0.
        reflexivity. }
Qed.

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

Record cfg: Type:= {
non_terminal: Type;
terminal: Type;
start_symbol: non_terminal;
sf:= list (non_terminal + terminal);
rules: non_terminal -> sf -> Prop
}.

Inductive derives (g: cfg) : sf g -> sf g -> Prop :=
| derives_refl: forall s,
                derives g s s
| derives_step: forall s1 s2 s3: sf g,
                forall left: non_terminal g,
                forall right: sf g,
                derives g s1 (s2 ++ inl left :: s3) ->
                rules g left right ->
                derives g s1 (s2 ++ right ++ s3).

Definition generates (g: cfg) (s: sf g): Prop:=
derives g [inl (start_symbol g)] s.

Definition convert (g: cfg) (t: terminal g): non_terminal g + terminal g:= inr t.

Definition produces (g: cfg) (s: list (terminal g)): Prop:=
generates g (map (convert g) s).

Theorem derives_direct:
forall g: cfg,
forall left: non_terminal g,
forall right: sf g,
rules g left right -> derives g [inl left] right.
Proof.
intros g left right H.
rewrite <- app_nil_l.
rewrite <- app_nil_r.
rewrite <- app_assoc.
apply derives_step with (left:=left).
rewrite app_nil_l.
apply derives_refl.
exact H.
Qed.

Theorem derives_context_free_add_left (g:cfg) (s1 s2 s: sf g):
derives g s1 s2 -> derives g (s++s1) (s++s2).
Proof.
intros H.
induction H as [| x y z left right H1 H2 H3].
apply derives_refl.
remember (s++x) as w1.
rewrite app_assoc.
rewrite app_assoc in H2.
remember (s++y) as w2.
apply derives_step with (left:=left).
exact H2.
exact H3.
Qed.

Theorem derives_context_free_add_right (g:cfg) (s1 s2 s: sf g):
derives g s1 s2 -> derives g (s1++s) (s2++s).
Proof.
intros H.
induction H as [| x y z left right H1 H2 H3].
apply derives_refl.
remember (x++s) as w1.
rewrite <- app_assoc.
rewrite <- app_assoc.
rewrite <- app_assoc in H2.
rewrite <- app_comm_cons in H2.
remember (z++s) as w2.
apply derives_step with (left:=left).
exact H2.
exact H3.
Qed.

Theorem derives_context_free_add (g:cfg) (s1 s2 s s': sf g):
derives g s1 s2 -> derives g (s++s1++s') (s++s2++s').
Proof.
intros H.
apply derives_context_free_add_left.
apply derives_context_free_add_right.
exact H.
Qed.

Theorem derives_trans (g: cfg) (s1 s2 s3: sf g):
derives g s1 s2 ->
derives g s2 s3 ->
derives g s1 s3.
Proof.
intros H1 H2.
induction H2 as [ s | x y z left right H3 H4 H5].
- trivial.
- econstructor.
  apply H4.
  exact H1.
  exact H5.
Qed.

Theorem derives_combine (g: cfg) (s1 s2 s3 s4: sf g):
derives g s1 s2 /\ derives g s3 s4 -> derives g (s1++s3) (s2++s4).
Proof.
intros [H1 H2].
induction H1,H2.
apply derives_refl.
apply derives_context_free_add_left.
apply derives_step with (left:= left).
exact H2.
exact H.
apply derives_context_free_add_right.
apply derives_step with (left:=left).
exact H1.
exact H.
rewrite <- app_assoc.
rewrite <- app_assoc.
rewrite <- app_assoc in IHderives.
simpl in IHderives.
remember (s0 ++ s4 ++ right0 ++ s5) as w.
apply derives_step with (left:=left).
exact IHderives.
exact H.
Qed.

Theorem derives_multiple (g: cfg) (s1 s2 s3: sf g) (left: non_terminal g) (right1 right2: sf g):
derives g s1 (s2 ++ inl left :: s3) ->
rules g left right1 ->
rules g left right2 ->
derives g s1 (s2 ++ right1 ++ s3) /\ derives g s1 (s2 ++ right2 ++ s3).
Proof.
intros H1 H2 H3.
split.
apply derives_step with (left:=left).
exact H1.
exact H2.
apply derives_step with (left:=left).
exact H1.
exact H3.
Qed.

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

Inductive g_uni_t (g1 g2: cfg): Type:=
| Transf1_uni_t: terminal g1 -> g_uni_t g1 g2
| Transf2_uni_t: terminal g2 -> g_uni_t g1 g2.

Inductive g_uni_nt (g1 g2: cfg): Type :=
| Start_uni : g_uni_nt g1 g2
| Transf1_uni_nt : non_terminal g1 -> g_uni_nt g1 g2
| Transf2_uni_nt : non_terminal g2 -> g_uni_nt g1 g2.

Definition g_uni_sf_lift1 (g1 g2: cfg)(c: non_terminal g1 + terminal g1): g_uni_nt g1 g2 + g_uni_t g1 g2:=
  match c with
  | inl nt => inl (Transf1_uni_nt g1 g2 nt)
  | inr t  => inr (Transf1_uni_t g1 g2 t)
  end.

Definition g_uni_sf_lift2 (g1 g2: cfg)(c: non_terminal g2 + terminal g2): g_uni_nt g1 g2 + g_uni_t g1 g2:=
  match c with
  | inl nt => inl (Transf2_uni_nt g1 g2 nt)
  | inr t  => inr (Transf2_uni_t g1 g2 t)
  end.

Inductive g_uni_rules (g1 g2: cfg): g_uni_nt g1 g2 -> list (g_uni_nt g1 g2 + g_uni_t g1 g2) -> Prop :=
| Start1_uni: g_uni_rules g1 g2 (Start_uni g1 g2) [inl (Transf1_uni_nt g1 g2 (start_symbol g1))]
| Start2_uni: g_uni_rules g1 g2 (Start_uni g1 g2) [inl (Transf2_uni_nt g1 g2 (start_symbol g2))]
| Lift1_uni: forall nt s,
             rules g1 nt s ->
             g_uni_rules g1 g2 (Transf1_uni_nt g1 g2 nt) (map (g_uni_sf_lift1 g1 g2) s)
| Lift2_uni: forall nt s,
             rules g2 nt s ->
             g_uni_rules g1 g2 (Transf2_uni_nt g1 g2 nt) (map (g_uni_sf_lift2 g1 g2) s).

Definition g_uni (g1 g2: cfg): cfg := {|
non_terminal:= g_uni_nt g1 g2;
terminal:= g_uni_t g1 g2;
start_symbol:= Start_uni g1 g2;
rules:= g_uni_rules g1 g2
|}.

Lemma derives_add_uni_left (g1 g2: cfg)(s1 s2: sf g1):
derives g1 s1 s2 ->
derives (g_uni g1 g2)
        (map (g_uni_sf_lift1 g1 g2) s1)
        (map (g_uni_sf_lift1 g1 g2) s2).
Proof.
intros H.
induction H as [|x y z left right H1 H2 H3].
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in H2.
  simpl in H2.
  apply derives_step with (left:=(Transf1_uni_nt g1 g2 left)).
  exact H2.
  simpl.
  apply Lift1_uni.
  exact H3.
Qed.

Lemma derives_add_uni_right (g1 g2: cfg)(s1 s2: sf g2):
derives g2 s1 s2 ->
derives (g_uni g1 g2)
        (map (g_uni_sf_lift2 g1 g2) s1)
        (map (g_uni_sf_lift2 g1 g2) s2).
Proof.
intros H.
induction H as [|x y z left right H1 H2 H3].
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in H2.
  simpl in H2.
  apply derives_step with (left:=(Transf2_uni_nt g1 g2 left)).
  exact H2.
  simpl.
  apply Lift2_uni.
  exact H3.
Qed.

Theorem g_uni_correct_left (g1 g2: cfg)(s: sf g1):
generates g1 s ->
generates (g_uni g1 g2)
          (map (g_uni_sf_lift1 g1 g2) s).
Proof.
unfold generates.
intros H.
apply derives_trans with (s2:= map (g_uni_sf_lift1 g1 g2) [(inl (start_symbol g1))]).
- simpl.
  match goal with
  | |- derives _ ?s1 ?s2 =>
       change s1 with ([] ++ s1)%list;
       change s2 with ([] ++ s2 ++ [])%list
  end.
  apply derives_step with (left:=(Start_uni g1 g2)).
  + apply derives_refl.
  + simpl.
    apply Start1_uni.
- apply derives_add_uni_left.
  exact H.
Qed.

Theorem g_uni_correct_right (g1 g2: cfg)(s: sf g2):
generates g2 s ->
generates (g_uni g1 g2)
          (map (g_uni_sf_lift2 g1 g2) s).
Proof.
unfold generates.
intros H.
apply derives_trans with (s2:= map (g_uni_sf_lift2 g1 g2) [(inl (start_symbol g2))]).
- simpl.
  match goal with
  | |- derives _ ?s1 ?s2 =>
       change s1 with ([] ++ s1)%list;
       change s2 with ([] ++ s2 ++ [])%list
  end.
  apply derives_step with (left:=(Start_uni g1 g2)).
  + apply derives_refl.
  + simpl.
    apply Start2_uni.
- apply derives_add_uni_right.
  exact H.
Qed.

Theorem g_uni_correct (g1 g2: cfg)(s1: sf g1)(s2: sf g2):
(generates g1 s1 -> generates (g_uni g1 g2) (map (g_uni_sf_lift1 g1 g2) s1)) /\
(generates g2 s2 -> generates (g_uni g1 g2) (map (g_uni_sf_lift2 g1 g2) s2)).
Proof.
split.
- apply g_uni_correct_left.
- apply g_uni_correct_right.
Qed.

Theorem g_uni_correct_inv (g1 g2: cfg)(s: sf (g_uni g1 g2)):
generates (g_uni g1 g2) s ->
(s=[inl (start_symbol (g_uni g1 g2))]) \/
(exists s1: sf g1,
(s=(map (g_uni_sf_lift1 g1 g2) s1) /\ generates g1 s1)) \/
(exists s2: sf g2,
(s=(map (g_uni_sf_lift2 g1 g2) s2) /\ generates g2 s2)).
Proof.
unfold generates.
remember [inl (start_symbol (g_uni g1 g2))] as init.
intro H.
induction H.
  (* Base case *)
- left. reflexivity.
- (* Induction hypothesis *)
  subst.
  specialize (IHderives eq_refl).
  destruct IHderives.
  + (* IHderives, first case *)
    destruct s2.
    * (* First case, left = Start_uni *)
      simpl in H1. inversion H1. subst. {
      inversion H0. subst. clear H1.
      - (* First case, right = start_symbol g1 *)
        simpl in *.
        right.
        left.
        exists [inl (start_symbol g1)].
        split.
        + simpl. reflexivity.
        + apply derives_refl.
      - (* Second case, right = start_symbol g2 *)
        simpl in *.
        right.
        right.
        exists [inl (start_symbol g2)].
        split.
        + simpl. reflexivity.
        + apply derives_refl. }
    * (* Second case, left = non_terminal (g_uni g1 g2 *)
      simpl in H1.
      inversion H1. {
      destruct s2.
      - simpl in H4. inversion H4.
      - inversion H4. }
  + (* IHderives, second case *)
    destruct H1.
    * (* H1, first case: comes from g1 *)
      destruct H1 as [x [H1 H2]]. {
      inversion H0.
      - (* First rule: Start1_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1.
            inversion H1. {
            destruct s.
            - inversion H4.
            - inversion H4. }
        + simpl in *.
          assert (IN: In (inl (Start_uni g1 g2)) (map (g_uni_sf_lift1 g1 g2) x)).
          { rewrite <- H1. simpl. right. apply in_app_iff. right. simpl. left. reflexivity. }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Second rule: Start2_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1. inversion H1. {
            destruct s.
            - inversion H4.
            - inversion H4. }
        + simpl in *.
          assert (IN: In (inl (Start_uni g1 g2)) (map (g_uni_sf_lift1 g1 g2) x)).
          { rewrite <- H1. simpl. right. apply in_app_iff. right. simpl. left. reflexivity. }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Third rule: Lift1_uni *)
        (* Should be true *)
        right.
        left.
        apply map_expand in H1.
        destruct H1 as [s1' [s2'[H6 [H7 H8]]]].
        replace (inl left::s3) with ([inl left]++s3) in H8.
        + symmetry in H8.
          apply map_expand in H8.
          destruct H8 as [m [n [H9 [H10 H11]]]].
          exists (s1'++s++n).
          split.
          * subst.
            repeat rewrite map_app.
            reflexivity.
          * subst. {
            destruct m.
            - inversion H10.
            - simpl in H10.
              inversion H10.
              destruct s0.
              + inversion H4.
                subst.
                apply map_eq_nil in H5.
                subst.
                apply derives_step with (right:=s) in H2.
                exact H2.
                exact H3.
              + inversion H4. }
        + simpl.
          reflexivity.
      - (* Forth rule: Lift2_uni *)
        (* Should be false *)
        simpl in *. subst.
        assert (IN: In (inl (Transf2_uni_nt g1 g2 nt)) (map (g_uni_sf_lift1 g1 g2) x)).
        { rewrite <- H1. rewrite in_app_iff. right. simpl. left. reflexivity. }
        rewrite in_map_iff in IN.
        destruct IN as [x0 [H4 H5]].
        destruct x0.
        + inversion H4.
        + inversion H4. }
    * (* H1, second case: comes from g2 *)
      destruct H1 as [x [H1 H2]]. {
      inversion H0.
      - (* First rule: Start1_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1.
            inversion H1. {
            destruct s.
            - inversion H4.
            - inversion H4. }
        + simpl in *.
          assert (IN: In (inl (Start_uni g1 g2)) (map (g_uni_sf_lift2 g1 g2) x)).
          { rewrite <- H1. simpl. right. apply in_app_iff. right. simpl. left. reflexivity. }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Second rule: Start2_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1. inversion H1. {
            destruct s.
            - inversion H4.
            - inversion H4. }
        + simpl in *.
          assert (IN: In (inl (Start_uni g1 g2)) (map (g_uni_sf_lift2 g1 g2) x)).
          { rewrite <- H1. simpl. right. apply in_app_iff. right. simpl. left. reflexivity. }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Third rule: Lift1_uni *)
        (* Should be false *)
        simpl in *. subst.
        assert (IN: In (inl (Transf1_uni_nt g1 g2 nt)) (map (g_uni_sf_lift2 g1 g2) x)).
        { rewrite <- H1. rewrite in_app_iff. right. simpl. left. reflexivity. }
        rewrite in_map_iff in IN.
        destruct IN as [x0 [H4 H5]].
        destruct x0.
        + inversion H4.
        + inversion H4.
      - (* Forth rule: Lift2_uni *)
        (* Should be true *)
        right.
        right.
        apply map_expand in H1.
        destruct H1 as [s1' [s2'[H6 [H7 H8]]]].
        replace (inl left::s3) with ([inl left]++s3) in H8.
        + symmetry in H8.
          apply map_expand in H8.
          destruct H8 as [m [n [H9 [H10 H11]]]].
          exists (s1'++s++n).
          split.
          * subst.
            repeat rewrite map_app.
            reflexivity.
          * subst. {
            destruct m.
            - inversion H10.
            - simpl in H10.
              inversion H10.
              destruct s0.
              + inversion H4.
                subst.
                apply map_eq_nil in H5.
                subst.
                apply derives_step with (right:=s) in H2.
                exact H2.
                exact H3.
              + inversion H4. }
        + simpl.
          reflexivity. }
Qed.

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

Inductive g_cat_t (g1 g2: cfg): Type:=
| Transf1_cat_t: terminal g1 -> g_cat_t g1 g2
| Transf2_cat_t: terminal g2 -> g_cat_t g1 g2.

Inductive g_cat_nt (g1 g2: cfg): Type :=
| Start_cat : g_cat_nt g1 g2
| Transf1_cat_nt : non_terminal g1 -> g_cat_nt g1 g2
| Transf2_cat_nt : non_terminal g2 -> g_cat_nt g1 g2.

Definition g_cat_sf_lift1 (g1 g2: cfg)(c: non_terminal g1 + terminal g1): g_cat_nt g1 g2 + g_cat_t g1 g2:=
  match c with
  | inl nt => inl (Transf1_cat_nt g1 g2 nt)
  | inr t  => inr (Transf1_cat_t g1 g2 t)
  end.

Definition g_cat_sf_lift2 (g1 g2: cfg)(c: non_terminal g2 + terminal g2): g_cat_nt g1 g2 + g_cat_t g1 g2:=
  match c with
  | inl nt => inl (Transf2_cat_nt g1 g2 nt)
  | inr t  => inr (Transf2_cat_t g1 g2 t)
  end.

Inductive g_cat_rules (g1 g2: cfg): g_cat_nt g1 g2 -> list (g_cat_nt g1 g2 + g_cat_t g1 g2) -> Prop :=
| New_cat: g_cat_rules g1 g2 (Start_cat g1 g2) ([inl (Transf1_cat_nt g1 g2 (start_symbol g1))]++[inl (Transf2_cat_nt g1 g2 (start_symbol g2))])
| Lift1_cat: forall nt s,
             rules g1 nt s ->
             g_cat_rules g1 g2 (Transf1_cat_nt g1 g2 nt) (map (g_cat_sf_lift1 g1 g2) s)
| Lift2_cat: forall nt s,
             rules g2 nt s ->
             g_cat_rules g1 g2 (Transf2_cat_nt g1 g2 nt) (map (g_cat_sf_lift2 g1 g2) s).

Definition g_cat (g1 g2: cfg): cfg := {|
non_terminal:= g_cat_nt g1 g2;
terminal:= g_cat_t g1 g2;
start_symbol:= Start_cat g1 g2;
rules:= g_cat_rules g1 g2
|}.

Lemma derives_add_cat_left (g1 g2: cfg)(s s': sf g1):
derives g1 s s' -> derives (g_cat g1 g2) (map (g_cat_sf_lift1 g1 g2) s) (map (g_cat_sf_lift1 g1 g2) s').
Proof.
intro H.
induction H as [| x y z left right H1 H2 H3].
apply derives_refl.
rewrite map_app.
rewrite map_app.
rewrite map_app in H2.
simpl in H2.
apply derives_step with (left:=(Transf1_cat_nt g1 g2 left)).
exact H2.
simpl.
apply Lift1_cat.
apply H3.
Qed.

Lemma derives_add_cat_right (g1 g2: cfg)(s s': sf g2):
derives g2 s s' -> derives (g_cat g1 g2) (map (g_cat_sf_lift2 g1 g2) s) (map (g_cat_sf_lift2 g1 g2) s').
Proof.
intro H.
induction H as [| x y z left right H1 H2 H3].
apply derives_refl.
rewrite map_app.
rewrite map_app.
rewrite map_app in H2.
simpl in H2.
apply derives_step with (left:=(Transf2_cat_nt g1 g2 left)).
exact H2.
simpl.
apply Lift2_cat.
apply H3.
Qed.

Lemma g_cat_correct_aux (g1 g2: cfg)(s11 s12: sf g1)(s21 s22: sf g2):
derives g1 s11 s12 /\ derives g2 s21 s22 ->
derives (g_cat g1 g2)
        ((map (g_cat_sf_lift1 g1 g2) s11)++(map (g_cat_sf_lift2 g1 g2) s21))
        ((map (g_cat_sf_lift1 g1 g2) s12)++(map (g_cat_sf_lift2 g1 g2) s22)).
Proof.
intros [H1 H2].
induction H1, H2.
apply derives_refl.
rewrite map_app.
rewrite map_app.
apply derives_trans with (s2:=
  (map (g_cat_sf_lift1 g1 g2) s ++
   map (g_cat_sf_lift2 g1 g2) (s2 ++ [inl left] ++ s3))).
apply derives_context_free_add_left.
apply derives_add_cat_right.
simpl.
exact H2.
apply derives_context_free_add_left.
rewrite map_app.
rewrite map_app.
simpl.
apply derives_step with (left:=(Transf2_cat_nt g1 g2 left)).
apply derives_refl.
simpl.
apply Lift2_cat.
exact H.
apply derives_context_free_add_right.
apply derives_add_cat_left.
apply derives_step with (left:=left).
exact H1.
exact H.
rewrite map_app.
rewrite map_app.
rewrite <- app_assoc.
rewrite <- app_assoc.
rewrite map_app.
rewrite map_app.
rewrite map_app in IHderives.
rewrite map_app in IHderives.
rewrite <- app_assoc in IHderives.
simpl in IHderives.
rewrite map_app in IHderives.
remember ((map (g_cat_sf_lift1 g1 g2) s1 ++
           map (g_cat_sf_lift2 g1 g2) s0)) as w1.
remember (map (g_cat_sf_lift1 g1 g2) s3 ++
          map (g_cat_sf_lift2 g1 g2) s4 ++
          map (g_cat_sf_lift2 g1 g2) right0 ++
          map (g_cat_sf_lift2 g1 g2) s5) as w2.
apply derives_step with (left:=(Transf1_cat_nt g1 g2 left)).
exact IHderives.
simpl.
apply Lift1_cat.
exact H.
Qed.

Theorem g_cat_correct (g1 g2: cfg)(s1: sf g1)(s2: sf g2):
generates g1 s1 /\ generates g2 s2 ->
generates (g_cat g1 g2)
          ((map (g_cat_sf_lift1 g1 g2) s1)++(map (g_cat_sf_lift2 g1 g2) s2)).
Proof.
unfold generates.
intros H.
destruct H as [H1 H2].
apply derives_trans with (s2:=(map (g_cat_sf_lift1 g1 g2) [(inl (start_symbol g1))]++map (g_cat_sf_lift2 g1 g2) [(inl (start_symbol g2))])).
match goal with
| |- derives _ ?s1 ?s2 =>
     change s1 with ([] ++ s1);
     change s2 with ([] ++ s2 ++ [])
end.
apply derives_step with (left:=(start_symbol (g_cat g1 g2))).
apply derives_refl.
simpl.
apply New_cat.
apply g_cat_correct_aux.
split.
exact H1.
exact H2.
Qed.

Theorem g_cat_correct_inv (g1 g2: cfg)(s: sf (g_cat g1 g2)):
generates (g_cat g1 g2) s ->
s = [inl (start_symbol (g_cat g1 g2))] \/
exists s1: sf g1,
exists s2: sf g2,
s =(map (g_cat_sf_lift1 g1 g2) s1)++(map (g_cat_sf_lift2 g1 g2) s2) /\
generates g1 s1 /\
generates g2 s2.
Proof.
unfold generates.
remember ([inl (start_symbol (g_cat g1 g2))]) as init.
intros H.
induction H.
- left. reflexivity.
- subst.
  specialize (IHderives eq_refl).
  destruct IHderives.
  + (* IHderives, first case *)
    (* A primeira cadeia gerada é a raiz da gramática *)
    destruct s2.
    * (* Se s2 é vazio, a primeira regra está sendo aplicada *)
      simpl in H1. inversion H1. subst. clear H1.
      simpl in H0. inversion H0. clear H0 H2.
      simpl in *.
      right.
      exists [inl (start_symbol g1)], [inl (start_symbol g2)]. {
      split.
        - simpl. reflexivity.
        - split. apply derives_refl. apply derives_refl. }
    * (* Se s2 não é vazio, temos uma contradição *)
      simpl in H1. {
      destruct s2.
      - simpl in *. inversion H1.
      - simpl in *. inversion H1. }
  + (* IHderives, second case *)
    (* A primeira cadeia gerada é a concatenação de map x com map x0 *)
    destruct H1 as (? & ? & ? & ? & ?).
    (* Análise da regra usada *)
    inversion H0.
    subst.
    clear H0.
    * (* Case 1: rule New_cat *)
      (* Contradiction: H1 cannot contain Start_cat *)
      assert (IN : In (inl (Start_cat g1 g2)) (map (g_cat_sf_lift1 g1 g2) x ++ map (g_cat_sf_lift2 g1 g2) x0)).
      { rewrite <- H1.
        rewrite in_app_iff. right. simpl. left. reflexivity. }
      rewrite in_app_iff in IN.
      (* Start_cat is in x or x0 *) {
      destruct IN.
      - (* Start_cat is in x, contradiction *)
        rewrite in_map_iff in H0. destruct H0 as (? & ? & ?).
        (* But Start_cat = lift x1 and x cannot contain x1 *)
        destruct x1.
        + simpl in H0. inversion H0.
        + simpl in H0. inversion H0.
      - (* Start_cat is in x0, contradiction *)
        rewrite in_map_iff in H0. destruct H0 as (? & ? & ?).
        destruct x1.
        + simpl in H0. inversion H0.
        + simpl in H0. inversion H0. }
    * (* Case 2: rule Lift1_cat *)
      (* A rule of g1 has been used *)
      subst.
      (* Consider both situations in H1 *)
      assert (IN : In (inl (Transf1_cat_nt g1 g2 nt)) (map (g_cat_sf_lift1 g1 g2) x ++ map (g_cat_sf_lift2 g1 g2) x0)).
      { rewrite <- H1.
        rewrite in_app_iff. right. simpl. left. reflexivity. }
      rewrite in_app_iff in IN.
      (* Transf1_cat_nt is in x or x0 *) {
      destruct IN.
      - (* Transf1_cat_nt is in x, ok *)
        apply equal_app in H1.
        destruct H1.
        + destruct H1 as [l [H1 H6]].
          right. {
          destruct l.
          * destruct x0.
            - simpl in H6.
              inversion H6.
            - simpl in H6.
              inversion H6.
              destruct s0.
              + inversion H8.
              + inversion H8.
          * inversion H6.
            subst.
            clear H6. {
            apply derives_step with (right:=(map (g_cat_sf_lift1 g1 g2) s)) in H.
            - symmetry in H1.
              apply map_expand in H1.
              destruct H1 as [s1' [s2' [H6 [H7 H8]]]].
              replace (inl (Transf1_cat_nt g1 g2 nt) :: l) with ([inl (Transf1_cat_nt g1 g2 nt)]++l) in H8.
              + symmetry in H8.
                apply map_expand in H8.
                destruct H8 as [s1'' [s2'' [H9 [H10 H11]]]].
                exists (s1'++s++s2''), x0.
                split.
                * repeat rewrite map_app.
                  subst.
                  repeat rewrite <- app_assoc.
                  reflexivity.
                * { split.
                    - subst.
                      destruct s1''.
                      + simpl in H10.
                        inversion H10.
                      + inversion H10.
                        destruct s0.
                        * inversion H6.
                          apply map_eq_nil in H7.
                          subst. {
                          apply derives_step with (right:= s) in H2.
                          - exact H2.
                          - exact H4. }
                        * inversion H6.
                    - exact H3. }
              + simpl.
                reflexivity.
            - exact H0. } }
        + destruct H1 as [l [H1 H6]].
          assert (IN: In (inl (Transf1_cat_nt g1 g2 nt)) (map (g_cat_sf_lift2 g1 g2) x0)).
          { rewrite H6. apply in_app_iff. right. simpl. left. reflexivity. }
          apply in_map_iff in IN.
          destruct IN.
          destruct H7.
          destruct x1.
          inversion H7.
          inversion H7.
      - (* Transf1_cat_nt is in x0, contradiction *)
        rewrite in_map_iff in H5.
        destruct H5.
        destruct H5.
        destruct x1.
        + inversion H5.
        + inversion H5. }
    * (* Case 3: rule Lift2_cat *)
      (* A rule of g2 has been used *)
      subst.
      (* Consider both situations in H1 *)
      assert (IN : In (inl (Transf2_cat_nt g1 g2 nt)) (map (g_cat_sf_lift1 g1 g2) x ++ map (g_cat_sf_lift2 g1 g2) x0)).
      { rewrite <- H1.
        rewrite in_app_iff. right. simpl. left. reflexivity. }
      rewrite in_app_iff in IN.
      (* Transf2_cat_nt is in x or x0 *) {
      destruct IN.
      - (* Transf2_cat_nt is in x, contradiction *)
        rewrite in_map_iff in H5.
        destruct H5.
        destruct H5.
        destruct x1.
        + inversion H5.
        + inversion H5.
      - (* Transf2_cat_nt is in x0, ok *)
        apply equal_app in H1.
        destruct H1.
        + destruct H1 as [l [H1 H6]].
          right. {
          destruct l.
          * destruct x0.
            - simpl in H6.
              inversion H6.
            - simpl in H6.
              inversion H6.
              rewrite app_nil_r in H1.
              subst.
              exists x.
              exists (s++x0).
              split.
              rewrite map_app.
              reflexivity.
              split.
              exact H2.
              inversion H6.
              destruct s0.
              + simpl in H7.
                inversion H7.
                subst.
                rewrite <- app_nil_l in H3. {
                apply derives_step with (right:=s) in H3.
                * exact H3.
                * exact H4. }
              + inversion H7.
          * inversion H6.
            subst.
            clear H6.
            assert (IN : In (inl (Transf2_cat_nt g1 g2 nt)) (map (g_cat_sf_lift1 g1 g2) x)).
            { rewrite H1. rewrite in_app_iff. right. simpl. left. reflexivity. }
            rewrite in_map_iff in IN.
            destruct IN as [x0' [H6 H7]]. {
            destruct x0'.
            - simpl in H6.
              inversion H6.
            - inversion H6. } }
        + destruct H1 as [l [H7 H8]].
          subst.
          symmetry in H8.
          apply map_expand in H8.
          destruct H8 as [ s1' [s2' [H10 [H11 H12]]]].
          subst.
          destruct s2'.
          * inversion H12.
          * inversion H12.
            subst.
            right.
            exists x.
            exists (s1'++s++s2').
            split.
            rewrite <- app_assoc.
            repeat rewrite map_app.
            reflexivity.
            split.
            exact H2. {
            destruct s0.
            - inversion H6.
              subst.
              apply derives_step with (right:=s) in H3.
              exact H3.
              exact H4.
            - inversion H6. } }
Qed.

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

Inductive g_clo_t (g: cfg): Type:=
| Transf_clo_t: terminal g -> g_clo_t g.

Inductive g_clo_nt (g: cfg): Type :=
| Start_clo : g_clo_nt g
| Transf_clo_nt : non_terminal g -> g_clo_nt g.

Definition g_clo_sf_lift (g: cfg)(c: non_terminal g + terminal g): g_clo_nt g + g_clo_t g:=
  match c with
  | inl nt => inl (Transf_clo_nt g nt)
  | inr t  => inr (Transf_clo_t g t)
  end.

Inductive g_clo_rules (g: cfg): g_clo_nt g -> list (g_clo_nt g + g_clo_t g) -> Prop :=
| New1_clo: g_clo_rules g (Start_clo g) ([inl (Start_clo g)]++[inl (Transf_clo_nt g (start_symbol g))])
| New2_clo: g_clo_rules g (Start_clo g) []
| Lift_clo: forall nt s,
            rules g nt s ->
            g_clo_rules g (Transf_clo_nt g nt) (map (g_clo_sf_lift g) s).

Definition g_clo (g: cfg): cfg := {|
non_terminal:= g_clo_nt g;
terminal:= g_clo_t g;
start_symbol:= Start_clo g;
rules:= g_clo_rules g
|}.

Theorem derives_add_clo (g: cfg) (s1 s2: sf g):
derives g s1 s2 -> derives (g_clo g) (map (g_clo_sf_lift g) s1) (map (g_clo_sf_lift g) s2).
Proof.
intro H.
induction H.
apply derives_refl.
rewrite map_app.
rewrite map_app.
rewrite map_app in IHderives.
simpl in IHderives.
apply derives_step with (g := g_clo g) (left:=(Transf_clo_nt g left)).
exact IHderives.
simpl.
apply Lift_clo.
exact H0.
Qed.

Theorem g_clo_correct (g: cfg)(s: sf g)(s': sf (g_clo g)):
generates (g_clo g) nil /\
(generates (g_clo g) s' /\ generates g s -> generates (g_clo g) (s'++ (map (g_clo_sf_lift g)) s)).
Proof.
unfold generates.
split.
simpl.
rewrite <- app_nil_l.
rewrite <- app_nil_r.
rewrite <- app_assoc.
apply derives_step with (left:=Start_clo g).
rewrite app_nil_l.
apply derives_refl.
simpl.
apply New2_clo.
intros [H1 H2].
apply derives_trans with (s2:=[inl (Start_clo g)]++(map (g_clo_sf_lift g) [inl (start_symbol g)])).
simpl.
apply (derives_direct (g_clo g) (Start_clo g) ([inl (Start_clo g); inl (Transf_clo_nt g (start_symbol g))])).
simpl.
apply New1_clo.
apply derives_add_clo in H2.
apply derives_combine with (g:= (g_clo g)).
split.
exact H1.
exact H2.
Qed.

Theorem g_clo_correct_inv (g: cfg)(s: sf (g_clo g)):
generates (g_clo g) s ->
(s=[]) \/
(s=[inl (start_symbol (g_clo g))]) \/
(exists s': sf (g_clo g),
 exists s'': sf g,
 generates (g_clo g) s' /\ generates g s'' /\ s=s'++map (g_clo_sf_lift g) s'').
Proof.
unfold generates.
remember ([inl (start_symbol (g_clo g))]) as init.
intro H.
induction H.
- right.
  left.
  reflexivity.
- subst.
  specialize (IHderives eq_refl).
  destruct IHderives.
  + destruct s2.
    * inversion H1.
    * inversion H1.
  + destruct H1.
    * { destruct s2.
        - inversion H1.
          subst.
          inversion H0.
          + simpl in *.
            right.
            right.
            exists [inl (Start_clo g)].
            exists [inl (start_symbol g)].
            split.
            apply derives_refl.
            split.
            apply derives_refl.
            simpl.
            reflexivity.
          + left.
            trivial.
        - right.
          right.
          inversion H1.
          destruct s2.
          + inversion H4.
          + inversion H4.  }
    * destruct H1 as [s' [s'' [H2 [H3 H4]]]]. {
      inversion H0.
      - (* First case, rule New1_clo *)
        subst. simpl in *.
        assert (IN : In (inl (Start_clo g)) (s'++map (g_clo_sf_lift g) s'')).
        { simpl in *. rewrite <- H4. apply in_app_iff. right. simpl. left. reflexivity. }
        apply in_app_iff in IN.
        destruct IN.
        + (* Start_clo is in s', ok *)
          apply equal_app in H4. {
          destruct H4.
          * destruct H4 as [l [H5 H6]].
            destruct l.
            - simpl in H6.
              rewrite cons_app in H6.
              apply map_expand in H6.
              destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
              subst.
              destruct s1'.
              + inversion H8.
              + inversion H8. {
                destruct s.
                * inversion H5.
                * inversion H5. }
            - right.
              right.
              inversion H6.
              subst.
              exists (s2++inl (Start_clo g)::inl (Transf_clo_nt g (start_symbol g))::l).
              exists s''.
              split.
              + { apply derives_step with (right:=[@inl (non_terminal (g_clo g))(terminal (g_clo g)) (Start_clo g); @inl (non_terminal (g_clo g))(terminal (g_clo g)) (Transf_clo_nt g (start_symbol g))]) in H2.
                  * exact H2.
                  * exact H0. }
              + { split.
                  * exact H3.
                  * rewrite <- app_assoc.
                    simpl.
                    reflexivity. }
          * destruct H4 as [l [H5 H6]].
            symmetry in H6.
            apply map_expand in H6.
            destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
            destruct s2'.
            - inversion H9.
            - inversion H9.
              destruct s.
              + inversion H6.
              + inversion H6. }
        + (* Start_clo is in s'', contradiction *)
          rewrite in_map_iff in H1.
          destruct H1 as [x [H5 H6]].
          destruct x.
          * inversion H5.
          * inversion H5.
      - (* Second case, rule New2_clo *)
        simpl in *.
        subst.
        assert (IN: In (inl (Start_clo g)) (s' ++ map (g_clo_sf_lift g) s'')).
        { simpl in *. rewrite <- H4. rewrite in_app_iff. right. simpl. left. reflexivity. }
        apply in_app_iff in IN.
        destruct IN.
        + (* Start_clo is in s', ok *)
          right.
          right.
          apply equal_app in H4.
          destruct H4.
          * destruct H4 as [l [H5 H6]]. {
            destruct l.
            - simpl in H6.
              rewrite cons_app in H6.
              apply map_expand in H6.
              destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
              destruct s1'.
              + inversion H8.
              + simpl in H8.
                inversion H8.
                destruct s.
                * inversion H6.
                * inversion H6.
            - inversion H6.
              subst.
              exists (s2++l).
              exists s''.
              split.
              + replace (s2++l) with (s2++[]++l).
                * { apply derives_step with (left:=(Start_clo g)).
                    - exact H2.
                    - exact H0. }
                * simpl.
                  reflexivity.
              + split.
                * exact H3.
                * rewrite <- app_assoc.
                  reflexivity. }
          * destruct H4 as [l [H5 H6]].
            symmetry in H6.
            apply map_expand in H6.
            destruct H6 as [s1' [s2' [H7 [H8 H9]]]]. {
            destruct s2'.
            - inversion H9.
            - inversion H9.
              destruct s.
              + inversion H6.
              + inversion H6. }
        + (* Start_clo is in s'', contradiction *)
          rewrite in_map_iff in H1.
          destruct H1 as [x [H5 H6]].
          destruct x.
          * inversion H5.
          * inversion H5.
      - (* Third case, rule Lift_clo *)
        right.
        right.
        subst.
        apply equal_app in H4.
        destruct H4.
        + destruct H4 as [l [H5 H6]].
          subst.
          destruct l.
          * simpl in H6.
            rewrite cons_app in H6.
            apply map_expand in H6.
            destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
            subst.
            exists s2.
            exists (s++s2'). {
            split.
            - rewrite app_nil_r in H2.
              exact H2.
            - split.
              + destruct s1'.
                * inversion H8.
                * inversion H8. {
                  destruct s0.
                  - inversion H5.
                    subst.
                    apply map_eq_nil in H6.
                    subst.
                    rewrite <- app_nil_l in H3.
                    apply derives_step with (right:=s) in H3.
                    + exact H3.
                    + exact H1.
                  - inversion H5. }
              + rewrite map_app.
                reflexivity. }
          * inversion H6.
            subst.
            exists (s2 ++ map (g_clo_sf_lift g) s ++ l).
            exists s''. {
            split.
            - apply derives_step with (right:=(map (g_clo_sf_lift g) s)) in H2.
              + exact H2.
              + exact H0.
            - split.
              + exact H3.
              + repeat rewrite <- app_assoc.
                reflexivity. }
        + destruct H4 as [l [H5 H6]].
          subst.
          symmetry in H6.
          apply map_expand in H6.
          destruct H6 as [s1' [s2' [H7 [H8 H9]]]].
          subst.
          rewrite cons_app in H9.
          symmetry in H9.
          apply map_expand in H9.
          destruct H9 as [s1'' [s2'0 [H6 [H7 H8]]]].
          subst.
          exists s'.
          exists (s1'++s++s2'0).
          split.
          * exact H2.
          * { split.
              - destruct s1''.
                + inversion H7.
                + simpl in H7.
                  inversion H7.
                  destruct s0.
                  * inversion H5.
                    subst.
                    apply map_eq_nil in H6.
                    subst. {
                    apply derives_step with (right:=s) in H3.
                    - exact H3.
                    - exact H1. }
                  * inversion H5.
              - rewrite <- app_assoc.
                repeat rewrite map_app.
                reflexivity. } }
Qed.

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

Inductive nt1: Type:= S | X | Y.
Inductive  t1: Type:= a | b | c.
Inductive rs1: nt1 -> list (nt1+t1) -> Prop:=
  r11: rs1 S [inr a;inl S]
| r12: rs1 S [inr b].
Definition g1:= {|
non_terminal:= nt1;
terminal:= t1;
start_symbol:= S;
rules:= rs1
|}.

Lemma generates_g1_b: generates g1 [inr b].
Proof.
unfold generates.
apply derives_direct.
simpl.
apply r12.
Qed.

Lemma generates_g1_aab: generates g1 ([inr a]++[inr a]++[inr b]).
Proof.
unfold generates.
rewrite <- app_nil_l.
rewrite <- app_nil_r.
rewrite <- app_assoc.
rewrite <- app_assoc.
rewrite <- app_assoc.
rewrite <- (app_nil_l [inl (start_symbol g1)]).
rewrite <- (app_nil_r [inl (start_symbol g1)]).
apply derives_step with (left:=S)(s2:=[] ++ [inr a] ++ [inr a]).
rewrite <- app_nil_r.
rewrite <- app_assoc.
rewrite <- app_assoc.
rewrite <- app_assoc.
apply derives_step with (left:=S)(right:=[inr a]++[inl S]).
rewrite app_nil_l.
rewrite app_nil_r.
apply derives_direct.
apply r11.
apply r11.
apply r12.
Qed.

Inductive nt2: Type:= W | Z.
Inductive  t2: Type:= d | e | f.
Inductive rs2: nt2 -> list (nt2+t2) -> Prop:=
  rs21: rs2 W [inr d;inl Z]
| rs22: rs2 W [inr e].
Definition g2:= {|
non_terminal:= nt2;
terminal:= t2;
start_symbol:= W;
rules:= rs2
|}.

Definition g3:= g_uni g1 g2.
Definition g4:= g_cat g1 g2.
Definition g5:= g_clo g1.


(*
  Autor(s):
    Yannick Forster (1)
    Dominik Kirst (1), contributed the code in section Inf
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts.
From Undecidability.Shared Require Import ListAutomation Dec.
Require Import List Lia.
Import ListNotations ListAutomationNotations.

Lemma enumerable_enum {X} {p : X -> Prop} :
  enumerable p <-> list_enumerable p.
Proof.
  split. eapply enumerable_list_enumerable. eapply list_enumerable_enumerable.
Qed.

Hint Extern 4 => match goal with [H : list_enumerator _ ?p |- ?p _ ] => eapply H end : core.

Lemma decider_eq_dec {X} {d} :
  decider d (eq_on X) -> eq_dec X.
Proof.
  intros Hd x y. eapply (decider_dec _ _ _ Hd (x,y)).
Qed.
Local Hint Extern 0 => match goal with [H : decider ?d (eq_on ?X) |- eq_dec ?X ] => exact (decider_eq_dec H) end : typeclass_instances.

Lemma list_enumerator_conj X (p q : X -> Prop) d f g (Hd : decider d (eq_on X)) :
  list_enumerator f p -> list_enumerator g q -> list_enumerator (fun n => [ x | x ∈ cumul f n, x el cumul g n]) (fun x => p x /\ q x).
Proof.
  intros Hf Hg x. split.
  + intros [Hp Hq]. eapply (cumul_spec Hf) in Hp as [m1]. eapply (cumul_spec Hg) in Hq as [m2].
    exists (m1 + m2). in_collect x.
    eapply cum_ge'; eauto. lia.
    eapply cum_ge'; eauto. lia.
  + intros [m].
    inv_collect; eauto.
Qed.

Lemma list_enumerable_conj X (p q : X -> Prop) :
  discrete X -> list_enumerable p -> list_enumerable q -> list_enumerable (fun x => p x /\ q x).
Proof.
  intros [] [] []. eapply ex_intro, @list_enumerator_conj; eauto. Unshelve. 2: eauto.
Qed.

Lemma enumerator_conj X (p q : X -> Prop) d f g :
  decider d (eq_on X) -> enumerator f p -> enumerator g q -> ∑ h, enumerator h (fun x => p x /\ q x).
Proof.
  intros Hd Hf % enumerator_list_enumerator Hg % enumerator_list_enumerator.
  unshelve eapply exist, list_enumerator_enumerator, list_enumerator_conj; eauto.
Qed.

Lemma list_enumerator_disj X (p q : X -> Prop) f g :
  list_enumerator f p -> list_enumerator g q -> list_enumerator (fun n => [ x | x ∈ f n] ++ [ y | y ∈ g n]) (fun x => p x \/ q x).
Proof.
  intros Hf Hg x. split.
  - intros [H1 | H1].
    + eapply Hf in H1 as [m]. exists m. in_app 1. in_collect x. eauto.
    + eapply Hg in H1 as [m]. exists m. in_app 2. in_collect x. eauto.
  - intros [m].
    inv_collect; eauto.
Qed.

Lemma list_enumerable_disj X (p q : X -> Prop) :
  list_enumerable p -> list_enumerable q -> list_enumerable (fun x => p x \/ q x).
Proof.
  intros [] []. eapply ex_intro, @list_enumerator_disj; eauto.
Qed.

Lemma enumerator_disj X (p q : X -> Prop) f g :
  enumerator f p -> enumerator g q -> ∑ h, enumerator h (fun x => p x \/ q x).
Proof.
  intros Hf % enumerator_list_enumerator Hg % enumerator_list_enumerator.
  unshelve eapply exist, list_enumerator_enumerator, list_enumerator_disj; eauto.
Qed.

Lemma enumerable_conj X (p q : X -> Prop) :
  discrete X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros [] [] []. edestruct enumerator_conj as [h Hh]. 4:eapply ex_intro, Hh.
  all: eauto.
Qed.

Lemma enumerable_disj X (p q : X -> Prop) :
  enumerable p -> enumerable q -> enumerable (fun x => p x \/ q x).
Proof.
  intros [] []. edestruct enumerator_disj as [h Hh]. 3:eapply ex_intro, Hh.
  all: eauto.
Qed.

Require Import ConstructiveEpsilon.
From Undecidability Require Import Shared.ListAutomation Shared.mu_nat.

Import ListAutomationNotations.

Definition mu_nat_p := constructive_indefinite_ground_description_nat.

Lemma mu_nat_p_least (P : nat -> Prop) d H : forall m, P m -> m >= proj1_sig (@mu_nat_p P d H).
Proof.
  intros. unfold mu_nat_p, constructive_indefinite_ground_description_nat in *.
  destruct (Compare_dec.le_lt_dec (proj1_sig (linear_search P d 0 (let (n, p) := H in O_witness P n (stop P n p)))) m).
  eassumption. exfalso.
  eapply linear_search_smallest. split. 2:eassumption. eapply le_0_n. eassumption.
Qed.

Opaque mu_nat.

Set Implicit Arguments.
Unset Strict Implicit.
(* ** Definition of infinite and generating types *)

Definition injective X Y (f : X -> Y) :=
  forall x x', f x = f x' -> x = x'.

Definition infinite {X} (p : X -> Prop) :=
  exists (f : nat -> X), injective f /\ forall n, p (f n).

Section Inf.

  Variables (X : Type) (f : nat -> option X).
  Variable p : X -> Prop.
  Hypothesis Hf : forall x, p x <-> exists n, f n = Some x.
  Hypothesis HX : eq_dec X.

  Hypothesis Hg : generative p.

  Instance el_dec :
    forall (A : list X) x, dec (x el A).
  Proof.
    intros A x. induction A; cbn; auto.
  Qed.

  From Coq.Logic Require Import ConstructiveEpsilon.

  Definition le_f x y :=
    exists n, f n = Some x /\ forall n', f n' = Some y -> n <= n'.

  Lemma nxt' (l : list X) :
    { x | ~ x el l /\ (forall y, ~ y el l -> le_f x y) /\ p x}.
  Proof.
    pose (q := fun n => exists x, f n = Some x /\ ~ x el l).
    assert (H1 : forall x, dec (q x)).
    { intros n. unfold q. destruct (f n). 2:firstorder congruence.
      decide (x el l); firstorder congruence. }
    assert (H2 : exists x, q x).
    { destruct (Hg l) as (x & [n Hx1] % Hf & Hx2). exists n. red. eauto. }
    eapply mu_nat_dep_least in H2 as [n Hn].
    destruct (f n) as [x | ] eqn:E.
    - exists x. destruct Hn as (H2 & (x' & H3 & H4) & H5). rewrite E in H3. specialize H3 as [= <-]. split. 2:split.
      + eauto.
      + intros y Hy. exists n. split. eauto. intros. eapply H5. lia. firstorder.
      + eapply Hf. eauto.
    - exfalso. firstorder congruence.
    - eapply H1.
  Qed.

  Definition nxt l :=
    proj1_sig (nxt' l).

  Lemma nxt_spec l :
    ~ nxt l el l.
  Proof.
    unfold nxt. destruct (nxt' l); cbn. apply a.
  Qed.

  Lemma nxt_le_f l :
    forall x, ~ x el l -> le_f (nxt l) x.
  Proof.
    unfold nxt. destruct (nxt' l); cbn. apply a.
  Qed.

  Definition LL := generate nxt.

  Definition F n :=
    nxt (LL n).

  Lemma LL_cum :
    cumulative LL.
  Proof.
    intros n. now exists [(F n)].
  Qed.

  Lemma F_nel n :
    ~ F n el LL n.
  Proof.
    apply nxt_spec.
  Qed.

  Lemma F_el n :
    F n el LL (S n).
  Proof.
    cbn. apply in_app_iff. right. left. reflexivity.
  Qed.

  Lemma F_lt n m :
    n < m -> F n el LL m.
  Proof.
    intros H. apply (cum_ge' (n:=S n)).
    - apply LL_cum.
    - apply F_el.
    - lia.
  Qed.

  Lemma F_inj' n m :
    F n = F m -> ~ n < m.
  Proof.
    intros H1 H2 % F_lt. rewrite H1 in H2. apply (F_nel H2).
  Qed.

  Lemma F_inj :
    injective F.
  Proof.
    intros n m Hnm. destruct (PeanoNat.Nat.lt_total n m) as [H|[H|H] ]; trivial.
    - contradiction (F_inj' Hnm H).
    - symmetry in Hnm. contradiction (F_inj' Hnm H).
  Qed.

  Lemma F_p :
    forall n, p (F n).
  Proof.
    unfold F. unfold nxt. intros.
    destruct nxt' as (? & ? & ? & ?); eassumption.
  Qed.

  (* ** Generating data types are in bijection to nat *)

  Lemma LL_f n x :
    f n = Some x -> x el LL (S n).
  Proof.
    revert x.
    induction n as [n IH] using Wf_nat.lt_wf_ind. intros x He.
    decide _; try eassumption. exfalso.
    assert (H : ~ x el LL n).
    { intros H. apply n0. apply (cum_ge' LL_cum H). auto. }
    apply nxt_le_f in H as [n'[H1 H2] ].
    specialize (H2 n He).
    destruct (PeanoNat.Nat.lt_total n' n) as [H3|[->|H3] ].
    - apply (nxt_spec (l:=LL n)).
      eapply cum_ge'; eauto.
    - apply n0. cbn. apply in_app_iff.
      right. left. congruence.
    - lia.
  Qed.

  Lemma LL_F x n :
    x el LL n -> exists m, F m = x.
  Proof.
    induction n; cbn; auto.
    - intros [H|[H|H]] % in_app_iff; auto.
      now exists n.
  Qed.

  Lemma F_sur :
    forall x, p x -> exists n, F n = x.
  Proof.
    intros x [n H] % Hf.
    destruct (LL_F (LL_f H)) as [m H'].
    exists m. congruence.
  Qed.

  Definition G x (H : p x) : nat := (proj1_sig (mu_nat_p _ (fun n => HX (F n) x) (F_sur H))).

  Lemma FG x (H : p x) :
    F (@G x H) = x.
  Proof.
    unfold G. apply @proj2_sig.
  Qed.

  Lemma GF n H :
    @G (F n) H = n.
  Proof.
    apply F_inj. now rewrite FG.
  Qed.

End Inf.

Lemma generative_enumerable_strong {X} (p : X -> Prop) :
  discrete X -> enumerable p -> generative p -> exists f : nat -> X, (forall n1 n2, f n1 = f n2 -> n1 = n2) /\ forall x, p x <-> exists n, f n = x.
Proof.
  intros [D] % discrete_iff [e He] G.
  unshelve eexists (F He _ _). abstract firstorder.
  split.
  - intros. eapply F_inj; eauto.
  - intros x. split.
    + eapply F_sur.
    + intros [n <-]. eapply F_p.
Qed.

Lemma generative_dedekind_infinite {X} (p : X -> Prop) :
  discrete X -> enumerable p -> generative p -> dedekind_infinite p.
Proof.
  intros H1 H2 H3.
  destruct (generative_enumerable_strong H1 H2 H3) as [f [Hf1 Hf2]].
  exists f. split.
  - eapply Hf2. eauto.
  - eauto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(** Tactics related to subsets and proof irrelevance. *)

Require Import Coq.Program.Utils.
Require Import Coq.Program.Equality.
Require Export ProofIrrelevance.

Local Open Scope program_scope.

(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to
   factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *)

Ltac on_subset_proof_aux tac T :=
  match T with
    | context [ exist ?P _ ?p ] => try on_subset_proof_aux tac P ; tac p
  end.

Ltac on_subset_proof tac :=
  match goal with
    [ |- ?T ] => on_subset_proof_aux tac T
  end.

Ltac abstract_any_hyp H' p :=
  match type of p with
    ?X =>
    match goal with
      | [ H : X |- _ ] => fail 1
      | _ => set (H':=p) ; try (change p with H') ; clearbody H'
    end
  end.

Ltac abstract_subset_proof :=
  on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H).

Ltac abstract_subset_proofs := repeat abstract_subset_proof.

Ltac pi_subset_proof_hyp p :=
  match type of p with
    ?X =>
    match goal with
      | [ H : X |- _ ] =>
        match p with
          | H => fail 2
          | _ => rewrite (proof_irrelevance X p H)
        end
      | _ => fail " No hypothesis with same type "
    end
  end.

Ltac pi_subset_proof := on_subset_proof pi_subset_proof_hyp.

Ltac pi_subset_proofs := repeat pi_subset_proof.

(** The two preceding tactics in sequence. *)

Ltac clear_subset_proofs :=
  abstract_subset_proofs ; simpl in * |- ; pi_subset_proofs ; clear_dups.

Ltac pi := repeat f_equal ; apply proof_irrelevance.

Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m.
Proof.
  destruct n as (x,p).
  destruct m as (x',p').
  simpl.
  split ; intros ; subst.

  inversion H.
  reflexivity.

  pi.
Qed.

(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f]
   in tactics. *)

Definition match_eq (A B : Type) (x : A) (fn : {y : A | y = x} -> B) : B :=
  fn (exist _ x eq_refl).

(* This is what we want to be able to do: replace the originally matched object by a new,
   propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *)

Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B)
  (y : {y:A | y = x}),
  match_eq A B x fn = fn y.
Proof.
  intros.
  unfold match_eq.
  f_equal.
  destruct y.
  (* uses proof-irrelevance *)
  apply <- subset_eq.
  symmetry. assumption.
Qed.

(** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary
   equality [t = u], and [u] is now the subject of the [match]. *)

Ltac rewrite_match_eq H :=
  match goal with
    [ |- ?T ] =>
    match T with
      context [ match_eq ?A ?B ?t ?f ] =>
      rewrite (match_eq_rewrite A B t f (exist _ _ (eq_sym H)))
    end
  end.

(** Otherwise we can simply unfold [match_eq] and the term trivially reduces to the original definition. *)

Ltac simpl_match_eq := unfold match_eq ; simpl.