(** * RIS.regexp : regular expressions and the free Kleene algebra. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import tools algebra language.
Require Import Bool.
Section regexp.
  Context {X : Set}.
  (** * Definitions *)
  (** Regular expressions are terms generated by the following syntax. *)
  Inductive regexp : Set :=
  | e_zero : regexp
  | e_un : regexp
  | e_add : regexp -> regexp -> regexp
  | e_prod : regexp -> regexp -> regexp
  | e_star : regexp -> regexp
  | atomic : X -> regexp.

  Notation " ⟪ l ⟫" := (atomic l).

  (** The size of an expression is the number of occurrences of variables appearing in it. *)
  Fixpoint sizeExpr e :=
    match e with
    | e_un | e_zero => 0
    | ⟪_⟫ => 1
    | e_add e f | e_prod e f => sizeExpr e + sizeExpr f
    | e_star e => sizeExpr e
    end.

  (** We may associate to an expression [e] the regular language [⟦e⟧]. *)
  Reserved Notation " ⟦ e ⟧ ".
  Fixpoint reg_lang (e : regexp) : language :=
    match e with
    | e_un => 𝟭
    | e_zero => 𝟬
    | e_prod e f => ⟦e⟧ · ⟦f⟧
    | e_add e f => ⟦e⟧ ∪ ⟦f⟧
    | e_star e => ⟦e⟧ ⋆
    | ⟪ l ⟫ => fun w => w = [l]
    end
  where " ⟦ e ⟧ " := (reg_lang e).

  (* begin hide *)
  Global Instance regUn : Un regexp := e_un.

  Global Instance regZero : Zero regexp :=e_zero.

  Global Instance regJoin : Join regexp := e_add.

  Global Instance regProduct : Product regexp :=e_prod.

  Global Instance regStar : Star regexp := e_star.
  (* end hide *)

  (** Given a set of identities [Ax] (i.e. a binary relation over
  expressions) and a set of quasi-equations [Ax'] (i.e. a quaternary
  relation), we define the relation [{| Ax , Ax' |} ⊢ e == f] as the
  smallest congruence stable by both [Ax] and [Ax']. *)
  Reserved Notation " {| Ax , Ax' |} ⊢ e == f " (at level 80).
  Inductive ax_eq (Ax : relation regexp) (Ax' : regexp -> regexp -> regexp -> regexp -> Prop)
    : relation regexp :=
  | ax_eq_refl e : {|Ax,Ax'|} ⊢ e == e
  | ax_eq_sym e f : {|Ax,Ax'|} ⊢ e == f -> {|Ax,Ax'|} ⊢ f == e
  | ax_eq_trans e f g : {|Ax,Ax'|} ⊢ e == f -> {|Ax,Ax'|} ⊢ f == g -> {|Ax,Ax'|} ⊢ e == g
  | ax_eq_prod e f e' f' : {|Ax,Ax'|} ⊢ e == f -> {|Ax,Ax'|} ⊢ e' == f' -> {|Ax,Ax'|} ⊢ e · e' == f · f'
  | ax_eq_add e f e' f' : {|Ax,Ax'|} ⊢ e == f -> {|Ax,Ax'|} ⊢ e' == f' -> {|Ax,Ax'|} ⊢ e ∪ e' == f ∪ f'
  | ax_eq_star e f : {|Ax,Ax'|} ⊢ e == f -> {|Ax,Ax'|} ⊢ e ⋆ == f ⋆
  | ax_eq_ax e f : Ax e f -> {|Ax,Ax'|} ⊢ e == f
  | ax_eq_ax' e f g h : Ax' e f g h -> {|Ax,Ax'|} ⊢ e == f -> {|Ax,Ax'|} ⊢ g == h
  where " {| Ax , Ax' |} ⊢ e == f " := (ax_eq Ax Ax' e f).

  Notation ax_inf Ax Ax' := (leqA (ax_eq Ax Ax')).
  Notation " {| Ax , Ax' |} ⊢ e =<= f " := (ax_inf Ax Ax' e f) (at level 80).

  Hint Constructors ax_eq.

  (** * Basic properties *)
  (** ** Properties of the language interpretation *)
  Lemma Σ_lang L u : ⟦Σ L⟧ u <-> exists e, e ∈ L /\ ⟦e⟧ u.
  Proof.
    revert u;induction L;intros;simpl.
    - split;[intro F;exfalso;apply F|intros (?&?&_);tauto].
    - split.
      + intros [I|I].
        * exists a;tauto.
        * apply IHL in I as (e&Ie&Iu);exists e;tauto.
      + intros (e&[<-|Ie]&Iu);[left|right;apply IHL;exists e];tauto.
  Qed.

  Lemma split_star e u v :
    ⟦e⋆⟧ (u++v) ->
    (u=[] /\ v=[])
    \/ exists u1 u2 v1 v2, u = u1++u2 /\ v=v1++v2 /\ ⟦e⋆⟧ u1 /\ ⟦e⟧ (u2++v1) /\ ⟦e⋆⟧ v2.
  Proof.
    intros (n&In);revert u v In;induction n;intros u v;simpl.
    - intro E;apply app_eq_nil in E as (->&->);tauto.
    - intros (w1&w2&E&I1&I2);right.
      levi E;subst;clear E.
      + exists [],w1,[],w2;repeat split.
        * exists 0;reflexivity.
        * rewrite app_nil_r;assumption.
        * exists n;assumption.
      + apply (IHn (a::w) v) in I2 as [(F&_)|(u1&u2&v1&v2&E1&->&h1&h2&h3)];
          [discriminate|].
        replace (cons a) with (app [a]) in * by reflexivity.
        rewrite E1 in *;clear E1 a w.
        exists (w1++u1),u2,v1,v2;rewrite app_ass;repeat split;try assumption.
        destruct h1 as (N&I).
        exists (S N),w1,u1;tauto.
      + clear IHn.
        exists [],u,(a::w),w2;repeat split.
        * exists 0;reflexivity.
        * assumption.
        * exists n;assumption.
  Qed.

  (** ** Properties of the axiomatic equivalence *)
  Global Instance ax_eq_Equivalence Ax Ax' : Equivalence (ax_eq Ax Ax').
  Proof.
    split.
    - intro e;auto.
    - intros e f;eauto.
    - intros e f g E1 E2;eauto.
  Qed.

  Global Instance prod_ax_eq Ax Ax' :
    Proper (ax_eq Ax Ax' ==> ax_eq Ax Ax' ==> ax_eq Ax Ax') prod.
  Proof. intros ? ? ? ? ? ?;eauto. Qed.

  Global Instance join_ax_eq Ax Ax' :
    Proper (ax_eq Ax Ax' ==> ax_eq Ax Ax' ==> ax_eq Ax Ax') join.
  Proof. intros ? ? ? ? ? ?;eauto. Qed.

  Global Instance star_ax_eq Ax Ax':
    Proper (ax_eq Ax Ax'==> ax_eq Ax Ax') star.
  Proof. intros ? ? ?;eauto. Qed.

  Global Instance subrelation_Ax Ax Ax' : subrelation Ax (ax_eq Ax Ax').
  Proof. intro;intros;eauto. Qed.

  (** If the axioms [Ax,Ax'] are sound with respect to the language
  interpretation, so is the relation [{|Ax,Ax'|}⊢_==_]. *)
  Remark soundness_proof (Ax: relation regexp)(Ax' : regexp -> regexp -> regexp -> regexp -> Prop):
    (forall e f, Ax e f -> ⟦e⟧ ≃ ⟦f⟧) ->
    (forall e f g h, Ax' e f g h -> ⟦e⟧ ≃ ⟦f⟧ -> ⟦g⟧ ≃ ⟦h⟧) ->
    forall e f, {|Ax,Ax'|} ⊢ e == f -> ⟦e⟧ ≃ ⟦f⟧.
  Proof.
    intros hyp1 hyp2 e f E;induction E.
    - reflexivity.
    - symmetry;assumption.
    - etransitivity;eassumption.
    - simpl;rewrite IHE1,IHE2;reflexivity.
    - simpl;rewrite IHE1,IHE2;reflexivity.
    - simpl;rewrite IHE;reflexivity.
    - apply hyp1;assumption.
    - eapply hyp2;eassumption.
  Qed.

  Section gen_proofs.
    Context {Ax : relation regexp}{Ax' : regexp -> regexp -> regexp -> regexp -> Prop}.

    (** A set of axioms is good enough if it entails that [∪] is
    idempotent, associative and commutative. *)
    Class GoodEnoughAxiom Ax :=
      {join_idem : forall e, Ax (e ∪ e) e;
       join_assoc : forall e f g, Ax (e ∪ (f ∪ g)) ((e ∪ f) ∪ g);
       join_comm : forall e f, Ax (e ∪ f) (f ∪ e)}.

    Context {G : GoodEnoughAxiom Ax}.

    (** In this case, we have a semi-lattice structure. *)
    Global Instance Semilattice_ax : Semilattice _ (ax_eq Ax Ax') join.
    Proof.
      split.
      - intros e e' Ee f f' Ef;eauto.
      - intros e f g;apply ax_eq_ax,join_assoc.
      - intros e f;apply ax_eq_ax,join_comm.
      - intro e;apply ax_eq_ax,join_idem.
    Qed.

    Lemma ax_eq_inf e f : {| Ax,Ax'|} ⊢ e == f -> {| Ax,Ax'|} ⊢ e =<= f.
    Proof. intros E;apply partialA in E;apply E. Qed.

    (** [Ax] is very good if in addition it entails distributivity of
    [·] over [∪]. *)
    Class VeryGoodAxioms Ax :=
      {left_distr : forall e f g, Ax (e · (f ∪ g))  (e·f ∪ e·g);
       right_distr : forall e f g, Ax ((e ∪ f)· g) (e·g ∪ f·g)}.

    Context {V : VeryGoodAxioms Ax}.

    (** In this case, the product preserves the ordering. *)
    Global Instance prod_ax_inf :
      Proper (ax_inf Ax Ax' ==> ax_inf Ax Ax' ==> ax_inf Ax Ax') prod.
    Proof.
      destruct V as (h1&h2);destruct G as [h3 h4 h5];intros e1 e2 E1 f1 f2 E2;
        unfold ax_inf,leqA in *.
      rewrite E2 at 1.
      transitivity (e2 · f1 ∪ e2 · f2);[now auto|].
      rewrite E1 at 1.
      transitivity ((e1 · f1 ∪ e2 · f1) ∪ e2 · f2);[now auto|].
      transitivity (e1 · f1 ∪ (e2 · f1 ∪ e2 · f2));[now auto|].
      transitivity (e1 · f1 ∪ e2 · (f1 ∪ f2));[now auto|].
      rewrite <- E2;reflexivity.
    Qed.

  End gen_proofs.

  (** * The axiomatization [KA]. *)
  Reserved Notation " e =KA f " (at level 80).
  Reserved Notation " e <=KA f " (at level 80).

  Inductive KA : relation regexp :=
  | KA_prod_assoc e f g : e · (f · g) =KA (e · f) · g
  | KA_add_assoc e f g : e ∪ (f ∪ g) =KA (e ∪ f) ∪ g
  | KA_add_comm e f : e ∪ f =KA f ∪ e
  | KA_left_distr e f g : e · (f ∪ g) =KA e·f ∪ e·g
  | KA_right_distr e f g : (e ∪ f)· g =KA e·g ∪ f·g
  | KA_zero e : 𝟬 ∪ e =KA e
  | KA_un_left e : 𝟭 · e =KA e
  | KA_un_right e : e · 𝟭 =KA e
  | KA_left_zero e : 𝟬 · e =KA 𝟬
  | KA_right_zero e : e · 𝟬 =KA 𝟬
  | KA_idem e : e ∪ e =KA e
  | KA_star_unfold e :  e⋆ =KA 𝟭 ∪ e · e ⋆ ∪  e⋆
  where " e =KA f " := (KA e f).

  Hint Constructors KA.

  Inductive KA' : regexp -> regexp -> regexp -> regexp -> Prop :=
  | KA_star_left_ind e f : KA' f (e · f ∪ f) f (e ⋆ · f ∪ f)
  | KA_star_right_ind e f : KA' e (e · f ∪ e) e (e · f ⋆ ∪ e).

  Hint Constructors KA'.

  Global Instance goodKA : GoodEnoughAxiom KA.
  Proof. split;intros;auto. Qed.
  Global Instance verygoodKA : VeryGoodAxioms KA.
  Proof. split;intros;auto. Qed.

  Lemma star_left_ind e f : {| KA,KA'|} ⊢ e · f =<= f -> {| KA,KA'|} ⊢ e⋆ · f =<= f.
  Proof.
    intro h;eapply ax_eq_ax'.
    - apply KA_star_left_ind.
    - apply h.
  Qed.
  Lemma star_right_ind e f : {| KA,KA'|} ⊢ e · f =<= e -> {| KA,KA'|} ⊢ e · f⋆ =<= e.
  Proof.
    intro h;eapply ax_eq_ax'.
    - apply KA_star_right_ind.
    - apply h.
  Qed.

  (** The set of expressions equipped with the axioms [KA,KA'] forms a Kleene algebra. *)
  Global Instance KA_regexp : KleeneAlgebra regexp (ax_eq KA KA').
  Proof.
    split.
    - apply star_ax_eq.
    - repeat split;try (typeclasses eauto);intro;intros;eauto.
    - repeat split;intro;intros;eauto.
    - intros a;apply ax_eq_ax;auto.
    - apply star_left_ind.
    - apply star_right_ind.
  Qed.
  Global Instance Semilattice_KA : Semilattice _ (ax_eq KA KA') join := join_semilattice.

  (** Axiomatic equivalence is sound with respect to the language interpretation. *)
  Proposition soundness e f : {|KA,KA'|} ⊢ e == f -> ⟦e⟧ ≃ ⟦f⟧.
  Proof.
    apply soundness_proof;clear.
    - intros e f E;destruct E;simpl;try now apply lang_KA.
      + apply mon_assoc.
      + apply mon_assoc.
      + apply semiring_comm.
    - intros e f g h E;destruct E;intro E;simpl in *.
      + apply ka_star_left_ind,E.
      + apply ka_star_right_ind,E.
  Qed.

  Lemma ax_inf_lang_incl e f : {| KA,KA' |} ⊢ e =<= f -> ⟦e⟧ ≲ ⟦f⟧.
  Proof.
    intro E;apply joinOrderLang.
    apply soundness in E;apply E.
  Qed.

  (** * Equatity modulo associativity, commutativity, idempotence and units. *)
  Inductive ACI0 : relation regexp :=
  | ACI0_prod_assoc e f g : ACI0(e · (f · g)) ((e · f) · g)
  | ACI0_add_assoc e f g : ACI0 (e ∪ (f ∪ g)) ((e ∪ f) ∪ g)
  | ACI0_add_comm e f : ACI0 (e ∪ f) (f ∪ e)
  | ACI0_add_idem e : ACI0 (e ∪ e) e
  | ACI0_add_zero e : ACI0 (e ∪ 𝟬) e
  | ACI0_prod_one e : ACI0 (𝟭 · e) e.
  Definition Empt : regexp -> regexp -> regexp -> regexp -> Prop := fun _ _ _ _ => False.
  Hint Constructors ACI0.

  Global Instance goodACI0 : GoodEnoughAxiom ACI0.
  Proof. split;intros;auto. Qed.

  Infix " ≡0 " := (ax_eq ACI0 Empt) (at level 80).
  Infix " ≦0 " := (ax_inf ACI0 Empt) (at level 80).

  Lemma KA_ACI0 e f : e ≡0 f -> {|KA,KA'|}⊢e==f.
  Proof.
    intros E;induction E.
    - reflexivity.
    - symmetry;assumption.
    - etransitivity;eassumption.
    - rewrite IHE1,IHE2;reflexivity.
    - rewrite IHE1,IHE2;reflexivity.
    - rewrite IHE;reflexivity.
    - destruct H;auto.
      transitivity (𝟬∪e);auto.
    - destruct H.
  Qed.

  (** * Utilities *)
  (** ** Variables *)
  (** [Var e] computes the set of variables appearing in [e]. *)
  Fixpoint Var (e : regexp) : list X :=
    match e with
    | e_un | e_zero => []
    | ⟪x⟫ => [x]
    | e_prod e f | e_add e f => Var e ++ Var f
    | e_star e => Var e
    end.

  Lemma Var_spec e w : ⟦ e ⟧ w -> w ⊆ Var e.
  Proof.
    revert w;induction e;intro w;simpl.
    - intro I;exfalso;apply I.
    - intros ->;reflexivity.
    - intros [I|I].
      + rewrite IHe1 by assumption;apply incl_appl;reflexivity.
      + rewrite IHe2 by assumption;apply incl_appr;reflexivity.
    - intros (u&v&->&Iu&Iv).
      apply IHe1 in Iu as ->.
      apply IHe2 in Iv as ->.
      reflexivity.
    - intros (n&I);revert w I;induction n.
      + intros w ->;apply incl_nil.
      + intros w (u&v&->&I1&I2).
        apply IHe in I1 as ->.
        apply IHn in I2 as ->.
        intro;simpl_In;tauto.
    - intros ->;reflexivity.
  Qed.

  (** ** Empty word *)
  (** [ϵ e] yields [𝟭] if [⟦e⟧] contains the empty word, [𝟬] otherwise. *)
  Fixpoint ϵ (e : regexp) : regexp :=
    match e with
    | e_un | e_star _ => e_un
    | e_zero | ⟪_⟫ => e_zero
    | e_prod e f =>
      match (ϵ e,ϵ f) with
      | (e_un,e_un) => e_un
      | _ => e_zero
      end
    | e_add e f =>
      match (ϵ e,ϵ f) with
      | (e_un,_) | (_,e_un) => e_un
      | _ => e_zero
      end
    end.

  Lemma nil_prod_lang (l m : @language X) : (l·m) [] <-> l [] /\ m [].
  Proof.
    split.
    - intros (u&v&e&h);symmetry in e;apply app_eq_nil in e as (->&->);assumption.
    - intros h;exists [],[];split;[reflexivity|assumption].
  Qed.

  Lemma ϵ_zero_or_un e : {ϵ e = e_un} + {ϵ e = e_zero}.
  Proof.
    induction e;simpl;try tauto.
    - destruct IHe1 as [-> | ->] ;[|destruct IHe2 as [-> | ->]];tauto.
    - destruct IHe1 as [-> | ->] ;[destruct IHe2 as [-> | ->]|];tauto.
  Qed.

  Lemma ϵ_spec e : ϵ e = e_un <-> ⟦e⟧ [].
  Proof.
    induction e;simpl.
    - split;[discriminate|intro F;exfalso;apply F].
    - split;reflexivity.
    - destruct (ϵ e1);tauto || destruct (ϵ e2);
        try (split;[discriminate|intros [h|h];apply IHe1 in h||apply IHe2 in h;discriminate]);
        try (split;[intros _;(left;apply IHe1;reflexivity)
                             ||(right;apply IHe2;reflexivity)
                   |reflexivity]).
    - etransitivity;[|symmetry;apply nil_prod_lang].
      rewrite <- IHe1,<-IHe2;clear.
      split.
      + destruct (ϵ e1);tauto || destruct (ϵ e2);discriminate||tauto.
      + intros (-> & ->);reflexivity.
    - split;[|reflexivity].
      intros _;exists 0;reflexivity.
    - split;discriminate.
  Qed.

  Lemma ϵ_inf_e e : {|KA,KA'|} ⊢ ϵ e =<= e.
  Proof.
    induction e;simpl.
    - reflexivity.
    - reflexivity.
    - replace e_add with join by reflexivity.
      transitivity (ϵ e1 ∪ ϵ e2);[clear IHe1 IHe2|rewrite IHe1,IHe2;reflexivity].
      destruct (ϵ_zero_or_un e1) as [-> | ->]; try destruct (ϵ_zero_or_un e2)as [-> | ->];eauto.
      + rewrite (ka_idem _);reflexivity.
      + rewrite KA_add_comm,KA_zero;reflexivity.
      + rewrite KA_zero;reflexivity.
      + rewrite (ka_idem _);reflexivity.
    - replace e_prod with prod by reflexivity.
      transitivity (ϵ e1 · ϵ e2);[clear IHe1 IHe2|rewrite IHe1,IHe2;reflexivity].
      apply ax_eq_inf.
      destruct (ϵ_zero_or_un e1) as [-> | ->]; try destruct (ϵ_zero_or_un e2)as [-> | ->];eauto.
    - apply one_inf_star.
    - replace e_zero with zero by reflexivity;apply zero_minimal.
  Qed.

  (** [ϵ e] is [𝟭] exactly when the inequation [𝟭<=e] is provable in [KA]. *)
  Lemma ϵ_ax_spec e : ϵ e = un <-> {|KA,KA'|} ⊢ un =<= e.
  Proof.
    split.
    - intro E;etransitivity;[|apply ϵ_inf_e].
      rewrite E;reflexivity.
    - intro E;apply ϵ_spec.
      apply (ax_inf_lang_incl E);reflexivity.
  Qed.

  Lemma ϵ_zero e : ϵ e = e_zero <-> ~ ⟦e⟧ [].
  Proof.
    rewrite <- ϵ_spec;destruct (ϵ_zero_or_un e) as [-> | ->].
    - split;[discriminate|tauto].
    - split;[discriminate|reflexivity].
  Qed.

  Remark ϵ_sub_id e : {|KA,KA'|} ⊢ ϵ e =<= 𝟭.
  Proof. destruct (ϵ_zero_or_un e) as [-> | ->];unfold ax_inf,leqA ; now auto. Qed.

  Lemma ϵ_add e f :  {|KA,KA'|} ⊢ ϵ (e ∪ f) == ϵ e ∪ ϵ f.
  Proof.
    simpl;destruct (ϵ_zero_or_un e) as [-> | ->];destruct (ϵ_zero_or_un f) as [-> | ->].
    - now auto.
    - transitivity (𝟬∪𝟭);now auto.
    - now auto.
    - now auto.
  Qed.

  Lemma ϵ_prod e f :  {|KA,KA'|} ⊢ ϵ (e · f) == ϵ e · ϵ f.
  Proof.
    simpl;destruct (ϵ_zero_or_un e) as [-> | ->];destruct (ϵ_zero_or_un f) as [-> | ->];now auto.
  Qed.

  Global Instance ϵ_proper : Proper (ax_eq KA KA' ==> ax_eq KA KA') ϵ.
  Proof.
    intros e f E;induction E;simpl;auto.
    - eauto.
    - revert IHE1 IHE2.
      destruct (ϵ_zero_or_un e)
        as [-> | ->],
           (ϵ_zero_or_un e')
          as [-> | -> ],
             (ϵ_zero_or_un f)
            as [-> | ->],
               (ϵ_zero_or_un f')
              as [-> | ->];auto.
    - revert IHE1 IHE2.
      destruct (ϵ_zero_or_un e)
        as [-> | ->],
           (ϵ_zero_or_un e')
          as [-> | -> ],
             (ϵ_zero_or_un f)
            as [-> | ->],
               (ϵ_zero_or_un f')
              as [-> | ->];auto.
    - destruct H;simpl;try destruct  (ϵ_zero_or_un e) as [-> | ->];
        try destruct  (ϵ_zero_or_un f) as [-> | ->];
        try destruct  (ϵ_zero_or_un g) as [-> | ->];auto.
    - destruct H;revert IHE;simpl;try destruct  (ϵ_zero_or_un e) as [-> | ->];
        try destruct  (ϵ_zero_or_un f) as [-> | ->];auto.
  Qed.

  Global Instance ϵ_proper_inf : Proper (ax_inf KA KA' ==> ax_inf KA KA') ϵ.
  Proof.
    intros e f E.
    apply ϵ_proper in E as ->;simpl.
    unfold ax_inf,leqA;simpl.
    destruct (ϵ_zero_or_un e) as [-> | ->]; try destruct (ϵ_zero_or_un f)as [-> | ->];auto.
  Qed.

  Lemma ϵ_idem e : ϵ (ϵ e) = ϵ e.
  Proof. destruct (ϵ_zero_or_un e) as [-> | ->];reflexivity. Qed.

  Lemma ϵ_KA e f : {|KA, KA'|}⊢ e == f -> ϵ e = ϵ f.
  Proof.
    intro E;apply soundness in E.
    destruct (ϵ_zero_or_un e) as [E1|E1];rewrite E1.
    - symmetry;apply ϵ_spec,E,ϵ_spec,E1.
    - symmetry;apply ϵ_zero;rewrite <-(E []);apply ϵ_zero,E1.
  Qed.

  (** ** Empty language *)
  (** [test0 e] is a boolean, it returns [true] if and only if the language of [e] is empty. *)
  Fixpoint test0 e :=
    match e with
    | e_zero => true
    | e_un | e_star _ | ⟪_⟫ => false
    | e_add e f => test0 e && test0 f
    | e_prod e f => test0 e || test0 f
    end.

  Lemma test0_false e : test0 e = false -> exists u, ⟦e⟧ u.
  Proof.
    induction e;simpl.
    - discriminate.
    - intros _;exists [];reflexivity.
    - rewrite andb_false_iff;intros [h|h].
      + apply IHe1 in h as (u&I);exists u;now left.
      + apply IHe2 in h as (u&I);exists u;now right.
    - rewrite orb_false_iff;intros (h1&h2).
      apply IHe1 in h1 as (u1&I1);apply IHe2 in h2 as (u2&I2).
      exists (u1++u2),u1,u2;tauto.
    - intros _;exists [],0;reflexivity.
    - intros _;exists [x];reflexivity.
  Qed.

  (** [test0 e] is [true] exactly when the equation [e=𝟬] is provable in [KA]. *)
  Lemma test0_spec e : test0 e = true <-> {|KA,KA'|} ⊢ e == e_zero.
  Proof.
    split.
    - induction e;simpl.
      + reflexivity.
      + discriminate.
      + rewrite andb_true_iff;intros (I1&I2);apply IHe1 in I1 as ->;apply IHe2 in I2 as ->.
        auto.
      + rewrite orb_true_iff;intros [I1|I2];[apply IHe1 in I1 as ->|apply IHe2 in I2 as ->];
          auto.
      + discriminate.
      + discriminate.
    - intros h;apply soundness in h.
      apply inf_lang_PartialOrder in h as (h&_).
      case_eq (test0 e);[reflexivity|].
      intro F;exfalso;apply test0_false in F as (u&F).
      apply (h u),F.
  Qed.

  Lemma test0_Σ L :
    test0 (Σ L) = forallb test0 L.
  Proof. induction L;simpl;congruence. Qed.

  Lemma test0_KA e f : {|KA, KA'|}⊢ e == f -> test0 e = test0 f.
  Proof.
    intro E;apply eq_true_iff_eq.
    repeat rewrite test0_spec.
    rewrite E;tauto.
  Qed.

  Lemma test0_ϵ e : test0 e = true -> test0 (ϵ e) = true.
  Proof. repeat rewrite test0_spec;intro E;apply ϵ_KA in E as ->;reflexivity. Qed.

  (** ** Unit language *)
  (** [test1 e] checks whether [e=𝟭] is provable in [KA]. If the value
  is [false], then [⟦e⟧] is either the empty language or it contains a
  non-empty word [a::u]. *)
  Fixpoint test1 e :=
    match e with
    | e_zero => false
    | e_un => true
    | ⟪_⟫ => false
    | e_star e => test1 e || test0 e
    | e_add e f => (test1 e && test1 f)||(test1 e && test0 f)||(test0 e && test1 f)
    | e_prod e f => test1 e && test1 f
    end.

  Lemma test0_test1_false e : test0 e = false -> test1 e = false -> exists a u, ⟦e⟧ (a::u).
  Proof.
    intros h1 h2;revert h2 h1.
    induction e;simpl;try discriminate;repeat rewrite orb_false_iff||rewrite andb_false_iff;firstorder.
    - apply test0_false in H1 as (v&I).
      exists x,(x0++v),(x::x0),v;tauto.
    - apply test0_false in H0 as ([|a v]&I).
      + exists x,x0,[],(x::x0);tauto.
      + exists a,(v++x::x0),(a::v),(x::x0);tauto.
    - exists x,x0,1,(x::x0),[].
      rewrite app_nil_r;simpl;repeat split;assumption.
    - exists x,[];reflexivity.
  Qed.

  Lemma test1_spec e : test1 e = true <-> {|KA,KA'|} ⊢ e == e_un.
  Proof.
    split.
    - induction e;simpl.
      + discriminate.
      + reflexivity.
      + repeat rewrite orb_true_iff; repeat rewrite andb_true_iff.
        repeat rewrite test0_spec;intros [[I|I]|I];destruct I as (I1&I2);
          try apply IHe1 in I1 as ->;try apply IHe2 in I2 as -> ;
          try rewrite I1;try rewrite I2;auto.
        transitivity (e_zero ∪ e_un);auto.
      + rewrite andb_true_iff;intros (I1&I2);apply IHe1 in I1 as ->;apply IHe2 in I2 as ->;auto.
      + rewrite orb_true_iff,test0_spec;intros [I|I].
        * apply IHe in I as ->.
          apply antisymmetry.
          -- rewrite <- (ax_eq_ax _ (KA_un_left _));apply star_right_ind.
             apply ax_eq_inf;auto.
          -- apply star_incr.
        * rewrite I;apply ka_zero_star.
      + discriminate.
    - intros h;apply soundness in h.
      case_eq (test1 e);[reflexivity|intro e1].
      case_eq (test0 e);intro e2.
      + apply test0_spec,soundness in e2.
        rewrite e2 in h.
        exfalso;apply (h []);reflexivity.
      + destruct (test0_test1_false e2 e1) as (a&u&I).
        apply h in I;discriminate.
  Qed.

  (** ** Finite sums *)
  Fixpoint join_list {A} f (E : list A) : regexp :=
    match E with
    | [] => 𝟬
    | x::E => (f x) ∪ (join_list f E)
    end.

  Notation "Σ_{ X } f" := (join_list f X) (at level 35).

  Lemma join_list_app {A} f (E F : list A) : Σ_{E++F} f ≡0 Σ_{E} f ∪ Σ_{F} f.
  Proof. induction E as [|e E];simpl;[|rewrite IHE];eauto. Qed.

  Lemma join_list_monotone {A} f (E F : list A) : E ⊆ F -> Σ_{E} f ≦0 Σ_{F} f.
  Proof.
    unfold ax_inf,leqA;induction E as [|e E];simpl.
    - eauto.
    - intro L;rewrite IHE at 1 by (rewrite <- L;clear;intro;simpl;tauto).
      transitivity (e_add (f e) (e_add (join_list f E) (join_list f F)));[|auto].
      repeat rewrite <- join_list_app.
      assert (Ie : e ∈ (E++F)) by (simpl_In;rewrite <- L;simpl;tauto).
      clear L IHE;induction (E++F).
      + simpl in *;tauto.
      + destruct Ie as [<-|I].
        * simpl;transitivity ((f a∪f a)∪(join_list f l));now auto.
        * simpl;rewrite IHl at 1 by assumption.
          transitivity ((f e∪f a)∪(join_list f l));[|now auto].
          transitivity ((f a ∪ f e)∪(join_list f l));now auto.
  Qed.

  Lemma join_list_add {B} (A : list B) f g :
    Σ_{A} (fun x => f x ∪ g x) ≡0 Σ_{A} f ∪ Σ_{A} g.
  Proof.
    induction A;simpl.
    - now auto.
    - rewrite IHA;clear.
      transitivity (f a ∪ (g a ∪ (join_list f A ∪ join_list g A)));[now auto|].
      transitivity (f a ∪ ((g a ∪ join_list f A) ∪ join_list g A));[now auto|].
      transitivity (f a ∪ ((join_list f A ∪ g a) ∪ join_list g A));[now auto|].
      transitivity (f a ∪ (join_list f A ∪ (g a ∪ join_list g A)));[now auto|].
      now auto.
  Qed.

  Lemma join_list_left_distr {B} (A : list B) f e :
    {|KA,KA'|} ⊢ Σ_{A} (fun x => e · f x) == e · Σ_{A} f.
  Proof.
    induction A;simpl.
    - now auto.
    - rewrite IHA;now auto.
  Qed.

  Lemma join_list_right_distr {B} (A : list B) f e :
    {|KA,KA'|} ⊢ Σ_{A} (fun x => f x · e) == Σ_{A} f · e.
  Proof.
    induction A;simpl.
    - now auto.
    - rewrite IHA;now auto.
  Qed.

  Lemma join_list_equivalent {C} (A B : list C) f g :
    (forall x, x ∈ A -> {|KA,KA'|} ⊢ f x == g x) -> A ≈ B ->
    {|KA,KA'|} ⊢ Σ_{A} f == Σ_{B} g.
  Proof.
    intros hypf hypA.
    transitivity (join_list g A).
    - revert hypf;clear;induction A.
      + reflexivity.
      + intros;simpl;rewrite IHA,hypf.
        * reflexivity.
        * simpl;tauto.
        * intros x Ix;apply hypf;now right.
    - apply KA_ACI0,antisymmetry;apply join_list_monotone;rewrite hypA;reflexivity.
  Qed.

  Lemma join_list_equivalent_ACI0 {C} (A B : list C) f g :
    (forall x, x ∈ A -> f x ≡0 g x) -> A ≈ B -> Σ_{A} f ≡0 Σ_{B} g .
  Proof.
    intros hypf hypΣ.
    transitivity (join_list g A).
    - revert hypf;clear;induction A.
      + reflexivity.
      + intros;simpl;rewrite IHA,hypf.
        * reflexivity.
        * simpl;tauto.
        * intros x Ix;apply hypf;now right.
    - apply antisymmetry;apply join_list_monotone;rewrite hypΣ;reflexivity.
  Qed.

  Lemma join_list_zero {B} (A : list B) : Σ_{A} (fun _ => e_zero) ≡0 𝟬.
  Proof. induction A;simpl;[|rewrite IHA];auto. Qed.

  Lemma Σ_app L M : Σ L ∪ Σ M ≡0 Σ (L++M).
  Proof. induction L;simpl;[|rewrite <- IHL];eauto. Qed.

  Lemma Σ_incl0 L M : L ⊆ M -> Σ L ≦0 Σ M.
  Proof.
    unfold ax_inf,leqA;rewrite Σ_app;revert M;induction L;intros M I.
    - reflexivity.
    - simpl;rewrite <- IHL by (rewrite <- I;intro;simpl;tauto).
      assert (Ia : a ∈ M) by (apply I;now left).
      clear I L IHL.
      induction M as [|e L].
      + simpl in *;tauto.
      + simpl;destruct Ia as [->|Ia];simpl;
          replace e_add with join in * by reflexivity.
        * transitivity ((a∪a)∪Σ L);auto.
        * transitivity ((a∪e)∪Σ L);[|auto].
          transitivity ((e∪a)∪Σ L);[|auto].
          rewrite IHL at 1 by assumption;auto.
  Qed.

  Global Instance Σ_equivalent : Proper (@equivalent _ ==> ax_eq ACI0 Empt) Σ.
  Proof.
    intros l1 l2 E.
    apply incl_PartialOrder in E as (E1&E2);unfold Basics.flip in E2.
    apply Σ_incl0 in E1; apply Σ_incl0 in E2;unfold ax_inf,leqA in *.
    rewrite E1, E2 at 1;auto.
  Qed.

  Lemma Σ_map_concat l :
    Σ (map Σ l) ≡0 Σ (concat l).
  Proof.
    induction l;simpl.
    - reflexivity.
    - rewrite  <- Σ_app,IHl;reflexivity.
  Qed.

  Lemma Σ_map_equiv {A} (f g : A -> regexp) (L : list A) :
    (forall e, e ∈ L -> {| KA , KA' |} ⊢  f e == g e) -> {| KA , KA' |} ⊢ Σ (map f L) == Σ (map g L).
  Proof.
    intro hyp.
    induction L as [|e L].
    - reflexivity.
    - simpl;rewrite (hyp e) by (now left).
      apply ax_eq_add;[reflexivity|].
      apply IHL;intros;apply hyp;now right.
  Qed.

  Lemma ϵ_Σ_un L : (exists e, e ∈ L /\ ϵ e = un) -> ϵ (Σ L) = un.
  Proof.
    intros (e&Ie&Ee);induction L;simpl;[simpl in Ie;tauto|].
    destruct Ie as [->|Ie].
    - rewrite Ee;simpl;reflexivity.
    - destruct (ϵ_zero_or_un a) as [-> | ->];[reflexivity|].
      rewrite (IHL Ie);reflexivity.
  Qed.

  Lemma ϵ_Σ_zero L : (forall e, e ∈ L -> ϵ e = zero) -> ϵ (Σ L) = zero.
  Proof.
    induction L;simpl;[reflexivity|].
    intros hyp;rewrite (hyp a) by (left;reflexivity).
    rewrite IHL;[reflexivity|].
    intros;apply hyp;now right.
  Qed.

  (** ** Finite products *)
  Definition Π : list regexp -> regexp := fold_right prod un.

  Lemma Π_lang E u :
    ⟦Π E⟧ u <-> exists U, u = fold_right (@app _) [] U
                   /\ ⎢U⎥ = ⎢E⎥
                   /\ forall n, ⟦nth n E un⟧ (nth n U []).
  Proof.
    revert u;induction E;intro u;simpl.
    - split.
      + intros -> ;exists [];split;[reflexivity|split;[reflexivity|]].
        intros [|n];reflexivity.
      + intros ([|]&->&h&h');[reflexivity|discriminate].
    - split.
      + intros (u1&u2&->&I1&I2).
        apply IHE in I2 as (U&E2&len&h).
        exists (u1::U);split;[|split].
        * rewrite E2;reflexivity.
        * simpl;rewrite len;reflexivity.
        * intros [|n];simpl;[assumption|].
          apply h.
      + intros ([|u1 U]&->&len&h);[discriminate|].
        exists u1,(fold_right (@app _) [] U);split;[reflexivity|].
        split;[apply (h 0)|].
        apply IHE;exists U;split;[reflexivity|].
        split;[simpl in *;lia|].
        intros n;apply (h (S n)).
  Qed.

  Lemma fold_star_prodList (e : regexp) l :
   {| KA , KA' |} ⊢  fold_right (fun f1 f2 => e_prod (e_prod e f1) f2) e l == Π (pad e l).
  Proof.
    unfold pad,Π.
    induction l;simpl.
    - eauto.
    - rewrite IHl; clear IHl;simpl.
      replace e_prod with prod by reflexivity.
      auto.
  Qed.

  Remark idem_fold_star (g : regexp) P :
    ⟦fold_right (fun e f => g ⋆ · e · f ) (g ⋆) P⟧ ≃ ⟦g ⋆ · fold_right (fun e f => g ⋆ · e · f ) (g ⋆) P⟧.
  Proof.
    simpl;destruct P;simpl.
    - symmetry;apply (ka_star_dup ⟦g⟧).
    - repeat rewrite (mon_assoc _ _ _).
      rewrite ka_star_dup;reflexivity.
  Qed.

  (** * Derivatives*)
  (** From now on we assume that the alphabet [X] has decidable equality. *)
  Context {decX: decidable_set X }.

  (** This entails quite easily that the syntactic equality of regular
  expressions is decidable. *)
  Global Instance decidable_regexp : decidable_set regexp.
  Proof.
    Fixpoint eq_regexp e1 e2 :=
      match (e1,e2) with
      | (e_zero,e_zero) | (e_un,e_un) => true
      | (⟪x⟫,⟪y⟫) => x =?= y
      | (e_add e1 f1,e_add e2 f2) | (e_prod e1 f1,e_prod e2 f2) =>
                                    eq_regexp e1 e2 && eq_regexp f1 f2
      | (e_star e,e_star f) => eq_regexp e f
      | _  => false
      end.
    apply Build_decidable_set with (eqX:=eq_regexp).
    intros e f;apply iff_reflect;revert f;induction e;intros [| |f1 f2|f1 f2|f|y];simpl;
      try (split;discriminate||reflexivity).
    - rewrite andb_true_iff;rewrite <- IHe1,<-IHe2.
      split;[intro h;inversion h;split|intros (->&->)];reflexivity.
    - rewrite andb_true_iff;rewrite <- IHe1,<-IHe2.
      split;[intro h;inversion h;split|intros (->&->)];reflexivity.
    - rewrite <- IHe;split;[intro h;inversion h|intros ->];reflexivity.
    - unfold_eqX;[tauto|split;[intro h;inversion h;tauto|discriminate]].
  Qed.

  (** [δ x e] is the Brzozowski derivative of [e] at [x]. *)
  Fixpoint δ (x:X) (e : regexp) :=
    match e with
    | e_un | e_zero => e_zero
    | ⟪y⟫ => if x =?= y
            then e_un
            else e_zero
    | e_prod e f =>
      if ϵ e =?= 𝟭
      then δ x e · f ∪ δ x f
      else δ x e · f
    | e_add e f => δ x e ∪ δ x f
    | e_star e => δ x e · e⋆
    end.

  Proposition fundamental_theorem e A :
    Var e ⊆ A -> {|KA,KA'|} ⊢ e == ϵ e ∪ Σ_{A} (fun x => ⟪x⟫ · δ x e).
  Proof.
    intro V;induction e.
    - simpl;clear.
      transitivity (𝟬 ∪ 𝟬);[now auto|].
      apply ax_eq_add;[reflexivity|].
      rewrite join_list_right_distr;auto.
    - simpl;clear.
      rewrite join_list_right_distr;auto.
      transitivity (𝟬 ∪ 𝟭);[now auto|].
      transitivity (𝟭 ∪ 𝟬);now auto.
    - replace (e_add e1 e2) with (e1 ∪ e2) by reflexivity.
      simpl in V;apply incl_app_split in V.
      rewrite ϵ_add.
      rewrite IHe1,IHe2 at 1 by tauto;clear.
      transitivity ((ϵ e1 ∪ ϵ e2) ∪ join_list (fun x : X => ⟪ x ⟫ · δ x e1 ∪ ⟪ x ⟫ · δ x e2) A).
      + rewrite (KA_ACI0 (join_list_add _ _ _)).
        apply refactor.
      + apply ax_eq_add;[reflexivity|].
        apply join_list_equivalent.
        * intros x _;simpl;auto.
        * reflexivity.
    - rewrite ϵ_prod;simpl;replace e_prod with prod by reflexivity.
      simpl in V;apply incl_app_split in V.
      destruct V as (E1&E2);apply IHe1 in E1;apply IHe2 in E2;clear IHe1 IHe2.
      remember (join_list (fun x : X => ⟪ x ⟫ · δ x e1) A) as f1.
      remember (join_list (fun x : X => ⟪ x ⟫ · δ x e2) A) as f2.
      revert E1;destruct (ϵ_zero_or_un e1) as [-> | ->];intros;simpl_eqX.
      + transitivity ((𝟭 · ϵ e2) ∪ join_list (fun x : X => ((⟪ x ⟫ · δ x e1) · e2)
                                                             ∪ (⟪ x ⟫ · δ x e2)) A);
          [|apply ax_eq_add;[reflexivity|];apply join_list_equivalent;
            [intros x _;transitivity ((⟪ x ⟫ · (δ x e1 · e2)) ∪ (⟪ x ⟫ · δ x e2));auto|reflexivity]].
        rewrite (KA_ACI0 (join_list_add _ _ _)).
        rewrite join_list_right_distr.
        rewrite <- Heqf1,<-Heqf2.
        transitivity (ϵ e2 ∪ (f2 ∪ f1 · e2));[|auto].
        transitivity ((ϵ e2 ∪ f2) ∪ f1 · e2);[|auto].
        rewrite <- E2.
        transitivity ((𝟭 · e2) ∪ f1 · e2);[|auto].
        rewrite E1;auto.
      + transitivity ((𝟬 · ϵ e2) ∪ join_list (fun x : X => (⟪ x ⟫ · δ x e1) · e2) A);
          [|apply ax_eq_add;[reflexivity|];apply join_list_equivalent;
            [intros x _;transitivity (⟪ x ⟫ · (δ x e1 · e2));auto|reflexivity]].
        rewrite join_list_right_distr.
        rewrite <-Heqf1.
        rewrite E1.
        transitivity (𝟬 · e2 ∪ f1 · e2);[auto|].
        transitivity (𝟬 ∪ f1 · e2);auto.
    - cut ( {|KA, KA'|}⊢ join_list (fun x : X => ⟪ x ⟫ · δ x (e ⋆)) A
            ==join_list (fun x : X => (⟪ x ⟫ · δ x e) · e ⋆) A);
        [intro E;apply antisymmetry;rewrite E;clear E|].
      + replace e_star with star by reflexivity.
        replace (ϵ (e⋆)) with 𝟭 by reflexivity.
        apply IHe in V;clear IHe.
        cut ({|KA, KA'|}⊢ e⋆ =<= ( 𝟭 ∪ join_list (fun x => (⟪ x ⟫ · δ x e) · e ⋆) A) ·e ⋆).
        * intros ->; apply star_right_ind.
          rewrite join_list_right_distr.
          transitivity  (𝟭·e ∪ (join_list (fun x : X => ⟪ x ⟫ · δ x e) A · e ⋆)· e);
            [apply ax_eq_inf;now auto|].
          apply inf_join_inf.
          -- transitivity e;[apply ax_eq_inf;now auto|].
             rewrite V at 1.
             apply proper_join_inf.
             ++ apply ϵ_sub_id.
             ++ etransitivity;[|apply proper_prod_inf;[reflexivity|apply one_inf_star]].
               rewrite right_unit;reflexivity.
          -- etransitivity;[|apply inf_cup_right].
             rewrite <- (mon_assoc _ _ _).
             apply proper_prod_inf;[reflexivity|].
             rewrite (star_incr e) at 2;rewrite ka_star_dup;reflexivity.
        * transitivity (𝟭·e⋆);[apply ax_eq_inf;now auto|].
          apply prod_ax_inf;[|reflexivity].
          apply inf_cup_left.
      + etransitivity;[|apply ax_eq_inf;symmetry;apply ka_star_unfold_eq].
        apply proper_join_inf;[reflexivity|].
        rewrite join_list_right_distr.
        apply proper_prod_inf;[|reflexivity].
        rewrite (IHe V).
        apply inf_cup_right.
      + apply join_list_equivalent;[|reflexivity].
        now intros x _;simpl;repeat rewrite prod'_prod;auto.
    - assert (E: A ≈ x :: (rm x A)).
      + intro z;simpl_In.
        rewrite rm_In.
        destruct_eqX x z.
        * split;[tauto|].
          intros _;apply V;now left.
        * tauto.
      + transitivity (ϵ ⟪ x ⟫ ∪ join_list (fun x0 : X => ⟪ x0 ⟫ · δ x0 ⟪ x ⟫) (x::A∖x)).
        * transitivity (𝟬∪⟪x⟫);[now auto|].
          transitivity (⟪x⟫∪𝟬);[now auto|].
          transitivity (𝟬∪(⟪x⟫∪𝟬));[now auto|].
          simpl;apply ax_eq_add;[reflexivity|].
          repeat rewrite prod'_prod||rewrite join'_join; apply ax_eq_add;[simpl;simpl_beq;now auto|].
          rewrite <- (KA_ACI0 (join_list_zero (A ∖ x))) at 1;apply join_list_equivalent;[|reflexivity].
          intros y I.
          apply rm_In in I as (I&N).
          simpl_beq;auto.
        * apply join_ax_eq;[reflexivity|].
          apply join_list_equivalent;[|symmetry;apply E].
          intros;reflexivity.
  Qed.

  Lemma δ_lang e a w : ⟦e⟧ (a::w) <-> ⟦δ a e⟧ w.
  Proof.
    revert a w;induction e as [| |e IHe f IHf |e IHe f IHf |e|x];intros y w;simpl.
    - tauto.
    - split;[discriminate|intro F;exfalso;apply F].
    - unfold join,joinLang;rewrite IHe,IHf;tauto.
    - split.
      + intros (u&v&E&Iu&Iv).
        destruct u as [|? u].
        * simpl in E;subst.
          apply ϵ_spec in Iu as ->;simpl_beq.
          right;apply IHf,Iv.
        * apply IHe in Iu;inversion E;subst;clear E.
          unfold_eqX;[left|];exists u,v;tauto.
      + unfold_eqX;[intros [(u&v&->&Iu&Iv)|Iw]|intros (u&v&->&Iu&Iv)];
          apply IHe in Iu || apply IHf in Iw.
        * exists (y::u),v;tauto.
        * exists [],(y::w);rewrite <- ϵ_spec;tauto.
        * exists (y::u),v;tauto.
    - unfold join,joinLang,prod,prodLang;setoid_rewrite <- IHe;clear IHe;split.
      + intros (n&In).
        revert y w In;induction n;intros.
        * simpl in In;discriminate.
        * destruct In as ([|x u]&v&E&Iu&Iv).
          -- simpl in E;subst;apply IHn,Iv.
          -- clear IHn;inversion E;subst;clear E.
             exists u,v;repeat split;[|exists n];assumption.
      + intros (u&v&->&Iu&n&Iv).
        exists (S n),(y::u),v;tauto.
    - unfold_eqX;simpl;split.
      + destruct w;[reflexivity|discriminate].
      + intros ->;reflexivity.
      + intro E;apply N;inversion E;reflexivity.
      + intro F;exfalso;apply F.
  Qed.

  Lemma δ_inf_e a e : {| KA , KA' |} ⊢ ⟪a⟫ · (δ a e) =<= e.
  Proof.
    assert (E: Var e ⊆ a::Var e) by (intro;simpl;tauto).
    apply fundamental_theorem in E.
    etransitivity;[|apply ax_eq_inf;symmetry;apply E].
    etransitivity;[|apply inf_cup_right].
    apply inf_cup_left.
  Qed.

  Lemma δ_Σ l L : δ l (Σ L) = Σ (map (δ l) L).
  Proof.
    induction L;[reflexivity|].
    simpl;rewrite IHL;reflexivity.
  Qed.

  Lemma δ_proper_KA l :
    Proper ((ax_eq KA KA') ==> (ax_eq KA KA')) (δ l).
  Proof.
    intros e1 e2 E;induction E.
    - reflexivity.
    - symmetry;assumption.
    - etransitivity;eassumption.
    - simpl;unfold_eqX.
      + rewrite IHE1,IHE2,E2;reflexivity.
      + exfalso.
        apply soundness in E1;apply ϵ_spec,E1,ϵ_spec in E.
        apply N,E.
      + exfalso.
        apply soundness in E1;apply ϵ_spec,E1,ϵ_spec in E.
        apply N,E.
      + rewrite IHE1,E2;reflexivity.
    - simpl;rewrite IHE1,IHE2;reflexivity.
    - simpl;rewrite IHE,E;reflexivity.
    - destruct H;simpl.
      + unfold_eqX;simpl.
        * rewrite (ax_eq_ax _ (KA_right_distr _ _ _)).
          repeat rewrite (ax_eq_ax _ (KA_add_assoc _ _ _)).
          repeat rewrite (ax_eq_ax _ (KA_prod_assoc _ _ _)).
          reflexivity.
        * exfalso;revert E0 N;simpl.
          destruct (ϵ_zero_or_un f) as [-> | ->];[tauto|discriminate].
        * rewrite (ax_eq_ax _ (KA_right_distr _ _ _)).
          repeat rewrite (ax_eq_ax _ (KA_add_assoc _ _ _)).
          repeat rewrite (ax_eq_ax _ (KA_prod_assoc _ _ _)).
          reflexivity.
        * exfalso;revert E N;simpl.
          destruct (ϵ_zero_or_un e) as [-> | ->];[tauto|discriminate].
        * repeat rewrite (ax_eq_ax _ (KA_prod_assoc _ _ _));reflexivity.
      + apply ax_eq_ax;auto.
      + apply ax_eq_ax;auto.
      + unfold_eqX;repeat rewrite (ax_eq_ax _ (KA_right_distr _ _ _))
                   || rewrite (ax_eq_ax _ (KA_left_distr _ _ _))
                   || rewrite (ax_eq_ax _ (KA_add_assoc _ _ _))
                   || rewrite (ax_eq_ax _ (KA_prod_assoc _ _ _)).
        * apply ax_eq_add;[|reflexivity].
          rewrite <- (ax_eq_ax _ (KA_add_assoc _ _ _)), <- (ax_eq_ax _ (KA_add_assoc _ _ _)).
          apply ax_eq_add;[reflexivity|].
          apply ax_eq_ax;auto.
        * reflexivity.
      + destruct (ϵ_zero_or_un e) as [-> | ->];destruct (ϵ_zero_or_un f) as [-> | ->];simpl_eqX;
          repeat rewrite (ax_eq_ax _ (KA_right_distr _ _ _))
          || rewrite (ax_eq_ax _ (KA_left_distr _ _ _))
          || rewrite <- (ax_eq_ax _ (KA_add_assoc _ _ _));
          (apply ax_eq_add;[reflexivity|]);[|now auto |now auto|now auto].
        transitivity (δ l f · g ∪ (δ l g∪δ l g));[now auto|].
        transitivity ((δ l f · g ∪ δ l g)∪δ l g);[now auto|].
        transitivity ((δ l g ∪ δ l f · g)∪δ l g);[now auto|].
        auto.
      + apply ax_eq_ax,KA_zero.
      + simpl_eqX.
        transitivity ((𝟬·e)∪δ l e);[reflexivity|].
        transitivity (𝟬∪δ l e);[now auto|].
        apply ax_eq_ax;auto.
      + unfold_eqX.
        * replace e_zero with zero by reflexivity.
          transitivity (δ l e ∪ zero);[now auto|].
          transitivity (zero ∪ δ l e);now auto.
        * auto.
      + simpl_eqX.
        replace e_zero with zero by reflexivity.
        auto.
      + unfold_eqX.
        * transitivity (δ l e · zero ∪ zero);[now auto|].
          transitivity zero;[|now auto].
          transitivity (zero ∪ zero);auto.
        * transitivity zero;now auto.
      + auto.
      + replace e_zero with zero by reflexivity.
        rewrite (ax_eq_ax _ (KA_zero _)).
        unfold_eqX;[|now auto].
        transitivity (δ l e · e⋆ ∪ δ l e · e⋆);now auto.
    - destruct H;simpl in *;revert IHE;simpl_eqX;unfold_eqX;intros IHE.
      + rewrite <- (ax_eq_ax _ (KA_add_assoc _ _ _)) in IHE.
        rewrite (ax_eq_ax _ (KA_idem _)) in IHE.
        cut ({|KA, KA'|}⊢e⋆·f =<= f).
        * intro L.
          rewrite <- (ax_eq_ax _ (KA_add_assoc _ _ _)).
          rewrite (ax_eq_ax _ (KA_idem _)).
          cut ({|KA, KA'|}⊢(δ l e · e ⋆) · f =<= δ l f);[intro H;apply H|].
          rewrite <- (ax_eq_ax _ (KA_prod_assoc _ _ _)).
          rewrite L.
          apply IHE.
        * eapply ax_eq_ax';[|apply E].
          auto.
      + cut ({|KA, KA'|}⊢e⋆·f =<= f).
        * intro L.
          rewrite <- (ax_eq_ax _ (KA_add_assoc _ _ _)).
          rewrite (ax_eq_ax _ (KA_idem _)).
          cut ({|KA, KA'|}⊢(δ l e · e ⋆) · f =<= δ l f);[intro H;apply H|].
          rewrite <- (ax_eq_ax _ (KA_prod_assoc _ _ _)).
          rewrite L.
          apply IHE.
        * eapply ax_eq_ax';[|apply E].
          auto.
      + cut ({|KA, KA'|}⊢δ l e · f ⋆ ∪ δ l f · f ⋆ =<= δ l e);[intro H;apply H|].
        transitivity (δ l e · f ⋆ ∪ δ l e · f ⋆).
        * apply proper_join_inf;[reflexivity|].
           apply proper_prod_inf;[|reflexivity].
           etransitivity;[|apply IHE].
           apply inf_cup_right.
        * rewrite (ax_eq_ax _ (KA_idem _)).
           eapply ax_eq_ax';[apply KA_star_right_ind|].
           cut ({|KA, KA'|}⊢δ l e · f =<= δ l e);[intro H;apply H|].
           transitivity (δ l e · f ∪ δ l f);[apply inf_cup_left|apply IHE].
      + cut ({|KA, KA'|}⊢δ l e · f ⋆ =<= δ l e);[intro H;apply H|].
        eapply ax_eq_ax';[apply KA_star_right_ind|].
        cut ({|KA, KA'|}⊢δ l e · f =<= δ l e);[intro H;apply H|apply IHE].
  Qed.

  Lemma δ_proper_KA_inf l :
    Proper ((ax_inf KA KA') ==> (ax_inf KA KA')) (δ l).
  Proof.
    intros e1 e2 E.
    apply δ_proper_KA with (l:=l) in E.
    simpl in E;apply E.
  Qed.

  Lemma test0_δ x e : test0 e = true -> test0 (δ x e) = true.
  Proof.
    induction e;simpl;try reflexivity||discriminate.
    - rewrite andb_true_iff;intros (T1&T2);rewrite IHe1,IHe2;tauto.
    - destruct (ϵ_zero_or_un e1) as [E|E];rewrite orb_true_iff;intros [T|T].
      + apply test0_ϵ in T;rewrite E in T;discriminate.
      + rewrite E;simpl_eqX;simpl.
        rewrite IHe2,T,orb_true_r;tauto.
      + rewrite E;simpl_eqX;simpl.
        rewrite IHe1;tauto.
      + rewrite E;simpl_eqX;simpl.
        rewrite T,orb_true_r;tauto.
  Qed.

  Remark δ_prod l e f : {|KA, KA'|}⊢ δ l (e·f) == δ l e ·f ∪ ϵ e·δ l f.
  Proof.
    simpl;destruct (ϵ_zero_or_un e) as [-> | ->];simpl_eqX.
    - replace e_un with un by reflexivity.
      rewrite left_unit;reflexivity.
    - replace e_zero with zero by reflexivity.
      rewrite left_absorbing,right_unit;reflexivity.
  Qed.

  (** [δ] may be extended to words in the obvious way. *)
  Fixpoint δ_words w e :=
    match w with
    | [] => e
    | a::w => δ_words w (δ a e)
    end.

  Notation " δ⋆ " := δ_words.

  Lemma δ_words_zero w : δ⋆ w e_zero = e_zero.
  Proof.
    induction w;simpl.
    - reflexivity.
    - rewrite IHw ;reflexivity.
  Qed.

  Lemma δ_words_add e f w : δ⋆ w (e ∪ f) = (δ⋆ w e) ∪ (δ⋆ w f).
  Proof.
    revert e f;induction w as [|a w];intros e f;simpl;[reflexivity|].
    rewrite <- IHw;f_equal;clear;destruct e,f;unfold join';simpl;try reflexivity.
  Qed.

  Lemma δ_words_lang e : ⟦ e ⟧ ≃ (fun w => ϵ (δ⋆ w e) = 𝟭).
  Proof.
    intro w;revert e;induction w;intro e;simpl.
    - symmetry;apply ϵ_spec.
    - rewrite δ_lang,IHw;reflexivity.
  Qed.

  Lemma δ_words_last e u a : δ⋆ (u++[a]) e = δ a (δ⋆ u e).
  Proof.
    revert e;induction u;intro e;simpl;[reflexivity|apply IHu].
  Qed.

  (** * Prefixes of a regular language *)
  Fixpoint prefixes e :=
    match e with
    | e_zero => []
    | e_un => [𝟭]
    | ⟪x⟫ => [𝟭;⟪x⟫]
    | e_add e f => prefixes e ++ prefixes f
    | e_prod e f => if test0 e || test0 f
                   then []
                   else prefixes e ++ map (prod e) (prefixes f)
    | e_star e =>  if test0 e
                  then [𝟭]
                  else map (prod (e⋆)) (prefixes e)
    end.

  Lemma prefixes_spec e : forall u, ⟦Σ (prefixes e)⟧ u <-> exists v, ⟦e⟧ (u++v).
  Proof.
    induction e;intro u;simpl.
    - split;[intros I|intros (v&I)];exfalso;apply I.
    - split.
      + intros [->|I];[|exfalso;apply I].
        exists [];reflexivity.
      + intros (v&I);apply app_eq_nil in I as (->&->).
        left;reflexivity.
    - rewrite <- (soundness (KA_ACI0 (Σ_app (prefixes e1) (prefixes e2))) u);simpl.
      Transparent joinLang.
      unfold join at 1,joinLang;simpl.
      rewrite IHe1,IHe2;clear IHe1 IHe2.
      firstorder.
      Opaque joinLang.
    - case_eq (test0 e1 || test0 e2).
      + intro h;simpl.
        split;[intro I;exfalso;apply I|].
        intros (v&w1&w2&_&I1&I2).
        apply orb_true_iff in h as [h|h];apply test0_spec,soundness in h.
        * apply h in I1;apply I1.
        * apply h in I2;apply I2.
      + intros F.
        rewrite <- (soundness (KA_ACI0 (Σ_app (prefixes e1) _)) u);simpl.
        Transparent joinLang.
        unfold join at 1,joinLang;simpl.
        rewrite <- (soundness (Σ_distr_l _ _) u);simpl.
        rewrite IHe1;clear IHe1.
        split.
        * intros [(v&Iv)|(u1&u2&->&I1&I2)].
          -- apply orb_false_iff in F as (_&F);apply test0_false in F as (w&Iw).
             exists (v++w),(u++v),w;rewrite app_ass;tauto.
          -- apply IHe2 in I2 as (v&I2);exists v,u1,(u2++v);rewrite app_ass;tauto.
        * intros (v&w1&w2&E&I1&I2).
          levi E;subst;clear E.
          -- left;exists [];rewrite app_nil_r;tauto.
          -- right;exists w1,(a::w);split;[reflexivity|];split;[assumption|].
             apply IHe2;exists v;apply I2.
          -- left;exists (a::w);apply I1.
             Opaque joinLang.
    - case_eq (test0 e).
      + intro h;simpl.
        apply test0_spec,soundness in h.
        split;[intros [->|I];[exists[],0;reflexivity|exfalso;apply I]|].
        intros (v&[|n]&I);[apply app_eq_nil in I as (->&_);left;reflexivity|].
        destruct I as (u1&_&_&I&_).
        exfalso;apply h in I;apply I.
      + intros F.
        rewrite <- (soundness (Σ_distr_l _ _) u);simpl;split.
        * intros (u1&u2&->&(n&In)&I).
          apply IHe in I as (v&I).
          exists v,(S n);apply iter_lang_last.
          rewrite app_ass;exists u1,(u2++v);tauto.
        * intros (v&n&I);revert v I;induction n;intros v I.
          -- apply app_eq_nil in I as (->&_).
             exists [],[];split;[reflexivity|].
             split;[exists 0;reflexivity|].
             apply IHe;apply test0_false in F as (w&Iw);exists w;apply Iw.
          -- apply iter_lang_last in I as (u1&u2&E&I1&I2).
             levi E;subst;clear E.
             ++ exists u1,[];rewrite app_nil_r.
                split;[reflexivity|];split;[exists n;apply I1|].
                apply IHe;exists u2;apply I2.
             ++ exists u1,(a::w);split;[reflexivity|].
                split;[exists n;apply I1|].
                apply IHe;exists v;apply I2.
             ++ apply (IHn (a::w)),I1.
    - split.
      + intros [->|[->|F]].
        * exists [x];reflexivity.
        * exists [];reflexivity.
        * exfalso;apply F.
      + intros (v&E);destruct u as [|y[|z u]];simpl in *;inversion E;subst.
        * left;reflexivity.
        * right;left;reflexivity.
  Qed.

  Lemma test0_prefixes e : test0 e = true -> prefixes e = [].
  Proof.
    induction e;simpl;firstorder (try discriminate).
    - apply andb_true_iff in H as (h1&h2).
      rewrite IHe1,IHe2 by assumption.
      reflexivity.
    - rewrite H;reflexivity.
  Qed.

End regexp.

Notation "Σ_{ X } f" := (join_list f X) (at level 35).
Notation " ⟪ l ⟫" := (atomic l).

Notation " ⟦ e ⟧ " := (reg_lang e).

Notation " {| Ax , Ax' |} ⊢ e == f " := (ax_eq Ax Ax' e f) (at level 80).
Notation ax_inf Ax Ax' := (leqA (ax_eq Ax Ax')).
Notation " {| Ax , Ax' |} ⊢ e =<= f " := (ax_inf Ax Ax' e f) (at level 80).
Hint Constructors ax_eq.
Hint Constructors KA.
Hint Constructors KA'.
Notation " e =KA f " := (ax_eq KA KA' e f) (at level 80).
Notation " e <=KA f " := (ax_inf KA KA' e f) (at level 80).
Notation " δ⋆ " := δ_words.

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

  (** * Antimirov derivatives *)

  Fixpoint δA a e :=
    match e with
    | e_zero | e_un => []
    | ⟪ b ⟫ => if a =?= b then [e_un] else []
    | e_add e f => δA a e ++ δA a f
    | e_prod e f =>
      map (fun g => g · f) (δA a e)++(if ϵ e =?= e_un then (δA a f) else [])
    | e_star e => map (fun g => g · e⋆) (δA a e)
    end.

  Fixpoint stateSpace (e:@regexp X) :=
    e::match e with
       | e_zero => []
       | e_un => []
       | ⟪ x ⟫ => [e_un]
       | e_add e f => (stateSpace e) ++ (stateSpace f)
       | e_prod e f => map (fun g => g · f) (stateSpace e)++(if negb (test0 e) then stateSpace f else [])
       | e_star e => map (fun g => g · e⋆) (stateSpace e)
       end.

  Lemma stateSpace_refl e : e ∈ stateSpace e.
  Proof. destruct e;now left. Qed.

  Lemma test0_stateSpace e f :
    test0 f = true -> e ∈ stateSpace f -> test0 e = true.
  Proof.
    revert e;induction f;intro e;simpl;simpl_In;
      repeat rewrite andb_true_iff||rewrite orb_true_iff.
    - intros _ [<-|F];[reflexivity|tauto].
    - discriminate.
    - intros (IH1&IH2) [<-|[I|I]].
      + simpl;rewrite IH1,IH2;reflexivity.
      + apply IHf1;assumption.
      + apply IHf2;assumption.
    - intros [T|T] [<-|[I|I]];simpl.
      + rewrite T;reflexivity.
      + apply in_map_iff in I as (g&<-&Ig);simpl.
        rewrite (IHf1 _ T Ig);reflexivity.
      + rewrite T in I;simpl in I;tauto.
      + rewrite T,orb_true_r;reflexivity.
      + apply in_map_iff in I as (g&<-&Ig);simpl.
        rewrite T,orb_true_r;reflexivity.
      + destruct (test0 f1);simpl in I;[tauto|].
        apply (IHf2 _ T I).
    - discriminate.
    - discriminate.
  Qed.

  Lemma stateSpace_trans e f :
    f ∈ stateSpace e -> stateSpace f ⊆ stateSpace e.
  Proof.
    revert f;induction e;simpl;intros f;try tauto.
    - intros [<-|F];[reflexivity|tauto].
    - intros [<-|F];[reflexivity|tauto].
    - simpl_In;intros [<-|[If|If]];[reflexivity|apply IHe1 in If as ->|apply IHe2 in If as ->];
        apply incl_tl.
      + apply incl_appl;reflexivity.
      + apply incl_appr;reflexivity.
    - intros [<-|I];[reflexivity|revert I].
      simpl_In;repeat rewrite in_map_iff.
      intros [(f'&<-&I)|I].
      + apply IHe1 in I.
        intros g;simpl;simpl_In;repeat rewrite in_map_iff.
        intros [<-|[(g'&<-&Ig)|Ig]].
        * right;left;exists f';split.
          -- reflexivity.
          -- apply I,stateSpace_refl.
        * right;left;exists g';split.
          -- reflexivity.
          -- apply I,Ig.
        * revert Ig;case_eq (test0 f');simpl;[tauto|].
          case_eq (test0 e1);simpl;[|tauto].
          intros T1 T2;exfalso.
          cut (test0 f' = true);[intros E;rewrite E in T2;discriminate|].
          apply (test0_stateSpace T1).
          apply I,stateSpace_refl.
      + revert I; case_eq (test0 e1);simpl;[tauto|].
        intros _ I; apply IHe2 in I as ->;intro;simpl_In;tauto.
    - intros [<-|I];[reflexivity|revert I].
      rewrite in_map_iff;intros (f'&<-&I).
      apply IHe in I;intro g;simpl.
      simpl_In;repeat rewrite in_map_iff.
      intros [<-|[(g'&<-&Ig')|Ig]].
      + right;exists f';split;[reflexivity|].
        apply I,stateSpace_refl.
      + right;exists g';split;[reflexivity|].
        apply I,Ig'.
      + revert Ig.
        destruct (test0 f');simpl;[tauto|].
        rewrite in_map_iff;intros [<-|(g'&<-&Ig')].
        * left;reflexivity.
        * right;exists g';split;[reflexivity|].
          apply Ig'.
    - intros [<-|[<-|F]];[reflexivity| |tauto].
      intros ? [<-|F];[|simpl in F;tauto].
      now right;left.
  Qed.

  Lemma δA_stateSpace e a : δA a e ⊆ stateSpace e.
  Proof.
    induction e;simpl;apply incl_tl;try reflexivity.
    - rewrite IHe1,IHe2;apply reflexivity.
    - case_eq (test0 e1);intro T;simpl.
      + rewrite app_nil_r.
        unfold_eqX.
        * exfalso.
          apply ϵ_spec in E.
          apply test0_spec,soundness in T.
          apply T in E;apply E.
        * rewrite app_nil_r.
          rewrite <- IHe1;reflexivity.
      + rewrite <- IHe1,<-IHe2.
        apply incl_app_Proper;[reflexivity|].
        destruct (ϵ e1 =?= e_un);[reflexivity|apply incl_nil].
    - rewrite IHe;reflexivity.
    - destruct_eqX a x;[reflexivity|apply incl_nil].
  Qed.

  Lemma Antimirov_lang e a w : ⟦e⟧ (a::w) <-> exists f, f ∈ δA a e /\ ⟦f⟧ w.
  Proof.
    revert w;induction e;intro w;simpl;split.
    - intro F;exfalso;apply F.
    - firstorder.
    - intro F;discriminate.
    - firstorder.
    - intros [I|I].
      + apply IHe1 in I as (f&If);exists f;simpl_In;tauto.
      + apply IHe2 in I as (f&If);exists f;simpl_In;tauto.
    - intros (f&If&Iw);simpl_In in If;destruct If as [If|If].
      + left;apply IHe1;exists f;tauto.
      + right;apply IHe2;exists f;tauto.
    - intros ([|b u]&v&E&I1&I2).
      + apply ϵ_spec in I1 as ->;simpl_beq.
        simpl in E;subst.
        apply IHe2 in I2 as (f&If&Iw).
        exists f;simpl_In;tauto.
      + simpl in E;inversion E;subst;clear E.
        apply IHe1 in I1 as (f&If&Iw).
        exists (f·e2);split.
        * simpl_In;left;apply in_map_iff;exists f;tauto.
        * exists u,v;tauto.
    - intros (f&If&Iw);simpl_In in If;destruct If as [If|If].
      + apply in_map_iff in If as (f'&<-&If).
        destruct Iw as (u1&u2&->&I1&I2).
        exists (a::u1),u2;repeat split.
        * apply IHe1;exists f';tauto.
        * assumption.
      + destruct_eqX (ϵ e1) (@e_un X);[|exfalso;apply If].
        exists [],(a::w);repeat split.
        * apply ϵ_spec,E.
        * apply IHe2;exists f;tauto.
    - intros (n&In);revert In;induction n.
      + discriminate.
      + intros (u&v&E&I1&I2).
        destruct u as [|b u].
        * simpl in E;subst;apply IHn,I2.
        * simpl in E;inversion E;subst;clear IHn E.
          apply IHe in I1 as (f&If&Iu).
          exists (f·e⋆);split.
          -- apply in_map_iff;exists f;tauto.
          -- exists u,v;repeat split.
             ++ assumption.
             ++ exists n;tauto.
    - intros (f&If&Iw).
      apply in_map_iff in If as (f'&<-&If').
      destruct Iw as (u&v&->&I1&n&I2).
      exists (S n),(a::u),v;repeat split.
      + apply IHe;exists f';tauto.
      + assumption.
    - intros E;inversion E;subst.
      simpl_beq;exists e_un;split.
      + now left.
      + reflexivity.
    - destruct_eqX a x;subst;intros (f&If&Iw).
      + destruct If as [<-|F];[|exfalso;apply F].
        rewrite Iw;reflexivity.
      + exfalso;apply If.
  Qed.

  Remark In_δA_stateSpace_incl : (forall e f a, f ∈ δA a e -> stateSpace f ⊆ stateSpace e).
  Proof.
    intros;apply stateSpace_trans.
    apply δA_stateSpace in H;assumption.
  Qed.

 Lemma test0_δA e x : test0 e = true -> forall f, f ∈ δA x e -> test0 f = true.
  Proof.
    induction e;simpl;try tauto||discriminate.
    - rewrite andb_true_iff;intros (h1&h2) f;simpl_In;intros [I|I];
        [apply IHe1,I|apply IHe2,I];assumption.
    - rewrite orb_true_iff;intros [h|h] f;simpl_In;
        (intros [I|I];[apply in_map_iff in I as (g&<-&Ig)|revert I;unfold_eqX;simpl;[|tauto]]).
      + simpl;apply orb_true_iff;left;apply IHe1;assumption.
      + exfalso.
        apply test0_spec,soundness in h;simpl in h.
        exfalso;cut (𝟬 (@nil X));[tauto|].
        apply h,ϵ_spec,E.
      + simpl;apply orb_true_iff;right;assumption.
      + apply IHe2,h.
  Qed.

  Lemma stateSpace_Var e f : e ∈ stateSpace f -> Var e ⊆ Var f.
  Proof.
    revert e;induction f;intros e;simpl.
    - intros [<-|F];[reflexivity|tauto].
    - intros [<-|F];[reflexivity|tauto].
    - simpl_In;intros [<-|[I|I]];
        [simpl;reflexivity
        |rewrite IHf1 by assumption;intro;simpl_In;tauto
        |rewrite IHf2 by assumption;intro;simpl_In;tauto].
    - simpl_In;intros [<-|[I|I]];
        [simpl;reflexivity
        |
        |destruct (test0 f1);simpl in I;[tauto|];rewrite IHf2 by assumption;intro;simpl_In;tauto].
      apply in_map_iff in I as (g&<-&Ig);simpl.
      rewrite IHf1 by assumption;reflexivity.
    - simpl_In;intros [<-|I];
        [simpl;reflexivity|].
      apply in_map_iff in I as (g&<-&Ig);simpl.
      rewrite IHf by assumption;intro;simpl_In;tauto.
    - intros [<-|[<-|F]];[reflexivity|apply incl_nil|tauto].
  Qed.
End Antimirov.

(** * Spines*)
Section spines.
  Context {X : Set}{decX: decidable_set X }.
  Fixpoint spines (e : @regexp X) :=
    match e with
    | e_zero => []
    | e_un => [(𝟭,𝟭)]
    | ⟪ x ⟫ => [(⟪x⟫,𝟭);(𝟭,⟪x⟫)]
    | e_add e f => (spines e) ++ (spines f)
    | e_prod e f => map (fun g => (fst g,snd g · f)) (spines e)
                       ++(map (fun g => (e·fst g,snd g)) (spines f))
    | e_star e =>(𝟭,𝟭)::map (fun g => (e⋆·fst g,snd g · e⋆)) (spines e)
    end.

  Lemma spines_eq e : e =KA Σ (map (fun g => fst g · snd g) (spines e)).
  Proof.
    induction e;simpl.
    - reflexivity.
    - rewrite left_unit,right_unit;reflexivity.
    - rewrite map_app,<-algebra.Σ_app.
      rewrite <- IHe1,<-IHe2.
      reflexivity.
    - rewrite map_app,<-algebra.Σ_app.
      replace e_prod with prod by reflexivity.
      rewrite <- (KA_idem (e1 · e2)).
      apply ax_eq_add.
      + rewrite IHe1,Σ_distr_r at 1.
        repeat rewrite map_map;simpl.
        apply Σ_map_equiv.
        intros;symmetry;apply mon_assoc.
      + rewrite IHe2,Σ_distr_l at 1.
        repeat rewrite map_map;simpl.
        apply Σ_map_equiv.
        intros;apply mon_assoc.
    - rewrite left_unit.
      transitivity (𝟭 ∪ (e⋆·e·e⋆)).
      + replace e_star with star by reflexivity.
        rewrite star_switch_side,<- (mon_assoc _),ka_star_dup.
        apply ka_star_unfold_eq.
      + apply ax_eq_add;[reflexivity|].
        rewrite IHe at 2.
        rewrite Σ_distr_l,Σ_distr_r.
        repeat rewrite map_map;simpl.
        apply Σ_map_equiv.
        intros;repeat rewrite (mon_assoc _);reflexivity.
    - rewrite left_unit,right_unit,right_unit,KA_idem;reflexivity.
  Qed.

  Corollary spines_inf e e1 e2 : (e1,e2) ∈ spines e -> e1 · e2 <=KA e.
  Proof.
    intros I;rewrite (spines_eq e).
    apply Σ_bigger,in_map_iff;exists (e1,e2);simpl;tauto.
  Qed.

  Lemma spines_lang e u v :
    ⟦e⟧ (u++v) -> exists e1 e2, (e1,e2) ∈ spines e /\ ⟦e1⟧ u /\ ⟦e2⟧ v.
  Proof.
    revert u v;induction e;intros u v I.
    - exfalso;apply I.
    - apply app_eq_nil in I as (->&->);exists 𝟭,𝟭;simpl;repeat split;auto.
    - simpl in *;destruct I as [I|I];[apply IHe1 in I|apply IHe2 in I];
        destruct I as (f1&f2&I&I1&I2);exists f1,f2;rewrite in_app_iff;split;auto.
    - simpl in *;destruct I as (u'&v'&E&I1&I2).
      levi E;subst;clear E.
      + rewrite <- app_nil_r in I1.
        apply IHe1 in I1 as (f1&f2&I1&I1'&I2').
        exists f1,(f2 · e2);split;[|split;[|exists [],v'];simpl;tauto].
        apply in_app_iff;left;apply in_map_iff;exists (f1,f2);simpl;tauto.
      + rewrite app_comm_cons in I2;apply IHe2 in I2 as (f1&f2&I2&I'1&I'2).
        exists (e1·f1), f2;split;[|split;[exists u',(a::w)|];simpl;tauto].
        apply in_app_iff;right;apply in_map_iff;exists (f1,f2);simpl;tauto.
      + apply IHe1 in I1 as (f1&f2&I1&I1'&I2').
        exists f1,(f2 · e2);split;[|split;[|exists (a::w),v'];simpl;tauto].
        apply in_app_iff;left;apply in_map_iff;exists (f1,f2);simpl;tauto.
    - apply split_star in I as [(->&->)|(u1&u2&v1&v2&->&->&I1&I2&I3)].
      + exists 𝟭,𝟭;simpl;repeat split;auto.
      + apply IHe in I2 as (e1&e2&I2&I'1&I'2).
        exists (e⋆· e1),(e2 ·e⋆);simpl;repeat split.
        * right;apply in_map_iff;exists (e1,e2);simpl;tauto.
        * exists u1,u2;simpl;auto.
        * exists v1,v2;simpl;auto.
    - destruct u;simpl in I;inversion I as [[e1 e2]];subst.
      + exists 𝟭,⟪x⟫;simpl;repeat split;auto.
      + apply app_eq_nil in e2 as (->&->).
        exists ⟪x⟫,𝟭;simpl;repeat split;auto.
  Qed.

  Fixpoint treeSize (e : @regexp X) :=
    match e with
    | e_zero | e_un | ⟪ _ ⟫ => 1
    | e_add e f | e_prod e f => treeSize e + treeSize f
    | e_star e => 1 + treeSize e
    end.

  Lemma nb_spines e : ⎢spines e⎥ <= 2*(treeSize e).
  Proof.
    induction e;simpl;repeat rewrite app_length;repeat rewrite map_length;try lia.
  Qed.

  Lemma size_spines e1 e2 e :
    (e1,e2) ∈ (spines e) -> treeSize (e1·e2) <= 2 * treeSize e * treeSize e.
  Proof.
    revert e1 e2;induction e;intros f1 f2;simpl;
      repeat rewrite in_app_iff;repeat rewrite in_map_iff.
    - tauto.
    - intros [E|E];inversion E;subst;simpl;reflexivity.
    - intros [I|I];[apply IHe1 in I as ->|apply IHe2 in I as ->];simpl.
      + repeat rewrite PeanoNat.Nat.mul_add_distr_r.
        repeat rewrite PeanoNat.Nat.mul_add_distr_l.
        lia.
      + repeat rewrite PeanoNat.Nat.mul_add_distr_r.
        repeat rewrite PeanoNat.Nat.mul_add_distr_l.
        lia.
    - assert (hyp : forall n, n <= n * n)
        by (intros n;case_eq n;[reflexivity|intros m E;rewrite <- E at 1 3;simpl;lia]).
      pose proof (hyp (treeSize e1)) as h1.
      pose proof (hyp (treeSize e2)) as h2.
      intros [I|I];destruct I as ((g1&g2)&E&I);inversion E;subst;clear E;simpl;
        [rewrite PeanoNat.Nat.add_assoc|rewrite <- PeanoNat.Nat.add_assoc];
        [apply IHe1 in I as ->|apply IHe2 in I as ->];simpl;revert h1 h2;
          repeat (rewrite PeanoNat.Nat.mul_add_distr_r)
          || (rewrite PeanoNat.Nat.mul_add_distr_l)
          || (rewrite (PeanoNat.Nat.mul_comm (treeSize e2) (treeSize e1)));simpl;
            generalize (treeSize e1 * treeSize e1);
            generalize (treeSize e1 * treeSize e2);
            generalize (treeSize e2 * treeSize e2);intros;lia.
    - intros [E|I].
      + inversion E;subst;simpl;lia.
      + destruct I as ((e1&e2)&E&I);inversion E;subst;clear E.
        transitivity (2*treeSize (e⋆)+treeSize (e1 · e2)).
        * simpl;lia.
        * apply IHe in I as ->;simpl.
          lia.
    - intros [E|[E|E]];inversion E;subst;simpl;lia.
  Qed.

End spines.
(* begin hide *)
Section simulation_expr.
  Context {X : Set}{dec_X : decidable_set X}.
  Notation E := (@regexp X).

  CoInductive similar (e f : E) : Prop :=
  | simulation_step : ϵ e <=KA ϵ f -> (forall a, similar (δ a e) (δ a f)) -> similar e f.

  Lemma simulation_language (e f : E) :
    ⟦e⟧ ≲ ⟦f⟧ <-> similar e f.
  Proof.
    split.
    - revert e f;cofix hE.
      intros e f hL;apply simulation_step.
      + destruct (ϵ_zero_or_un e) as [e1|e0].
        * rewrite e1.
          apply ϵ_spec,hL,ϵ_spec in e1 as ->;reflexivity.
        * rewrite e0;unfold ax_inf,leqA;eauto.
      + intros a;apply hE.
        intros u;repeat rewrite <- δ_lang;apply hL.
    - intros hE u;revert e f hE.
      induction u;intros e f hE;inversion hE as [h1 hS].
      + rewrite (ϵ_inf_e f) in h1.
        apply ax_inf_lang_incl in h1.
        intros e1;apply ϵ_spec in e1.
        apply h1;rewrite e1;reflexivity.
      + repeat rewrite δ_lang.
        apply IHu,hS.
  Qed.

  Lemma similar_join e f g : similar (e ∪ f) g -> similar e g /\ similar f g.
  Proof.
    repeat rewrite <-simulation_language.
    intros L;split;rewrite <- L;simpl;intro;simpl;firstorder.
  Qed.

End simulation_expr.
(* end hide *)


From prelude Require Export base tactics.

Section definitions.
  Context {A T : Type} `{∀ a b : A, Decision (a = b)}.
  Global Instance fn_insert : Insert A T (A → T) :=
    λ a t f b, if decide (a = b) then t else f b.
  Global Instance fn_alter : Alter A T (A → T) :=
    λ (g : T → T) a f b, if decide (a = b) then g (f a) else f b.
End definitions.

(* For now, we only have the properties here that do not need a notion
   of equality of functions. *)

Section functions.
  Context {A T : Type} `{∀ a b : A, Decision (a = b)}.

  Lemma fn_lookup_insert (f : A → T) a t : <[a:=t]>f a = t.
  Proof. unfold insert, fn_insert. by destruct (decide (a = a)). Qed.
  Lemma fn_lookup_insert_rev  (f : A → T) a t1 t2 :
    <[a:=t1]>f a = t2 → t1 = t2.
  Proof. rewrite fn_lookup_insert. congruence. Qed.
  Lemma fn_lookup_insert_ne (f : A → T) a b t : a ≠ b → <[a:=t]>f b = f b.
  Proof. unfold insert, fn_insert. by destruct (decide (a = b)). Qed.

  Lemma fn_lookup_alter (g : T → T) (f : A → T) a : alter g a f a = g (f a).
  Proof. unfold alter, fn_alter. by destruct (decide (a = a)). Qed.
  Lemma fn_lookup_alter_ne (g : T → T) (f : A → T) a b :
    a ≠ b → alter g a f b = f b.
  Proof. unfold alter, fn_alter. by destruct (decide (a = b)). Qed.
End functions.


Require Export D5_ParalleleConst.

Section SUM_ANGLES_PROPERTIES.

Lemma SumAnglesRec : forall A B C D E : Point,
	Clockwise A B C ->
	Clockwise A C D ->
	Between B A E ->
	Angle B A C = Angle A C D ->
	Angle D A E = Angle A D C.
Proof.
	intros.
	destruct (ExistsCongruentStrictTriangle D A C A D) as (F, (H3, H4)).
	 autoClockwise.
	 autoDistance.
	 rewrite (CongruentStrictTrianglesA _ _ _ _ _ _ H3).
	   apply HalfLineAngleC.
	  autoDistinct.
	  apply (BetweenDistinctBC _ _ _ H1).
	  assert (H5 : Between B A F).
	   apply (SumAngles A B C D F H H0 H4 H2).
	     rewrite (CongruentStrictTrianglesA _ _ _ _ _ _ H3); trivial.
	   assert (H6 := EquiOrientedRev _ _ _ H1); canonize.
Qed.

Lemma SumAnglesCorollary : forall A B C D E A' B' C' : Point,
	Clockwise A' B' C' ->
	Clockwise A B C ->
	Clockwise A C D ->
	Angle B A C = Angle A' B' C' ->
	Angle C A D = Angle B' A' C' ->
	Between B A E ->
	Angle D A E = Angle A' C' B'.
Proof.
	intros.
	destruct (ExistsHalfLineEquidistant A C A' B') as (B'', (H6, H7)).
	 autoDistinct.
	 autoDistinct.
	 destruct (ExistsHalfLineEquidistant A D A' C') as (C'', (H8, H9)).
	  autoDistinct.
	  autoDistinct.
	  assert (H10 : CongruentStrictTriangles A' B' C' A B'' C'').
	   apply CongruentStrictTrianglesSASA.
	    auto.
	    auto.
	    rewrite <- H3; apply HalfLineAngleBC.
	     autoDistinct.
	     autoDistinct.
	     trivial.
	     trivial.
	    exact (ClockwiseNotCollinear _ _ _ H).
	   rewrite (CongruentStrictTrianglesC _ _ _ _ _ _ H10).
	     rewrite (HalfLineAngleB A D E C'').
	    apply (SumAnglesRec A B).
	     apply ClockwiseBCA; generalizeChangeSense.
	       apply H4; autoClockwise.
	     generalizeChangeSense.
	       apply H6; apply ClockwiseBCA; apply H12; autoClockwise.
	     trivial.
	     rewrite <- (CongruentStrictTrianglesB _ _ _ _ _ _ H10); rewrite <- H2.
	       apply HalfLineAngleC.
	      autoDistinct.
	      apply (HalfLineDistinct A C B'').
	       autoDistinct.
	       trivial.
	      apply HalfLineSym.
	       autoDistinct.
	       trivial.
	    autoDistinct.
	    exact (BetweenDistinctBC _ _ _ H4).
	    trivial.
Qed.

Lemma TwoEmbeddedTriangles : forall A B C D E : Point,
	Clockwise A B C ->
	Between A D B ->
	Between A E C ->
	Angle A D E = Angle A B C ->
	Angle A E D = Angle A C B.
Proof.
	intros.
	destruct (ExistsDParallelogramm _ _ _ (ClockwiseBCA _ _ _ H)) as (F, H3).
	destruct
	 (CentralSymetPoint F A (sym_not_eq (ParallelogrammDistinctCD _ _ _ _ H3)))
	 as (G, (_, H4)).
	rewrite <- (SumAnglesRec A F B C G).
	 rewrite <- (SumAnglesRec A F D E G).
	  apply BetweenAngleB.
	   exact (BetweenDistinctBC _ _ _ H4).
	   trivial.
	  apply ClockwiseBCA; apply (BetweenClockwiseMBC B A F D).
	   apply ClockwiseCAB;
	    apply
	     (ParallelogrammClockwiseBCD _ _ _ _ (ParallelogrammPermut _ _ _ _ H3)).
	   exact (BetweenSym _ _ _ H0).
	  exact (TriangleAMN A B C D E H H0 H1).
	  trivial.
	  rewrite (BetweenAngleC A F D B).
	   rewrite H2; assert (H5 := ParallelogrammCongruentTrianglesAC _ _ _ _ H3).
	     rewrite <- (CongruentStrictTrianglesA _ _ _ _ _ _ H5).
	     apply AngleSym; autoDistinct.
	   apply sym_not_eq; exact (BetweenDistinctAB _ _ _ H4).
	   trivial.
	 apply (ParallelogrammClockwiseBCD _ _ _ _ (ParallelogrammPermut _ _ _ _ H3)).
	 trivial.
	 trivial.
	 assert (H5 := ParallelogrammCongruentTrianglesAC _ _ _ _ H3).
	   rewrite <- (CongruentStrictTrianglesA _ _ _ _ _ _ H5).
	   apply AngleSym; autoDistinct.
Qed.

Lemma TwoEmbeddedSymTriangles : forall A B C D E : Point,
	Clockwise A B C ->
	Between A D B ->
	Between A E C ->
	Angle A E D = Angle A C B ->
	Angle A D E = Angle A B C.
Proof.
	intros.
	destruct (ExistsHalfLineEquidistant A C A B) as (B', (H3, H4)).
	 autoDistinct.
	 autoDistinct.
	 destruct (ExistsHalfLineEquidistant A B A C) as (C', (H5, H6)).
	  autoDistinct.
	  autoDistinct.
	  assert (H7 := TriangleAMN A B C D E H H0 H1).
	    destruct (ExistsHalfLineEquidistant A E A D) as (D', (H8, H9)).
	   autoDistinct.
	   autoDistinct.
	   destruct (ExistsHalfLineEquidistant A D A E) as (E', (H10, H11)).
	    autoDistinct.
	    autoDistinct.
	    assert (H12 : CongruentStrictTriangles A B C A B' C').
	     apply CongruentStrictTrianglesSASA.
	      auto.
	      auto.
	      apply CongruentItself; autoDistinct.
	      exact (ClockwiseNotCollinear _ _ _ H).
	     assert (H13 : CongruentStrictTriangles A D E A D' E').
	      apply CongruentStrictTrianglesSASA.
	       auto.
	       auto.
	       apply CongruentItself; autoDistinct.
	       exact (ClockwiseNotCollinear _ _ _ H7).
	      rewrite (CongruentStrictTrianglesB _ _ _ _ _ _ H12).
	        rewrite (CongruentStrictTrianglesB _ _ _ _ _ _ H13).
	        apply TwoEmbeddedTriangles.
	       generalizeChangeSense.
	         apply H5; apply ClockwiseBCA.
	         apply H1; autoClockwise.
	       apply LSltBetween.
	        apply (HalfLineDistinct A D); [ autoDistinct | auto ].
	        assert (H14 := BetweenHalfLine _ _ _ H0).
	          canonize.
	          apply H5; apply H14.
	          clear H3 H5 H8 H14 H16 H17; generalizeChange.
	        rewrite H11; rewrite H6; exact (BetweenLSlt _ _ _ H1).
	       apply LSltBetween.
	        apply (HalfLineDistinct A E); [ autoDistinct | auto ].
	        assert (H14 := BetweenHalfLine _ _ _ H1).
	          canonize.
	          apply H3; apply H14.
	          clear H3 H5 H10 H14 H16 H17; generalizeChange.
	        rewrite H9; rewrite H4; exact (BetweenLSlt _ _ _ H0).
	       rewrite <- (CongruentStrictTrianglesC _ _ _ _ _ _ H12).
	         rewrite <- (CongruentStrictTrianglesC _ _ _ _ _ _ H13).
	         trivial.
Qed.

Lemma ExternParallelogramm  : forall A B C D E : Point,
	Parallelogramm A B C D ->
	Between D C E ->
	Angle A B C = Angle B C E.
Proof.
	intros.
	rewrite (AngleSym B).
	 apply sym_eq; apply (SumAnglesRec C D A B E).
	  apply (ParallelogrammClockwiseBCD _ _ _ _ (ParallelogrammPermut _ _ _ _ H)).
	  apply (ParallelogrammClockwiseBDA _ _ _ _ (ParallelogrammPermut _ _ _ _ H)).
	  trivial.
	  rewrite (AngleSym A).
	   apply sym_eq; apply CongruentStrictTrianglesA.
	     exact (ParallelogrammCongruentTrianglesAC _ _ _ _ H).
	   exact (ParallelogrammDistinctAC _ _ _ _ H).
	   exact (ParallelogrammDistinctAB _ _ _ _ H).
	 exact (sym_not_eq (ParallelogrammDistinctAB _ _ _ _ H)).
	 exact (ParallelogrammDistinctAB _ _ _ _ (ParallelogrammPermut _ _ _ _ H)).
Qed.

Lemma ExternOppParallelogramm  : forall A B C D E : Point,
	Parallelogramm A B C D ->
	Between B C E ->
	Angle A B C = Angle D C E.
Proof.
	intros.
	destruct (CentralSymetPoint D C) as (F, (H1, H2)).
	 apply sym_not_eq; exact (ParallelogrammDistinctCD _ _ _ _ H).
	 rewrite (ExternParallelogramm _ _ _ _ _ H H2).
	   apply CongruentOpp.
	  trivial.
	  exact (BetweenSym _ _ _ H2).
	  apply ClockwiseNotCollinear.
	    apply ClockwiseBCA; apply (EquiOrientedRev _ _ _ (BetweenSym _ _ _ H2)).
	    canonize; apply ClockwiseBCA;
	     exact (ParallelogrammClockwiseBCD _ _ _ _ H).
Qed.

Lemma ParallelogrammExtern  : forall A B C D E : Point,
	Parallelogramm A B C D ->
	Clockwise C B E ->
	Angle A B C = Angle B C E ->
	Between D C E.
Proof.
	intros.
	apply (SumAngles C D A B E).
	 exact (ParallelogrammClockwiseBCD _ _ _ _ (ParallelogrammPermut _ _ _ _ H)).
	 exact (ParallelogrammClockwiseBDA _ _ _ _ (ParallelogrammPermut _ _ _ _ H)).
	 trivial.
	 assert (H2 := ParallelogrammCongruentTrianglesAC _ _ _ _ H).
	   apply sym_eq; rewrite (AngleSym A).
	  exact (CongruentStrictTrianglesA _ _ _ _ _ _ H2).
	  exact (ParallelogrammDistinctAC _ _ _ _ H).
	  exact (ParallelogrammDistinctAB _ _ _ _ H).
	 rewrite (AngleSym B); auto.
	  autoDistinct.
	  exact (sym_not_eq (ParallelogrammDistinctAB _ _ _ _ H)).
Qed.

End SUM_ANGLES_PROPERTIES.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype finset.
Require Import fingroup perm morphism.

(******************************************************************************)
(* Group automorphisms and characteristic subgroups.                          *)
(* Unlike morphisms on a group G, which are functions of type gT -> rT, with  *)
(* a canonical structure of dependent type {morphim G >-> rT}, automorphisms  *)
(* are permutations of type {perm gT} contained in Aut G : {set {perm gT}}.   *)
(* This lets us use the finGroupType of {perm gT}. Note also that while       *)
(* morphisms on G are undefined outside G, automorphisms have their support   *)
(* in G, i.e., they are the identity ouside G.                                *)
(* Definitions:                                                               *)
(*    Aut G (or [Aut G]) == the automorphism group of G.                      *)
(*             [Aut G]%G == the group structure for Aut G.                    *)
(*            autm AutGa == the morphism on G induced by a, given             *)
(*                          AutGa : a \in Aut G.                              *)
(*       perm_in injf fA == the permutation with support B in induced by f,   *)
(*                          given injf : {in A &, injective f} and            *)
(*                          fA : f @: A \subset A.                            *)
(*           aut injf fG == the automorphism of G induced by the morphism f,  *)
(*                          given injf : 'injm f and fG : f @* G \subset G.   *)
(*    Aut_isom injf sDom == the injective homomorphism that maps Aut G to     *)
(*                          Aut (f @* G), with f : {morphism D >-> rT} and    *)
(*                          given injf: 'injm f and sDom : G \subset D.       *)
(*              conjgm G == the conjugation automorphism on G.                *)
(*             H \char G == H is a characteristic subgroup of G.              *)
(******************************************************************************)

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

Import GroupScope.

(***********************************************************************)
(* A group automorphism, defined as a permutation on a subset of a     *)
(* finGroupType that respects the morphism law.                        *)
(* Here perm_on is used as a closure rule for the set A.               *)
(***********************************************************************)

Section Automorphism.

Variable gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types a b : {perm gT}.

Definition Aut A := [set a | perm_on A a & morphic A a].

Lemma Aut_morphic A a : a \in Aut A -> morphic A a.
Proof. by case/setIdP. Qed.

Lemma out_Aut A a x : a \in Aut A -> x \notin A -> a x = x.
Proof. by case/setIdP=> Aa _; exact: out_perm. Qed.

Lemma eq_Aut A : {in Aut A &, forall a b, {in A, a =1 b} -> a = b}.
Proof.
move=> a g Aa Ag /= eqag; apply/permP=> x.
by have [/eqag // | /out_Aut out] := boolP (x \in A); rewrite !out.
Qed.

(* The morphism that is represented by a given element of Aut A. *)

Definition autm A a (AutAa : a \in Aut A) := morphm (Aut_morphic AutAa).
Lemma autmE A a (AutAa : a \in Aut A) : autm AutAa = a.
Proof. by []. Qed.

Canonical autm_morphism A a aM := Eval hnf in [morphism of @autm A a aM].

Section AutGroup.

Variable G : {group gT}.

Lemma Aut_group_set : group_set (Aut G).
Proof.
apply/group_setP; split=> [|a b].
  by rewrite inE perm_on1; apply/morphicP=> ? *; rewrite !permE.
rewrite !inE => /andP[Ga aM] /andP[Gb bM]; rewrite perm_onM //=.
apply/morphicP=> x y Gx Gy; rewrite !permM (morphicP aM) //.
by rewrite (morphicP bM) ?perm_closed.
Qed.

Canonical Aut_group := group Aut_group_set.

Variable (a : {perm gT}) (AutGa : a \in Aut G).
Notation f := (autm AutGa).
Notation fE := (autmE AutGa).

Lemma injm_autm : 'injm f.
Proof. apply/injmP; apply: in2W; exact: perm_inj. Qed.

Lemma ker_autm : 'ker f = 1. Proof. by move/trivgP: injm_autm. Qed.

Lemma im_autm : f @* G = G.
Proof.
apply/setP=> x; rewrite morphimEdom (can_imset_pre _ (permK a)) inE.
by have:= AutGa; rewrite inE => /andP[/perm_closed <-]; rewrite permKV.
Qed.

Lemma Aut_closed x : x \in G -> a x \in G.
Proof. by move=> Gx; rewrite -im_autm; exact: mem_morphim. Qed.

End AutGroup.

Lemma Aut1 : Aut 1 = 1.
Proof.
apply/trivgP/subsetP=> a /= AutGa; apply/set1P.
apply: eq_Aut (AutGa) (group1 _) _ => _ /set1P->.
by rewrite -(autmE AutGa) morph1 perm1.
Qed.

End Automorphism.

Arguments Scope Aut [_ group_scope].
Notation "[ 'Aut' G ]" := (Aut_group G)
  (at level 0, format "[ 'Aut'  G ]") : Group_scope.
Notation "[ 'Aut' G ]" := (Aut G)
  (at level 0, only parsing) : group_scope.

Prenex Implicits Aut autm.

(* The permutation function (total on the underlying groupType) that is the *)
(* representant of a given morphism f with domain A in (Aut A).             *)

Section PermIn.

Variables (T : finType) (A : {set T}) (f : T -> T).

Hypotheses (injf : {in A &, injective f}) (sBf : f @: A \subset A).

Lemma perm_in_inj : injective (fun x => if x \in A then f x else x).
Proof.
move=> x y /=; wlog Ay: x y / y \in A.
  by move=> IH eqfxy; case: ifP (eqfxy); [symmetry | case: ifP => //]; auto.
rewrite Ay; case: ifP => [Ax | nAx def_x]; first exact: injf.
by case/negP: nAx; rewrite def_x (subsetP sBf) ?mem_imset.
Qed.

Definition perm_in := perm perm_in_inj.

Lemma perm_in_on : perm_on A perm_in.
Proof.
by apply/subsetP=> x; rewrite inE /= permE; case: ifP => // _; case/eqP.
Qed.

Lemma perm_inE : {in A, perm_in =1 f}.
Proof. by move=> x Ax; rewrite /= permE Ax. Qed.

End PermIn.

(* properties of injective endomorphisms *)

Section MakeAut.

Variables (gT : finGroupType) (G : {group gT}) (f : {morphism G >-> gT}).
Implicit Type A : {set gT}.

Hypothesis injf : 'injm f.

Lemma morphim_fixP A : A \subset G -> reflect (f @* A = A) (f @* A \subset A).
Proof.
rewrite /morphim => sAG; have:= eqEcard (f @: A) A.
rewrite (setIidPr sAG) card_in_imset ?leqnn ?andbT  => [<-|]; first exact: eqP.
move/injmP: injf; apply: sub_in2; exact/subsetP.
Qed.

Hypothesis Gf : f @* G = G.

Lemma aut_closed : f @: G \subset G.
Proof. by rewrite -morphimEdom; exact/morphim_fixP. Qed.

Definition aut := perm_in (injmP _ injf) aut_closed.

Lemma autE : {in G, aut =1 f}.
Proof. exact: perm_inE. Qed.

Lemma morphic_aut : morphic G aut.
Proof. by apply/morphicP=> x y Gx Gy /=; rewrite !autE ?groupM // morphM. Qed.

Lemma Aut_aut : aut \in Aut G.
Proof. by rewrite inE morphic_aut perm_in_on. Qed.

Lemma imset_autE A : A \subset G -> aut @: A = f @* A.
Proof.
move=> sAG; rewrite /morphim (setIidPr sAG).
apply: eq_in_imset; apply: sub_in1 autE; exact/subsetP.
Qed.

Lemma preim_autE A : A \subset G -> aut @^-1: A = f @*^-1 A.
Proof.
move=> sAG; apply/setP=> x; rewrite !inE permE /=.
by case Gx: (x \in G) => //; apply/negP=> Ax; rewrite (subsetP sAG) in Gx.
Qed.

End MakeAut.

Implicit Arguments morphim_fixP [gT G f].
Prenex Implicits aut morphim_fixP.

Section AutIsom.

Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).

Hypotheses (injf : 'injm f) (sGD : G \subset D).
Let domG := subsetP sGD.

Lemma Aut_isom_subproof a :
  {a' | a' \in Aut (f @* G) & a \in Aut G -> {in G, a' \o f =1 f \o a}}.
Proof.
set Aut_a := autm (subgP (subg [Aut G] a)).
have aDom: 'dom (f \o Aut_a \o invm injf) = f @* G.
  rewrite /dom /= morphpre_invm -morphpreIim; congr (f @* _).
  by rewrite [_ :&: D](setIidPl _) ?injmK ?injm_autm ?im_autm.
have [af [def_af ker_af _ im_af]] := domP _ aDom.
have inj_a': 'injm af by rewrite ker_af !injm_comp ?injm_autm ?injm_invm.
have im_a': af @* (f @* G) = f @* G.
  by rewrite im_af !morphim_comp morphim_invm // im_autm.
pose a' := aut inj_a' im_a'; exists a' => [|AutGa x Gx]; first exact: Aut_aut.
have Dx := domG Gx; rewrite /= [a' _]autE ?mem_morphim //.
by rewrite def_af /= invmE // autmE subgK.
Qed.

Definition Aut_isom a := s2val (Aut_isom_subproof a).

Lemma Aut_Aut_isom a : Aut_isom a \in Aut (f @* G).
Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed.

Lemma Aut_isomE a : a \in Aut G -> {in G, forall x, Aut_isom a (f x) = f (a x)}.
Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed.

Lemma Aut_isomM : {in Aut G &, {morph Aut_isom: x y / x * y}}.
Proof.
move=> a b AutGa AutGb.
apply: (eq_Aut (Aut_Aut_isom _)); rewrite ?groupM ?Aut_Aut_isom // => fx.
case/morphimP=> x Dx Gx ->{fx}.
by rewrite permM !Aut_isomE ?groupM /= ?permM ?Aut_closed.
Qed.
Canonical Aut_isom_morphism := Morphism Aut_isomM.

Lemma injm_Aut_isom : 'injm Aut_isom.
Proof.
apply/injmP=> a b AutGa AutGb eq_ab'; apply: (eq_Aut AutGa AutGb) => x Gx.
by apply: (injmP _ injf); rewrite ?domG ?Aut_closed // -!Aut_isomE //= eq_ab'.
Qed.

End AutIsom.

Section InjmAut.

Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).

Hypotheses (injf : 'injm f) (sGD : G \subset D).
Let domG := subsetP sGD.

Lemma im_Aut_isom : Aut_isom injf sGD @* Aut G = Aut (f @* G).
Proof.
apply/eqP; rewrite eqEcard; apply/andP; split.
  by apply/subsetP=> _ /morphimP[a _ AutGa ->]; exact: Aut_Aut_isom.
have inj_isom' := injm_Aut_isom (injm_invm injf) (morphimS _ sGD).
rewrite card_injm ?injm_Aut_isom // -(card_injm inj_isom') ?subset_leq_card //.
apply/subsetP=> a /morphimP[a' _ AutfGa' def_a].
by rewrite -(morphim_invm injf sGD) def_a Aut_Aut_isom.
Qed.

Lemma Aut_isomP : isom (Aut G) (Aut (f @* G)) (Aut_isom injf sGD).
Proof. by apply/isomP; split; [exact: injm_Aut_isom | exact: im_Aut_isom]. Qed.

Lemma injm_Aut : Aut (f @* G) \isog Aut G.
Proof. by rewrite isog_sym (isom_isog _ _ Aut_isomP). Qed.

End InjmAut.

(* conjugation automorphism *)

Section ConjugationMorphism.

Variable gT : finGroupType.
Implicit Type A : {set gT}.

Definition conjgm of {set gT} := fun x y : gT => y ^ x.

Lemma conjgmE A x y : conjgm A x y = y ^ x. Proof. by []. Qed.

Canonical conjgm_morphism A x :=
  @Morphism _ _ A (conjgm A x) (in2W (fun y z => conjMg y z x)).

Lemma morphim_conj A x B : conjgm A x @* B = (A :&: B) :^ x.
Proof. by []. Qed.

Variable G : {group gT}.

Lemma injm_conj x : 'injm (conjgm G x).
Proof. by apply/injmP; apply: in2W; exact: conjg_inj. Qed.

Lemma conj_isom x : isom G (G :^ x) (conjgm G x).
Proof. by apply/isomP; rewrite morphim_conj setIid injm_conj. Qed.

Lemma conj_isog x : G \isog G :^ x.
Proof. exact: isom_isog (conj_isom x). Qed.

Lemma norm_conjg_im x : x \in 'N(G) -> conjgm G x @* G = G.
Proof. by rewrite morphimEdom; exact: normP. Qed.

Lemma norm_conj_isom x : x \in 'N(G) -> isom G G (conjgm G x).
Proof. by move/norm_conjg_im/restr_isom_to/(_ (conj_isom x))->. Qed.

Definition conj_aut x := aut (injm_conj _) (norm_conjg_im (subgP (subg _ x))).

Lemma norm_conj_autE : {in 'N(G) & G, forall x y, conj_aut x y = y ^ x}.
Proof. by move=> x y nGx Gy; rewrite /= autE //= subgK. Qed.

Lemma conj_autE : {in G &, forall x y, conj_aut x y = y ^ x}.
Proof. by apply: sub_in11 norm_conj_autE => //; exact: subsetP (normG G). Qed.

Lemma conj_aut_morphM : {in 'N(G) &, {morph conj_aut : x y / x * y}}.
Proof.
move=> x y nGx nGy; apply/permP=> z /=; rewrite permM.
case Gz: (z \in G); last by rewrite !permE /= !Gz.
by rewrite !norm_conj_autE // (conjgM, memJ_norm, groupM).
Qed.

Canonical conj_aut_morphism := Morphism conj_aut_morphM.

Lemma ker_conj_aut : 'ker conj_aut = 'C(G).
Proof.
apply/setP=> x; rewrite inE; case nGx: (x \in 'N(G)); last first.
  by symmetry; apply/idP=> cGx; rewrite (subsetP (cent_sub G)) in nGx.
rewrite 2!inE /=; apply/eqP/centP=> [cx1 y Gy | cGx].
  by rewrite /commute (conjgC y) -norm_conj_autE // cx1 perm1.
apply/permP=> y; case Gy: (y \in G); last by rewrite !permE Gy.
by rewrite perm1 norm_conj_autE // conjgE -cGx ?mulKg.
Qed.

Lemma Aut_conj_aut A : conj_aut @* A \subset Aut G.
Proof. by apply/subsetP=> _ /imsetP[x _ ->]; exact: Aut_aut. Qed.

End ConjugationMorphism.

Arguments Scope conjgm [_ group_scope].
Prenex Implicits conjgm conj_aut.

Reserved Notation "G \char H" (at level 70).

(* Characteristic subgroup *)

Section Characteristicity.

Variable gT : finGroupType.
Implicit Types A B : {set gT}.
Implicit Types G H K L : {group gT}.

Definition characteristic A B :=
  (A \subset B) && [forall f in Aut B, f @: A \subset A].

Infix "\char" := characteristic.

Lemma charP H G :
  reflect [/\ H \subset G
            & forall f : {morphism G >-> gT},
               'injm f -> f @* G = G -> f @* H = H]
          (H \char G).
Proof.
apply: (iffP andP) => [] [sHG chHG]; split=> //.
  move=> f injf Gf; apply/morphim_fixP=> //.
  by have:= forallP chHG (aut injf Gf); rewrite Aut_aut imset_autE.
apply/forallP=> f; apply/implyP=> Af; have injf := injm_autm Af.
move/(morphim_fixP injf _ sHG): (chHG _ injf (im_autm Af)).
by rewrite /morphim (setIidPr _).
Qed.

(* Characteristic subgroup properties : composition, relational properties *)

Lemma char1 G : 1 \char G.
Proof. by apply/charP; split=> [|f _ _]; rewrite (sub1G, morphim1). Qed.

Lemma char_refl G : G \char G.
Proof. exact/charP. Qed.

Lemma char_trans H G K : K \char H -> H \char G -> K \char G.
Proof.
case/charP=> sKH chKH; case/charP=> sHG chHG.
apply/charP; split=> [|f injf Gf]; first exact: subset_trans sHG.
rewrite -{1}(setIidPr sKH) -(morphim_restrm sHG) chKH //.
  rewrite ker_restrm; move/trivgP: injf => ->; exact: subsetIr.
by rewrite morphim_restrm setIid chHG.
Qed.

Lemma char_norms H G : H \char G -> 'N(G) \subset 'N(H).
Proof.
case/charP=> sHG chHG; apply/normsP=> x /normP Nx.
have:= chHG [morphism of conjgm G x] => /=.
by rewrite !morphimEsub //=; apply; rewrite // injm_conj.
Qed.

Lemma char_sub A B : A \char B -> A \subset B.
Proof. by case/andP. Qed.

Lemma char_norm_trans H G A : H \char G -> A \subset 'N(G) -> A \subset 'N(H).
Proof. by move/char_norms=> nHnG nGA; exact: subset_trans nHnG. Qed.

Lemma char_normal_trans H G K : K \char H -> H <| G -> K <| G.
Proof.
move=> chKH /andP[sHG nHG].
by rewrite /normal (subset_trans (char_sub chKH)) // (char_norm_trans chKH).
Qed.

Lemma char_normal H G : H \char G -> H <| G.
Proof. by move/char_normal_trans; apply; apply/andP; rewrite normG. Qed.

Lemma char_norm H G : H \char G -> G \subset 'N(H).
Proof. by case/char_normal/andP. Qed.

Lemma charI G H K : H \char G -> K \char G -> H :&: K \char G.
Proof.
case/charP=> sHG chHG; case/charP=> _ chKG.
apply/charP; split=> [|f injf Gf]; first by rewrite subIset // sHG.
rewrite morphimGI ?(chHG, chKG) //; exact: subset_trans (sub1G H).
Qed.

Lemma charMgen G H K : H \char G -> K \char G -> H <*> K \char G.
Proof.
case/charP=> sHG chHG; case/charP=> sKG chKG.
apply/charP; split=> [|f injf Gf]; first by rewrite gen_subG subUset sHG.
by rewrite morphim_gen ?(morphimU, subUset, sHG, chHG, chKG).
Qed.

Lemma charM G H K : H \char G -> K \char G -> H * K \char G.
Proof.
move=> chHG chKG; rewrite -norm_joinEl ?charMgen //.
exact: subset_trans (char_sub chHG) (char_norm chKG).
Qed.

Lemma lone_subgroup_char G H :
  H \subset G -> (forall K, K \subset G -> K \isog H -> K \subset H) ->
  H \char G.
Proof.
move=> sHG Huniq; apply/charP; split=> // f injf Gf; apply/eqP.
have{injf} injf: {in H &, injective f}.
  by move/injmP: injf; apply: sub_in2; exact/subsetP.
have fH: f @* H = f @: H by rewrite /morphim (setIidPr sHG).
rewrite eqEcard {2}fH card_in_imset ?{}Huniq //=.
  by rewrite -{3}Gf morphimS.
rewrite isog_sym; apply/isogP.
exists [morphism of restrm sHG f] => //=; first exact/injmP.
by rewrite morphimEdom fH.
Qed.

End Characteristicity.

Arguments Scope characteristic [_ group_scope group_scope].
Notation "H \char G" := (characteristic H G) : group_scope.

Section InjmChar.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).

Hypothesis injf : 'injm f.

Lemma injm_char (G H : {group aT}) :
  G \subset D -> H \char G -> f @* H \char f @* G.
Proof.
move=> sGD /charP[sHG charH].
apply/charP; split=> [|g injg gfG]; first exact: morphimS.
have /domP[h [_ ker_h _ im_h]]: 'dom (invm injf \o g \o f) = G.
  by rewrite /dom /= -(morphpreIim g) (setIidPl _) ?injmK // gfG morphimS.
have hH: h @* H = H.
  apply: charH; first by rewrite ker_h !injm_comp ?injm_invm.
  by rewrite im_h !morphim_comp gfG morphim_invm.
rewrite /= -{2}hH im_h !morphim_comp morphim_invmE morphpreK //.
by rewrite (subset_trans _ (morphimS f sGD)) //= -{3}gfG !morphimS.
Qed.

End InjmChar.

Section CharInjm.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Hypothesis injf : 'injm f.

Lemma char_injm (G H : {group aT}) :
  G \subset D -> H \subset D -> (f @* H \char f @* G) = (H \char G).
Proof.
move=> sGD sHD; apply/idP/idP; last exact: injm_char.
by move/(injm_char (injm_invm injf)); rewrite !morphim_invm ?morphimS // => ->.
Qed.

End CharInjm.

Unset Implicit Arguments.