Require Import Real.
Require Import MultiLimit.
Require Import Euclidean.
Require Import Nnat.
Require Import ArithRing.
Require Export Ring Field.

Section Complex.
  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Definition complex := @euclidean Real 2.

  Definition real_to_complex : Real -> complex.
  Proof.
    intro x.
    exact (cons x (cons real_0 nil)).
  Defined.

  Definition Imag_to_complex : Real -> complex.
  Proof.
    intro x.
    exact (cons real_0 (cons x nil)).
  Defined.

  Definition Complex : Real -> Real -> complex.
  Proof.
    intros r i.
    exact (cons r (cons i nil)).
  Defined.

  Definition complex_destruct : forall x : complex, {r & {i | x = Complex r i} }.
  Proof.
    intros.
    destruct (dim_succ_destruct x).
    destruct s.
    exists x0.
    destruct (dim_succ_destruct x1).
    exists x2.
    destruct s.
    rewrite e.
    rewrite e0.
    unfold Complex.
    rewrite (dim_zero_destruct x3).
    auto.
  Defined.

  Definition complex0 := euclidean_zero 2.
  Definition complex1 := Complex real_1 real_0.
  Definition complex_opp : complex -> complex := euclidean_opp.
  Definition complex_plus : complex -> complex -> complex := euclidean_plus.
  Definition complex_minus : complex -> complex -> complex := euclidean_minus.
  Definition complex_mult : complex -> complex -> complex.
  Proof.
    intros x y.
    destruct (complex_destruct x) as [rx [ix ex]].
    destruct (complex_destruct y) as [ry [iy ey]].
    exact (Complex (rx * ry - ix * iy) (rx * iy + ix * ry)).
  Defined.

  Lemma complex_plus_unit : forall x : complex, complex_plus complex0 x = x.
  Proof.
    intros.
    destruct (complex_destruct x) as [rx [ix ex]].
    rewrite ex.
    unfold Complex.
    unfold complex_plus.
    simpl.
    replace (real_0 + rx) with rx by ring.
    replace (real_0 + ix) with ix by ring.
    auto.
  Qed.

  Lemma complex_plus_comm : forall (x y : complex), complex_plus x y = complex_plus y x.
  Proof.
    apply euclidean_plus_comm.
  Qed.

  Lemma complex_plus_assoc : forall  (x y z : complex), complex_plus x (complex_plus y z) = complex_plus (complex_plus x y) z.
  Proof.
    apply euclidean_plus_assoc.
  Qed.

  Lemma complex_mult_unit : forall x, complex_mult complex1 x = x.
  Proof.
    intros.
    destruct (complex_destruct x) as [rx [ix ex]].
    rewrite ex.
    unfold complex1.
    unfold complex_mult.
    simpl.
    unfold Complex.
    replace (real_1 * rx - real_0 * ix) with rx by ring.
    replace (real_1 * ix + real_0 * rx) with ix by ring.
    auto.
  Defined.

  Lemma complex_mult_comm : forall x y, complex_mult x y = complex_mult y x.
  Proof.
    intros.
    destruct (complex_destruct x) as [rx [ix ex]].
    destruct (complex_destruct y) as [ry [iy ey]].
    rewrite ex, ey.
    unfold Complex, complex_mult.
    simpl.
    replace (rx * ry - ix * iy) with (ry * rx - iy * ix) by ring.
    replace (rx * iy + ix * ry) with (ry * ix + iy * rx) by ring.
    auto.
  Qed.

  Definition lp2 : forall S T R (f : S -> T -> R) (a b : S) (c d  : T), a = b -> c = d -> f a c = f b d.
  Proof.
    intros.
    rewrite H, H0.
    exact (eq_refl _).
  Defined.

  Lemma complex_mult_assoc : forall x y z, complex_mult x (complex_mult y z) = complex_mult (complex_mult x y) z.
  Proof.
    intros.
    destruct (complex_destruct x) as [rx [ix ex]].
    destruct (complex_destruct y) as [ry [iy ey]].
    destruct (complex_destruct z) as [rz [iz ez]].

    rewrite ex, ey, ez.
    unfold Complex, complex_mult.
    simpl.
    apply lp2; ring.
  Qed.

  Lemma complex_mult_plus_distr : forall x y z, complex_mult (complex_plus x y) z = complex_plus (complex_mult x z) (complex_mult y z).
  Proof.
    intros.
    destruct (complex_destruct x) as [rx [ix ex]].
    destruct (complex_destruct y) as [ry [iy ey]].
    destruct (complex_destruct z) as [rz [iz ez]].

    rewrite ex, ey, ez.
    unfold Complex, complex_plus, complex_mult.
    simpl.
    unfold Complex.
    apply lp2.
    ring.
    apply lp2.
    ring.
    auto.
  Qed.

  Lemma complex_plus_inv : forall x, complex_plus x (complex_opp x) = complex0.
  Proof.
    apply euclidean_plus_inv.
  Qed.

  Lemma complexTheory : ring_theory complex0 complex1 complex_plus complex_mult complex_minus complex_opp (eq (A:=complex)).
  Proof.
    constructor.
    intro; apply complex_plus_unit.
    exact complex_plus_comm.
    apply complex_plus_assoc.
    intro; apply complex_mult_unit.
    exact complex_mult_comm.

    apply complex_mult_assoc.
    intros m n p.
    apply complex_mult_plus_distr.
    auto.
    exact complex_plus_inv.
  Qed.

  Definition IZcomplex p := real_to_complex (IZreal p).

  Ltac IZcomplex_tac t :=
    match t with
    | complex0 => constr:(0%Z)
    | complex1 => constr:(1%Z)
    | IZcomplex ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring complexRing : complexTheory (constants [IZcomplex_tac]).

End Complex.

Declare Scope Complex_scope.
Delimit Scope Complex_scope with Complex.
Local Open Scope Complex_scope.

Infix "+" := complex_plus : Complex_scope.
Infix "*" := complex_mult : Complex_scope.
Notation "- x" := (complex_opp x) : Complex_scope.
Infix "-" := complex_minus : Complex_scope.


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

(*i $Id: NBase.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Decidable.
Require Export NAxioms.
Require Import NZProperties.

Module NBasePropFunct (Import N : NAxiomsSig').
(** First, we import all known facts about both natural numbers and integers. *)
Include NZPropFunct N.

(** We prove that the successor of a number is not zero by defining a
function (by recursion) that maps 0 to false and the successor to true *)

Definition if_zero (A : Type) (a b : A) (n : N.t) : A :=
  recursion a (fun _ _ => b) n.

Implicit Arguments if_zero [A].

Instance if_zero_wd (A : Type) :
 Proper (Logic.eq ==> Logic.eq ==> N.eq ==> Logic.eq) (@if_zero A).
Proof.
intros; unfold if_zero.
repeat red; intros. apply recursion_wd; auto. repeat red; auto.
Qed.

Theorem if_zero_0 : forall (A : Type) (a b : A), if_zero a b 0 = a.
Proof.
unfold if_zero; intros; now rewrite recursion_0.
Qed.

Theorem if_zero_succ :
 forall (A : Type) (a b : A) (n : N.t), if_zero a b (S n) = b.
Proof.
intros; unfold if_zero.
now rewrite recursion_succ.
Qed.

Theorem neq_succ_0 : forall n, S n ~= 0.
Proof.
intros n H.
generalize (Logic.eq_refl (if_zero false true 0)).
rewrite <- H at 1. rewrite if_zero_0, if_zero_succ; discriminate.
Qed.

Theorem neq_0_succ : forall n, 0 ~= S n.
Proof.
intro n; apply neq_sym; apply neq_succ_0.
Qed.

(** Next, we show that all numbers are nonnegative and recover regular
    induction from the bidirectional induction on NZ *)

Theorem le_0_l : forall n, 0 <= n.
Proof.
nzinduct n.
now apply eq_le_incl.
intro n; split.
apply le_le_succ_r.
intro H; apply -> le_succ_r in H; destruct H as [H | H].
assumption.
symmetry in H; false_hyp H neq_succ_0.
Qed.

Theorem induction :
  forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
    A 0 -> (forall n, A n -> A (S n)) -> forall n, A n.
Proof.
intros A A_wd A0 AS n; apply right_induction with 0; try assumption.
intros; auto; apply le_0_l. apply le_0_l.
Qed.

(** The theorems [bi_induction], [central_induction] and the tactic [nzinduct]
refer to bidirectional induction, which is not useful on natural
numbers. Therefore, we define a new induction tactic for natural numbers.
We do not have to call "Declare Left Step" and "Declare Right Step"
commands again, since the data for stepl and stepr tactics is inherited
from NZ. *)

Ltac induct n := induction_maker n ltac:(apply induction).

Theorem case_analysis :
  forall A : N.t -> Prop, Proper (N.eq==>iff) A ->
    A 0 -> (forall n, A (S n)) -> forall n, A n.
Proof.
intros; apply induction; auto.
Qed.

Ltac cases n := induction_maker n ltac:(apply case_analysis).

Theorem neq_0 : ~ forall n, n == 0.
Proof.
intro H; apply (neq_succ_0 0). apply H.
Qed.

Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m.
Proof.
cases n. split; intro H;
[now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0].
intro n; split; intro H; [now exists n | apply neq_succ_0].
Qed.

Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m.
Proof.
cases n.
now left.
intro n; right; now exists n.
Qed.

Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1.
Proof.
cases n.
rewrite pred_0. setoid_replace (0 == 1) with False using relation iff. tauto.
split; intro H; [symmetry in H; false_hyp H neq_succ_0 | elim H].
intro n. rewrite pred_succ.
setoid_replace (S n == 0) with False using relation iff by
  (apply -> neg_false; apply neq_succ_0).
rewrite succ_inj_wd. tauto.
Qed.

Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n.
Proof.
cases n.
intro H; exfalso; now apply H.
intros; now rewrite pred_succ.
Qed.

Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m.
Proof.
intros n m; cases n.
intros H; exfalso; now apply H.
intros n _; cases m.
intros H; exfalso; now apply H.
intros m H2 H3. do 2 rewrite pred_succ in H3. now rewrite H3.
Qed.

(** The following induction principle is useful for reasoning about, e.g.,
Fibonacci numbers *)

Section PairInduction.

Variable A : N.t -> Prop.
Hypothesis A_wd : Proper (N.eq==>iff) A.

Theorem pair_induction :
  A 0 -> A 1 ->
    (forall n, A n -> A (S n) -> A (S (S n))) -> forall n, A n.
Proof.
intros until 3.
assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))].
induct n; [ | intros n [IH1 IH2]]; auto.
Qed.

End PairInduction.

(** The following is useful for reasoning about, e.g., Ackermann function *)

Section TwoDimensionalInduction.

Variable R : N.t -> N.t -> Prop.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem two_dim_induction :
   R 0 0 ->
   (forall n m, R n m -> R n (S m)) ->
   (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m.
Proof.
intros H1 H2 H3. induct n.
induct m.
exact H1. exact (H2 0).
intros n IH. induct m.
now apply H3. exact (H2 (S n)).
Qed.

End TwoDimensionalInduction.

Section DoubleInduction.

Variable R : N.t -> N.t -> Prop.
Hypothesis R_wd : Proper (N.eq==>N.eq==>iff) R.

Theorem double_induction :
   (forall m, R 0 m) ->
   (forall n, R (S n) 0) ->
   (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m.
Proof.
intros H1 H2 H3; induct n; auto.
intros n H; cases m; auto.
Qed.

End DoubleInduction.

Ltac double_induct n m :=
  try intros until n;
  try intros until m;
  pattern n, m; apply double_induction; clear n m;
  [solve_relation_wd | | | ].

End NBasePropFunct.


Require Import Ensembles Bool.

Section Diaconescu.

Arguments In {U}.
Arguments Inhabited {U}.
Arguments Couple {U}.
Arguments Couple_l {U} {x} {y}.
Arguments Couple_r {U} {x} {y}.

Variable choice : forall {A : Set}, A -> Ensemble A -> A.
Variable choice_prop :
  forall {A : Set} (x : Ensemble A) (v : A), Inhabited x -> In x (choice A v x).

Definition U (P : Prop) (x : bool) := x = true \/ P.
Definition V (P : Prop) (x : bool) := x = false \/ P.

Lemma P_imp_in_U : forall {P : Prop}, P -> forall (x : bool), In (U P) x.
Proof.
intuition.
unfold U, In.
intuition.
Qed.

Lemma U_inhabited : forall {P : Prop}, Inhabited (U P).
Proof.
intuition.
exists true.
unfold U, In.
intuition.
Qed.

Lemma V_inhabited : forall {P : Prop}, Inhabited (V P).
Proof.
intuition.
exists false.
unfold V, In.
intuition.
Qed.

Lemma P_imp_in_V : forall {P : Prop}, P -> forall (x : bool), In (V P) x.
Proof.
intuition.
unfold V, In.
intuition.
Qed.

Lemma P_imp_full : forall {P : Prop}, P -> U P = V P.
Proof.
intuition.
apply Extensionality_Ensembles.

unfold Same_set, Included.
intuition.
- now (apply P_imp_in_V).
- now (apply P_imp_in_U).
Qed.

Theorem diaconescu : forall (P : Prop), P \/ ~P.
Proof.
intuition.

pose proof choice_prop bool (U P) true U_inhabited as fu.
pose proof choice_prop bool (V P) true V_inhabited as fv.

inversion fu. inversion fv.

- right.
intros prf.
pose proof P_imp_full prf as eq_prf.
now (rewrite eq_prf, H0 in H).

- now left.
- now left.
Qed.

Lemma ex_middle_neg : forall (P : Prop), ~(~(P \/ ~P)).
Proof.
intros.

unfold not.
intro prf.

cut (P -> False).

- intro assum.
exact (prf (or_intror assum)).

- intro assum.
exact (prf (or_introl assum)).
Qed.

End Diaconescu.


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(*                     Abelian group structure                         *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)

Require Import ssreflect ssrbool ssrfun ssrnat.
Require Import eqtype seq fintype finset.
Require Import groups div cyclic bigops.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

(*
Structure theorem for abelian finite groups. The development involves:
- definition of "base" (may be replaced by the one in pgroups).
- a functional (from finGroupType to nat) representation for combination of elements in an abelian setting.
- a reflection lemma relating generated groups to the above functional representation.
- the main result: every abelian finite group has a base.
- a few lemmas that are presumably useful to working with abelian finite groups.

Note: there is room for cleaning and improvment.
*)

(* Definitions about functions *)

Section Function_Misc_Def.

Variables (gT : finGroupType) (f g : gT -> nat).
Variables (x : gT) (n : nat) (A : {set gT}).

Definition addf f g := fun y : gT => f y + g y.

Definition peak y := if y == x then n else 0.

Definition force y := if y == x then n else f y.

Definition support := forallb y, (0 < f y) ==> (y \in A).

End Function_Misc_Def.

(* Lemmas involving the above definitions, predU1, predD1 and foldr *)

Section Function_Pred_Misc_Prop.

Variables (gT : finGroupType) (f h : gT -> nat) (x : gT).
Variables (n m : nat) (A B : {set gT}).

Lemma eq_force : force f x (f x) =1 f.
Proof.
by move=> y; rewrite/force; case yx: (y == x) => //; move/eqP: yx ->.
Qed.

Lemma force_peak : addf (force f x n) (peak x m) =1 force f x (n + m).
Proof.
by move=> y; rewrite/addf/peak/force; case: (y == x).
Qed.

Lemma neq_force : forall y, y <> x -> force f x n y = f y.
Proof.
by move=> y xy; rewrite/force; case yx: (y == x) => //; move/eqP: yx xy.
Qed.

Lemma supP : forall g (C : {set gT}),
  reflect (forall y, 0 < g y -> y \in C) (support g C).
Proof.
by move=> g C; apply: (iffP forallP); move=> H y; move/implyP: (H y).
Qed.

Lemma sup0P : forall g (C : {set gT}),
  reflect (forall y, y \notin C -> g y = 0) (support g C).
Proof.
move=> g C; apply: (iffP (supP _ _)) => insupp y => [nCy | gy_pos].
  by apply/eqP; apply/idPn; rewrite -lt0n => gy_pos; rewrite insupp in nCy.
by apply/idPn=> nCy; rewrite insupp in gy_pos.
Qed.

Lemma sup_sub : A \subset B -> support f A -> support f B.
Proof.
move/subsetP=> AB; move/supP => supA.
by apply/supP => y fy; apply: AB; apply: supA.
Qed.

Lemma eq_sup : A =i B -> support f A = support f B.
Proof.
by move=> AB; apply/supP/supP=> insupp y; move/(_ y): insupp; rewrite AB.
Qed.

Lemma sup_addf : support f A && support h A = support (addf f h) A.
Proof.
apply/andP/supP=> [[inf inh y]|infh].
  rewrite ltn_0add; case/orP; [exact: (supP _ _ inf) | exact: (supP _ _ inh)].
by split; apply/supP=> y fy_pos; rewrite infh // ltn_0add fy_pos ?orbT.
Qed.

Lemma sup_peak : (x \in A) || (n == 0) = support (peak x n) A.
Proof.
apply: eq_true_iff_eq; rewrite/peak; split.
  move=> Axn; apply/supP => /= y; case: (y =P x) Axn => // -> Axn n_pos.
  by rewrite eqn0Ngt n_pos orbF in Axn.
by move/supP; move/(_ x); rewrite eqxx orbC; case: n => // ? ->.
Qed.

Lemma sup_force : x \in A -> support f A = support (force f x n) A.
Proof.
by rewrite/force; move=> Ax; apply: eq_true_iff_eq; split;
move/supP => H; apply/supP => y; [| move: (H y)];
case yx: (y == x); try done; try exact: H; move/eqP: yx ->.
Qed.

Lemma sup_predU1_force : support f (x |: A) = support (force f x 0) A.
Proof.
rewrite/force; apply/idP/idP; move/supP => H; apply/supP => y;
  by move/(_ y): H; rewrite !inE; case: (y == x).
Qed.

Lemma predU1_sub : (x |: B) \subset A -> B \subset A /\ x \in A.
Proof. by rewrite subUset sub1set andbC; move/andP. Qed.

Lemma predU1_super : A \subset (x |: A).
Proof. by apply/subsetP => y Ay; rewrite inE Ay orbT. Qed.

Lemma predD1E : x \in A -> A = x |: A :\ x.
Proof.
by move=> Ax; apply/setP=> y; rewrite !inE; case: (y =P x) => //= ->.
Qed.

Lemma eq_foldr : forall (f1 f2 : gT -> gT -> gT)(s : seq gT),
  (forall y z, y \in s -> f1 y z = f2 y z) -> foldr f1 1 s = foldr f2 1 s.
Proof.
move=> f1 f2; elim => //= y s Hind H.
rewrite Hind; first by apply: H; rewrite inE eqxx.
by move=> z p sz; apply: H; rewrite inE sz orbT.
Qed.

End Function_Pred_Misc_Prop.

(* Definition of and lemmas on combinations of elements by exponentiation
   according to a function and multiplication along a sequence.
   "esums" stands for sum of exponents along the sequence.
   "ems" stands for exponentiation and multiplication along the sequence *)

Section Combo_Sequence.

Variable (gT : finGroupType).

Definition esums (f : gT -> nat) (s : seq gT) :=
  foldr (fun x n => (f x) + n) 0 s.

Definition ems (f : gT -> nat) (s : seq gT) :=
  foldr (fun x y => x ^+ (f x) * y) 1 s.

Lemma eq_esums : forall (f g : gT -> nat), f =1 g ->
forall s, esums f s = esums g s.
Proof.
by move=> f g fg; elim => //= x s ->; rewrite (fg x).
Qed.

Lemma esums_addf : forall (f g : gT -> nat),
forall s, esums (addf f g) s =  esums f s + esums g s.
Proof.
by move=> f g; elim => //= x s Hind; rewrite/addf Hind /=
!addnA -(addnA _ (g x)) (addnC (g x)) addnA.
Qed.

Lemma esums_peak : forall (y : gT) n s,
  esums (peak y n) s = (n * count (pred1 y) s)%N.
Proof.
move=> y n; elim => //= x s ->; rewrite/peak eq_sym muln_addr.
by case yx: (y == x) => //=; [rewrite muln1 | rewrite muln0].
Qed.

Lemma eq_ems : forall (f g : gT -> nat), f =1 g -> ems f =1 ems g.
Proof.
by move => f g fg; elim => //= x s ->; rewrite fg.
Qed.

Lemma ems1: forall s, ems (fun _ => 0) s = 1.
Proof.
elim => //= x s ->; gsimpl.
Qed.

Lemma ems_peak : forall (y : gT) n s,
  ems (peak y n) s = y ^+ (n * count (pred1 y) s).
Proof.
rewrite/peak; move=> y n; elim => //=; first by rewrite muln0 /=; gsimpl.
move=> x s ->; rewrite eq_sym muln_addr expgn_add.
by case yx: (y == x) => //=; [rewrite (eqP yx) muln1 | rewrite muln0].
Qed.

Lemma ems_not1 : forall (f : gT -> nat) s,
  ems f s <> 1 -> exists2 x, x \in s & 0 < f x.
Proof.
move => f; elim => //= x s Hind.
case xfx: (x ^+ (f x) == 1).
  move/eqP: xfx ->; gsimpl => emsf.
  by case: (Hind emsf) => y sy fy; exists y => //; rewrite inE sy orbT.
move=> _; exists x; first by rewrite inE eqxx.
by case fx: (f x) xfx => //; rewrite eqxx.
Qed.

Lemma ems1_not1 : forall (f : gT -> nat) s x,
  uniq s -> ems f s = 1 -> x \in s -> x ^+ (f x) <> 1 ->
  exists2 y, y <> x & 0 < f y.
Proof.
move=> f; elim => //= y s Hind x.
case/andP; move/negP=> notsy us yemsf; case/predU1P=> [-> yfy|sx xfx].
  case: (@ems_not1 f s) => [emsf | z sz fz].
    by rewrite -yemsf emsf mulg1 in yfy.
  by exists z => // zy; rewrite zy in sz.
case: (y ^+ (f y) =P 1) => [yfy | nyfy].
  by rewrite yfy mul1g in yemsf; exact: Hind.
by exists y => [yx|]; [rewrite -yx in sx | case: (f y) nyfy].
Qed.

End Combo_Sequence.

(* Definition of and lemmas on combinations of elements by exponentiation
   according to a function and multiplication along the enum sequence
   (the carrier of the underlying finGroupType). "esum" stands for
    sum of exponents. "em" stands for exponentiation and multiplication *)

Section Combo_Enum.

Variable (gT : finGroupType).

Definition esum (f : gT -> nat) := esums f (enum gT).

Definition em (f : gT -> nat) := ems f (enum gT).

Lemma eq_esum : forall (f g : gT -> nat), f =1 g -> esum f = esum g.
Proof.
move=> f g fg; exact: eq_esums.
Qed.

Lemma esum_addf : forall (f g : gT -> nat),
esum (addf f g) =  esum f + esum g.
Proof.
move=> f g; exact: esums_addf.
Qed.

Lemma esum_peak : forall (y : gT) n, esum (peak y n) = n.
Proof.
move=> y n; have:= esums_peak y n (enum gT).
rewrite /esum count_pred1_uniq; last exact: uniq_enum.
by rewrite mem_enum /= muln1.
Qed.

Lemma esum_leq : forall (f : gT -> nat) x, f x <= esum f.
Proof.
by move=> f x; rewrite -(eq_esum (eq_force f x)) -(add0n (f x))
-(eq_esum (force_peak _ _ _ _)) esum_addf esum_peak leq_add2r.
Qed.

Lemma esum_force : forall (f : gT -> nat) x n ,
esum (force f x n) = esum f + n - f x.
Proof.
move=> f x n; apply: (@addn_injl (f x)); rewrite addnC subnK;
last by apply: (leq_trans (esum_leq _ _)); apply: leq_addr.
by rewrite -(eq_esum (eq_force f x)) -{1}(esum_peak x (f x))
-{2}(esum_peak x n) -!esum_addf !(eq_esum (force_peak _ _ _ _)) addnC.
Qed.

Lemma eq_em : forall (f g : gT -> nat), f =1 g -> em f = em g.
Proof.
move => f g fg; exact: eq_ems.
Qed.

Lemma em1: em (fun _ => 0) = 1.
Proof.
exact: ems1.
Qed.

Lemma em_peak : forall (y : gT) n, em (peak y n) = y ^+ n.
Proof.
move=> y n; rewrite/em ems_peak count_pred1_uniq;
last exact (uniq_enum gT). by rewrite mem_enum /= muln1.
Qed.

Lemma em_not1 : forall (f : gT -> nat), em f <> 1 -> exists x, 0 < f x.
Proof.
by rewrite/em; move=> f emsf; case: (ems_not1 emsf) => x; exists x.
Qed.

Lemma em1_not1 : forall (f : gT -> nat) x, em f = 1 -> x ^+ (f x) <> 1 ->
exists2 y, y <> x & 0 < f y.
Proof.
rewrite/em; move=> f x emsf xfx; apply: (@ems1_not1 gT f (enum gT)) => //;
[exact: uniq_enum | exact: mem_enum].
Qed.

End Combo_Enum.

(* Definition of and lemmas on
   abelian sets and combinations in abelian sets *)

Section Abelian.

Variable (gT : finGroupType).
Variable (A : {set gT}) (abelA : abelian A).

Lemma asub : forall B : {set gT}, B \subset A -> abelian B.
Proof.
by move=> B BA; apply/centsP => x Bx y By;
move/subsetP: BA => BA; move/centsP: abelA; apply; apply: BA.
Qed.

Lemma aems_com : forall (f : gT -> nat) x n,
   x \in A -> support f A ->
   forall s, (x ^+ n) * ems f s = ems f s * (x ^+ n).
Proof.
move=> f x n Ax fA; elim => /=; first by gsimpl. move=> y s Hind;
rewrite -mulgA -{}Hind !mulgA -commuteX //; apply: commute_sym.
case fy: (f y); first exact: commute1.
apply: commuteX; apply: (centsP abelA) => //.
by apply: (supP _ _ fA); rewrite fy.
Qed.

Lemma aems_addf : forall f g : gT -> nat,
  support f A -> support g A ->
  forall s, ems (addf f g) s = ems f s * ems g s.
Proof.
move=> f g fA gA; rewrite/ems/addf; elim => /=; try move=> x s ->; gsimpl.
congr (_ * _); rewrite expgn_add -!mulgA; congr (_ * _).
case gx: (g x); first by rewrite mulg1 mul1g.
by apply: aems_com => //; apply: (supP _ _ gA); rewrite gx.
Qed.

Lemma aem_addf : forall f g : gT -> nat,
  support f A -> support g A -> em (addf f g) = em f * em g.
Proof. move=> f g fA gA; exact: aems_addf. Qed.

Lemma aem_force : forall f x n,
  x \in A -> support f A ->
  em (force f x n) = em f * (x ^+ n) * (x ^+ (f x))^-1.
Proof.
move=> f x n Ax fA; apply: (mulg_injr (x ^+ (f x))); gsimpl.
by rewrite -(eq_em (eq_force f x)) -!(em_peak) -!aem_addf;
first rewrite !(eq_em (force_peak _ _ _ _)) addnC;
try rewrite -sup_peak Ax; try rewrite -sup_force .
Qed.

Lemma aem_force0 :  forall f x, x \in A -> support f A ->
  em f = em (force f x 0) * x ^+ (f x).
Proof. by move=> f x Ax fA; rewrite aem_force; rewrite // mulg1 mulgKV. Qed.

End Abelian.

(* Definition of and lemmas on sets that are generated
   by multiplication of cyclic groups along the enum sequence
   The "m" in "mgen" stands for "multiplication" *)

Section Generated_Sequence.

Variable (gT : finGroupType).

(*
Definition mgens s : set gT :=
foldr (fun x Y => (<[x]>) :*: Y) [set 1] s.
*)

Definition mgen (A : {set gT}) : {set gT} := \prod_(x \in A) <[x]>.

Lemma mgenP : forall A x,
  reflect (exists2 f, support f A & em f = x) (x \in mgen A).
Proof.
move=> A x; rewrite /mgen /em /index_enum.
elim: {+}(enum _) x (uniq_enum gT) => /= [x _ | y s IHs x].
  rewrite big_seq0 inE; apply: (iffP eqP) => [->|[]//].
  exists (fun _ : gT => 0) => //=; exact/supP.
case/andP=> nsy; move/IHs=> {IHs}IHs; rewrite big_adds.
case Ay: (y \in A); last first.
  apply: (iffP (IHs x)); case=> f Af <-; exists f => //;
    by rewrite (sup0P _ _ Af) (Ay, mul1g).
apply: (iffP mulsgP) => [[x1 x2] | [f Af <-{x}]].
  case/cycleP=> i <-{x1}; case/IHs=> f Af <- -> {x x2}.
  exists (force f y i); first by rewrite -sup_force.
  rewrite /force eqxx; congr (_ * _).
  by apply: eq_foldr => x z sx; case: eqP => // eqxy; rewrite -eqxy sx in nsy.
exists (y ^+ (f y)) (ems f s) => //; first by apply/cycleP; exists (f y).
apply/IHs; exists (force f y 0); first by rewrite -sup_force.
apply: eq_foldr => x z sx.
by rewrite /force; case: eqP => // eqxy; rewrite -eqxy sx in nsy.
Qed.

Lemma mgen_super : forall A : {set gT}, A \subset mgen A.
Proof.
move=> A; apply/subsetP => x Ax.
apply/mgenP; exists (peak x 1); first by rewrite -sup_peak Ax.
by rewrite em_peak expg1.
Qed.

Lemma mgen_sub : forall (A : {set gT}) (G : {group gT}),
  A \subset G -> mgen A \subset G.
Proof.
move=> A G sAG; rewrite /mgen; elim: index_enum  => /= [| x s IHs].
  by rewrite big_seq0 sub1set.
rewrite big_adds; case Ax: (x \in A) => //=.
apply/subsetP=> y; case/mulsgP=> y1 y2.
case/cycleP => i <-; move/(subsetP IHs)=> sy2 ->.
by rewrite groupMr // groupX // (subsetP sAG).
Qed.

(* This result -- abelian sets generate abelian groups -- is not *)
(* used in the main theorem. *)

Lemma amgen : forall A : {set gT}, abelian A -> abelian (mgen A).
Proof.
move=> A abelA.
suff comgen: forall B C : {set gT}, B \subset 'C(C) -> B \subset 'C(mgen C).
  apply: (comgen); rewrite centsC; exact: comgen.
move=> B C; rewrite !(centsC B); exact: mgen_sub.
Qed.

End Generated_Sequence.

(* Coincidence of the combinations of elements of a given set and
   the group that is generated by the given set, and a reflection lemma *)

Section Generated_Abelian.

Variable (gT : finGroupType) (A : {set gT}) (abelA : abelian A).

Lemma amgen_group_set : group_set (mgen A).
Proof.
apply/andP; split.
  apply/mgenP; exists (fun _ : gT => 0); first by apply/supP.
  by rewrite/em; elim: enum => //= x s ->; rewrite mulg1.
apply/subsetP=> xy; case/mulsgP=> x y.
case/mgenP => f Af <-; case/mgenP => g Ag <- -> {x y xy}.
apply/mgenP; exists (addf f g); first by rewrite -sup_addf Af.
by apply: (aem_addf abelA).
Qed.

Canonical Structure amgen_group := Group amgen_group_set.

Lemma amgen_gen : <<A>> = mgen A.
Proof.
by apply/eqP; rewrite eqEsubset gen_subG mgen_super mgen_sub // subset_gen.
Qed.

Lemma agen : abelian <<A>>.
Proof. rewrite amgen_gen; exact: amgen. Qed.

Lemma agenP : forall x,
  reflect (exists2 f, support f A & em f = x) (x \in <<A>>).
Proof. rewrite amgen_gen; exact: mgenP. Qed.

End Generated_Abelian.

(* Definition of and lemmas on freeness *)

Section Free.

Variable (gT : finGroupType).

Definition Free (B : {set gT}) :=
    1 \notin B
 /\ forall f g, support f B -> support g B -> em f = em g ->
    forall x, x ^+ (f x) = x ^+ (g x).

Definition free (B : {set gT}) :=
  1 \notin B /\ forall f, support f B -> em f = 1 -> forall x, x ^+ (f x) = 1.

Lemma Free_set0 : Free set0.
Proof.
by split=> [|f g f0 g0 _ x]; rewrite ?(sup0P  _ _ f0, sup0P  _ _ g0) ?inE.
Qed.

Lemma Free_free : forall B, Free B -> free B.
Proof.
move=> B [nB1 frB]; split=> // f fB emf x.
rewrite (frB f (fun _ => 0)) => //; first by apply/supP.
by rewrite em1 emf.
Qed.

Lemma afree_Free : forall B, abelian B -> free B -> Free B.
Proof.
move=> B abelB; case=> nB1 frB; split=> // f g Bf Bg emfg.
have: (em g)^-1 \in << B >> by rewrite groupV; apply/agenP=> //; exists g.
case/agenP=> // h Bh; move/(congr1 (mulg^~ (em g))); rewrite mulVg => hg.
have hf: em h * em f = 1 by rewrite emfg.
move: hg; rewrite -(aem_addf abelB Bh Bg) => emhg.
move: hf; rewrite -(aem_addf abelB Bh Bf) => emhf.
have Bhg: support (addf h g) B by rewrite -sup_addf Bh Bg.
have Bhf: support (addf h f) B by rewrite -sup_addf Bh Bf.
have Hf := frB _ Bhf emhf; have Hg := frB _ Bhg emhg.
move=> x; apply: (mulg_injl (x ^+ (h x))).
by rewrite -!expgn_add; rewrite Hf Hg.
Qed.

Lemma free_predU1 : forall B x, x != 1 -> abelian (x |: B) ->
  <[x]> :&: << B >> = 1 -> free B -> free (x |: B).
Proof.
move=> B x nx1 abelxB xB1 [nB1 frB].
split=> [|f xBf]; first by rewrite !inE negb_or eq_sym nx1.
rewrite (@aem_force0 _ _ abelxB f x _ xBf); last by rewrite setU11.
move/(canRL (mulgK _)); rewrite mul1g; set z := _^-1 => def_z.
have xz: z \in <[x]> by rewrite groupV; apply: groupX; exact: cycle_id.
have genBz: z \in << B >>.
  rewrite -def_z; apply/agenP; first by rewrite (asub abelxB) ?predU1_super.
  by exists (force f x 0) => //; rewrite -sup_predU1_force.
have{xz genBz} z1: z = 1 by apply/set1P; rewrite -[[set 1]]xB1 inE xz.
move=> y; case: (y =P x) => [->|nyx]; first by apply: invg_inj; rewrite invg1.
by rewrite -(neq_force f 0 nyx) frB ?{}def_z // -sup_predU1_force.
Qed.

(*
Fixpoint sfreeb (s : seq gT) : bool :=
if s is x::s'
then (x != 1) && sfreeb s' && subset (<[x]> :&: << s' >>) [set 1]
else true.

Definition freeb (B : pred gT) := sfreeb (enum B).

Lemma freeb1 : forall B, freeb B -> ~B 1.
Proof.
move=> B. rewrite/freeb -(filter_enum B).
elim: (enum gT) => //= x s Hind.
case Bx: (B x) => //=. case/andP; case/andP; move/negP => notx1 Hfree _.
case/orP => //=; exact: Hind. exact: Hind.
Qed.

Lemma freeb_free : forall B, freeb B -> free B.
Proof.
rewrite/free/freeb/em; move=> B sfB; split; first exact: freeb1.
move=> f; rewrite -(eq_sup f (filter_enum B));
elim: (enum gT) (uniq_enum gT) f sfB => /= [_ f _ f0 _ x | x s Hind];
first by case fx: (f x) => //; move/forallP: f0; move/(_ x); rewrite fx.
case/andP => notsx us; case Bx: (B x) => /=; last first.
- move=> f freeB fB; case fx: (f x) => /=; gsimpl; first exact: Hind.
  by move: (supP _ _ fB x); rewrite mem_filter Bx fx; move/implyP.
- move=> f; case/andP; case/andP => _ sfB Inter fB.
  rewrite -{2}(mulgV (x ^+ f x)); move/mulg_injl => xfx.
  have xfx1:  x ^+ f x = 1. apply: sym_eq; apply/set1P;
  apply: (subsetP Inter); apply/setIP; split; first by apply/cycleP;
  exists (f x). rewrite -groupV -xfx; clear Hind sfB Inter xfx.
  elim: s f x Bx notsx fB us => /= [* | y s Hind f x Bx]; first exact: group1.
    rewrite negb_or; case/andP; move/negP => ynotx notsx; case By: (B y);
    last first.
  + move=> fB; case/andP => notsy us; case fy: (f y) => /=; first by gsimpl;
    apply: (Hind _ x). by move/implyP: (supP _ _ fB y);
    rewrite /= fy eq_sym (mem_filter B s y) By /= orbF.
  + move=> fB; case/andP => sy us; apply: groupM; first by apply: groupX;
    apply: (subsetP (subset_generated _)); rewrite /= eq_refl.
    have: subset << filter B s >> << y :: filter B s >>. by apply: sub_gen;
    apply/subsetP => z /= ->; rewrite orbT. move/subsetP; apply.
    rewrite (@eq_foldr gT (fun a b => (a ^+ f a) * b)
    (fun a b => (a ^+ force f x 0 a) * b) s);
    first by apply: (Hind _ y) => //; rewrite -sup_predU1_force.
    by move=> a b sa; rewrite neq_force => // ax; rewrite ax in sa;
    apply: (negP notsx).
  move=> y; case xy: (x == y); first by move/eqP: xy <-.
  rewrite -!(@neq_force gT f x 0); last by move=> yx;
  rewrite yx eq_refl in xy. apply: Hind => //=;
  first by rewrite -sup_predU1_force.
  rewrite -(@eq_foldr gT (fun a b => (a ^+ f a) * b)
  (fun a b => (a ^+ (force f x 0 a)) * b)); first by rewrite xfx xfx1;
  gsimpl. by move=> a b sa; rewrite neq_force => // ax; rewrite ax in sa;
  apply: (negP notsx).
Qed.
*)

(*
Lemma free_freeb : forall B, abelian B -> free B -> freeb B.
Proof.
move=> B abelB; case => notB1 H; rewrite/free/freeb/em.
elim: (enum gT) (uniq_enum gT) => //= x s Hind. case/andP => notsx us.
case Bx: (B x) => /=; last exact: Hind. apply/andP. split.
- apply/andP. split; last by exact: Hind.
  by  apply/negP; move/eqP=> x1; rewrite x1 in Bx.
- apply/subsetP => y. case/setIP. case/cycleP => n. move/eqP <-.
  case/agenP; first by apply: (@asub _ B _) => //; apply/subsetP => z;
  rewrite mem_filter; case/andP. move=> f fB. emxn. apply

rewrite/free/freeb/em; move=> B; case => notB1.
elim: (enum gT) (uniq_enum gT) => //= x s Hind. case/andP => notsx us H.
case Bx: (B x) => /=; last by apply: Hind => // f fB H2;
apply: H => //; rewrite (sup0P _ _ fB x) /=; gsimpl; rewrite Bx.
apply/andP. split.
- apply/andP. split; last first. apply: Hind => //.

by exact: Hind.
  by  apply/negP; move/eqP=> x1; rewrite x1 in Bx.
- apply/subsetP => y. case/setIP. case/cycleP => n. move/eqP <-.
*)

End Free.

(* Definition of and lemmas on bases *)

Section Base.

Variable (gT : finGroupType).

Definition base (E B : {set gT}) := free B /\ <<B>> = E.

Lemma base1 : base 1 set0.
Proof. split; [apply: Free_free; exact: Free_set0 | exact: gen0]. Qed.

End Base.

Section StructureTheorems.

(* Every abelian finite group has a base. Lemma + theorem *)

Variable (gT : finGroupType).

Lemma abelian_base_aux : forall E : {set gT}, abelian E ->
  exists2 B : seq gT, #|B| < #|E|.+1 & base <<E>> [set x \in B].
Proof.
move=> E; elim: {E}_.+1 {-2 4}E (ltnSn #|E|) => // n IHn E cardE abelE.
case: (pickP (mem E)) => /= [z Ez | E0]; last first.
  exists ([::] : seq gT); first by rewrite card0.
  rewrite (_ : E = set0) ?gen0; first exact: base1.
  apply/setP=> x; rewrite inE; exact: E0.
case E1: (1 \in E); last move/idPn: E1 => notE1.
  rewrite -(@genD1 gT E 1 _) ?group1 //.
  case: (IHn (E :\ 1)); first by rewrite (cardsD1 1 E) E1 /= in cardE.
    by apply: (asub abelE); apply/subsetP => x; rewrite inE; case/andP.
  by move=> B; move/(ltn_addl 1) => cardB baseB; exists B.
have{Ez} [f []]: exists f, [/\ support f E, em f = 1 & 0 < f z].
  exists (peak z #[z]); split; first by rewrite -sup_peak Ez.
    by rewrite em_peak order_expn1.
  by rewrite /peak eqxx ltn_0order.
move: {-4 6}E cardE notE1 (erefl << E >>).
elim: {f z}_.+1 {-2}f {-2}z (ltnSn (f z)) => // m mind f.
elim: {f}_.+1 {-2}f (ltnSn (esum f)) => // M Mind f esumf.
move=> x fxm1 X cardX notX1 XE fX emf fx0.
have abelX: abelian <<X>> by rewrite XE; apply: agen.
have Xx: x \in X by exact: (supP _ _ fX).
have genXx: x \in <<X>> by apply: mem_gen.
have fgenX: support f <<X>> by apply: (sup_sub (subset_gen X)).
have sXxX: X :\ _ \subset X.
  by move=> y; apply/subsetP=> z; rewrite inE; case/andP.
have sxX: [set x] \subset X by rewrite sub1set.
case: (x ^+ (f x) =P 1) => [xfx1 | xfx].
  case: (<[x]> :&: << X :\ x >> =P 1) => [X1x|].
    case: (IHn (X :\ x)) => [|| B cardB [FreeB BXx]].
    - by rewrite (cardsD1 x X) (supP _ _ fX x fx0) in cardX.
    - apply: (asub abelX); exact: subset_trans (subset_gen X).
    exists (x :: B).
      rewrite -cardsE set_adds cardsU1 ltnS inE cardsE.
      by rewrite (leq_trans _ cardB) // -add1n leq_add2r leq_b1.
    split; last first; rewrite set_adds.
      by rewrite -XE; apply: genDU; rewrite ?sub1set.
    apply: free_predU1 => //=; last by rewrite BXx.
      by apply/eqP=> x1; rewrite -x1 Xx in notX1.
    by apply: (asub abelX); rewrite -gen_subG (@genDU _ _ _ X).
  move/eqP; case/trivgPn=> y; case/setIP; case/cycleP => k <-{y}.
  rewrite (divn_eq k (f x)) expgn_add mulnC expgn_mul xfx1 exp1gn.
  rewrite mul1g -groupV; case/agenP=> [|g gX emg xknot1].
    by apply: (asub abelX); rewrite -gen_subG genS // subsetDr.
  apply: (mind (force g x (k %% f x)) x _ X) => //.
  - by rewrite /force eqxx (leq_trans _ (fxm1 : f x <= m)) // ltn_mod.
  - rewrite -sup_force => //; exact: sup_sub gX.
  - rewrite (aem_force abelX) //; last first.
      by apply: (sup_sub _ gX); rewrite -gen_subG genS // subsetDr.
    rewrite (sup0P _ _ gX x) /=; last by rewrite !inE eqxx Xx.
    by rewrite emg; gsimpl; apply: invg1.
  rewrite /force eqxx lt0n; apply: contra xknot1.
  by move/eqP=> ->; rewrite eqxx.
case: (em1_not1 emf xfx) => y ynotx fy0.
have Xy: y \in X by exact: supP fX _ _.
have genXy: y \in <<X>> by rewrite mem_gen.
have xyyx: commute x y by exact: (centsP abelX).
have notxyx: x * y != x.
  apply/eqP; move/(canRL (mulKg _)); rewrite mulVg => y1.
  by rewrite -y1 Xy in notX1.
have notxyy: x * y != y.
  apply/eqP; move/(canRL (mulgK _)); rewrite mulgV => x1.
  by rewrite -x1 Xx in notX1.
case Xxy: (x * y \in X).
  case: (IHn (X :\ x * y)) => [||B cardB [FreeB genB]].
  - by rewrite -(ltn_add2l (x * y \in X)) -cardsD1 Xxy.
  - apply: (asub abelX); exact: subset_trans (subset_gen X).
  exists B; first exact: (ltn_trans cardB).
  split=> //; rewrite genB -XE; apply: genD1.
  by rewrite groupMl mem_gen // !inE eq_sym; exact/andP.
case: (ltnP (f y) (f x)) => fxfy.
  apply: (mind f y _ X) => //; exact: leq_trans fxfy _.
case: (x * y =P 1) => [xy1 | xynot1].
  case: (IHn (X :\ y)) => [||B cardB [FreeB genB]].
  - by rewrite (cardsD1 y) (supP _ _ fX) in cardX.
  - by apply: (asub abelX); apply: subset_trans (subset_gen X).
  exists B; [exact: ltnW | split => //].
  rewrite genB -XE; apply: genD1; rewrite -{1}(mulKg x y) xy1 mulg1 groupV.
  apply: mem_gen; rewrite !inE Xx andbT eq_sym; exact/eqP.
pose f' := force (force (force f x 0) (x * y) (f x)) y (f y - f x).
pose X' := x * y |: (X :\ x).
apply: (Mind f' _ (x * y) _ X') => //; last 1 first.
- by rewrite /f' /force (negPf notxyx) (negPf notxyy) eqxx.
- rewrite !esum_force /force (negPf notxyx) eq_sym (negPf notxyy).
  rewrite (introF eqP ynotx) (sup0P _ _ fX (x * y)) ?Xxy //.
  rewrite addn0 subn0 -addnA (subnK fxfy) addnK.
  by rewrite -[M](subn1 M.+1) -leq_subS (esum_leq, leq_sub2) //.
- by rewrite /f' /force eqxx (negPf notxyy).
- by rewrite cardsU1 inE Xxy andbF -[~~ _]Xx -cardsD1.
- by rewrite !inE eq_sym (introF eqP xynot1) (negPf notX1) andbF.
- rewrite -XE; apply/setP; apply/subset_eqP; apply/andP.
  split; rewrite gen_subG; apply/subsetP => t.
    rewrite 3!inE; case/predU1P=> [->|].
      by apply: groupM; apply: mem_gen.
    case/andP=> _; exact: mem_gen.
  case tx: (t == x) => Xt; last first.
    by apply: mem_gen; rewrite !inE Xt tx orbT.
  rewrite {t tx Xt}(eqP tx) -(mulgK y x).
  by rewrite groupMl ?groupV mem_gen // !inE ?eqxx // Xy orbC; case: eqP.
- rewrite -sup_force; last by rewrite !inE Xy orbC; case: eqP.
  rewrite -sup_force; last by rewrite setU11.
  rewrite -sup_predU1_force; apply/supP => t ft /=.
  by rewrite !inE (supP _ _ fX t ft); case (t == x); rewrite ?orbT.
rewrite !(aem_force abelX) /force => //; first 1 last; first exact: groupM.
- by apply/supP => t; case tx: (t == x) => // ft; exact: (supP _ _ fgenX).
- apply/supP => t; case: eqP => [-> _ | _]; first exact: groupM.
  by case: eqP => // _; apply: (supP _ _ fgenX).
rewrite emf !mul1g expMgn // mulKg (negPf notxyx) eq_sym (negPf notxyy).
rewrite (introF eqP ynotx) (sup0P _ _ fX (x * y)) ?Xxy // invg1 mulg1.
by rewrite -expgn_add subnK ?mulgV.
Qed.

Theorem abelian_base : forall G : {group gT},
  abelian G -> exists B, base G B.
Proof.
by move=> G; case/abelian_base_aux=> B _; rewrite genGid; exists [set x \in B].
Qed.

End StructureTheorems.


Require Import Frap.

Set Implicit Arguments.
Set Asymmetric Patterns.
Set Universe Polymorphism.

(** * Proving Evenness *)

Inductive isEven : nat -> Prop :=
| Even_O : isEven O
| Even_SS : forall n, isEven n -> isEven (S (S n)).

Theorem even_256 : isEven 256.
Proof.
Admitted.

(** * Reifying the Syntax of a Trivial Tautology Language *)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
Proof.
  tauto.
Qed.

Print true_galore.

(** * A Monoid Expression Simplifier *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A -> A -> A.

  Infix "+" := f.

  Hypothesis assoc : forall a b c, (a + b) + c = a + (b + c).
  Hypothesis identl : forall a, e + a = a.
  Hypothesis identr : forall a, a + e = a.

  Inductive mexp : Set :=
  | Ident : mexp
  | Var : A -> mexp
  | Op : mexp -> mexp -> mexp.

  (* Next, we write an interpretation function. *)

  Fixpoint mdenote (me : mexp) : A :=
    match me with
      | Ident => e
      | Var v => v
      | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  Ltac reify me :=
    match me with
      | e => Ident
      | ?me1 + ?me2 =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          constr:(Op r1 r2)
      | _ => constr:(Var me)
    end.

  (*Ltac monoid :=
    match goal with
      | [ |- ?me1 = ?me2 ] =>
        let r1 := reify me1 in
        let r2 := reify me2 in
          change (mdenote r1 = mdenote r2);
            apply monoid_reflect; simplify
    end.

  Theorem t1 : forall a b c d, a + b + c + d = a + (b + c) + d.
    simplify; monoid.
    reflexivity.
  Qed.*)
End monoid.

(** * Set Simplification for Model Checking *)

(* Let's take a closer look at model-checking proofs like from last class. *)

(* Here's a simple transition system, where state is just a [nat], and where
 * each step subtracts 1 or 2. *)

Inductive subtract_step : nat -> nat -> Prop :=
| Subtract1 : forall n, subtract_step (S n) n
| Subtract2 : forall n, subtract_step (S (S n)) n.

Definition subtract_sys (n : nat) : trsys nat := {|
  Initial := {n};
  Step := subtract_step
|}.

Lemma subtract_ok :
  invariantFor (subtract_sys 5)
               (fun n => n <= 5).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.
  (* Here we'll see that the Frap library uses slightly different, optimized
   * versions of the model-checking relations.  For instance, [multiStepClosure]
   * takes an extra set argument, the _worklist_ recording newly discovered
   * states.  There is no point in following edges out of states that were
   * already known at previous steps. *)

  (* Now, some more manual iterations: *)
  eapply MscStep.
  closure.
  (* Ew.  What a big, ugly set expression.  Let's shrink it down to something
   * more readable, with duplicates removed, etc. *)
  simplify.
  (* How does the Frap library do that?  Proof by reflection is a big part of
   * it!  Let's develop a baby version of that automation.  The full-scale
   * version is in file Sets.v. *)
Abort.

(* Back to our example, which we can now finish without calling [simplify] to
 * reduces trees of union operations. *)
(*Lemma subtract_ok :
  invariantFor (subtract_sys 5)
               (fun n => n <= 5).
Proof.
  eapply invariant_weaken.

  apply multiStepClosure_ok.
  simplify.

  (* Now, some more manual iterations: *)
  eapply MscStep.
  closure.
  simplify_set.
  (* Success!  One subexpression shrunk.  Now for the other. *)
  simplify_set.
  (* Our automation doesn't handle set difference, so we finish up calling the
   * library tactic. *)
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  eapply MscStep.
  closure.
  simplify_set.
  simplify_set.
  simplify.

  model_check_done.

  simplify.
  linear_arithmetic.
Qed.*)

(** * A Smarter Tautology Solver *)

Definition propvar := nat.

Inductive formula : Set :=
| Atomic : propvar -> formula
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.

Definition asgn := nat -> Prop.

Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => atomics v
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 -> formulaDenote atomics f2
  end.

Require Import ListSet.

Section my_tauto.
  Variable atomics : asgn.

  Definition add (s : set propvar) (v : propvar) := set_add eq_nat_dec v s.

  Fixpoint allTrue (s : set propvar) : Prop :=
    match s with
      | nil => True
      | v :: s' => atomics v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> atomics v
    -> allTrue (add s v).
  Proof.
    induct s; simplify; propositional;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; simplify; propositional.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> atomics v.
  Proof.
    induct s; simplify; equality.
  Qed.

  Fixpoint forward (known : set propvar) (hyp : formula)
           (cont : set propvar -> bool) : bool :=
    match hyp with
    | Atomic v => cont (add known v)
    | Truth => cont known
    | Falsehood => true
    | And h1 h2 => forward known h1 (fun known' =>
                     forward known' h2 cont)
    | Or h1 h2 => forward known h1 cont && forward known h2 cont
    | Imp _ _ => cont known
    end.

  Compute fun cont => forward [] (Atomic 0) cont.
  Compute fun cont => forward [] (Or (Atomic 0) (Atomic 1)) cont.
  Compute fun cont => forward [] (Or (Atomic 0) (And (Atomic 1) (Atomic 2))) cont.

  Fixpoint backward (known : set propvar) (f : formula) : bool :=
    match f with
    | Atomic v => if In_dec eq_nat_dec v known then true else false
    | Truth => true
    | Falsehood => false
    | And f1 f2 => backward known f1 && backward known f2
    | Or f1 f2 => backward known f1 || backward known f2
    | Imp f1 f2 => forward known f1 (fun known' => backward known' f2)
    end.

  Compute backward [] (Atomic 0).
  Compute backward [0] (Atomic 0).
  Compute backward [0; 2] (Or (Atomic 0) (Atomic 1)).
  Compute backward [2] (Or (Atomic 0) (Atomic 1)).
  Compute backward [2] (Imp (Atomic 0) (Or (Atomic 0) (Atomic 1))).
  Compute backward [2] (Imp (Or (Atomic 0) (Atomic 3)) (Or (Atomic 0) (Atomic 1))).
  Compute backward [2] (Imp (Or (Atomic 1) (Atomic 0)) (Or (Atomic 0) (Atomic 1))).
End my_tauto.

Lemma forward_ok : forall atomics hyp f known cont,
    forward known hyp cont = true
    -> (forall known', allTrue atomics known'
                       -> cont known' = true
                       -> formulaDenote atomics f)
    -> allTrue atomics known
    -> formulaDenote atomics hyp
    -> formulaDenote atomics f.
Proof.
  induct hyp; simplify; propositional.

  apply H0 with (known' := add known p).
  apply allTrue_add.
  assumption.
  assumption.
  assumption.

  eapply H0.
  eassumption.
  assumption.

  eapply IHhyp1.
  eassumption.
  simplify.
  eauto.
  assumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHhyp1.
  eassumption.
  assumption.
  assumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHhyp2.
  eassumption.
  assumption.
  assumption.
  assumption.

  eapply H0.
  eassumption.
  assumption.
Qed.

Lemma backward_ok' : forall atomics f known,
    backward known f = true
    -> allTrue atomics known
    -> formulaDenote atomics f.
Proof.
  induct f; simplify; propositional.

  cases (in_dec Nat.eq_dec p known); propositional.
  eapply allTrue_In.
  eassumption.
  unfold set_In.
  assumption.
  equality.

  equality.

  apply andb_true_iff in H; propositional.
  eapply IHf1.
  eassumption.
  assumption.

  apply andb_true_iff in H; propositional.
  eapply IHf2.
  eassumption.
  assumption.

  apply orb_true_iff in H; propositional.
  left.
  eapply IHf1.
  eassumption.
  assumption.
  right.
  eapply IHf2.
  eassumption.
  assumption.

  eapply forward_ok.
  eassumption.
  simplify.
  eapply IHf2.
  eassumption.
  assumption.
  assumption.
  assumption.
Qed.

Theorem backward_ok : forall f,
    backward [] f = true
    -> forall atomics, formulaDenote atomics f.
Proof.
  simplify.
  apply backward_ok' with (known := []).
  assumption.
  simplify.
  propositional.
Qed.

(* Find the position of an element in a list. *)
Ltac position x ls :=
  match ls with
  | [] => constr:(@None nat)
  | x :: _ => constr:(Some 0)
  | _ :: ?ls' =>
    let p := position x ls' in
    match p with
    | None => p
    | Some ?n => constr:(Some (S n))
    end
  end.

(* Compute a duplicate-free list of all variables in [P], combining it with
 * [acc]. *)
Ltac vars_in P acc :=
  match P with
  | True => acc
  | False => acc
  | ?Q1 /\ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 \/ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 -> ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | _ =>
    let pos := position P acc in
    match pos with
    | Some _ => acc
    | None => constr:(P :: acc)
    end
  end.

(* Reification of formula [P], with a pregenerated list [vars] of variables it
 * may mention *)
Ltac reify_tauto' P vars :=
  match P with
  | True => Truth
  | False => Falsehood
  | ?Q1 /\ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(And q1 q2)
  | ?Q1 \/ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Or q1 q2)
  | ?Q1 -> ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Imp q1 q2)
  | _ =>
    let pos := position P vars in
    match pos with
    | Some ?pos' => constr:(Atomic pos')
    end
  end.

(* Our final tactic implementation is now fairly straightforward.  First, we
 * [intro] all quantifiers that do not bind [Prop]s.  Then we reify.  Finally,
 * we call the verified procedure through a lemma. *)

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1
               | _ => intro
             end
         end;
  match goal with
    | [ |- ?P ] =>
      let vars := vars_in P (@nil Prop) in
      let p := reify_tauto' P vars in
      change (formulaDenote (nth_default False vars) p)
  end;
  apply backward_ok; reflexivity.

(* A few examples demonstrate how the tactic works: *)

Theorem mt1 : True.
Proof.
  my_tauto.
Qed.

Print mt1.

Theorem mt2 : forall x y : nat, x = y -> x = y.
Proof.
  my_tauto.
Qed.

Print mt2.

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
Proof.
  my_tauto.
Qed.

Print mt3.

Theorem mt4 : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
Proof.
  my_tauto.
Qed.

Print mt4.

Theorem mt4' : True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
Proof.
  tauto.
Qed.

Print mt4'.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal50.

Set Printing Depth 1000.
Definition lfind_eval  x l:=
count l x.

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil))).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Nil).


Require Import Setoid.

Require Import basics.
Require Import categories.

(** Monoidal category *)

Module Monoidal.
Section Monoidal.
  Variables (ob:Type) (hom:ob -> ob -> Type).
  Variable eq:forall A B:ob, Eq.mixin_of (hom A B).
  Variable comp:Comp.mixin_of ob hom.
  Variable cat_axioms:Category.axioms ob hom eq comp.

  Definition eq' A B := Eq.Pack _ (eq A B).
  Definition comp' := Comp.Pack ob hom comp.
  Definition cat' := Category ob hom eq comp cat_axioms.
  Canonical Structure eq'.
  Canonical Structure comp'.
  Canonical Structure cat'.

  Section axioms.
    Variable tensor : ob -> ob -> ob.
    Variable unit : ob.
    Variable tensor_map : forall (A B C D:ob) (f:A → B) (g:C → D),
      tensor A C → tensor B D.
    Arguments tensor_map [A B C D] f g.

    Variable assoc : forall (A B C:ob), tensor (tensor A B) C ↔ tensor A (tensor B C).
    Variable unitor1 : forall (A:ob), tensor unit A ↔ A.
    Variable unitor2 : forall (A:ob), tensor A unit ↔ A.

    Record axioms :=
      Axioms
      { tensor_map_respects : forall A B C D (f f':A → C) (g g':B → D),
           f ≈ f' -> g ≈ g' -> tensor_map f g ≈ tensor_map f' g'

      ; tensor_map_id : forall (A B:ob),
           tensor_map id(A) id(B) ≈ id(tensor A B)

      ; tensor_map_compose : forall (A A' B B' C C':ob)
            (f:hom A B) (g:hom A' B') (h:hom B C) (i:hom B' C'),
            tensor_map h i ∘ tensor_map f g ≈ tensor_map (h ∘ f) (i ∘ g)

      ; unitor1_natural : forall (A B:ob) (x:A → B),
           unitor1 B ∘ tensor_map id x ≈ x ∘ unitor1 A

      ; unitor2_natural : forall (A B:ob) (x:A → B),
           unitor2 B ∘ tensor_map x id ≈ x ∘ unitor2 A

      ; assoc_natural : forall (A A' B B' C C':ob) (f:A→A') (g:B → B') (h:C → C'),
           assoc A' B' C' ∘ tensor_map (tensor_map f g) h
           ≈
           tensor_map f (tensor_map g h) ∘ assoc A B C

      ; unitor_triangle : forall (A B:ob),
           tensor_map (unitor2 A) id(B) ≈
           tensor_map id(A) (unitor1 B) ∘ assoc A unit B

      ; assoc_pentagon : forall (A B C D:ob),
            assoc A B (tensor C D) ∘ assoc (tensor A B) C D
            ≈
            tensor_map id(A) (assoc B C D)
            ∘
            assoc A (tensor B C) D
            ∘
            tensor_map (assoc A B C) id(D)
      }.
  End axioms.

  Record mixin_of :=
  Mixin
  { tensor : ob -> ob -> ob
  ; unit : ob
  ; tensor_map : forall (A B C D:ob) (f:hom A B) (g:hom C D),
      hom (tensor A C) (tensor B D)
  ; assoc : forall (A B C:ob), tensor (tensor A B) C ↔ tensor A (tensor B C)
  ; unitor1 : forall (A:ob), tensor unit A ↔ A
  ; unitor2 : forall (A:ob), tensor A unit ↔ A
  ; monoidal_axioms : axioms tensor unit tensor_map assoc unitor1 unitor2
  }.
End Monoidal.

Record monoidal :=
  Monoidal
  { ob : Type
  ; hom : ob -> ob -> Type
  ; eq:forall A B:ob, Eq.mixin_of (hom A B)
  ; comp:Comp.mixin_of ob hom
  ; cat_axioms:Category.axioms ob hom eq comp
  ; mixin : mixin_of ob hom eq comp cat_axioms
  }.

Definition category (X:monoidal) :=
  Category (ob X) (hom X) (eq X) (comp X) (cat_axioms X).

End Monoidal.

Notation monoidal := Monoidal.monoidal.
Notation Monoidal := Monoidal.Monoidal.
Canonical Structure Monoidal.category.
Coercion Monoidal.category : monoidal >-> category.

Canonical Structure monoidal_eq (X:monoidal) (A B:ob X) :=
  Eq.Pack (A → B) (Monoidal.eq X A B).

Definition tensor (X:monoidal) : ob X -> ob X -> ob X:=
  Monoidal.tensor _ _ _ _ _ (Monoidal.mixin X).
Definition munit (X:monoidal) : ob X :=
  Monoidal.unit _ _ _ _ _ (Monoidal.mixin X).

Arguments tensor [X] A B.

Notation "A ⊗ B" := (@tensor _ A B) : category_ob_scope.
Notation "1" := (munit _) : category_ob_scope.

Definition tensor_map (X:monoidal) (A B C D:ob X) (f:A → B) (g:C → D) : A⊗C → B⊗D :=
  Monoidal.tensor_map _ _ _ _ _ (Monoidal.mixin X) A B C D f g.

Definition associator (X:monoidal) (A B C:ob X) : (A⊗B)⊗C ↔ A⊗(B⊗C) :=
  Monoidal.assoc _ _ _ _ _ (Monoidal.mixin X) A B C.

Definition unitor1 (X:monoidal) (A:ob X) : 1⊗A ↔ A :=
  Monoidal.unitor1 _ _ _ _ _ (Monoidal.mixin X) A.

Definition unitor2 (X:monoidal) (A:ob X) : A⊗1 ↔ A :=
  Monoidal.unitor2 _ _ _ _ _ (Monoidal.mixin X) A.

Arguments tensor_map [X A B C D] f g.
Arguments associator [X] A B C.
Arguments unitor1 [X] A.
Arguments unitor2 [X] A.

Lemma tensor_map_respects (X:monoidal) :
  forall (A B C D:ob X) (f f':A → C) (g g':B → D),
    f ≈ f' -> g ≈ g' -> tensor_map f g ≈ tensor_map f' g'.

Proof (@Monoidal.tensor_map_respects _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Add Parametric Morphism (X:monoidal) (A B C D:ob X) :
  (@tensor_map X A B C D)
  with signature eq_op _ ==> eq_op _ ==> eq_op _
  as tensor_map_morphism.
Proof.
  intros. apply tensor_map_respects; auto.
Qed.

Lemma tensor_map_id (X:monoidal) : forall (A B:ob X),
  tensor_map id(A) id(B) ≈ id(A ⊗ B).

Proof (@Monoidal.tensor_map_id _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma tensor_map_compose (X:monoidal) : forall (A A' B B' C C':ob X)
            (f:A → B) (g:A' → B') (h:B → C) (i:B' → C'),
            tensor_map h i ∘ tensor_map f g ≈ tensor_map (h ∘ f) (i ∘ g).

Proof (@Monoidal.tensor_map_compose _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma unitor1_natural (X:monoidal) : forall (A B:ob X) (x:A → B),
           unitor1 B ∘ tensor_map id x ≈ x ∘ unitor1 A.

Proof (@Monoidal.unitor1_natural _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma unitor2_natural (X:monoidal) : forall (A B:ob X) (x:A → B),
           unitor2 B ∘ tensor_map x id ≈ x ∘ unitor2 A.

Proof (@Monoidal.unitor2_natural _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma assoc_natural (X:monoidal) :
  forall (A A' B B' C C':ob X) (f:A→A') (g:B → B') (h:C → C'),
           associator A' B' C' ∘ tensor_map (tensor_map f g) h
           ≈
           tensor_map f (tensor_map g h) ∘ associator A B C.

Proof (@Monoidal.assoc_natural _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma unitor_triangle (X:monoidal) : forall (A B:ob X),
           tensor_map (unitor2 A) id(B) ≈
           tensor_map id(A) (unitor1 B) ∘ associator A 1 B.

Proof (@Monoidal.unitor_triangle _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma assoc_pentagon (X:monoidal) : forall (A B C D:ob X),
            associator A B (C⊗D)
            ∘
            associator (A⊗B) C D
            ≈
            tensor_map id(A) (associator B C D)
            ∘
            associator A (B⊗C) D
            ∘
            tensor_map (associator A B C) id(D).

Proof (@Monoidal.assoc_pentagon _ _ _ _ _ _ _ _ _ _ _
          (@Monoidal.monoidal_axioms _ _ _ _ _ (Monoidal.mixin X))).

Lemma kelly1 (X:monoidal) (A B:ob X) :
  unitor1 (A⊗B) ∘ associator 1 A B ≈ tensor_map (unitor1 A) id(B).
Admitted.

Lemma kelly2 (X:monoidal) (A B:ob X) :
  tensor_map id(A) (unitor2 B) ∘ associator A B 1 ≈ unitor2 (A⊗B).
Admitted.

Lemma kelly3 (X:monoidal) : @unitor1 X 1 ≈ @unitor2 X 1.
Admitted.

Module Enriched.
Section Enriched.
  Variable M:monoidal.

  Notation α := (@associator M _ _ _).
  Notation ρ := (@unitor1 M _).
  Notation λ := (@unitor2 M _).
  Notation "f ⋆ g" := (tensor_map f g)
    (at level 37, left associativity).

  Section axioms.
    Variable Ob:Type.
    Variable Hom:Ob -> Ob -> M.
    Variable compose : forall (A B C:Ob), Hom B C ⊗ Hom A B → Hom A C.
    Variable identity : forall (A:Ob), 1 → Hom A A.

    Record axioms :=
    Axioms
    { compose_assoc : forall (A B C D:Ob),
           compose A B D ∘ (compose B C D ⋆ id(Hom A B))
           ≈
           compose A C D ∘ (id(Hom C D) ⋆ compose A B C) ∘ α

    ; compose_unital1 : forall (A B:Ob),
           ρ ≈ compose A B B ∘ (identity B ⋆ id(Hom A B))

    ; compose_unital2 : forall (A B:Ob),
           λ ≈ compose A A B ∘ (id(Hom A B) ⋆ identity A)
    }.
  End axioms.

  Record enriched :=
  Enriched
  { Ob :> Type
  ; Hom : Ob -> Ob -> M
  ; compose : forall (A B C:Ob), Hom B C ⊗ Hom A B → Hom A C
  ; identity : forall (A:Ob), 1 → Hom A A
  ; enriched_axioms : axioms Ob Hom compose identity
  }.
  Notation comp E := (compose E _ _ _).

  Lemma compose_assoc' (X:enriched) (Z1 Z2:M) (A B C D:Ob X) (f:Z1 → _) (g: Z2 → _) :
    compose X A B D ∘ ((compose X B C D ∘ g) ⋆ f) ≈
    compose X A C D ∘ (id ⋆ compose X A B C) ∘ α ∘ (g ⋆ f).
  Proof.
    transitivity (comp X ∘ (comp X ⋆ id) ∘ (g ⋆ f)).
    rewrite <- (cat_assoc M).
    rewrite (tensor_map_compose M).
    rewrite (cat_ident2 M). auto.
    rewrite (compose_assoc X); auto. apply enriched_axioms.
  Qed.

  Record functor (X Y:enriched) :=
  Functor
  { ob_map :> Ob X -> Ob Y
  ; hom_map : forall (A B:Ob X), Hom X A B → Hom Y (ob_map A) (ob_map B)

  ; respect_compose : forall (A B C:Ob X),
        hom_map A C ∘ comp X ≈ comp Y ∘ (hom_map B C ⋆ hom_map A B)

  ; respect_units : forall (A:Ob X),
        hom_map A A ∘ identity X A ≈ identity Y (ob_map A)
  }.
  Arguments hom_map [X Y] f A B.

  Program Definition FunctorCompose (X Y Z:enriched) (F:functor Y Z) (G:functor X Y) :=
    Functor X Z
      (fun A => F (G A))
      (fun A B => hom_map F (G A) (G B) ∘ hom_map G A B)
      _ _.
  Next Obligation.
    rewrite <- (cat_assoc M).
    rewrite (respect_compose _ _ G).
    rewrite (cat_assoc M).
    rewrite (respect_compose _ _ F).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    apply (tensor_map_compose M).
  Qed.
  Next Obligation.
    rewrite <- (cat_assoc M).
    rewrite respect_units. apply respect_units.
  Qed.

  Program Definition FunctorIdent (X:enriched) :=
    Functor X X
      (fun A => A)
      (fun A B => id(Hom X A B))
      _ _.
  Next Obligation.
    etransitivity.
    apply cat_ident2.
    rewrite tensor_map_id.
    symmetry. apply cat_ident1.
  Qed.
  Next Obligation.
    apply cat_ident2.
  Qed.

  Definition functor_comp :=
    Comp.Mixin enriched functor FunctorIdent FunctorCompose.

  Record nt (X Y:enriched) (F G:functor X Y) :=
  NT
  { transform :> forall A:Ob X, 1 → Hom Y (F A) (G A)
  ; nt_axiom : forall (A B:Ob X),
       comp Y ∘ (hom_map G A B ⋆ transform A) ∘ λ⁻¹
       ≈
       comp Y ∘ (transform B ⋆ hom_map F A B) ∘ ρ⁻¹
  }.

Check unitor1_natural.

  Lemma unitor1_natural' (A B:M) (x:A → B) :
    id ⋆ x ∘ ρ⁻¹ ≈ iso_hom (ρ⁻¹) ∘ x.
  Proof.
    transitivity (iso_hom ρ⁻¹ ∘ (x ∘ ρ) ∘ ρ⁻¹).
    rewrite <- (unitor1_natural M).
    rewrite (cat_assoc M).
    simpl.
    rewrite (iso_axiom1 ρ). rewrite (cat_ident2 M); auto.
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    simpl.
    rewrite (cat_assoc M).
    transitivity (iso_inv ρ ∘ x ∘ id).
    apply cat_respects. auto.
    apply (iso_axiom2 ρ).
    apply cat_ident1.
  Qed.

  Lemma unitor2_natural' (A B:M) (x:A → B) :
    x ⋆ id ∘ λ⁻¹ ≈ iso_hom (λ⁻¹) ∘ x.
  Admitted.

  Lemma unitor_lemma1 : λ ∘ ρ⁻¹ ≈ id.
  Proof.
    rewrite <- (kelly3 M). apply (iso_axiom2 ρ).
  Qed.

  Lemma unitor_lemma2 (A:ob M) :
    id ⋆ λ⁻¹ ∘ ρ⁻¹ ≈ associator 1 A 1 ∘ (ρ⁻¹ ⋆ id ∘ λ⁻¹).
  Proof.
    rewrite (unitor2_natural').
    rewrite (unitor1_natural').

    cut (ρ ∘ ρ⁻¹ ∘ λ⁻¹ ≈ ρ ∘ associator 1 A 1 ∘ (λ⁻¹ ∘ ρ⁻¹)).
    intros.
    assert
      (iso_hom ρ⁻¹ ∘ (ρ ∘ ρ⁻¹ ∘ λ⁻¹)
        ≈ iso_hom ρ⁻¹ ∘ (ρ ∘ associator 1 A 1 ∘ (λ⁻¹ ∘ ρ⁻¹))).
    rewrite H. auto.
    rewrite (cat_assoc M) in H0.
    rewrite (cat_assoc M) in H0.
    rewrite (cat_assoc M) in H0.
    rewrite (cat_assoc M) in H0.
    simpl in H0.
    etransitivity.
    etransitivity.
    2: apply H0.
    symmetry.
    etransitivity.
    rewrite <- (cat_assoc M).
    apply cat_respects.
    apply (iso_axiom1 ρ).
    reflexivity.
    apply (cat_ident2 M).
    apply cat_respects; auto.
    etransitivity.
    apply cat_respects.
    apply (iso_axiom1 ρ).
    reflexivity.
    apply cat_ident2.

    rewrite (kelly1 M A 1).
    symmetry.
    etransitivity. apply cat_assoc.
    rewrite unitor2_natural'.
    etransitivity. symmetry. apply cat_assoc.
    etransitivity. apply cat_respects. reflexivity.
    apply iso_axiom2.
    rewrite (cat_ident1 M).
    symmetry.
    etransitivity. apply cat_respects.
    apply iso_axiom2. reflexivity.
    apply cat_ident2.
  Qed.

  Lemma unitor_lemma3 (A B:M) :
    associator A 1 B ∘ λ⁻¹ ⋆ id ≈ id ⋆ ρ⁻¹.
  Proof.
    cut (id ⋆ ρ ∘ iso_hom (associator A 1 B) ∘ λ⁻¹ ⋆ id
          ≈ id ⋆ ρ ∘ id ⋆ ρ⁻¹).
    intros.
    transitivity
      (id ⋆ ρ⁻¹ ∘ (id ⋆ ρ ∘ associator A 1 B ∘ λ⁻¹ ⋆ id)).
    rewrite (cat_assoc M).
    rewrite (cat_assoc M).
    rewrite (tensor_map_compose M).
    etransitivity.
    symmetry. apply (cat_ident2 M).
    rewrite <- (cat_assoc M).
    apply cat_respects.
    etransitivity.
    symmetry. apply tensor_map_id.
    apply tensor_map_respects.
    symmetry. apply cat_ident1.
    symmetry. apply iso_axiom1.
    auto.
    rewrite H.
    etransitivity.
    apply cat_respects. reflexivity.
    rewrite tensor_map_compose.
    apply tensor_map_respects.
    apply cat_ident1.
    apply iso_axiom2.
    etransitivity.
    apply cat_respects. reflexivity.
    apply tensor_map_id.
    rewrite (cat_ident1 M). auto.

    rewrite <- (unitor_triangle M A B).
    rewrite tensor_map_compose.
    rewrite tensor_map_compose.
    apply tensor_map_respects.
    rewrite (cat_ident1 M).
    apply iso_axiom2.
    rewrite (cat_ident1 M).
    symmetry.
    apply iso_axiom2.
  Qed.

  Program Definition nt_compose (X Y:enriched) (F G H:functor X Y)
    (x:nt X Y G H) (y:nt X Y F G) : nt X Y F H :=

    NT X Y F H (fun A => comp Y ∘ (x A ⋆ y A) ∘ ρ⁻¹) _.
  Next Obligation.
    symmetry.
    rewrite <- (cat_assoc M _ _ _ _ (comp Y) (x B ⋆ y B) (iso_inv ρ)).
    rewrite (compose_assoc' Y).
    transitivity (comp Y ∘ id ⋆ comp Y ∘ α ∘ (x B ⋆ y B) ⋆ hom_map F A B
      ∘ ρ⁻¹ ⋆ id ∘ ρ⁻¹).
    apply cat_respects; auto.
    repeat rewrite <- (cat_assoc M).
    apply cat_respects; auto.
    apply cat_respects; auto.
    apply cat_respects; auto.
    rewrite (tensor_map_compose M).
    apply tensor_map_respects; auto.
    symmetry. apply cat_ident1; auto.

    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite (cat_assoc M _ _ _ _ α).
    rewrite (assoc_natural M).

    transitivity (comp Y ∘ x B ⋆ (comp Y ∘ y B ⋆ hom_map F A B ∘ ρ⁻¹) ∘ ρ⁻¹).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    apply cat_respects; auto.
    rewrite (cat_assoc M).
    rewrite (tensor_map_compose M).
    rewrite (cat_ident2 M).
    transitivity (x B ⋆ (comp Y ∘ y B ⋆ hom_map F A B) ∘
                ((id ⋆ ρ⁻¹) ∘ (id ⋆ ρ)) ∘ α ∘ (ρ⁻¹ ⋆ id ∘ ρ⁻¹)).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    symmetry.
    rewrite (tensor_map_compose M).
    rewrite (cat_ident2 M).
    etransitivity. apply cat_respects.
    simpl. rewrite (iso_axiom1 ρ).
    apply (tensor_map_id M). reflexivity.
    rewrite (cat_ident2 M). auto.
    rewrite (cat_assoc M).
    rewrite (cat_assoc M).
    rewrite (tensor_map_compose M).
    rewrite (cat_ident1 M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    rewrite (cat_assoc M).
    rewrite <- (unitor_triangle M).
    rewrite (cat_assoc M).
    rewrite (tensor_map_compose M).
    etransitivity. apply cat_respects. 2: reflexivity.
    apply tensor_map_respects. 2: apply cat_ident1.
    instantiate (1:=id).
    apply unitor_lemma1.

    etransitivity. apply cat_respects.
    apply (tensor_map_id M). reflexivity.
    apply cat_ident2.
    rewrite <- (nt_axiom _ _ _ _ y).
    transitivity
       (comp Y ∘ x B ⋆ (comp Y ∘ hom_map G A B ⋆ y A)
         ∘ id ⋆ λ⁻¹ ∘ ρ⁻¹).
    symmetry.
    rewrite <- (cat_assoc M _ _ _ _ (comp Y)).
    rewrite (tensor_map_compose M).
    rewrite (cat_ident1 M).
    auto.
    transitivity
       (comp Y ∘ x B ⋆ (comp Y ∘ hom_map G A B ⋆ y A) ∘
         α ∘ ρ⁻¹ ⋆ id ∘ λ⁻¹).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    apply cat_respects. auto.
    apply unitor_lemma2.
    transitivity
      (comp Y ∘ id ⋆ comp Y ∘ α ∘ (x B ⋆ hom_map G A B ⋆ y A)
        ∘ ρ⁻¹ ⋆ id ∘ λ⁻¹).
    apply cat_respects; auto.
    apply cat_respects; auto.
    symmetry.
    rewrite <- (cat_assoc M).
    rewrite (assoc_natural M _ _ _ _ _ _ (x B)).
    rewrite <- (cat_assoc M).
    rewrite (cat_assoc M _ _ _ _ (id ⋆ comp Y)).
    rewrite (tensor_map_compose M).
    rewrite (cat_ident2 M).
    rewrite (cat_assoc M).
    auto.
    rewrite <- (compose_assoc). 2: apply enriched_axioms.
    apply cat_respects. 2: auto.
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite (tensor_map_compose M).
    rewrite (tensor_map_compose M).
    rewrite (cat_assoc M).
    rewrite <- (nt_axiom _ _ _ _ x A B).
    rewrite (cat_ident1 M).
    rewrite (cat_ident2 M).
    rewrite <- (cat_assoc M).
    rewrite (compose_assoc' Y).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    transitivity
      (id ⋆ comp Y ∘ (α ∘ (hom_map H A B ⋆ x A) ⋆ y A) ∘ (λ⁻¹) ⋆ id).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    rewrite (tensor_map_compose M).
    rewrite (cat_ident1 M). auto.
    rewrite (assoc_natural M).
    rewrite (cat_assoc M).
    rewrite (cat_assoc M).
    rewrite (tensor_map_compose M).
    rewrite (cat_ident2 M).
    transitivity
      (hom_map H A B ⋆ (comp Y ∘ x A ⋆ y A) ∘ id ⋆ ρ⁻¹).
    rewrite <- (cat_assoc M).
    apply cat_respects. auto.
    apply unitor_lemma3.

    rewrite (tensor_map_compose M).
    rewrite (cat_ident1 M).
    auto.
  Qed.

End Enriched.
End Enriched.

Notation enriched := Enriched.enriched.
Notation Enriched := Enriched.Enriched.


Set Implicit Arguments.

Require Import List.

Section NEList.

  Variable A:Type.

  Definition nelist := (A * list A)%type.

  Definition single x : nelist := (x, nil).

  Definition append (l1 l2: nelist) : nelist :=
    let (x, xs) := l1 in
    let (y, ys) := l2 in
    (x, xs ++ cons y ys).

  Definition hd (l:nelist) : A :=
    let (x, _) := l in x.

  Definition tl (l:nelist) : list A :=
    let (_, xs) := l in xs.

End NEList.


Require Import Lia.
Require Export DFA.

(* The pigeonhole principle *)
Lemma pigeonhole {X} (l1 l2 : list X) :
  (forall x1 x2 : X, {x1 = x2} + {x1 <> x2}) ->
  (forall x, In x l2 -> In x l1) -> length l2 > length l1 ->
  exists l2a l2b l2c y, l2 = l2a ++ [y] ++ l2b ++ [y] ++ l2c.
Proof.
  intro eq_dec; revert l1; induction l2 as [|y l2 IH]; intros l1 H H0.
  - simpl in H0; nia.
  - destruct l1 as [|x l1].
    destruct (H y); left; auto.
    destruct (in_dec eq_dec y l2) as [H1|H1].
    + apply in_split in H1; destruct H1 as [l2a [l2b H1]]; subst;
      exists nil, l2a, l2b, y; auto.
    + assert (H2: In y (x::l1)). apply H; left; auto.
      apply in_split in H2; destruct H2 as [l1a [l1b H2]];
      destruct IH with (l1a ++ l1b) as [l2a [l2b [l2c [z H4]]]].
      * intros z H3; apply in_or_app; rewrite H2 in H; specialize (H z);
        assert (H4: In z (l1a ++ y :: l1b)). apply H; right; auto.
        apply in_app_or in H4; destruct H4 as [H4|H4].
        left; auto.
        destruct H4 as [H4|H4].
        subst; contradiction.
        right; auto.
      * assert (H3: length l1 = length (l1a ++ l1b)). {
          rewrite app_length; assert (H3: length ([x] ++ l1) = length (l1a ++ [y] ++ l1b)).
            simpl ([x] ++ l1); rewrite H2; auto.
          rewrite app_length, app_length, app_length in H3; simpl in H3; nia.
        }
        simpl in H0; rewrite app_length; rewrite app_length in H3; nia.
      * exists (y::l2a), l2b, l2c, z; subst; auto.
Qed.

Section Pumping.

Context {State Symbol : Type}.
Definition Word := @Word Symbol.
Hypothesis State_eq_dec : forall (x1 x2:State), { x1 = x2 } + { x1 <> x2 }.
Hypothesis Symbol_eq_dec : forall (x1 x2:Symbol), { x1 = x2 } + { x1 <> x2 }.
Definition NFA := @NFA State Symbol.
Definition transitionf := transitionf State_eq_dec Symbol_eq_dec.
Definition nfa_accepts := nfa_accepts State_eq_dec Symbol_eq_dec.
Definition reachable_state := reachable_state State_eq_dec Symbol_eq_dec.

(* We need a definition of path with history *)
Inductive path' (g:NFA) : list State->list Symbol->Prop :=
  | path'_nil q : path' g [q] nil
  | path'_trans p q1 q2 w a : In (transition q1 a q2) g -> path' g (q2::p) w ->
    path' g (q1::q2::p) (a::w).

(* It is equivalent to the former *)
Lemma path'_correct g q1 q2 w :
  w <> nil ->
  path g q1 q2 w <-> exists l, path' g (q1::l ++ [q2]) w.
Proof.
  intro H; split; intro H0.
  - induction H0.
    intuition.
    destruct w as [|b w].
    + inversion H1; subst.
      exists nil; simpl.
      apply path'_trans.
      intuition.
      constructor.
    + assert (H2: b::w <> nil).
      intro H2; discriminate.
      apply IHpath in H2; clear IHpath.
      destruct H2 as [l H2].
      exists (q2::l); simpl.
      apply path'_trans; intuition.
  - destruct H0 as [l H0];
    generalize dependent q1;
    generalize dependent l;
    induction w as [|a w IH];
    intros l q1 H0.
    intuition.
    destruct w as [|b w].
    + inversion H0; subst.
      inversion H6; subst.
      destruct l.
      2: destruct l; discriminate.
      simpl in H2; injection H2; intros; subst.
      apply path_trans with q2.
      intuition.
      constructor.
    + inversion H0; subst.
      destruct l; simpl in *.
      * destruct p.
        2: discriminate.
        inversion H0;
        inversion H10.
      * injection H2; intros; subst.
        apply IH in H6.
        2: intro conta; discriminate.
        apply path_trans with s; intuition.
Qed.

(* The history length is equal to the word length plus one *)
Lemma path'_length g l w :
  path' g l w -> length l = S (length w).
Proof.
  intro H; induction H.
  intuition.
  simpl in *; nia.
Qed.

(* All terms in the history are states *)
Lemma path'_in_states g l w :
  w <> nil -> path' g l w -> (forall q, In q l -> In q (states g)).
Proof.
  intros H H0.
  induction H0.
  intuition.
  destruct w as [|b w].
  - inversion H1; subst.
    apply transition_states_alphabet in H0.
    intros q [H2|H2].
    2: apply in_singleton in H2.
    1,2: subst; intuition.
  - intros q [H3|H3].
    subst; apply transition_states_alphabet in H0; intuition.
    apply IHpath' in H3.
    intuition.
    intro contra; discriminate.
Qed.

(* We can decompose the path' *)
Lemma app_path' g l1 q l2 w :
  path' g (l1 ++ [q] ++ l2) w -> exists w1 w2, w = w1 ++ w2 /\ path' g (l1 ++ [q]) w1 /\
  path' g (q::l2) w2.
Proof.
  generalize dependent w;
  induction l1 as [|q1 l1 IH];
  intros w H.
  exists nil, w; split.
  intuition.
  split.
  constructor.
  intuition.
  inversion H; subst.
  destruct l1; discriminate.
  rewrite H1 in H4.
  apply IH in H4; destruct H4 as [w1 [w2 [H4 [H5 H6]]]].
  exists (a::w1), w2; split.
  simpl; rewrite H4; intuition.
  split.
  destruct l1 as [|q0 l1]; injection H1; intros; subst.
  apply path'_trans; intuition.
  simpl; apply path'_trans; intuition.
  intuition.
Qed.

(* And compose *)
Lemma path'_app g l1 q l2 w1 w2 :
  path' g (l1 ++ [q]) w1 ->
  path' g (q::l2) w2 ->
  path' g (l1 ++ [q] ++ l2) (w1 ++ w2).
Proof.
  intros H H0;
  generalize dependent w1;
  induction l1 as [|q1 l1 IH];
  intros w1 H.
  inversion H; subst; intuition.
  inversion H; subst.
  destruct l1; discriminate.
  rewrite H2 in H5; apply IH in H5.
  destruct l1 as [|q0 l1];
  injection H2; intros; subst;
  simpl; apply path'_trans; intuition.
Qed.

(** Pumping lemma: **)

(*
  For every path, there's another path from and to the same states through a word
  whose length is less or qual to the number of states
*)
Lemma pumping' g q1 l q2 w :
  q1 <> q2 ->
  path' g (q1::l ++ [q2]) w ->
  exists l' w', path' g (q1::l' ++ [q2]) w' /\
  length w' <= length (states g).
Proof.
  generalize dependent q1;
  generalize dependent l;
  induction w as [|a w IH];
  intros l q1 H H0. {
    apply path'_length in H0;
    simpl in H0; rewrite app_length in H0;
    simpl in H0; nia.
  }
  inversion H0; subst.
  destruct l as [|q3' l].
  - simpl in H2; injection H2; intros; subst.
    exists nil, [a].
    simpl; split.
    apply path'_trans.
    intuition.
    constructor.
    apply transition_states_alphabet in H4; destruct H4 as [H4 _];
    apply in_split in H4; destruct H4 as [l1 [l2 H4]]; rewrite H4;
    destruct l1; simpl; nia.
  - injection H2; intros; subst; clear H2.
    destruct (State_eq_dec q3' q2) as [H2|H2].
    subst; exists nil, [a]; split.
    simpl; apply path'_trans.
    intuition.
    constructor.
    apply transition_states_alphabet in H4; destruct H4 as [H4 _];
    apply in_split in H4; destruct H4 as [l1 [l2 H4]]; rewrite H4;
    destruct l1; simpl; nia.
    apply IH in H6.
    2: intuition.
    destruct H6 as [l' [w' [H6 H7]]].
    destruct (Compare_dec.le_gt_dec (length (a::w')) (length (states g))).
    exists (q3'::l'), (a::w'); split.
    simpl; apply path'_trans.
    1-3: intuition.
    clear IH; assert (path' g (q1 :: q3' :: l' ++ [q2]) (a::w')).
    apply path'_trans; intuition.
    assert (exists l2a l2b l2c y, q1 :: q3' :: l' ++ [q2] = l2a ++ [y] ++ l2b ++ [y] ++ l2c).
    apply pigeonhole with (states g).
    intuition.
    apply path'_in_states with (a :: w').
    intro contra; discriminate.
    intuition.
    apply path'_length in H1.
    simpl in *; nia.
    destruct H3 as [l1 [l2 [l3 [q H3]]]]; rewrite H3 in H1.
    apply app_path' in H1; destruct H1 as [w1 [w2 [H1 [H8 H9]]]].
    replace (q :: l2 ++ [q] ++ l3) with ((q :: l2) ++ [q] ++ l3) in H9.
    2: intuition.
    apply app_path' in H9; destruct H9 as [w2' [w3 [H9 [H10 H11]]]].
    assert (path' g (l1 ++ [q] ++ l3) (w1 ++ w3)).
    apply path'_app; intuition.
    destruct l1 as [|q'' l1]; destruct l3 as [|q' l3 _] using rev_ind;
    subst; simpl in *; injection H3; intros; subst.
    + replace (q3' :: l' ++ [q2]) with ((q3' :: l') ++ [q2]) in H9.
      2: intuition.
      apply app_inj_tail in H9; destruct H9; subst.
      destruct H; intuition.
    + replace (q3' :: l' ++ [q2]) with ((q3' :: l') ++ [q2]) in H9.
      replace (l2 ++ q :: l3 ++ [q']) with ((l2 ++ q :: l3) ++ [q']) in H9.
      2,3: repeat rewrite <- app_assoc; intuition.
      apply app_inj_tail in H9; destruct H9; subst.
      exists l3, (w1 ++ w3); split.
      intuition.
      rewrite app_length.
      assert (length (w1 ++ w2' ++ w3) <= S (length (states g))).
      rewrite <- H1; simpl; nia.
      repeat rewrite app_length in H12.
      apply path'_length in H10.
      simpl in H10; rewrite app_length in H10.
      simpl in *; nia.
    + replace (q3' :: l' ++ [q2]) with ((q3' :: l') ++ [q2]) in H9.
      replace (l1 ++ q :: l2 ++ [q]) with ((l1 ++ q :: l2) ++ [q]) in H9.
      2,3: repeat rewrite <- app_assoc; intuition.
      apply app_inj_tail in H9; destruct H9; subst.
      exists l1, (w1 ++ w3); split.
      intuition.
      rewrite app_length.
      assert (length (w1 ++ w2' ++ w3) <= S (length (states g))).
      rewrite <- H1; simpl; nia.
      repeat rewrite app_length in H12.
      apply path'_length in H10.
      simpl in H10; rewrite app_length in H10.
      simpl in *; nia.
    + replace (q3' :: l' ++ [q2]) with ((q3' :: l') ++ [q2]) in H9.
      replace (l1 ++ q :: l2 ++ q :: l3 ++ [q']) with ((l1 ++ q :: l2 ++ q :: l3) ++ [q']) in H9.
      apply app_inj_tail in H9; destruct H9; subst.
      exists (l1 ++ q :: l3), (w1 ++ w3); split.
      rewrite <- app_assoc; intuition.
      2,3: repeat (rewrite <- app_assoc; simpl); intuition.
      rewrite app_length.
      assert (length (w1 ++ w2' ++ w3) <= S (length (states g))).
      rewrite <- H1; simpl; nia.
      repeat rewrite app_length in H12.
      apply path'_length in H10.
      simpl in H10; rewrite app_length in H10.
      simpl in *; nia.
Qed.

Lemma pumping (g:NFA) q1 q2 w :
  path g q1 q2 w ->
  exists w', path g q1 q2 w' /\
  length w' <= length (states g).
Proof.
  intro H; destruct w as [|a w].
  - inversion H; subst.
    exists nil; split.
    intuition.
    simpl; nia.
  - apply path'_correct in H.
    2: intro contra; discriminate.
    destruct H as [l H].
    destruct (State_eq_dec q1 q2) as [H0|H0].
    subst; exists nil; split; try constructor; simpl; nia.
    apply pumping' in H.
    2: intuition.
    destruct H as [l' [w' [H H1]]].
    exists w'; split.
    2: intuition.
    inversion H; subst.
    destruct l'; discriminate.
    apply path'_correct.
    intro contra; discriminate.
    exists l'; intuition.
Qed.

(* Decides whether there's a path from q1 to q2 with length n *)
Fixpoint is_reachableb g q1 q2 n :=
  if State_eq_dec q1 q2 then true
  else
    match n with
    | 0 => false
    | S n => existsb (fun q3 => is_reachableb g q3 q2 n) (flat_map (fun a => transitionf g [q1] a) (alphabet g))
    end.

(* The function is correct *)
Lemma is_reachableb_correct g q1 q2 n :
  is_reachableb g q1 q2 n = true <-> exists w, length w <= n /\ path g q1 q2 w.
Proof.
  split; intro H.
  - generalize dependent q1;
    induction n as [|n IH];
    intros q1 H; simpl in H;
    destruct (State_eq_dec q1 q2) as [H0|H0].
    1,3: subst; exists nil; split; constructor.
    apply le_0_n.
    discriminate.
    apply existsb_exists in H; destruct H as [q3 [H H1]].
    apply IH in H1; clear IH; destruct H1 as [w [H1 H2]].
    apply in_flat_map in H; destruct H as [a [H H3]].
    exists (a::w); split.
    simpl; nia.
    apply path_trans with q3.
    apply transition_transitionf in H3.
    1,2: intuition.
  - destruct H as [w [H H0]].
    generalize dependent n;
    induction H0;
    intros [|n] H1.
    1,2: simpl; destruct (State_eq_dec q q) as [H|H]; intuition.
    simpl in H1; nia.
    simpl; simpl in H1.
    destruct (State_eq_dec q1 q3) as [H2|H2].
    intuition.
    apply existsb_exists; exists q2; split.
    apply in_flat_map; exists a; split.
    apply transition_states_alphabet in H; intuition.
    apply transition_transitionf; intuition.
    apply IHpath; nia.
Qed.

(* Reachable state decider *)
Lemma reachable_state_dec (g:NFA) :
  forall q, {reachable_state g q} + {~reachable_state g q}.
Proof.
  intro q.
  assert ({ exists q0, In q0 (start_states g) /\ is_reachableb g q0 q (length (states g)) = true } +
  { ~ exists q0, In q0 (start_states g) /\ is_reachableb g q0 q (length (states g)) = true }).
  2: {
    destruct H as [H|H].
    - left; destruct H as [q0 [H H0]].
      apply is_reachableb_correct in H0.
      destruct H0 as [w [H0 H1]].
      exists w; apply ext_transitionf_generalize with q0.
      2: apply path_ext_transitionf.
      1,2: intuition.
    - right; intros [w H0]; apply H; clear H.
      apply ext_transitionf_singleton in H0.
      destruct H0 as [q0 [H0 H1]]; exists q0; split.
      intuition.
      apply path_ext_transitionf, pumping in H1.
      clear w; destruct H1 as [w [H1 H2]].
      apply is_reachableb_correct; exists w; intuition.
  }
  generalize dependent (length (states g)); intro n;
  induction (start_states g) as [|q0 s IH].
  simpl; right; intros [q0 [[] _]].
  destruct IH as [H|H].
  left; destruct H as [q1 [H H0]]; exists q1; intuition.
  destruct (is_reachableb g q0 q n) eqn:H0.
  left; exists q0; intuition.
  right; intros [q1 [H1 H2]].
  apply H; clear H.
  destruct H1.
  subst; rewrite H0 in H2; discriminate.
  exists q1; intuition.
Qed.

(* Remove the unreachable states of a NFA *)
Fixpoint remove_unreachable_states' (g cp:NFA) :=
  match g with
  | state q::g => (
    if reachable_state_dec cp q then [state q] else []
  ) ++ remove_unreachable_states' g cp
  | start q::g => (
    if reachable_state_dec cp q then [start q] else []
  ) ++ remove_unreachable_states' g cp
  | accept q::g => (
    if reachable_state_dec cp q then [accept q] else []
  ) ++ remove_unreachable_states' g cp
  | transition q1 a q2::g => (
    if reachable_state_dec cp q1 then [transition q1 a q2] else []
  ) ++ remove_unreachable_states' g cp
  | x::g => x::remove_unreachable_states' g cp
  | nil => nil
  end.

Definition remove_unreachable_states g := remove_unreachable_states' g g.

(* The resulting states are in the original NFA *)
Lemma remove_unreachable_states'_states g cp q :
  In q (states (remove_unreachable_states' g cp)) ->
  In q (states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  2: intuition.
  - simpl in H; apply in_states_app in H.
    destruct H.
    destruct (reachable_state_dec cp q0).
    destruct H.
    2,3: contradiction.
    simpl; left; intuition.
    right; apply IH, H.
  (* same code from above: *)
  - simpl in H; apply in_states_app in H.
    destruct H.
    destruct (reachable_state_dec cp q0).
    destruct H.
    2,3: contradiction.
    simpl; left; intuition.
    right; apply IH, H.
  (* same code from above: *)
  - simpl in H; apply in_states_app in H.
    destruct H.
    destruct (reachable_state_dec cp q0).
    destruct H.
    2,3: contradiction.
    simpl; left; intuition.
    right; apply IH, H.
  - simpl in H; apply in_states_app in H.
    destruct H.
    destruct (reachable_state_dec cp q1).
    simpl in H; destruct H.
    2: destruct H.
    left; intuition.
    right; left; intuition.
    1,2: contradiction.
    right; right; intuition.
Qed.

Lemma remove_unreachable_states_states g q :
  In q (states (remove_unreachable_states g)) ->
  In q (states g).
Proof.
  apply remove_unreachable_states'_states.
Qed.

(*
  All states in remove_unreachable_states' g cp are reachable
  in the original NFA if g is subset of cp
*)
Lemma remove_unreachable_states'_reachable_state g cp q :
  (subset NFA_comp g cp) ->
  In q (states (remove_unreachable_states' g cp)) ->
  reachable_state cp q.
Proof.
  intros H H0.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  5: {
    simpl in H, H0; apply in_states_app in H0.
    destruct H0. {
      destruct (reachable_state_dec cp q1) as [H1|H1].
      2: contradiction.
      simpl in H0; destruct H0.
      subst; intuition.
      destruct H0; subst.
      2: contradiction.
      destruct H1 as [w H1].
      exists (w ++ [a]); rewrite ext_transitionf_app.
      assert (In q (transitionf cp [q1] a)).
      2: apply ext_transitionf_generalize with q1; intuition.
      apply transition_transitionf, H; intuition.
    }
    apply IH.
    2: intuition.
    intros c H1.
    apply H; intuition.
  }
  2: apply IH; try (intros c H2; apply H); intuition.
  - simpl in H0; destruct (reachable_state_dec cp q0).
    destruct H0.
    subst; intuition.
    1,2: apply IH; try (intros c H2; apply H); intuition.
  (* same code from above: *)
  - simpl in H0; destruct (reachable_state_dec cp q0).
    destruct H0.
    subst; intuition.
    1,2: apply IH; try (intros c H2; apply H); intuition.
  (* same code from above: *)
  - simpl in H0; destruct (reachable_state_dec cp q0).
    destruct H0.
    subst; intuition.
    1,2: apply IH; try (intros c H2; apply H); intuition.
Qed.

(* The resulting start states are the same *)
Lemma remove_unreachable_states'_start_states g cp :
  (subset NFA_comp g cp) ->
  start_states (remove_unreachable_states' g cp) = start_states g.
Proof.
  intro H.
  induction g as [|c g IH].
  intuition.
  destruct c.
  1,4: simpl; destruct (reachable_state_dec cp q);
  simpl; apply IH; intros c H2; apply H; intuition.
  simpl; apply IH; intros c H2; apply H; intuition.
  2: simpl; destruct (reachable_state_dec cp q1);
  simpl; apply IH; intros c H2; apply H; intuition.
  simpl.
  assert (reachable_state cp q).
  2: {
    destruct (reachable_state_dec cp q).
    simpl; rewrite IH.
    intuition.
    intros c H2; apply H; intuition.
    contradiction.
  }
  exists nil; simpl; apply in_start_states.
  apply H; intuition.
Qed.

Lemma remove_unreachable_states_start_states g :
  start_states (remove_unreachable_states g) = start_states g.
Proof.
  apply remove_unreachable_states'_start_states, subset_self.
Qed.

(* The resulting accept states are in the original NFA *)
Lemma remove_unreachable_states'_accept_states g cp q :
  In q (accept_states (remove_unreachable_states' g cp)) ->
  In q (accept_states g).
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1-3: apply IH, in_accept_states; intuition;
  simpl in H; apply in_accept_states in H; intuition;
  destruct (reachable_state_dec cp q0); intuition;
  destruct H; try discriminate; intuition.
  2: apply IH, in_accept_states; intuition;
  simpl in H; apply in_accept_states in H; intuition;
  destruct (reachable_state_dec cp q1); intuition;
  destruct H; try discriminate; intuition.
  simpl in H; destruct (reachable_state_dec cp q0).
  destruct H.
  subst; left.
  2,3: right.
  1-3: intuition.
Qed.

Lemma remove_unreachable_states_accept_states g q :
  In q (accept_states (remove_unreachable_states g)) ->
  In q (accept_states g).
Proof.
  apply remove_unreachable_states'_accept_states.
Qed.

(*
  If an original accept state is in the resulting NFA,
  then it is a resulting accept state.
*)
Lemma remove_unreachable_states'_has_accept_state g cp q :
  (subset NFA_comp g cp) ->
  In q (states (remove_unreachable_states' g cp)) ->
  In q (accept_states g) ->
  In q (accept_states (remove_unreachable_states' g cp)).
Proof.
  intros H10 H H0.
  apply remove_unreachable_states'_reachable_state in H.
  2: intuition.
  clear H10.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  2: destruct H; try discriminate; intuition.
  1-2,4: destruct H; try discriminate; simpl;
  destruct (reachable_state_dec cp q);
  apply in_accept_states_app; intuition.
  simpl; simpl in H0; destruct H0.
  subst; destruct (reachable_state_dec cp q).
  left; intuition.
  contradiction.
  apply in_accept_states_app; intuition.
Qed.

Lemma remove_unreachable_states_has_accept_state g q :
  In q (states (remove_unreachable_states g)) ->
  In q (accept_states g) ->
  In q (accept_states (remove_unreachable_states g)).
Proof.
  apply remove_unreachable_states'_has_accept_state, subset_self.
Qed.

(* The resulting transitions are in the original NFA *)
Lemma remove_unreachable_states'_transitions1 g cp q1 a q2 :
  In (transition q1 a q2) (remove_unreachable_states' g cp) ->
  In (transition q1 a q2) g.
Proof.
  intro H.
  induction g as [|c g IH].
  contradiction.
  destruct c.
  1,3,4: simpl in H; destruct (reachable_state_dec cp q); intuition;
  destruct H; try discriminate; intuition.
  right; destruct H; try discriminate; intuition.
  simpl in H; destruct (reachable_state_dec cp q0).
  destruct H.
  2,3: right; intuition.
  injection H; intros; subst;
  left; intuition.
Qed.

Lemma remove_unreachable_states_transitions1 g q1 a q2 :
  In (transition q1 a q2) (remove_unreachable_states g) ->
  In (transition q1 a q2) g.
Proof.
  apply remove_unreachable_states'_transitions1.
Qed.

(*
  If a transition from a resulting state exists in the original NFA,
  then the transition is maintained.
*)
Lemma remove_unreachable_states'_transitions2 g cp q1 a q2 :
  (subset NFA_comp g cp) ->
  In q1 (states (remove_unreachable_states' g cp)) ->
  In (transition q1 a q2) g ->
  In (transition q1 a q2) (remove_unreachable_states' g cp).
Proof.
  intros H10 H H0.
  assert (reachable_state cp q1).
  2: {
    clear H H10.
    induction g as [|c g IH].
    contradiction.
    destruct c.
    2: destruct H0; try discriminate; right; intuition.
    1-3: destruct H0; try discriminate; simpl;
    destruct (reachable_state_dec cp q); try right;
    intuition.
    simpl in H0; simpl; destruct H0;
    destruct (reachable_state_dec cp q0).
    1,2: injection H; intros; subst.
    2: contradiction.
    left; intuition.
    apply in_or_app; right.
    1,2: intuition.
  }
  apply remove_unreachable_states'_reachable_state with g;
  intuition.
Qed.

Lemma remove_unreachable_states_transitions2 g q1 a q2 :
  In q1 (states (remove_unreachable_states g)) ->
  In (transition q1 a q2) g ->
  In (transition q1 a q2) (remove_unreachable_states g).
Proof.
  apply remove_unreachable_states'_transitions2, subset_self.
Qed.

(* Algorithm is correct: all resulting states are reachable *)
Lemma remove_unreachable_correct g q :
  In q (states (remove_unreachable_states g)) ->
  reachable_state (remove_unreachable_states g) q.
Proof.
  intros H.
  apply remove_unreachable_states'_reachable_state in H.
  2: apply subset_self.
  destruct H as [w H].
  apply ext_transitionf_singleton in H.
  destruct H as [q0 [H H0]].
  apply path_ext_transitionf in H0.
  assert (path (remove_unreachable_states g) q0 q w).
  2: {
    exists w; apply ext_transitionf_generalize with q0.
    rewrite remove_unreachable_states_start_states; intuition.
    apply path_ext_transitionf; intuition.
  }
  generalize dependent q;
  induction w as [|a w IH] using rev_ind;
  intros q H0.
  inversion H0; subst; constructor.
  apply path_trans_inv2 in H0.
  destruct H0 as [q' [H0 H1]].
  pose proof H0 as H10.
  apply IH in H0; clear IH.
  apply path_trans_inv1 with q'.
  intuition.
  apply remove_unreachable_states'_transitions2.
  apply subset_self.
  2: intuition.
  assert (reachable_state g q'). {
    exists w; apply ext_transitionf_generalize with q0.
    2: apply path_ext_transitionf.
    1,2: intuition.
  }
  clear H10 H0 H w q0.
  assert (forall cp, reachable_state cp q' -> In q' (states (remove_unreachable_states' g cp))). {
    clear H2.
    intros cp H.
    induction g as [|c g IH].
    contradiction.
    destruct c.
    - destruct H1.
      discriminate.
      simpl; apply in_states_app.
      right; intuition.
    - destruct H1.
      discriminate.
      intuition.
    - destruct H1.
      discriminate.
      simpl; apply in_states_app.
      right; intuition.
    - destruct H1.
      discriminate.
      simpl; apply in_states_app.
      right; intuition.
    - destruct H1.
      2: {
        simpl; apply in_states_app.
        right; intuition.
      }
      injection H0; intros; subst; simpl.
      destruct (reachable_state_dec cp q').
      left; intuition.
      contradiction.
  }
  apply H; intuition.
Qed.

End Pumping.