(* Solutions of a quadratic equation over the algebraic numbers *)

Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool.
Require Import Ssreflect.ssrnat Ssreflect.eqtype Ssreflect.seq.
Require Import Ssreflect.fintype.

Require Import MathComp.bigop MathComp.ssralg MathComp.ssrnum.
Require Import MathComp.algC MathComp.poly.
Require Import MathComp.cyclotomic MathComp.binomial.

Require Import ssrring.

Section Roots.

Local Open Scope ring_scope.

Section Quadratic.

Variables a b c : algC.

Lemma quadratic x :
  a != 0 ->
  let D := b ^+ 2 - 4%:R * a * c in
  (a * x ^+ 2 + b * x + c == 0) =
  (x \in [:: (-b + sqrtC D) / (2%:R * a);
             (-b - sqrtC D) / (2%:R * a)]).
Proof.
move=> an0 D.
rewrite (can2_eq (GRing.addrK c) (GRing.subrK c)) GRing.add0r.
rewrite -(inj_eq (GRing.mulfI (_ : 4%:R * a != 0))); last first.
  by rewrite GRing.mulf_eq0 -[0]/(0%:R) eqC_nat.
rewrite GRing.mulrN GRing.mulrDr (GRing.mulrC b).
rewrite -[4 in X in X == _]/((2 * 2)%N) [in X in X == _]GRing.natrM.
rewrite GRing.mulrA -[_ * a * a]GRing.mulrA -(GRing.expr2 a).
rewrite -{1}(GRing.expr2 2%:R) -GRing.exprMn_comm; last exact: GRing.mulrC.
rewrite -GRing.exprMn_comm; last exact: GRing.mulrC.
rewrite -[_ * _ * a]GRing.mulrA -[_ * _ * (x * b)]GRing.mulrA.
rewrite [2%:R * (_ * _)]GRing.mulr_natl GRing.mulrA.
rewrite -(inj_eq (GRing.addIr (b ^+ 2))) -GRing.sqrrD.
rewrite [_ + b ^+ _]GRing.addrC -[b ^+ _ + _]/D -[D in LHS]sqrtCK GRing.eqf_sqr.
rewrite !(can2_eq (GRing.addrK b) (GRing.subrK b)) ![_ - b]GRing.addrC.
have e : 2%:R * a != 0 by rewrite GRing.mulf_eq0 -[0]/(0%:R) eqC_nat.
by rewrite !(can2_eq (GRing.mulKf e) (GRing.mulVKf e)) ![_^-1 * _]GRing.mulrC !inE.
Qed.

End Quadratic.

Section Cubic.

Lemma eqCn0 (n : nat) : (n%:R == 0 :> algC) = (n == 0%N).
Proof. by rewrite -[0]/0%:R eqC_nat. Qed.

Ltac solve_neq0 :=
  repeat match goal with
  | |- context[_ * _ == 0] =>
    rewrite GRing.mulf_eq0 //=
  | |- context[_%:R == 0] =>
    rewrite eqCn0 //=
  | |- context[_ ^+ _ == 0] =>
    rewrite GRing.expf_eq0 //=
  | |- context[_ ^-1 == 0] =>
    rewrite GRing.invr_eq0 //=
  | |- context[- _ == 0] =>
    rewrite GRing.oppr_eq0 //=
  end.

Lemma cubic (a b c d x : algC) :
  a != 0 ->
  let y := b / (3%:R * a) in
  let p := (3%:R * a * c - b ^+ 2)
           / (3%:R * a ^+ 2) in
  let q := (2%:R * b ^+ 3 - 9%:R * a * b * c + 27%:R * a ^+ 2 * d)
           / (27%:R * a ^+ 3) in
  let u := 3.-root (- q / 2%:R + sqrtC (q ^+ 2 / 4%:R + p ^+ 3 / 27%:R)) in
  let s := val (C_prim_root_exists (erefl (0 < 3)%N)) in
  (a * x ^+ 3 + b * x ^+ 2 + c * x + d == 0) =
  [exists i : 'I_3,
     x == (if p == 0 then - y + s ^+ i * 3.-root (- q)
           else - y + (s ^+ i * u - p / (3%:R * s ^+ i * u)))].
Proof.
move=> an0 y p q u s.
move: s (valP _ : 3.-primitive_root s) => s prim_s.
have ->: a * x ^+ 3 + b * x ^+ 2 + c * x + d =
         a * ((x + y) ^+ 3 + p * (x + y) + q).
  by rewrite /y /p /q; ssfield; solve_neq0.
rewrite (can2_eq (GRing.mulKf an0) (GRing.mulVKf an0)) GRing.mulr0.
rewrite -{3}(GRing.addrK y x).
transitivity [exists i : 'I_3,
                x + y == (if p == 0 then s ^+ i * 3.-root (- q)
                          else s ^+ i * u - p / (3%:R * s ^+ i * u))]; last first.
  apply: eq_existsb=> i.
  rewrite [in RHS]fun_if [_ - y]GRing.addrC !(inj_eq (GRing.addrI _)).
  by rewrite -fun_if.
move: (x + y) p q @u => {x y a b c d an0} x p q u.
have [-> {p u}|pn0] := altP (p =P 0).
  rewrite GRing.mul0r GRing.addr0 (can2_eq (GRing.addrK q) (GRing.subrK q)).
  rewrite GRing.add0r -[X in _ == X](rootCK (erefl (0 < 3)%N)).
  move: (3.-root _)=> {q} q.
  have [->{q}|qn0] := altP (q =P 0).
    rewrite GRing.expr0n /= GRing.expf_eq0 /=.
    apply/eqP/existsP=> [->|[? /eqP ->]]; first exists ord0;
    by rewrite ?GRing.mulr0.
  have q3n0 : q ^+ 3 != 0 by exact: GRing.expf_neq0.
  transitivity [exists i : 'I_3, x / q == s ^+ i]; last first.
    apply: eq_existsb=> i.
    by rewrite (can2_eq (GRing.mulfVK qn0) (GRing.mulfK qn0)).
  rewrite -(GRing.mul1r (q ^+ 3)).
  rewrite -(can2_eq (GRing.mulfVK q3n0) (GRing.mulfK q3n0)).
  rewrite -GRing.expr_div_n.
  apply/eqP/existsP; first by move/(prim_rootP prim_s)=> [i ->]; eauto.
  case=> [i /eqP ->].
  by rewrite GRing.exprAC (prim_expr_order prim_s) GRing.expr1n.
apply/eqP/existsP.
  have [v vn0 -> {x}]: exists2 v, v != 0 & x = v - p / (3%:R * v).
    pose v := (x + sqrtC (x ^+ 2 + 4%:R * p / 3%:R)) / 2%:R.
    have := quadratic 1 (- x) (- p / 3%:R) v (GRing.oner_neq0 _).
    rewrite /= GRing.mul1r inE GRing.opprK GRing.sqrrN !GRing.mulr1.
    rewrite GRing.mulrA [in RHS]/v GRing.mulrN !GRing.mulNr GRing.opprK eqxx.
    move: v => v /=; have [->|vn0] := eqVneq v 0.
      rewrite GRing.expr0n GRing.mulr0 /= GRing.add0r GRing.addrC GRing.subr0.
      rewrite GRing.oppr_eq0 GRing.mulf_eq0 (negbTE pn0) /= GRing.invr_eq0.
      by rewrite eqCn0.
    move=> /eqP Pv; exists v=> //.
    apply: (GRing.mulIf vn0).
    apply: (GRing.addIr (- (x * v))).
    rewrite GRing.subrr -Pv.
    ssfield; solve_neq0.
  set v' := - (p / (3%:R * v)).
  have ->: (v + v') ^+ 3 = v ^+ 3 + v' ^+ 3 + 3%:R * v * v' * (v + v').
    by ssring.
  have ->: 3%:R * v * v' = - p.
    rewrite /v' GRing.mulrC GRing.mulNr; apply: f_equal.
    by rewrite GRing.mulfVK //; solve_neq0.
  rewrite GRing.mulNr GRing.subrK => ev.
  have /eqP: 1 * (v ^+ 3) ^+2 + q * v ^+ 3 - p ^+ 3 / 27%:R = 0.
    apply: (@GRing.mulfI _ (v ^- 3)); solve_neq0.
    rewrite GRing.mulr0 -{}ev /v'; ssfield; solve_neq0.
  rewrite quadratic; last exact: GRing.oner_neq0.
  rewrite GRing.mulr1 GRing.mulrN GRing.opprK GRing.mulr1 2!inE => ev'.
  wlog ev: v @v' vn0 {ev ev'} /
           v ^+ 3 = (- q + sqrtC (q ^+ 2 + 4%:R * (p ^+ 3 / 27%:R))) / 2%:R.
    case/orP: ev' => [] /eqP ev'; first by eauto.
    move/(_ v'); rewrite (_ : - (p / (3%:R * v')) = v); last first.
      rewrite /v'; ssfield; solve_neq0.
    rewrite /= (GRing.addrC v' v); apply.
      by rewrite /v' GRing.oppr_eq0; solve_neq0; rewrite negb_or pn0.
    have ->: v' ^+ 3 = v ^+ 3 + v' ^+ 3 + q - v ^+ 3 - q by ssring.
    by rewrite ev ev'; ssfield; solve_neq0.
  have {ev} ev: v ^+ 3 = u ^+ 3.
    rewrite ev /u rootCK // GRing.mulrDl; congr GRing.add.
    rewrite {1}(_ : q ^+ 2 = 4%:R * (q ^+ 2 / 4%:R)); last first.
      by ssfield; solve_neq0.
    rewrite -GRing.mulrDr rootCMl; last by rewrite -[0]/0%:R leC_nat.
    rewrite -(@sqrCK 2%:R); last by rewrite -[0]/0%:R leC_nat.
    by rewrite -GRing.natrX -[2 ^ 2]/4; ssfield; rewrite sqrtC_eq0; solve_neq0.
  have un0 : u != 0.
    suff : u ^+ 3 != 0 by rewrite GRing.expf_eq0.
    by rewrite -ev GRing.expf_eq0.
  have {ev} /(prim_rootP prim_s) [i ev] : (v / u) ^+ 3 = 1.
    by rewrite GRing.expr_div_n -ev GRing.divff //; solve_neq0.
  by exists i; rewrite -ev -[3%:R * _ * _]GRing.mulrA GRing.mulfVK //.
case=> [i /eqP -> {x}].
have eu : u ^+ 6 + q * u ^+ 3 - p ^+ 3 / 27%:R = 0.
  rewrite -(GRing.mul1r (u ^+ 6)) -{1}[6]/(3 * 2)%N GRing.exprM.
  apply/eqP; rewrite quadratic ?GRing.oner_neq0 //.
  rewrite inE; apply/orP; left; apply/eqP.
  rewrite !GRing.mulr1 GRing.mulrN GRing.opprK {}/u.
  rewrite rootCK // GRing.mulrDl; congr GRing.add.
  rewrite {2}(_ : q ^+ 2 = 4%:R * (q ^+ 2 / 4%:R)); last first.
    by ssfield; solve_neq0.
  rewrite -GRing.mulrDr rootCMl; last by rewrite -[0]/0%:R leC_nat.
  rewrite -(@sqrCK 2%:R); last by rewrite -[0]/0%:R leC_nat.
  by rewrite -GRing.natrX -[2 ^ 2]/4; ssfield; rewrite sqrtC_eq0; solve_neq0.
have un0 : u != 0.
  move/eqP: eu; apply: contraTN => /eqP ->.
  rewrite !GRing.expr0n /= GRing.add0r GRing.mulr0 GRing.add0r.
  by solve_neq0; rewrite negb_or pn0.
rewrite -GRing.mulrA; set u1 := s ^+ i * u.
have s3 : s ^+ i ^+ 3 = 1.
  rewrite -GRing.exprM mulnC GRing.exprM (prim_expr_order prim_s).
  by rewrite GRing.expr1n.
have sin0 : s ^+ i != 0.
  by move: (GRing.oner_neq0 algCring); rewrite -s3 GRing.expf_eq0.
have u1n0 : u1 != 0 by rewrite /u1 GRing.mulf_eq0 negb_or sin0.
set u2 := - (p / (3%:R * u1)).
have ->: (u1 + u2) ^+ 3 = u1 ^+ 3 + u2 ^+ 3 + 3%:R * u1 * u2 * (u1 + u2).
  by move: (u1) (u2)=> u1' u2'; ssring.
have ->: 3%:R * u1 * u2 = - p.
  rewrite /u2 GRing.mulrC GRing.mulNr; apply: f_equal.
  by rewrite GRing.mulfVK //; solve_neq0.
rewrite GRing.mulNr GRing.subrK.
apply: (GRing.mulfI (_ : u1 ^+ 3 != 0)); first by rewrite /u1; solve_neq0.
rewrite GRing.mulr0 2!GRing.mulrDr -GRing.expr2.
rewrite -GRing.exprMn_comm; last exact: GRing.mulrC.
have -> : u1 * u2 = - (p / 3%:R).
  rewrite /u2; move: (u1) u1n0=> u1' u1n0'.
  ssfield; solve_neq0.
rewrite /u1 GRing.exprMn_comm; last exact: GRing.mulrC.
rewrite s3 GRing.mul1r -eu.
by ssfield; solve_neq0.
Qed.

End Cubic.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Stephane Le Roux, 2006-10-17
- Frederic Blanqui, 2007-01-22

paths
*)

Set Implicit Arguments.

Require Import CoLoRRelSub.
Require Import CoLoRListUtil.
Require Import CoLoRListRepeatFree.
Require Import Arith.
Require Import CoLoRRelUtil.
Require Import CoLoRLogicUtil.
Require Import CoLoRListShrink.
Require Import CoLoRRelMidex.

Section S.

Variable A : Type.

(***********************************************************************)
(** paths *)

Section Path.

Variable R : relation A.

Fixpoint is_path (x y : A) (l : list A) {struct l} : Prop :=
  match l with
    | nil => R x y
    | z::l' => R x z /\ is_path z y l'
  end.

Lemma path_clos_trans : forall y l x,
  is_path x y l -> clos_trans R x y.

Proof.
induction l; simpl; intros. constructor. assumption.
constructor 2 with a. constructor. tauto. apply IHl. tauto.
Qed.

Lemma path_app : forall y z l' l x,
  is_path x y l -> is_path y z l' -> is_path x z (l++y::l').

Proof.
induction l; simpl; intros. tauto. split. tauto. apply IHl; tauto.
Qed.

Lemma clos_trans_path : forall x y,
  clos_trans R x y -> exists l, is_path x y l.

Proof.
intros. induction H. exists (nil : list A). simpl. assumption.
destruct IHclos_trans1. destruct IHclos_trans2. exists (x0++y::x1).
apply path_app; assumption.
Qed.

Lemma path_app_elim_right : forall y z l l' x,
  is_path x z (l++y::l') -> is_path y z l'.

Proof.
induction l; simpl; intros. tauto. apply IHl with a. tauto.
Qed.

Lemma path_repeat_free_length :
  eq_midex A -> forall y l x,  is_path x y l ->
    exists l', ~In x l' /\ ~In y l' /\ repeat_free l'
      /\ length l'<= length l /\ incl l' l /\ is_path x y l'.

Proof.
induction l; intros; simpl in H0. exists (nil : list A). simpl.
pose (incl_nil (nil : list A)). pose (le_O_n 0). tauto.
destruct (IHl a). tauto.
destruct (H y a). exists (nil : list A). simpl.
pose (le_O_n (S (length l))). pose (incl_nil (a::l)). rewrite H2. tauto.
destruct (In_midex H x x0). destruct (In_elim_right H x x0). assumption.
destruct H4. exists x2. split. tauto. split. intro. absurd (In y x0). tauto.
rewrite (proj1 H4). apply in_or_app. simpl. tauto. rewrite (proj1 H4) in H1.
split.
destruct (repeat_free_app_elim_right x1 (x::x2)). tauto. tauto.
split. rewrite (length_app x1 (x::x2)) in H1. simpl in H1|-* . omega. split.
apply incl_tran with (x::x2). apply incl_tl. apply incl_refl.
apply incl_tran with (x1++(x::x2)). apply incl_appr. apply incl_refl.
apply incl_tran with l.
tauto. apply incl_tl. apply incl_refl. apply path_app_elim_right with x1 a.
tauto.
destruct (H x a). exists x0. rewrite H4. simpl.
assert (length x0 <= S (length l)). omega.
assert (incl x0 (a :: l)). apply incl_tl. tauto. tauto. exists (a::x0). simpl.
assert (S (length x0) <= S (length l)). omega.
assert (incl (a :: x0) (a :: l)). apply incl_double_cons. tauto.
assert (a<>x). intro. rewrite H7 in H4. tauto.
assert (a<>y). intro. rewrite H8 in H2. tauto. tauto.
Qed.

Lemma path_restricted_incl : forall y l l' x,
  is_restricted R l -> is_path x y l' -> incl l' l.

Proof.
unfold is_restricted. induction l'; simpl; intros. intro. simpl. tauto.
apply incl_cons. pose (H x a). tauto. apply IHl' with a; tauto.
Qed.

(***********************************************************************)
(** paths of bounded length *)

Inductive bound_path (n : nat) : relation A :=
  | bp_intro : forall x y l,
    length l<= n -> is_path x y l -> bound_path n x y.

Lemma bound_path_clos_trans : forall n,
  bound_path n << clos_trans R.

Proof.
repeat intro. inversion H. apply path_clos_trans with l. assumption.
Qed.

Lemma clos_trans_bound_path : eq_midex A -> forall l,
  is_restricted R l -> (clos_trans R) << (bound_path (length l)).

Proof.
do 6 intro. destruct (clos_trans_path H1).
destruct (path_repeat_free_length H y x0 x H2). apply bp_intro with x1.
apply repeat_free_incl_length. assumption. tauto.
apply path_restricted_incl with y x;tauto. tauto.
Qed.

Lemma bound_path_n_Sn : forall n x y,
  bound_path n x y -> bound_path (S n) x y.

Proof.
intros. inversion H. apply bp_intro with l. apply le_trans with n. assumption.
apply le_n_Sn. assumption.
Qed.

Lemma bound_path_Sn_n_or_Rn : forall n x y,
  bound_path (S n) x y ->
  bound_path n x y \/ exists z : A, R x z /\ bound_path n z y.

Proof.
intros. inversion H. destruct (le_le_S_dec (length l) n).
constructor. apply bp_intro with l; assumption. constructor 2.
destruct l. simpl in l0. pose (le_Sn_O n l0). tauto. exists a. simpl in H0, H1.
split. tauto. apply bp_intro with l. apply le_S_n. assumption. tauto.
Qed.

Lemma R_bound_path_n_Sn : forall x y z n,
  R x y -> bound_path n y z -> bound_path (S n) x z.

Proof.
intros. inversion H0. apply bp_intro with (y::l). simpl. apply le_n_S.
assumption.
simpl. tauto.
Qed.

End Path.

(***********************************************************************)
(** paths and sub-relations *)

Lemma path_preserved : forall R R' y l x,
  R << R' -> is_path R x y l -> is_path R' x y l.

Proof.
induction l; repeat intro; simpl in H0 |- * . apply H. assumption.
split. pose (H x a). tauto. pose (IHl a). tauto.
Qed.

Lemma path_restriction : forall R y l x,
  is_path R x y l -> is_path (restriction R (x::y::l)) x y l.

Proof.
unfold restriction. induction l; simpl; intros. tauto. split. tauto.
simpl in IHl.
apply path_preserved with (fun x0 y0 : A =>  (a = x0 \/ y = x0 \/ In x0 l) /\
(a = y0 \/ y = y0 \/ In y0 l) /\ R x0 y0). repeat intro. tauto.
apply IHl. tauto.
Qed.

End S.

(***********************************************************************)
(** properties when the equality is decidable *)

Section S2.

Variable A : Type.
Variable eqdec : eq_dec A.
Variable R : relation A.

(***********************************************************************)
(** path *)

Lemma path_app_elim : forall l x y z m,
  is_path R x y (l ++ z :: m) -> is_path R x z l /\ is_path R z y m.

Proof.
induction l; simpl; intros. exact H. destruct H. ded (IHl _ _ _ _ H0).
intuition.
Qed.

Lemma sub_path : forall l x y x' y' l' m p,
  x :: l ++ y :: nil = m ++ x' :: l' ++ y' :: p ->
  is_path R x y l -> is_path R x' y' l'.

Proof.
induction l; simpl; intros.
(* case l=nil *)
destruct m; simpl in H.
(* case m=nil *)
injection H; intros. subst x'. destruct l'; simpl in H1.
(* case l'=nil *)
injection H1; intros. subst y'. exact H0.
(* case l'=a::l' *)
injection H1; intros. destruct l'; discriminate.
(* case m=a::m *)
injection H; intros. destruct m; simpl in H1.
(* case m=nil *)
injection H1; intros. destruct l'; discriminate.
(* case m=a0::m *)
injection H1; intros. destruct m; discriminate.
(* case l=a::l *)
destruct H0. destruct m; simpl in H.
(* case m=nil *)
injection H; intros. subst x'. destruct l'; simpl in H2; simpl in H.
(* case l'=nil *)
injection H2; intros. subst a. exact H0.
(* case l'=a0::l' *)
simpl. injection H2; intros. subst a0. intuition.
apply (IHl a y a y' l' (@nil A) p). simpl. exact H2. exact H1.
(* case m=a0::m *)
injection H; intros. subst a0. eapply IHl. apply H2. exact H1.
Qed.

Lemma path_suffix : forall (y z : A) l' l'' (x : A),
  is_path R x y l' -> suffix (z::l'') l' -> is_path R z y l''.

Proof.
induction l'; intros. assert (rev (z :: l'')=nil). apply prefix_nil. hyp.
simpl in H1. symmetry in H1. pose (app_cons_not_nil (rev l'') nil z H1). tauto.
destruct (List.list_eq_dec eqdec (z :: l'')(a :: l')). inversion e. simpl in H.
tauto. simpl in H.
apply IHl' with a. tauto. apply suffix_smaller with a; assumption.
Qed.

Lemma path_cut : forall (y : A) l' (x : A),
  In x l' -> is_path R x y l' -> is_path R x y (tail(cut eqdec x l')).

Proof.
intros. apply path_suffix with l' x. assumption.
rewrite <- (cut_head eqdec x l' H). apply suffix_cut.
Qed.

Lemma path_cut_bis : forall l' (x y z : A),
  In z l' -> R x z -> is_path R z y l' -> is_path R x y (cut eqdec z l').

Proof.
intros. rewrite (cut_head eqdec z l'). simpl.
assert (is_path R z y (tail (cut eqdec z l'))).
apply path_cut; assumption. destruct l'. pose (in_nil H).
contradiction. tauto. assumption.
Qed.

Lemma path_shrink : forall (y : A) l' (x : A),
  is_path R x y l' -> is_path R x y (shrink eqdec l').

Proof.
induction l'; simpl; intros. assumption.
assert (is_path R a y (shrink eqdec l')).
apply IHl'; tauto. destruct (In_dec eqdec a (shrink eqdec l')).
apply path_cut_bis; tauto. simpl. tauto.
Qed.

Require Import Arith.

(***********************************************************************)
(** restriction *)

Section sub_Rel2.

Variable l : list A.

Lemma restricted_path_incl : is_restricted R l ->
  forall m x y, is_path R x y m -> incl (x :: m ++ y :: nil) l.

Proof.
induction m; simpl; intros.
ded (H _ _ H0). unfold is_restricted in H. unfold incl. simpl. intuition.
subst a. exact H2. subst a. exact H3.
destruct H0. apply incl_cons. ded (H _ _ H0). unfold is_restricted in H2.
intuition.
apply IHm. exact H1.
Qed.

Require Import CoLoRListOccur.

Notation occur := (occur eqdec).

Lemma long_path_occur : is_restricted R l ->
  forall x y m, is_path R x y m -> length m >= length l - 1 ->
    exists z, occur z (x :: m ++ y :: nil) >= 2.

Proof.
intros. apply pigeon_hole with l. apply restricted_path_incl.
apply H. apply H0. simpl. rewrite length_app. simpl. omega.
Qed.

Lemma path_restriction_In_left : forall (x y : A) l',
is_path (restriction R l) x y l' -> In x l.

Proof.
unfold restriction. intros; destruct l'; simpl in H; tauto.
Qed.

End sub_Rel2.

End S2.

Implicit Arguments path_app_elim [A R l x y z m].
Implicit Arguments restricted_path_incl [A R l m x y].


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

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

(*
m⊥n (mとnは互いに素)となる負でない分数 m/n をすべて作りあげるきれいな方法がある。
これは、ドイツの数学者 Stern とフランスの時計工 Brocot のふたりが独立に発見したため、
Stern-Brocot 木と呼ばれている。

まず、(0/1, 1/0)の2個の分数から始め、次の操作を好きなだけ繰り返す。

　隣接する分数 m/n と m'/n' の間に (m + m')/(n + n') を挿入する。

新しい分数 (m + m')/(n + n') を m/n と m'/n' の中関数(medinant)という。

それぞれの分数は、左側にあり最も近い祖先を m/n とし、右側にあり最も近い祖先を m'/n' としたとき、
(m + m')/(n + n') となっている。
ここで、祖先というのは、枝を上にたどることによって到達できる分数のことである。

この構成方法のどの段階においても、m/n と m'/n' が隣接した分数のとき、

  m' * n - m * n' = 1　・・・　★

が成り立つ。
これは最初の段階では、

  1 * 1 - 0 * 0 = 1　・・・　★0

であり、成り立っている。
新しい中関数 (m + m')/(n + n') を挿入する前に、★が成り立っていると仮定すると、
新しい中間数 (m + m')/(n + n') を挿入すると、

  (m + m') * n - m * (n + n') = 1

と

  m' * (n + n') - (m + m') * n' = 1

が成り立つことを示さなければならない。
しかし、

  (m + m') * n - m * (n + n')
  = m * n + m' * n - m * n - m * n'
  = m' * n - m * n'
  = 1 (★により)

  m' * (n + n') - (m + m') * n' = 1
  = m' * n + m' * n' - m * n' - m' * n'
  = m' * n - m * n'
  = 1 (★により)

となって、新しい中関数を挿入する前に★が成り立てば、新しい中間数を挿入しても★が成り立つことがわかる。
従って、★0と合わせて★は木の構成法のすべての段階で常に成り立つ。
*)

Lemma lm1 :
  forall m n m' n',
    m' * n - m * n' = 1 ->
    ((m + m') * n - m * (n + n') = 1) /\ (m' * (n + n') - (m + m') * n' = 1).
Proof.
  move=> m n m' n' H.
  split.
  - (* (m + m') * n - m * (n + n') = 1 の証明 *)
    by rewrite mulnDl mulnDr subnDl.
  - (* m' * (n + n') - (m + m') * n' = 1 の証明 *)
    by rewrite mulnDr mulnDl subnDr.
Qed.

(*
lm1 については、次の定理の証明の一部になると思います。トライしてみてください。

定理

自然数 n, m, n', m' の初期値を

n = 1, m = 0
n' = 0, m' = 1

とする。

(L) n と m は変えずに、n' ← n + n', m' ← m + m' とする。
(R) n' と m' は変えずに、n ← n + n', m ← m + m' とする。

(L)と(R)を任意の順番で任意回繰り返しても、m'n - mn' = 1 であることを証明せよ。

定理（終わり）

Bezout の補題（拡張ユーグリッドの互除法）から
隣り合った数は互いに素なので、m'n と mn' は互いに素である。

さらに、

m'n ⊥ mn'   <->  (n ⊥ m) /\ (n' ⊥ m')

なので、m/n は既約分数 で m'/n' も既約分数になることが証明できた。

補足；
lm2 で証明したとおり、0/1 < 1/0 なので m/n < n'/m から始めて、

Lのとき、あたらしい m'/n' は、m/n < m'/n' となり、
Rのとき、あたらしい m/n は、m/n < m'/n' となり、

mn' < m'n が保持されるはずなので（要確認）、自然数による計算でよいはずです。
*)

Inductive sbtree : nat -> nat -> nat -> nat -> Prop :=
  sbtInit  : sbtree 0 1 1 0
| sbtLeft  : forall m n m' n',
               sbtree m n m' n' -> sbtree m n (m + m') (n + n')
| sbtRight : forall m n m' n',
               sbtree m n m' n' -> sbtree (m + m') (n + n') m' n'.

Goal sbtree 0 1 1 1. (* 0/1, 1/1 -> (0+1)/(1+1) = 1/2 *)
Proof.
  apply: sbtLeft.
  by apply: sbtInit.
Qed.

Goal sbtree 2 5 1 2. (* 2/5, 1/2 -> (2+1)/(5+2) = 3/7 *)
Proof.
  apply: (@sbtRight 1 3 1 2). (* 1/3, 1/2 -> (1+1)/(3+2) = 2/5 *)
  apply: (@sbtRight 0 1 1 2). (* 0/1, 1/2 -> (0+1)/(1+2) = 1/3 *)
  apply: (@sbtLeft 0 1 1 1). (* 0/1, 1/1 -> (0+1)/(1+1) = 1/2 *)
  apply: (@sbtLeft 0 1 1 0). (* 0/1, 1/0 -> (0+1)/(1+0) = 1/1 *)
  by apply: sbtInit.
Qed.

(* (m+m')/(n+n')を作る関数を定義しておくとよい。 by 須原さん *)
Definition calc_sbnode (m n m' n' : nat) : (nat * nat) := (m + m', n + n').
(* とりあえず、こんなショボいものしかできませんでした。 *)
Eval compute in calc_sbnode 0 1 1 0. (* = (1, 1) : nat * nat *)
Eval compute in calc_sbnode 0 1 1 1. (* = (1, 2) : nat * nat *)
Eval compute in calc_sbnode 0 1 1 2. (* = (1, 3) : nat * nat *)
Eval compute in calc_sbnode 1 3 1 2. (* = (2, 5) : nat * nat *)
Eval compute in calc_sbnode 2 5 1 2. (* = (3, 7) : nat * nat *)

Check sbtree_ind
      : forall P : nat -> nat -> nat -> nat -> Prop,
          P 0 1 1 0 ->
          (forall m n m' n' : nat,
           sbtree m n m' n' -> P m n m' n' -> P m n (m + m') (n + n')) ->
          (forall m n m' n' : nat,
           sbtree m n m' n' -> P m n m' n' -> P (m + m') (n + n') m' n') ->
          forall n n0 n1 n2 : nat,
            sbtree n n0 n1 n2 -> P n n0 n1 n2.

Check (fun m n m' n' => m' * n - m * n' = 1)
      : nat -> nat -> nat -> nat -> Prop.

Check @sbtree_ind (fun m n m' n' => m' * n - m * n' = 1)
      : 1 * 1 - 0 * 0 = 1 ->
        (forall m n m' n' : nat,
         sbtree m n m' n' ->
         m' * n - m * n' = 1 -> (m + m') * n - m * (n + n') = 1) ->
        (forall m n m' n' : nat,
         sbtree m n m' n' ->
         m' * n - m * n' = 1 -> m' * (n + n') - (m + m') * n' = 1) ->
        forall n n0 n1 n2 : nat,
          sbtree n n0 n1 n2 -> n1 * n0 - n * n2 = 1.

Lemma lm1' :
  forall m n m' n',
    sbtree m n m' n' ->  m' * n - m * n' = 1.
Proof.
  move=> m n m' n' Hsbt.
  elim: (Hsbt) => //= [mm nn mm' nn' Hsbt' IH | mm nn mm' nn' Hsbt' IH].
  (* sbInitの場合は、//=により証明完了 *)
  - (* sbLeftの場合 *)
    by rewrite mulnDl mulnDr subnDl.
  - (* sbRightの場合 *)
    by rewrite mulnDr mulnDl subnDr.
Qed.

(*
P.118の真ん中辺りの式も証明する。by 須原さん
網羅性
*)
(*
加えて、a⊥b となる分数 a/b で、木のどこにも出現しないものは存在しない。
すなわち、a⊥b となる分数 a/b は、必ず木のどこかに出現することがわかる。
分数 a/b をちょうどはさむ部分において、木の構成方法がどうなっているかを見る。
まず最初に、次のようになっている。

  m/n = 0/1 < (a/b) < 1/0 = m'/n'　・・・　a/b を囲むカッコは、a/b がまだ存在していないことを示す。

そしてある時点で、次のようになっていたとする。

  m/n < (a/b) < m'/n'  (※m, n, m', n', a, b は、全て0より大となるはず。)

木の構成方法では (m + m')/(n + n') を作ることになるが、ことのとき3通りの場合が考えられる。

・(m + m')/(n + n') = a/b となる場合

    この場合、a/b は木に出現したので問題ない。

・(m + m')/(n + n') < a/b となる場合

    m + m' を m 、n + n' を n として木の構成方法を繰り返す。

・(m + m')/(n + n') > a/b となる場合

    m + m' を m' 、n + n' を n' として木の構成方法を繰り返す。

木の構成方法を繰り返していく場合、永遠に繰り返すことはできない。

  a/b - m/n > 0 かつ m'/n' - a/b > 0

が成り立つならば、
(つまり、m/n < a/b < m'/n' が成り立つならば、)

  a * n - b * m >= 1 かつ b * m' - a * n' >= 1

となる。

それは、次の様に示せる。

まず、a, b, m, n はすべて自然数(0より大きい整数)だから、

  a/b - m/n > 0

の両辺に (b * n) を乗じても大小関係は変わらない。

したがって

  (b * n) * (a/b - m/n) > (b * n) * 0

  a * n - b * m > 0

となる。

ここで再び a, b, m, n が全て自然数であることより、

  a * n - b * m > 0

なら、

  a * n - b * m >= 1

となる。(0の次に大きい整数は1だから。)

同様に、

  m'/n' - a/b > 0

より、

  b * m' - a * n' >= 1

となる。

したがって、a * n - b * m >= 1, b * m' - a * n' >= 1 となるのであれば次の不等式が成り立つ。

  (m' + n') * (a * n - b * m) + (m + n) * (b * m' - a * n') >= m' + n') * 1 + (m + n) * 1

すなわち、

  (m' + n') * (a * n - b * m) + (m + n) * (b * m' - a * n') >= m' + n' + m + n　・・・　★★

が成り立つ。

ここで、

  ★★の左辺
  = (m' + n') * (a * n - b * m) + (m + n) * (b * m' - a * n')
  = a * m' * n - b * m * m' + a * n * n' - b * m * n' + b * m * m' - a * m * n' + b * m' * n - a * n * n'
  = a * (m' * n - m * n') + b * (m' * n - m * n')
  = a * 1 + b * 1
  = a + b

従って、

  a + b >= m' + n' + m + n

が成り立つ。

もし、m, n, m', n' のどれかが木の構成方法の1ステップごとに増えていくとすると、
1ステップに1ずつしか増えなかったとしても、多くても a + b ステップ後には

  a + b = m' + n' + m + n = (m + m') + (n + n')

とならなければならない。

その時

  a/b = (m + m')/(n + n')

とならるらしい。

ということは、

  a = m + m', b = n + n'

となるらしい。

もしもそうなるなら、a⊥b となる分数 a/b は必ず木のどこかに出現することになる。
*)

Lemma lm1_1_1 (a b m n : nat) :
  a > 0 ->
  b > 0 ->
  m > 0 ->
  n > 0 ->
  m %/ n < a %/ b ->
  a * n - b * m >= 1.
Proof.
  (* natではうまく証明できないかもしれない。 *)
Abort.

Lemma lm1_2 (a b m n m' n' : nat) :
  a > 0 ->
  b > 0 ->
  m > 0 ->
  n > 0 ->
  m' > 0 ->
  n' > 0 ->
  a * n - b * m >= 1 ->
  b * m' - a * n' >= 1 ->
  (m' + n') * (a * n - b * m) + (m + n) * (b * m' - a * n') >= m' + n' + m + n.
Proof.
  move=> Hagt0 Hbgt0 Hmgt0 Hngt0 Hm'gt0 Hn'gt0 H1 H2.
  rewrite -addnA.
  apply: (@leq_add (m' + n') (m + n) ((m' + n') * (a * n - b * m)) ((m + n) * (b * m' - a * n'))).
  - (* m' + n' <= (m' + n') * (a * n - b * m) の証明 *)
    rewrite -{1}[m']muln1 -{1}[n']muln1 -mulnDl.
    by apply: (@leq_mul (m' + n') 1 (m' + n') (a * n - b * m)).
  - (* m + n <= (m + n) * (b * m' - a * n') の証明 *)
    rewrite -{1}[m]muln1 -{1}[n]muln1 -mulnDl.
    by apply: (@leq_mul (m + n) 1 (m + n) (b * m' - a * n')).
Qed.

(*
数学ガールの「数学的帰納法」の問題
https://qiita.com/suharahiromichi/items/da2322993ef727728ea9
上記で説明されている、有理数を使用するためのライブラリ設定を参照させていただきました。
*)
Import GRing.Theory.         (* mulrA などを使えるようにする。 *)
Import Num.Theory.           (* unitf_gt0 などを使えるようにする。 *)
Import intZmod.              (* addz など *)
Import intRing.              (* mulz など *)
Open Scope ring_scope.       (* 環の四則演算を使えるようにする。 *)

(*
さらに、m/n < m'/n' であり、m, n, m', n' がすべて負でないとき、

  m/n < (m + m')/(n + n') < m'/n'

となることを示せる。

  (m + m') * n - m * (n + n')
  = m * n + m' * n - m * n - m * n'
  = m' * n - m * n'
  = (n * n') * (m'/n' - m/n)
  > 0 (n * n' > 0, m'/n' > m/n により)

従って、

  (m + m') * n - m * (n + n')
  = (n * (n + n')) * ((m + m')/(n + n') - m/n)
  > 0

n * (n + n') > 0 より、(m + m')/(n + n') - m/n > 0 となり、(m + m')/(n + n') > m/n が示せた。

  m' * (n + n') - (m + m') * n'
  = m' * n + m' * n' - m * n' - m' * n'
  = m' * n - m * n'
  > 0

従って、

  m' * (n + n') - (m + m') * n'
  = ((n + n') * n') * (m'/n' - (m + m')/(n + n'))
  > 0

(n + n') * n' > 0 より、m'/n' - (m + m')/(n + n') > 0 となり、m'/n' > (m + m')/(n + n') が示せた。

中関数の分数は祖先のちょうど半分のところに位置するわけではないが、祖先の間のどこかには位置している。
つまり、この構成方法は順序を保存する。
従って、同じ分数が木の別のところに出現することはない。
*)

Lemma lm2_rat :
  forall (m n m' n' : rat),
    m / n < m' / n' ->
    m > 0 ->
    n > 0 ->
    m' > 0 ->
    n' > 0 ->
    (m / n < (m + m') / (n + n')) /\ ((m + m') / (n + n') < m' / n').
Proof.
  move=> m n m' n' Hmnltm'n' Hmgt0 Hngt0 Hm'gt0 Hn'gt0.
  split.
  - (* m / n < (m + m') / (n + n') の証明 *)
    rewrite ltr_pdivr_mulr; last done.
    rewrite -{2}[n]divr1 mulf_div mulr1.
    rewrite ltr_pdivl_mulr; last by apply: addr_gt0.
    rewrite mulrDl mulrDr.
    apply: ler_lt_add; first done.
    rewrite -ltr_pdivl_mulr; last done.
    rewrite -[n']mulr1 -mulf_div mulr1.
    rewrite -ltr_pdivr_mulr; last done.
    by [].
  - (* (m + m') / (n + n') < m' / n' の証明 *)
    rewrite ltr_pdivr_mulr; last by apply: addr_gt0.
      (* ここで、0 < n + n' を証明しておけば、1ステップ短くなる。 by 須原さん *)
    rewrite -[n + n']divr1 mulf_div mulr1.
    rewrite ltr_pdivl_mulr; last done.
    rewrite mulrDl mulrDr.
    rewrite ltr_le_add; first done; last done.
    rewrite -ltr_pdivr_mulr; last done.
    rewrite -[n]mulr1 -mulf_div divr1.
    by rewrite -ltr_pdivl_mulr.
Qed.

(*
m/n, m'/n' が既約なら、(m + m')/(n + n') も既約であることを、
拡張ユークリッド互除法を使って証明してみることもいいかもしれない。by 須原さん
*)

(*
SBツリーの任意のノードや、(L)、(R)といった操作を、
2行2列の行列とその積で表現できるとのこと。by 須原さん

SBツリーの任意のノード
[[n, n'],
 [m, m']]

(R)
[[n+n', n'], = [[n, n'],    [[1, 0],
 [m+m', m']]    [m, m']] ×  [1, 1]]

(L)
[[n, n+n'],  = [[n, n'],    [[1, 1],
 [m, m+m']]     [m, m']] ×  [0, 1]]

それらの行列の行列式は、すべて1であり、
行列式が1であるような行列を掛け算してできた行列の行列式もまた1になることを使って、
証明を行うことができるのではないか。by 盛田さん
*)

Definition sb_node (m n m' n' : nat) : 'M[nat]_2 :=
  \matrix_(i, j) (if (i, j) == (0, 0)
                  then n
                  else
                    if (i, j) == (0, 1)
                    then n'
                    else
                      if (i, j) == (1, 0)
                      then m
                      else m').

(* (R : ringType) としないと乗算ができない？ *)
Definition sb_node' (R : ringType) (m n m' n' : R) : 'M[R]_2 :=
  \matrix_(i, j) (if (i, j) == (0, 0)
                  then n
                  else
                    if (i, j) == (0, 1)
                    then n'
                    else
                      if (i, j) == (1, 0)
                      then m
                      else m').
(*
[[(0,0), (0,1)],   [[n, n'],
 [(1,0), (1,1)]]  = [m, m']]
のつもり。
*)

Definition sb_init  := sb_node 0 1 1 0.
(*
[[(0,0), (0,1)],   [[n, n'],   [[1, 0],
 [(1,0), (1,1)]]  = [m, m']]  = [0, 1]]
のつもり。
*)

Definition sb_left  := sb_node 0 1 1 1.
(*
[[(0,0), (0,1)],   [[n, n'],   [[1, 1],
 [(1,0), (1,1)]]  = [m, m']]  = [0, 1]]
のつもり。
*)

Definition sb_right := sb_node 1 1 1 0.
(*
[[(0,0), (0,1)],   [[n, n'],   [[1, 0],
 [(1,0), (1,1)]]  = [m, m']]  = [1, 1]]
のつもり。
*)

Variable (R : ringType).
Check @sb_node' R 0 1 1 0.
Definition sb_init'  := @sb_node' R 0 1 1 0.
Definition sb_left'  := @sb_node' R 0 1 1 1.
Definition sb_right' := @sb_node' R 1 1 1 0.

Check @mulmx
      : forall (R : ringType) (m n p : nat),
          'M_(m, n) -> 'M_(n, p) -> 'M_(m, p).

Check @mulmx R 2 2 2 : 'M_2 -> 'M_2 -> 'M_2.
Check @mulmx R 2 2 2 sb_init' sb_left' : 'M_2.

(* とりあえず、見様見真似で行列を使って定義したみただけの状態。 *)


Theorem NotNot_LEM : forall P : Prop, ~ ~(P \/ ~P).
unfold not.
Proof.
  intros.
  apply H.
  right.
  intro.
  apply H.
  left.
  apply H0.

Qed.


Require Export FunctorCategory Category.Product NaturalTransformation.Composition.Functorial ExponentialLaws.Law4.Functors.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section FunctorialComposition.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variable E : PreCategory.

  Local Open Scope natural_transformation_scope.

  Definition FunctorialComposition_MorphismOf
             s d (m : Morphism [C, D] s d)
  : Morphism [[D, E], [C, E]]
             (NTWhiskerR_Functorial _ s)
             (NTWhiskerR_Functorial _ d)
    := Build_NaturalTransformation
         (NTWhiskerR_Functorial E s)
         (NTWhiskerR_Functorial E d)
         (fun x => NTWhiskerL x m)
         (fun _ _ _ => NTWhiskerExchange _ _).

  Definition FunctorialComposition : Object [[C, D], [[D, E], [C, E]]].
  Proof.
    refine (Build_Functor
              [C, D] [[D, E], [C, E]]
              (@NTWhiskerR_Functorial _ _ _ _)
              FunctorialComposition_MorphismOf
              _
              _);
    abstract (
        nt_eq;
        rewrite ?FCompositionOf, ?FIdentityOf;
        reflexivity
      ).
  Defined.

  Definition FunctorialComposition_uncurried : Object [[C, D] * [D, E], [C, E]]
    := ExponentialLaw4Functor _ _ _ FunctorialComposition.
End FunctorialComposition.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export logic.
Definition lemma__ray2 : forall A B C, (euclidean__defs.Out A B C) -> (euclidean__axioms.neq A B).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (exists E, (euclidean__axioms.BetS E A C) /\ (euclidean__axioms.BetS E A B)) as H0 by exact H.
destruct H0 as [E H1].
destruct H1 as [H2 H3].
assert (* Cut *) (euclidean__axioms.neq A B) as H4.
- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq E A) /\ (euclidean__axioms.neq E B))) as H4.
-- apply (@lemma__betweennotequal.lemma__betweennotequal E A B H3).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H5.
- exact H4.
Qed.


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

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

Print Assumptions mul.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.

Section TrivialSemantics.

Context {Sigma: PropositionalVariables}.

Existing Instances L minL pL.

Definition model: Type := Var -> Prop.

Fixpoint denotation (x: expr Sigma): Ensemble model :=
  match x with
  | andp y z => Semantics.andp (denotation y) (denotation z)
  | orp y z => Semantics.orp (denotation y) (denotation z)
  | impp y z => Semantics.impp (denotation y) (denotation z)
  | falsep => Semantics.falsep
  | varp p => fun m => m p
  end.

Instance MD: Model :=
  Build_Model model.

Instance SM: Semantics L MD :=
  Build_Semantics L MD denotation.

Instance tminSM: TrivialMinimumSemantics L MD SM.
Proof.
  constructor.
  simpl; intros.
  apply Same_set_refl.
Qed.

Instance tpSM: TrivialPropositionalSemantics L MD SM.
Proof.
  constructor.
  + simpl; intros.
    apply Same_set_refl.
  + simpl; intros.
    apply Same_set_refl.
  + simpl; intros.
    apply Same_set_refl.
Qed.

End TrivialSemantics.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Limit.

Generalizable All Variables.

Definition Complete {C : Category} := ∀ (D : Category) (F : D ⟶ C), Limit F.

Definition Cocomplete {C : Category} := ∀ (D : Category) (F : D ⟶ C), Colimit F.


(* another example - tagging props with something they imply *)
Module Narrow.
  Structure tagged_prop := PTag {puntag :> Prop}.
  Definition andr_tag P := PTag P.
  Definition andl_tag P := andr_tag P.
  Canonical Structure id_tag P := andl_tag P.

  Structure narrowedTo (P : Prop) : Type := NarrowTo { BigP :> tagged_prop;
                                                       _ : (puntag BigP) -> P}.

  Arguments BigP {P} _.

  Lemma id_proof : forall (P : Prop), id_tag P -> P.
  Proof.
    auto.
  Qed.

  Canonical Structure id_narrow (P : Prop) :=
    NarrowTo P (id_tag P) (id_proof P).

  Lemma left_proof : forall (P P1 : Prop) (narr : narrowedTo P),
                       andl_tag (puntag (BigP narr) /\ P1) -> P.
  Proof.
    dependent inversion narr.
    intros. simpl in *.
    inversion H; auto.
  Qed.

  Canonical Structure andl_narrow (P P1 : Prop) (narr : narrowedTo P)  :=
    NarrowTo P (andl_tag (puntag (BigP narr) /\ P1)) (left_proof P P1 narr).

  Lemma right_proof : forall (P P1 : Prop) (narr : narrowedTo P),
                        andr_tag (P1 /\ puntag (BigP narr)) -> P.
  Proof.
    dependent inversion narr.
    intros; simpl in *.
    inversion H; auto.
  Qed.

  Canonical Structure andr_narrow (P P1 : Prop) (narr : narrowedTo P)  :=
    NarrowTo P (andr_tag (P1 /\ puntag (BigP narr))) (right_proof P P1 narr).

  Lemma herpR : forall (P : Prop) (narr : narrowedTo P),
                  puntag (BigP narr) -> P.
    dependent inversion narr.
    intros.
    simpl in H.
    auto.
  Qed.

  Arguments herpR P {narr} _.

  Lemma test1 : forall (A B : Prop), (A /\ B) -> A.
    intros A B.
    refine (herpR A).
  Qed.

  Lemma test2 : forall (A B C D : Prop), ((D /\ A) /\ (B /\ C)) -> A.
    intros A B C D.
    refine (herpR A).
  Qed.
End Narrow.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path fintype div.
Require Import bigop prime finset fingroup morphism automorphism quotient.
Require Import commutator gproduct gfunctor center gseries.

(******************************************************************************)
(*   This file defines nilpotent and solvable groups, and give some of their  *)
(* elementary properties; more will be added later (e.g., the nilpotence of   *)
(* p-groups in sylow.v, or the fact that minimal normal subgroups of solvable *)
(* groups are elementary abelian in maximal.v). This file defines:            *)
(*   nilpotent G == G is nilpotent, i.e., [~: H, G] is a proper subgroup of H *)
(*                  for all nontrivial H <| G.                                *)
(*    solvable G == G is solvable, i.e., H^`(1) is a proper subgroup of H for *)
(*                  all nontrivial subgroups H of G.                          *)
(*       'L_n(G) == the nth term of the lower central series, namely          *)
(*                  [~: G, ..., G] (n Gs) if n > 0, with 'L_0(G) = G.         *)
(*                  G is nilpotent iff 'L_n(G) = 1 for some n.                *)
(*       'Z_n(G) == the nth term of the upper central series, i.e.,           *)
(*                  with 'Z_0(G) = 1, 'Z_n.+1(G) / 'Z_n(G) = 'Z(G / 'Z_n(G)). *)
(*   nil_class G == the nilpotence class of G, i.e., the least n such that    *)
(*                  'L_n.+1(G) = 1 (or, equivalently, 'Z_n(G) = G), if G is   *)
(*                  nilpotent; we take nil_class G = #|G| when G is not       *)
(*                  nilpotent, so nil_class G < #|G| iff G is nilpotent.      *)
(******************************************************************************)

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

Import GroupScope.

Section SeriesDefs.

Variables (n : nat) (gT : finGroupType) (A : {set gT}).

Definition lower_central_at_rec := iter n (fun B => [~: B, A]) A.

Definition upper_central_at_rec := iter n (fun B => coset B @*^-1 'Z(A / B)) 1.

End SeriesDefs.

(* By convention, the lower central series starts at 1 while the upper series *)
(* starts at 0 (sic).                                                         *)
Definition lower_central_at n := lower_central_at_rec n.-1.

(* Note: 'nosimpl' MUST be used outside of a section -- the end of section    *)
(* "cooking" destroys it.                                                     *)
Definition upper_central_at := nosimpl upper_central_at_rec.

Arguments Scope lower_central_at [nat_scope _ group_scope].
Arguments Scope upper_central_at [nat_scope _ group_scope].

Notation "''L_' n ( G )" := (lower_central_at n G)
  (at level 8, n at level 2, format "''L_' n ( G )") : group_scope.

Notation "''Z_' n ( G )" := (upper_central_at n G)
  (at level 8, n at level 2, format "''Z_' n ( G )") : group_scope.

Section PropertiesDefs.

Variables (gT : finGroupType) (A : {set gT}).

Definition nilpotent :=
  [forall (G : {group gT} | G \subset A :&: [~: G, A]), G :==: 1].

Definition nil_class := index 1 (mkseq (fun n => 'L_n.+1(A)) #|A|).

Definition solvable :=
  [forall (G : {group gT} | G \subset A :&: [~: G, G]), G :==: 1].

End PropertiesDefs.

Arguments Scope nilpotent [_ group_scope].
Arguments Scope nil_class [_ group_scope].
Arguments Scope solvable [_ group_scope].
Prenex Implicits nil_class nilpotent solvable.

Section NilpotentProps.

Variable gT: finGroupType.
Implicit Types (A B : {set gT}) (G H : {group gT}).

Lemma nilpotent1 : nilpotent [1 gT].
Proof. apply/forallP=> H; rewrite commG1 setIid -subG1; exact/implyP. Qed.

Lemma nilpotentS A B : B \subset A -> nilpotent A -> nilpotent B.
Proof.
move=> sBA nilA; apply/forallP=> H; apply/implyP=> sHR.
have:= forallP nilA H; rewrite (subset_trans sHR) //.
by apply: subset_trans (setIS _ _) (setSI _ _); rewrite ?commgS.
Qed.

Lemma nil_comm_properl G H A :
    nilpotent G -> H \subset G -> H :!=: 1 -> A \subset 'N_G(H) ->
  [~: H, A] \proper H.
Proof.
move=> nilG sHG ntH; rewrite subsetI properE; case/andP=> sAG nHA.
rewrite (subset_trans (commgS H (subset_gen A))) ?commg_subl ?gen_subG //.
apply: contra ntH => sHR; have:= forallP nilG H; rewrite subsetI sHG.
by rewrite (subset_trans sHR) ?commgS.
Qed.

Lemma nil_comm_properr G A H :
    nilpotent G -> H \subset G -> H :!=: 1 -> A \subset 'N_G(H) ->
  [~: A, H] \proper H.
Proof. by rewrite commGC; exact: nil_comm_properl. Qed.

Lemma centrals_nil (s : seq {group gT}) G :
  G.-central.-series 1%G s -> last 1%G s = G -> nilpotent G.
Proof.
move=> cGs defG; apply/forall_inP=> H /subsetIP[sHG sHR].
move: sHG; rewrite -{}defG -subG1 -[1]/(gval 1%G).
elim: s 1%G cGs => //= L s IHs K /andP[/and3P[sRK sKL sLG] /IHs sHL] sHs.
exact: subset_trans sHR (subset_trans (commSg _ (sHL sHs)) sRK).
Qed.

End NilpotentProps.

Section LowerCentral.

Variable gT : finGroupType.
Implicit Types (A B : {set gT}) (G H : {group gT}).

Lemma lcn0 A : 'L_0(A) = A. Proof. by []. Qed.
Lemma lcn1 A : 'L_1(A) = A. Proof. by []. Qed.
Lemma lcnSn n A : 'L_n.+2(A) = [~: 'L_n.+1(A), A]. Proof. by []. Qed.
Lemma lcnSnS n G : [~: 'L_n(G), G] \subset 'L_n.+1(G).
Proof. by case: n => //; exact: der1_subG. Qed.
Lemma lcnE n A : 'L_n.+1(A) = lower_central_at_rec n A.
Proof. by []. Qed.
Lemma lcn2 A : 'L_2(A) = A^`(1). Proof. by []. Qed.

Lemma lcn_group_set n G : group_set 'L_n(G).
Proof. by case: n => [|[|n]]; exact: groupP. Qed.

Canonical lower_central_at_group n G := Group (lcn_group_set n G).

Lemma lcn_char n G : 'L_n(G) \char G.
Proof.
by case: n => [|n]; last elim: n => [|n IHn]; rewrite ?lcnSn ?charR ?char_refl.
Qed.

Lemma lcn_normal n G : 'L_n(G) <|  G.
Proof. by apply: char_normal; exact: lcn_char. Qed.

Lemma lcn_sub n G : 'L_n(G) \subset G.
Proof. by case/andP: (lcn_normal n G). Qed.

Lemma lcn_norm n G : G \subset 'N('L_n(G)).
Proof. by case/andP: (lcn_normal n G). Qed.

Lemma lcn_subS n G : 'L_n.+1(G) \subset 'L_n(G).
Proof.
case: n => // n; rewrite lcnSn commGC commg_subr.
by case/andP: (lcn_normal n.+1 G).
Qed.

Lemma lcn_normalS n G : 'L_n.+1(G) <| 'L_n(G).
Proof. by apply: normalS (lcn_normal _ _); rewrite (lcn_subS, lcn_sub). Qed.

Lemma lcn_central n G : 'L_n(G) / 'L_n.+1(G) \subset 'Z(G / 'L_n.+1(G)).
Proof.
case: n => [|n]; first by rewrite trivg_quotient sub1G.
by rewrite subsetI quotientS ?lcn_sub ?quotient_cents2r.
Qed.

Lemma lcn_sub_leq m n G : n <= m -> 'L_m(G) \subset 'L_n(G).
Proof.
by move/subnK <-; elim: {m}(m - n) => // m; exact: subset_trans (lcn_subS _ _).
Qed.

Lemma lcnS n A B : A \subset B -> 'L_n(A) \subset 'L_n(B).
Proof.
by case: n => // n sAB; elim: n => // n IHn; rewrite !lcnSn genS ?imset2S.
Qed.

Lemma lcn_cprod n A B G : A \* B = G -> 'L_n(A) \* 'L_n(B) = 'L_n(G).
Proof.
case: n => // n /cprodP[[H K -> ->{A B}] defG cHK].
have sL := subset_trans (lcn_sub _ _); rewrite cprodE ?(centSS _ _ cHK) ?sL //.
symmetry; elim: n => // n; rewrite lcnSn => ->; rewrite commMG /=; last first.
  by apply: subset_trans (commg_normr _ _); rewrite sL // -defG mulG_subr.
rewrite -!(commGC G) -defG -{1}(centC cHK).
rewrite !commMG ?normsR ?lcn_norm ?cents_norm // 1?centsC //.
by rewrite -!(commGC 'L__(_)) -!lcnSn !(commG1P _) ?mul1g ?sL // centsC.
Qed.

Lemma lcn_dprod n A B G : A \x B = G -> 'L_n(A) \x 'L_n(B) = 'L_n(G).
Proof.
move=> defG; have [[K H defA defB] _ _ tiAB] := dprodP defG.
rewrite !dprodEcp // in defG *; first exact: lcn_cprod.
by rewrite defA defB; apply/trivgP; rewrite -tiAB defA defB setISS ?lcn_sub.
Qed.

Lemma der_cprod n A B G : A \* B = G -> A^`(n) \* B^`(n) = G^`(n).
Proof. by move=> defG; elim: n => {defG}// n; apply: (lcn_cprod 2). Qed.

Lemma der_dprod n A B G : A \x B = G -> A^`(n) \x B^`(n) = G^`(n).
Proof. by move=> defG; elim: n => {defG}// n; apply: (lcn_dprod 2). Qed.

Lemma lcn_bigcprod n I r P (F : I -> {set gT}) G :
    \big[cprod/1]_(i <- r | P i) F i = G ->
  \big[cprod/1]_(i <- r | P i) 'L_n(F i) = 'L_n(G).
Proof.
elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first exact/esym/trivgP/lcn_sub.
by rewrite -(lcn_cprod n dG); have [[_ H _ dH]] := cprodP dG; rewrite dH (IH H).
Qed.

Lemma lcn_bigdprod n I r P (F : I -> {set gT}) G :
    \big[dprod/1]_(i <- r | P i) F i = G ->
  \big[dprod/1]_(i <- r | P i) 'L_n(F i) = 'L_n(G).
Proof.
elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first exact/esym/trivgP/lcn_sub.
by rewrite -(lcn_dprod n dG); have [[_ H _ dH]] := dprodP dG; rewrite dH (IH H).
Qed.

Lemma der_bigcprod n I r P (F : I -> {set gT}) G :
    \big[cprod/1]_(i <- r | P i) F i = G ->
  \big[cprod/1]_(i <- r | P i) (F i)^`(n) = G^`(n).
Proof.
elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1.
by rewrite -(der_cprod n dG); have [[_ H _ dH]] := cprodP dG; rewrite dH (IH H).
Qed.

Lemma der_bigdprod n I r P (F : I -> {set gT}) G :
    \big[dprod/1]_(i <- r | P i) F i = G ->
  \big[dprod/1]_(i <- r | P i) (F i)^`(n) = G^`(n).
Proof.
elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1.
by rewrite -(der_dprod n dG); have [[_ H _ dH]] := dprodP dG; rewrite dH (IH H).
Qed.

Lemma nilpotent_class G : nilpotent G = (nil_class G < #|G|).
Proof.
rewrite /nil_class; set s := mkseq _ _.
transitivity (1 \in s); last by rewrite -index_mem size_mkseq.
apply/idP/mapP=> {s}/= [nilG | [n _ Ln1]]; last first.
  apply/forall_inP=> H /subsetIP[sHG sHR].
  rewrite -subG1 {}Ln1; elim: n => // n IHn.
  by rewrite (subset_trans sHR) ?commSg.
pose m := #|G|.-1; exists m; first by rewrite mem_iota /= prednK.
rewrite ['L__(G)]card_le1_trivg //= -(subnn m).
elim: {-2}m => [|n]; [by rewrite subn0 prednK | rewrite lcnSn subnS].
case: (eqsVneq 'L_n.+1(G) 1) => [-> | ntLn]; first by rewrite comm1G cards1.
case: (m - n) => [|m' /= IHn]; first by rewrite leqNgt cardG_gt1 ntLn.
rewrite -ltnS (leq_trans (proper_card _) IHn) //.
by rewrite (nil_comm_properl nilG) ?lcn_sub // subsetI subxx lcn_norm.
Qed.

Lemma lcn_nil_classP n G :
  nilpotent G -> reflect ('L_n.+1(G) = 1) (nil_class G <= n).
Proof.
rewrite nilpotent_class /nil_class; set s := mkseq _ _.
set c := index 1 s => lt_c_G; case: leqP => [le_c_n | lt_n_c].
  have Lc1: nth 1 s c = 1 by rewrite nth_index // -index_mem size_mkseq.
  by left; apply/trivgP; rewrite -Lc1 nth_mkseq ?lcn_sub_leq.
right; apply/eqP/negPf; rewrite -(before_find 1 lt_n_c) nth_mkseq //.
exact: ltn_trans lt_n_c lt_c_G.
Qed.

Lemma lcnP G : reflect (exists n, 'L_n.+1(G) = 1) (nilpotent G).
Proof.
apply: (iffP idP) => [nilG | [n Ln1]].
  by exists (nil_class G); exact/lcn_nil_classP.
apply/forall_inP=> H /subsetIP[sHG sHR]; rewrite -subG1 -{}Ln1.
by elim: n => // n IHn; rewrite (subset_trans sHR) ?commSg.
Qed.

Lemma abelian_nil G : abelian G -> nilpotent G.
Proof. by move=> abG; apply/lcnP; exists 1%N; exact/commG1P. Qed.

Lemma nil_class0 G : (nil_class G == 0) = (G :==: 1).
Proof.
apply/idP/eqP=> [nilG | ->].
  by apply/(lcn_nil_classP 0); rewrite ?nilpotent_class (eqP nilG) ?cardG_gt0.
by rewrite -leqn0; apply/(lcn_nil_classP 0); rewrite ?nilpotent1.
Qed.

Lemma nil_class1 G : (nil_class G <= 1) = abelian G.
Proof.
have [-> | ntG] := eqsVneq G 1.
  by rewrite abelian1 leq_eqVlt ltnS leqn0 nil_class0 eqxx orbT.
apply/idP/idP=> cGG.
  apply/commG1P; apply/(lcn_nil_classP 1); rewrite // nilpotent_class.
  by rewrite (leq_ltn_trans cGG) // cardG_gt1.
by apply/(lcn_nil_classP 1); rewrite ?abelian_nil //; apply/commG1P.
Qed.

Lemma cprod_nil A B G : A \* B = G -> nilpotent G = nilpotent A && nilpotent B.
Proof.
move=> defG; case/cprodP: defG (defG) => [[H K -> ->{A B}] defG _] defGc.
apply/idP/andP=> [nilG | [/lcnP[m LmH1] /lcnP[n LnK1]]].
  by rewrite !(nilpotentS _ nilG) // -defG (mulG_subr, mulG_subl).
apply/lcnP; exists (m + n.+1); apply/trivgP.
case/cprodP: (lcn_cprod (m.+1 + n.+1) defGc) => _ <- _.
by rewrite mulG_subG /= -{1}LmH1 -LnK1 !lcn_sub_leq ?leq_addl ?leq_addr.
Qed.

Lemma mulg_nil G H :
  H \subset 'C(G) -> nilpotent (G * H) = nilpotent G && nilpotent H.
Proof. by move=> cGH; rewrite -(cprod_nil (cprodEY cGH)) /= cent_joinEr. Qed.

Lemma dprod_nil A B G : A \x B = G -> nilpotent G = nilpotent A && nilpotent B.
Proof. by case/dprodP=> [[H K -> ->] <- cHK _]; rewrite mulg_nil.
Qed.

Lemma bigdprod_nil I r (P : pred I) (A_ : I -> {set gT}) G :
  \big[dprod/1]_(i <- r | P i) A_ i = G
  -> (forall i, P i -> nilpotent (A_ i)) -> nilpotent G.
Proof.
move=> defG nilA; elim/big_rec: _ => [|i B Pi nilB] in G defG *.
  by rewrite -defG nilpotent1.
have [[_ H _ defB] _ _ _] := dprodP defG.
by rewrite (dprod_nil defG) nilA //= defB nilB.
Qed.

End LowerCentral.

Notation "''L_' n ( G )" := (lower_central_at_group n G) : Group_scope.

Lemma lcn_cont n : GFunctor.continuous (lower_central_at n).
Proof.
case: n => //; elim=> // n IHn g0T h0T H phi.
by rewrite !lcnSn morphimR ?lcn_sub // commSg ?IHn.
Qed.

Canonical lcn_igFun n := [igFun by lcn_sub^~ n & lcn_cont n].
Canonical lcn_gFun n := [gFun by lcn_cont n].
Canonical lcn_mgFun n := [mgFun by fun _ G H => @lcnS _ n G H].

Section UpperCentralFunctor.

Variable n : nat.
Implicit Type gT : finGroupType.

Lemma ucn_pmap : exists hZ : GFunctor.pmap, @upper_central_at n = hZ.
Proof.
elim: n => [|n' [hZ defZ]]; first by exists trivGfun_pgFun.
by exists [pgFun of center %% hZ]; rewrite /= -defZ.
Qed.

(* Now extract all the intermediate facts of the last proof. *)

Lemma ucn_group_set gT (G : {group gT}) : group_set 'Z_n(G).
Proof. by have [hZ ->] := ucn_pmap; exact: groupP. Qed.

Canonical upper_central_at_group gT G := Group (@ucn_group_set gT G).

Lemma ucn_sub gT (G : {group gT}) : 'Z_n(G) \subset G.
Proof. by have [hZ ->] := ucn_pmap; exact: gFsub. Qed.

Lemma morphim_ucn : GFunctor.pcontinuous (upper_central_at n).
Proof. by have [hZ ->] := ucn_pmap; exact: pmorphimF. Qed.

Canonical ucn_igFun := [igFun by ucn_sub & morphim_ucn].
Canonical ucn_gFun := [gFun by morphim_ucn].
Canonical ucn_pgFun := [pgFun by morphim_ucn].

Variable (gT : finGroupType) (G : {group gT}).

Lemma ucn_char : 'Z_n(G) \char G. Proof. exact: gFchar. Qed.
Lemma ucn_norm : G \subset 'N('Z_n(G)). Proof. exact: gFnorm. Qed.
Lemma ucn_normal : 'Z_n(G) <| G. Proof. exact: gFnormal. Qed.

End UpperCentralFunctor.

Notation "''Z_' n ( G )" := (upper_central_at_group n G) : Group_scope.

Section UpperCentral.

Variable gT : finGroupType.
Implicit Types (A B : {set gT}) (G H : {group gT}).

Lemma ucn0 A : 'Z_0(A) = 1.
Proof. by []. Qed.

Lemma ucnSn n A : 'Z_n.+1(A) = coset 'Z_n(A) @*^-1 'Z(A / 'Z_n(A)).
Proof. by []. Qed.

Lemma ucnE n A : 'Z_n(A) = upper_central_at_rec n A.
Proof. by []. Qed.

Lemma ucn_subS n G : 'Z_n(G) \subset 'Z_n.+1(G).
Proof. by rewrite -{1}['Z_n(G)]ker_coset morphpreS ?sub1G. Qed.

Lemma ucn_sub_geq m n G : n >= m -> 'Z_m(G) \subset 'Z_n(G).
Proof.
move/subnK <-; elim: {n}(n - m) => // n IHn.
exact: subset_trans (ucn_subS _ _).
Qed.

Lemma ucn_central n G : 'Z_n.+1(G) / 'Z_n(G) = 'Z(G / 'Z_n(G)).
Proof. by rewrite ucnSn cosetpreK. Qed.

Lemma ucn_normalS n G : 'Z_n(G) <| 'Z_n.+1(G).
Proof. by rewrite (normalS _ _ (ucn_normal n G)) ?ucn_subS ?ucn_sub. Qed.

Lemma ucn_comm n G : [~: 'Z_n.+1(G), G] \subset 'Z_n(G).
Proof.
rewrite -quotient_cents2 ?normal_norm ?ucn_normal ?ucn_normalS //.
by rewrite ucn_central subsetIr.
Qed.

Lemma ucn1 G : 'Z_1(G) = 'Z(G).
Proof.
apply: (quotient_inj (normal1 _) (normal1 _)).
by rewrite /= (ucn_central 0) -injmF ?norms1 ?coset1_injm.
Qed.

Lemma ucnSnR n G : 'Z_n.+1(G) = [set x in G | [~: [set x], G] \subset 'Z_n(G)].
Proof.
apply/setP=> x; rewrite inE -(setIidPr (ucn_sub n.+1 G)) inE ucnSn.
case Gx: (x \in G) => //=; have nZG := ucn_norm n G.
rewrite -sub1set -sub_quotient_pre -?quotient_cents2 ?sub1set ?(subsetP nZG) //.
by rewrite subsetI quotientS ?sub1set.
Qed.

Lemma ucn_cprod n A B G : A \* B = G -> 'Z_n(A) \* 'Z_n(B) = 'Z_n(G).
Proof.
case/cprodP=> [[H K -> ->{A B}] mulHK cHK].
elim: n => [|n /cprodP[_ /= defZ cZn]]; first exact: cprod1g.
set Z := 'Z_n(G) in defZ cZn; rewrite (ucnSn n G) /= -/Z.
have /mulGsubP[nZH nZK]: H * K \subset 'N(Z) by rewrite mulHK gFnorm.
have <-: 'Z(H / Z) * 'Z(K / Z) = 'Z(G / Z).
  by rewrite -mulHK quotientMl // center_prod ?quotient_cents.
have ZquoZ (B A : {group gT}):
  B \subset 'C(A) -> 'Z_n(A) * 'Z_n(B) = Z -> 'Z(A / Z) = 'Z_n.+1(A) / Z.
- move=> cAB {defZ}defZ; have cAZnB := subset_trans (ucn_sub n B) cAB.
  have /second_isom[/=]: A \subset 'N(Z).
    by rewrite -defZ normsM ?gFnorm ?cents_norm // centsC.
  suffices ->: Z :&: A = 'Z_n(A).
    by move=> f inj_f im_f; rewrite -!im_f ?gFsub // ucn_central injm_center.
  rewrite -defZ -group_modl ?gFsub //; apply/mulGidPl.
  have [-> | n_gt0] := posnP n; first exact: subsetIl.
  by apply: subset_trans (ucn_sub_geq A n_gt0); rewrite /= setIC ucn1 setIS.
rewrite (ZquoZ H K) 1?centsC 1?(centC cZn) // {ZquoZ}(ZquoZ K H) //.
have cZn1: 'Z_n.+1(K) \subset 'C('Z_n.+1(H)) by apply: centSS cHK; apply: gFsub.
rewrite -quotientMl ?quotientK ?mul_subG ?(subset_trans (gFsub _ _)) //=.
rewrite cprodE // -cent_joinEr ?mulSGid //= cent_joinEr //= -/Z.
by rewrite -defZ mulgSS ?ucn_subS.
Qed.

Lemma ucn_dprod n A B G : A \x B = G -> 'Z_n(A) \x 'Z_n(B) = 'Z_n(G).
Proof.
move=> defG; have [[K H defA defB] _ _ tiAB] := dprodP defG.
rewrite !dprodEcp // in defG *; first exact: ucn_cprod.
by rewrite defA defB; apply/trivgP; rewrite -tiAB defA defB setISS ?ucn_sub.
Qed.

Lemma ucn_bigcprod n I r P (F : I -> {set gT}) G :
    \big[cprod/1]_(i <- r | P i) F i = G ->
  \big[cprod/1]_(i <- r | P i) 'Z_n(F i) = 'Z_n(G).
Proof.
elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1.
by rewrite -(ucn_cprod n dG); have [[_ H _ dH]] := cprodP dG; rewrite dH (IH H).
Qed.

Lemma ucn_bigdprod n I r P (F : I -> {set gT}) G :
    \big[dprod/1]_(i <- r | P i) F i = G ->
  \big[dprod/1]_(i <- r | P i) 'Z_n(F i) = 'Z_n(G).
Proof.
elim/big_rec2: _ G => [_ <- | i A Z _ IH G dG]; first by rewrite gF1.
by rewrite -(ucn_dprod n dG); have [[_ H _ dH]] := dprodP dG; rewrite dH (IH H).
Qed.

Lemma ucn_lcnP n G : ('L_n.+1(G) == 1) = ('Z_n(G) == G).
Proof.
rewrite !eqEsubset sub1G ucn_sub /= andbT -(ucn0 G).
elim: {1 3}n 0 (addn0 n) => [j <- //|i IHi j].
rewrite addSnnS => /IHi <- {IHi}; rewrite ucnSn lcnSn.
have nZG := normal_norm (ucn_normal j G).
have nZL := subset_trans (lcn_sub _ _) nZG.
by rewrite -sub_morphim_pre // subsetI morphimS ?lcn_sub // quotient_cents2.
Qed.

Lemma ucnP G : reflect (exists n, 'Z_n(G) = G) (nilpotent G).
Proof.
apply: (iffP (lcnP G)) => [] [n /eqP clGn];
  by exists n; apply/eqP; rewrite ucn_lcnP in clGn *.
Qed.

Lemma ucn_nil_classP n G :
  nilpotent G -> reflect ('Z_n(G) = G) (nil_class G <= n).
Proof.
move=> nilG; rewrite (sameP (lcn_nil_classP n nilG) eqP) ucn_lcnP; exact: eqP.
Qed.

Lemma ucn_id n G : 'Z_n('Z_n(G)) = 'Z_n(G).
Proof. by rewrite -{2}['Z_n(G)]gFid. Qed.

Lemma ucn_nilpotent n G : nilpotent 'Z_n(G).
Proof. by apply/ucnP; exists n; rewrite ucn_id. Qed.

Lemma nil_class_ucn n G : nil_class 'Z_n(G) <= n.
Proof. by apply/ucn_nil_classP; rewrite ?ucn_nilpotent ?ucn_id. Qed.

End UpperCentral.

Section MorphNil.

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

Lemma morphim_lcn n G : G \subset D -> f @* 'L_n(G) = 'L_n(f @* G).
Proof.
move=> sHG; case: n => //; elim=> // n IHn.
by rewrite !lcnSn -IHn morphimR // (subset_trans _ sHG) // lcn_sub.
Qed.

Lemma injm_ucn n G : 'injm f -> G \subset D -> f @* 'Z_n(G) = 'Z_n(f @* G).
Proof. exact: injmF. Qed.

Lemma morphim_nil G : nilpotent G -> nilpotent (f @* G).
Proof.
case/ucnP=> n ZnG; apply/ucnP; exists n; apply/eqP.
by rewrite eqEsubset ucn_sub /= -{1}ZnG morphim_ucn.
Qed.

Lemma injm_nil G : 'injm f -> G \subset D -> nilpotent (f @* G) = nilpotent G.
Proof.
move=> injf sGD; apply/idP/idP; last exact: morphim_nil.
case/ucnP=> n; rewrite -injm_ucn // => /injm_morphim_inj defZ.
by apply/ucnP; exists n; rewrite defZ ?(subset_trans (ucn_sub n G)).
Qed.

Lemma nil_class_morphim G : nilpotent G -> nil_class (f @* G) <= nil_class G.
Proof.
move=> nilG; rewrite (sameP (ucn_nil_classP _ (morphim_nil nilG)) eqP) /=.
by rewrite eqEsubset ucn_sub -{1}(ucn_nil_classP _ nilG (leqnn _)) morphim_ucn.
Qed.

Lemma nil_class_injm G :
  'injm f -> G \subset D -> nil_class (f @* G) = nil_class G.
Proof.
move=> injf sGD; case nilG: (nilpotent G).
  apply/eqP; rewrite eqn_leq nil_class_morphim //.
  rewrite (sameP (lcn_nil_classP _ nilG) eqP) -subG1.
  rewrite -(injmSK injf) ?(subset_trans (lcn_sub _ _)) // morphim1.
  by rewrite morphim_lcn // (lcn_nil_classP _ _ (leqnn _)) //= injm_nil.
transitivity #|G|; apply/eqP; rewrite eqn_leq.
  rewrite -(card_injm injf sGD) (leq_trans (index_size _ _)) ?size_mkseq //.
  by rewrite leqNgt -nilpotent_class injm_nil ?nilG.
rewrite (leq_trans (index_size _ _)) ?size_mkseq // leqNgt -nilpotent_class.
by rewrite nilG.
Qed.

End MorphNil.

Section QuotientNil.

Variables gT : finGroupType.
Implicit Types (rT : finGroupType) (G H : {group gT}).

Lemma quotient_ucn_add m n G : 'Z_(m + n)(G) / 'Z_n(G) = 'Z_m(G / 'Z_n(G)).
Proof.
elim: m => [|m IHm]; first exact: trivg_quotient.
apply/setP=> Zx; have [x Nx ->{Zx}] := cosetP Zx.
have [sZG nZG] := andP (ucn_normal n G).
rewrite (ucnSnR m) inE -!sub1set -morphim_set1 //= -quotientR ?sub1set // -IHm.
rewrite !quotientSGK ?(ucn_sub_geq, leq_addl, comm_subG _ nZG, sub1set) //=.
by rewrite addSn /= ucnSnR inE.
Qed.

Lemma isog_nil rT G (L : {group rT}) : G \isog L -> nilpotent G = nilpotent L.
Proof. by case/isogP=> f injf <-; rewrite injm_nil. Qed.

Lemma isog_nil_class rT G (L : {group rT}) :
  G \isog L -> nil_class G = nil_class L.
Proof. by case/isogP=> f injf <-; rewrite nil_class_injm. Qed.

Lemma quotient_nil G H : nilpotent G -> nilpotent (G / H).
Proof. exact: morphim_nil. Qed.

Lemma quotient_center_nil G : nilpotent (G / 'Z(G)) = nilpotent G.
Proof.
rewrite -ucn1; apply/idP/idP; last exact: quotient_nil.
case/ucnP=> c nilGq; apply/ucnP; exists c.+1; have nsZ1G := ucn_normal 1 G.
apply: (quotient_inj _ nsZ1G); last by rewrite /= -(addn1 c) quotient_ucn_add.
by rewrite (normalS _ _ nsZ1G) ?ucn_sub ?ucn_sub_geq.
Qed.

Lemma nil_class_quotient_center G :
  nilpotent (G) -> nil_class (G / 'Z(G)) = (nil_class G).-1.
Proof.
move=> nilG; have nsZ1G := ucn_normal 1 G.
apply/eqP; rewrite -ucn1 eqn_leq; apply/andP; split.
  apply/ucn_nil_classP; rewrite ?quotient_nil //= -quotient_ucn_add ucn1.
  by rewrite (ucn_nil_classP _ _ _) ?addn1 ?leqSpred.
rewrite -subn1 leq_subLR addnC; apply/ucn_nil_classP => //=.
apply: (quotient_inj _ nsZ1G) => /=.
  by apply: normalS (ucn_sub _ _) nsZ1G; rewrite /= addnS ucn_sub_geq.
by rewrite quotient_ucn_add; apply/ucn_nil_classP; rewrite //= quotient_nil.
Qed.

Lemma nilpotent_sub_norm G H :
  nilpotent G -> H \subset G -> 'N_G(H) \subset H -> G :=: H.
Proof.
move=> nilG sHG sNH; apply/eqP; rewrite eqEsubset sHG andbT; apply/negP=> nsGH.
have{nsGH} [i sZH []]: exists2 i, 'Z_i(G) \subset H & ~ 'Z_i.+1(G) \subset H.
  case/ucnP: nilG => n ZnG; rewrite -{}ZnG in nsGH.
  elim: n => [|i IHi] in nsGH *; first by rewrite sub1G in nsGH.
  by case sZH: ('Z_i(G) \subset H); [exists i | apply: IHi; rewrite sZH].
apply: subset_trans sNH; rewrite subsetI ucn_sub -commg_subr.
by apply: subset_trans sZH; apply: subset_trans (ucn_comm i G); exact: commgS.
Qed.

Lemma nilpotent_proper_norm G H :
  nilpotent G -> H \proper G -> H \proper 'N_G(H).
Proof.
move=> nilG; rewrite properEneq properE subsetI normG => /andP[neHG sHG].
by rewrite sHG; apply: contra neHG; move/(nilpotent_sub_norm nilG)->.
Qed.

Lemma nilpotent_subnormal G H : nilpotent G -> H \subset G -> H <|<| G.
Proof.
move=> nilG; elim: {H}_.+1 {-2}H (ltnSn (#|G| - #|H|)) => // m IHm H.
rewrite ltnS => leGHm sHG; have:= sHG; rewrite subEproper.
case/predU1P=> [->|]; first exact: subnormal_refl.
move/(nilpotent_proper_norm nilG); set K := 'N_G(H) => prHK.
have snHK: H <|<| K by rewrite normal_subnormal ?normalSG.
have sKG: K \subset G by rewrite subsetIl.
apply: subnormal_trans snHK (IHm _ (leq_trans _ leGHm) sKG).
by rewrite ltn_sub2l ?proper_card ?(proper_sub_trans prHK).
Qed.

Lemma TI_center_nil G H : nilpotent G -> H <| G -> H :&: 'Z(G) = 1 -> H :=: 1.
Proof.
move=> nilG /andP[sHG nHG] tiHZ.
rewrite -{1}(setIidPl sHG); have{nilG} /ucnP[n <-] := nilG.
elim: n => [|n IHn]; apply/trivgP; rewrite ?subsetIr // -tiHZ.
rewrite [H :&: 'Z(G)]setIA subsetI setIS ?ucn_sub //= (sameP commG1P trivgP).
rewrite -commg_subr commGC in nHG.
rewrite -IHn subsetI (subset_trans _ nHG) ?commSg ?subsetIl //=.
by rewrite (subset_trans _ (ucn_comm n G)) ?commSg ?subsetIr.
Qed.

Lemma meet_center_nil G H :
  nilpotent G -> H <| G -> H :!=: 1 -> H :&: 'Z(G) != 1.
Proof. by move=> nilG nsHG; apply: contraNneq => /TI_center_nil->. Qed.

Lemma center_nil_eq1 G : nilpotent G -> ('Z(G) == 1) = (G :==: 1).
Proof.
move=> nilG; apply/eqP/eqP=> [Z1 | ->]; last exact: center1.
by rewrite (TI_center_nil nilG) // (setIidPr (center_sub G)).
Qed.

End QuotientNil.

Section Solvable.

Variable gT : finGroupType.
Implicit Types G H : {group gT}.

Lemma nilpotent_sol G : nilpotent G -> solvable G.
Proof.
move=> nilG; apply/forall_inP=> H /subsetIP[sHG sHH'].
apply: (implyP (forallP nilG H)).
by rewrite subsetI sHG (subset_trans sHH') ?commgS.
Qed.

Lemma abelian_sol G : abelian G -> solvable G.
Proof. by move/abelian_nil; exact: nilpotent_sol. Qed.

Lemma solvable1 : solvable [1 gT]. Proof. exact: abelian_sol (abelian1 gT). Qed.

Lemma solvableS G H : H \subset G -> solvable G -> solvable H.
Proof.
move=> sHG solG;  apply/forall_inP=> K /subsetIP[sKH sKK'].
by apply: (implyP (forallP solG K)); rewrite subsetI (subset_trans sKH).
Qed.

Lemma sol_der1_proper G H :
  solvable G -> H \subset G -> H :!=: 1 -> H^`(1) \proper H.
Proof.
move=> solG sHG ntH; rewrite properE comm_subG //; apply: implyP ntH.
by have:= forallP solG H; rewrite subsetI sHG implybNN.
Qed.

Lemma derivedP G : reflect (exists n, G^`(n) = 1) (solvable G).
Proof.
apply: (iffP idP) => [solG | [n solGn]]; last first.
  apply/forall_inP=> H /subsetIP[sHG sHH'].
  rewrite -subG1 -{}solGn; elim: n => // n IHn.
  exact: subset_trans sHH' (commgSS _ _).
suffices IHn n: #|G^`(n)| <= (#|G|.-1 - n).+1.
  by exists #|G|.-1; rewrite [G^`(_)]card_le1_trivg ?(leq_trans (IHn _)) ?subnn.
elim: n => [|n IHn]; first by rewrite subn0 prednK.
rewrite dergSn subnS -ltnS.
have [-> | ntGn] := eqVneq G^`(n) 1; first by rewrite commG1 cards1.
case: (_ - _) IHn => [|n']; first by rewrite leqNgt cardG_gt1 ntGn.
by apply: leq_trans (proper_card _); exact: sol_der1_proper (der_sub _ _) _.
Qed.

End Solvable.

Section MorphSol.

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

Lemma morphim_sol : solvable G -> solvable (f @* G).
Proof.
move/(solvableS (subsetIr D G)); case/derivedP=> n Gn1; apply/derivedP.
by exists n; rewrite /= -morphimIdom -morphim_der ?subsetIl // Gn1 morphim1.
Qed.

Lemma injm_sol : 'injm f -> G \subset D -> solvable (f @* G) = solvable G.
Proof.
move=> injf sGD; apply/idP/idP; last exact: morphim_sol.
case/derivedP=> n Gn1; apply/derivedP; exists n; apply/trivgP.
rewrite -(injmSK injf) ?(subset_trans (der_sub _ _)) ?morphim_der //.
by rewrite Gn1 morphim1.
Qed.

End MorphSol.

Section QuotientSol.

Variables gT rT : finGroupType.
Implicit Types G H K : {group gT}.

Lemma isog_sol G (L : {group rT}) : G \isog L -> solvable G = solvable L.
Proof. by case/isogP=> f injf <-; rewrite injm_sol. Qed.

Lemma quotient_sol G H : solvable G -> solvable (G / H).
Proof. exact: morphim_sol. Qed.

Lemma series_sol G H : H <| G -> solvable G = solvable H && solvable (G / H).
Proof.
case/andP=> sHG nHG; apply/idP/andP=> [solG | [solH solGH]].
  by rewrite quotient_sol // (solvableS sHG).
apply/forall_inP=> K /subsetIP[sKG sK'K].
suffices sKH: K \subset H.
  by apply: (implyP (forallP solH K)); rewrite subsetI sKH.
have nHK := subset_trans sKG nHG.
rewrite -quotient_sub1 // subG1 (implyP (forallP solGH _)) //.
by rewrite subsetI -morphimR ?morphimS.
Qed.

End QuotientSol.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Import List PeanoNat Lia.
Import ListNotations.

Require Import Undecidability.SetConstraints.FMsetC Undecidability.SetConstraints.Util.Facts.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Local Notation "A ≡ B" := (mset_eq A B) (at level 65).

Arguments mset_eq !A !B.

(* eq facts *)
Lemma eq_refl {A} : A ≡ A.
Proof. done. Qed.

Lemma eq_eq {A B}: A = B -> A ≡ B.
Proof. by move=> ->. Qed.

Lemma eq_symm {A B} : A ≡ B -> B ≡ A.
Proof. by firstorder done. Qed.

Lemma eq_in_iff {A B} : A ≡ B -> forall c, In c A <-> In c B.
Proof.
  rewrite /mset_eq => H c. constructor=> Hc.
  - have := iffLR (count_occ_In Nat.eq_dec A c) Hc.
    move: (H c) => ->.
    by move /(count_occ_In Nat.eq_dec B c).
  - have := iffLR (count_occ_In Nat.eq_dec B c) Hc.
    move: (H c) => <-.
    by move /(count_occ_In Nat.eq_dec A c).
Qed.

Lemma eq_nilE {A} : [] ≡ A -> A = [].
Proof.
  case: A; first done.
  move=> a A /eq_in_iff /(_ a) /iffRL.
  apply: unnest; [by left | done].
Qed.

Lemma eq_trans {A B C} : A ≡ B -> B ≡ C -> A ≡ C.
Proof.
  rewrite /mset_eq => + + c.
  move=> /(_ c) + /(_ c).
  by move=> -> ->.
Qed.

Lemma eq_Forall_iff {A B} : A ≡ B -> forall P, (Forall P A <-> Forall P B).
Proof.
  move /eq_in_iff => H P.
  rewrite ? Forall_forall. constructor; by firstorder done.
Qed.

Lemma eq_lr {A B A' B'}:
  A ≡ A' -> B ≡ B' -> (A ≡ B) <-> (A' ≡ B').
Proof.
  move=> HA HB. constructor.
  - move /eq_trans. move /(_ _ HB).
    move /(eq_trans _). by move /(_ _ (eq_symm HA)).
  - move /eq_trans. move /(_ _ (eq_symm HB)).
    move /(eq_trans _). by move /(_ _ HA).
Qed.

Lemma eq_appI {A B A' B'} : A ≡ A' -> B ≡ B' -> A ++ B ≡ A' ++ B'.
Proof.
  rewrite /mset_eq => + + c. move=> /(_ c) + /(_ c).
  rewrite ? count_occ_app. by move=> -> ->.
Qed.

(* solves trivial multiset equalities *)
Ltac eq_trivial :=
  move=> ?; rewrite ? (count_occ_app, count_occ_cons, count_occ_nil, eta_reduction); unlock; by lia.

Lemma eq_cons_iff {a A B} : (a :: A) ≡ (a :: B) <-> A ≡ B.
Proof.
  rewrite /mset_eq. constructor=> + c => /(_ c).
  all: rewrite -/([a] ++ A) -/([a] ++ B) ?count_occ_app; by lia.
Qed.

Lemma eq_app_iff {A B C} : (A ++ B) ≡ (A ++ C) <-> B ≡ C.
Proof.
  elim: A; first done.
  move=> a A IH /=.
  by rewrite eq_cons_iff.
Qed.

Lemma eq_app_comm {A B} : A ++ B ≡ B ++ A.
Proof. move=> ?. rewrite ?count_occ_app. by lia. Qed.

Lemma eq_length {A B} : A ≡ B -> length A = length B.
  elim /(measure_rect (@length nat)) : A B.
  case.
  { by move=> _ B /eq_nilE ->. }
  move=> a A IH B /copy [/eq_in_iff /(_ a) /iffLR].
  apply: unnest; first by left.
  move /(@in_split _ _) => [B1 [B2 ->]].
  under (eq_lr eq_refl (B' := a :: (B1 ++ B2))).
  { by eq_trivial. }
  move /eq_cons_iff. move /IH.
  apply: unnest; first done.
  rewrite ? app_length => /=. by lia.
Qed.

Lemma eq_repeatE {a A n} : repeat a n ≡ A -> A = repeat a n.
Proof.
  move=> /copy [/eq_length]. rewrite repeat_length => HlA.
  move /eq_Forall_iff /(_ (fun c => a = c)) /iffLR. apply: unnest.
  { clear. elim: n; firstorder (by constructor). }
  subst n. elim: A; first done.
  move=> b A IH /Forall_cons_iff [<-] /IH -> /=.
  by rewrite repeat_length.
Qed.

Lemma eq_singletonE {a A} : [a] ≡ A -> A = [a].
Proof.
  have -> : [a] = repeat a 1 by done.
  by move /eq_repeatE.
Qed.

Lemma eq_mapE {A f} : (forall n, n < f n) -> map f A ≡ A -> A = [].
Proof.
  case (nil_or_ex_max A); first done.
  move=> [a [Ha /Forall_forall HA]] Hf /eq_in_iff /(_ (f a)) /iffLR.
  rewrite in_map_iff. apply: unnest; first by exists a.
  move /HA. move: (Hf a). by lia.
Qed.

Lemma eq_consP {a A B}: a :: A ≡ a :: B <-> A ≡ B.
Proof.
  rewrite /mset_eq. constructor; move=> + c => /(_ c).
  all: rewrite ? count_occ_cons; by lia.
Qed.

Lemma eq_consE {a A B}: a :: A ≡ B -> exists B1 B2, B = B1 ++ (a :: B2) /\ A ≡ (B1 ++ B2).
Proof.
  move=> /copy [/mset_eq_utils.eq_in_iff /(_ a) /iffLR /(_ ltac:(by left))].
  move /(@in_split _ _) => [B1 [B2 ->]].
  under (mset_eq_utils.eq_lr mset_eq_utils.eq_refl (B' := a :: (B1 ++ B2))).
  { by mset_eq_utils.eq_trivial. }
  move /mset_eq_utils.eq_consP => H.
  exists B1, B2. by constructor.
Qed.

Lemma eq_app_nil_nilP {A B} : A ≡ A ++ B -> B = [].
Proof.
  elim: A; first by move /eq_nilE.
  move=> a A IH /=.
  by move /eq_consP.
Qed.

Lemma eq_mapI {A B} : A ≡ B -> map S A ≡ map S B.
Proof.
  rewrite /mset_eq => + c. move=> /(_ (Nat.pred c)).
  case: c.
  { move=> _.
    have H := iffLR (count_occ_not_In _ _ _).
    rewrite ? {}H; last done.
    all: by rewrite in_map_iff=> [[? [? ?]]]. }
  move=> c. rewrite - ? (count_occ_map S Nat.eq_dec Nat.eq_dec); last done.
  all: move=> >; by case.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From mathcomp Require Import choice finfun tuple fintype.
From CoqEAL Require Import hrel param refinements.
From CoqEAL Require Import seqmx_complements.  (* for Rord *)

(** * A generic implementation of [iteri] *)

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

Implicit Types n : nat.

(** ** Definition of type classes *)
Class I0_class I n := I0 : I n.
Class succ0_class I n := succ0 : I n -> I n.
Class nat_of_class I n := nat_of : I n -> nat.

Class nat_spec I n `{!I0_class I n, !succ0_class I n, !nat_of_class I n} :=
  {I0_prop : nat_of I0 = 0%N;
   succ0_prop : forall i : I n, ((nat_of i).+1 < n)%N -> nat_of (succ0 i) = (nat_of i).+1;
   nat_of_inj : forall i j : I n, nat_of i = nat_of j -> i = j}.

(** ** Generic definitions *)
Section generic_iteri.

Context {ord : nat -> Type}.
Context {n : nat}.
Context `{!I0_class ord n, !succ0_class ord n, !nat_of_class ord n}.

(** when [j <= n], [iteri_ord j f x] returns
[[
  for k : ordT n from 0 to (j - 1) do
    x := f k x
  done;
  x
]]
*)
Fixpoint iteri_ord_rec T k i (f : ord n -> T -> T) (x : T) :=
  match k with
    | O => x
    | S k => iteri_ord_rec k (succ0 i) f (f i x)
  end.
Definition iteri_ord T j (f : ord n -> T -> T) x := iteri_ord_rec j I0 f x.

End generic_iteri.

(** ** Main instantiations *)
Section theory_nat_of.

Context {n : nat}.
Global Instance I0_ssr : I0_class ordinal n.+1 := ord0.
Global Instance succ0_ssr : succ0_class ordinal n.+1 := fun i => inord i.+1.
Global Instance nat_of_ssr : nat_of_class ordinal n.+1 := @nat_of_ord n.+1.
Global Instance nat_spec_ssr : nat_spec (I := ordinal) (n := n.+1).
Proof.
constructor.
- done.
- by move=> i H; rewrite /nat_of /nat_of_ssr inordK.
- exact: ord_inj.
Qed.

Global Instance I0_instN : I0_class ord_instN n.+1 := O.
Global Instance succ0_instN : succ0_class ord_instN n.+1 := S.
Global Instance nat_of_instN : nat_of_class ord_instN n.+1 := id.
Global Instance nat_spec_instN : nat_spec (I := ord_instN) (n := n.+1).
Proof. done. Qed.

End theory_nat_of.

Section theory_nat_of2.

(** Extra refinement lemmas *)
Lemma Rord_I0 n1 n2 (rn : nat_R n1.+1 n2.+1) :
  Rord rn I0_ssr (@I0_instN n2).
Proof. done. Qed.

Global Instance Rord_nat_of n1 n2 (rn : nat_R n1.+1 n2.+1) :
  refines (Rord rn ==> eq) nat_of_ssr (nat_of_instN (n:=n2)).
Proof. by rewrite refinesE /Rord=> x y <-. Qed.

End theory_nat_of2.

(** ** Generic proofs *)
Section theory_iteri.

Context {n : nat} {ord : nat -> Type}.
Context `{!I0_class ord n.+1, !succ0_class ord n.+1, !nat_of_class ord n.+1}.

(*
(* Definition RordC : 'I_n.+1 -> ord n.+1 -> Prop :=
   (Rord \o fun_hrel nat_of_class0)%rel. *)

(* Useful? *)

Definition RordC (i : 'I_n.+1) (i' : ord n.+1) : Prop :=
  nat_of_ssr i = nat_of i'.
Instance RordC_nat_of : param (RordC ==> Logic.eq) nat_of_ssr nat_of.
Proof. by rewrite paramE. Qed.
 *)

Context `{!nat_spec (I := ord) (n := n.+1)}.

Lemma iteri_ord_rec_ind M P (f : ord n.+1 -> M -> M) :
  forall j, (j <= n.+1)%N ->
  (forall (i : ord n.+1) s,
    (nat_of i < n.+1)%N -> P (nat_of i) s -> P (nat_of i).+1 (f i s)) ->
  forall (i : ord n.+1) s, (nat_of i <= j)%N ->
    P (nat_of i) s -> P j (iteri_ord_rec (j - nat_of i)%N i f s).
Proof.
move=> j Hj Hind i s Hi H.
move Hk: (j - nat_of i)%N => k.
move: i Hi Hk s H; elim: k => [|k IHk] i Hi Hk s H /=.
{ replace j with (nat_of i); [by []|].
  by apply anti_leq; rewrite Hi /= -subn_eq0 Hk. }
case (ltnP (nat_of i) j) => [Hij|]; [|by rewrite /ssrnat.leq Hk].
case (ltnP (nat_of i) n) => Hjn.
{ have Hsisn : ((nat_of i).+1 < n.+1)%N.
  { by move: Hjn; rewrite -(ltn_add2r 1) !addn1. }
  apply IHk.
  by rewrite (succ0_prop Hsisn).
  rewrite (succ0_prop Hsisn) =>//.
  { by rewrite subnS Hk. }
  rewrite (succ0_prop Hsisn) =>//.
  by apply Hind; [apply leqW|]. }
have Hj' : j = n.+1.
{ by apply anti_leq; rewrite Hj /=; apply (leq_ltn_trans Hjn). }
have Hi' : nat_of i = n.
{ apply anti_leq; rewrite Hjn Bool.andb_true_r.
  apply (@leq_trans j.-1); [|by rewrite Hj'].
  by rewrite (pred_Sn (nat_of i)); apply /leP /le_pred /leP. }
have Hk' : k = 0%N.
{ apply sym_eq; move: Hk; rewrite Hi' Hj' subSnn; apply eq_add_S. }
by rewrite Hk' Hj' /= -Hi'; apply Hind; [rewrite Hi'|].
Qed.

Lemma iteri_ord_ind M P (f : ord n.+1 -> M -> M) :
  forall j, (j <= n.+1)%N ->
  (forall (i : ord n.+1) s,
    (nat_of i < n.+1)%N -> P (nat_of i) s -> P (nat_of i).+1 (f i s)) ->
  forall s, P 0%N s -> P j (iteri_ord j f s).
Proof.
move=> j Hj Hind s HP; rewrite /iteri_ord.
replace j with (j - nat_of I0)%N at 2.
by apply: iteri_ord_rec_ind =>//; rewrite I0_prop.
by rewrite I0_prop subn0.
Qed.

(* above lemma for P j s := forall i, nat_of i < j -> P i s *)
Lemma iteri_ord_ind_strong M P (f : ord n.+1 -> M -> M) :
  (forall (i : ord n.+1) s, (nat_of i < n.+1)%N ->
   (forall (j : ord n.+1), (nat_of j < nat_of i)%N -> P j s) ->
   forall (j : ord n.+1), (nat_of j < (nat_of i).+1)%N -> P j (f i s)) ->
  forall (i : ord n.+1) s, (nat_of i < n.+1)%N -> P i (iteri_ord n.+1 f s).
Proof.
move=> Hind i s Hi.
set P' := fun j s => forall (i : ord n.+1), (nat_of i < j)%N -> P i s.
set io := _ _ _ _; suff: P' n.+1 io; first by move=> H; apply H, Hi.
have : P' O s by done.
by eapply iteri_ord_ind.
Qed.

Lemma iteri_ord_ind_strong_cases M P (f : ord n.+1 -> M -> M) :
  (forall (i : ord n.+1) s, (nat_of i < n.+1)%N ->
   (forall (j : ord n.+1), (nat_of j < nat_of i)%N -> P j s) ->
   forall (j : ord n.+1), (nat_of j < nat_of i)%N -> P j (f i s)) ->
  (forall (i : ord n.+1) s, (nat_of i < n.+1)%N ->
   (forall (j : ord n.+1), (nat_of j < nat_of i)%N -> P j s) -> P i (f i s)) ->
  forall (i : ord n.+1) s, (nat_of i < n.+1)%N -> P i (iteri_ord n.+1 f s).
Proof.
move=> H1 H2; apply iteri_ord_ind_strong with (f := f) => // i s Hi H j Hj.
case (ltnP (nat_of j) (nat_of i)) => Hji; [by apply H1|].
have H' : j = i.
{ apply nat_of_inj => //; apply anti_leq.
  rewrite Hji Bool.andb_true_r; apply Hj. }
rewrite -H'; apply H2; rewrite H' //.
Qed.

Section Ind2.

Context {ord' : nat -> Type}.
Context `{!I0_class ord' n.+1, !succ0_class ord' n.+1, !nat_of_class ord' n.+1}.
Context `{!nat_spec (I := ord') (n := n.+1)}.

Lemma iteri_ord_rec_ind2 M M' P
      (f : ord n.+1 -> M -> M) (f' : ord' n.+1 -> M' -> M') :
  forall (j : nat), (j <= n.+1)%N ->
  (forall (i : ord n.+1) (i' : ord' n.+1) s s',
    (nat_of i <= n.+1)%N -> nat_of i' = nat_of i ->
    P s s' -> P (f i s) (f' i' s')) ->
  forall (i : ord n.+1) (i' : ord' n.+1) s s',
    (nat_of i <= j)%N -> nat_of i' = nat_of i ->
    P s s' ->
    P (iteri_ord_rec (j - nat_of i)%N i f s)
      (iteri_ord_rec (j - nat_of i')%N i' f' s').
Proof.
move=> j Hj Hind i i' s s' Hi Hi' H; rewrite Hi'.
move Hk: (j - nat_of i)%N => k.
elim: k i i' Hi Hi' Hk s s' H => // k IHk i i' Hi Hi' Hk s s' H /=.
case (ltnP (nat_of i) j); [move=> Hij|by rewrite /ssrnat.leq Hk].
case (ltnP (nat_of i) n) => Hjn.
{ have Hsisn : ((nat_of i).+1 < n.+1)%N.
  { by move: Hjn; rewrite -(ltn_add2r 1) !addn1. }
  apply: IHk; first by rewrite succ0_prop.
  { rewrite !succ0_prop ?Hi' //. }
  { by rewrite succ0_prop // subnS Hk. }
  apply Hind; by [apply: leq_trans Hi Hj|]. }
have Hj' : j = n.+1.
{ by apply anti_leq; rewrite Hj /=; apply (leq_ltn_trans Hjn). }
have Hi'n : nat_of i = n.
{ apply anti_leq; rewrite Hjn andbT.
  apply (@leq_trans j.-1); [|by rewrite Hj'].
  by rewrite (pred_Sn (nat_of i)); apply /leP /le_pred /leP. }
have Hk' : k = 0%N.
{ by rewrite Hi'n Hj' subSnn in Hk; case: Hk. }
by rewrite Hk'; apply: Hind =>//; apply (leq_trans Hi).
Qed.

Lemma iteri_ord_ind2 M M' P (f : ord n.+1 -> M -> M) (f' : ord' n.+1 -> M' -> M') :
  forall (j : nat), (j <= n.+1)%N ->
  (forall (i : ord n.+1) (i' : ord' n.+1) s s',
    (nat_of i <= n.+1)%N -> nat_of i' = nat_of i ->
    P s s' -> P (f i s) (f' i' s')) ->
  forall s s', P s s' -> P (iteri_ord j f s) (iteri_ord j f' s').
Proof.
move=> j Hj Hind s s' HP; rewrite /iteri_ord.
replace j with (j - @nat_of ord _ _ I0)%N at 1; [|by rewrite I0_prop subn0].
replace j with (j - nat_of I0)%N at 2; [|by rewrite I0_prop subn0].
by apply iteri_ord_rec_ind2; rewrite // !I0_prop.
Qed.

End Ind2.

End theory_iteri.


Require Export prosa.model.priority.classes.

(** * Deadline-Monotonic Fixed-Priority Policy *)

(** We define the notion of deadline-monotonic task priorities, i.e., the
    classic FP policy in which tasks are prioritized in order of their relative
    deadlines. *)
Instance DM (Task : TaskType) `{TaskDeadline Task} : FP_policy Task :=
{
  hep_task (tsk1 tsk2 : Task) := task_deadline tsk1 <= task_deadline tsk2
}.

(** In this section, we prove a few basic properties of the DM policy. *)
Section Properties.

  (**  Consider any kind of tasks with relative deadlines... *)
  Context {Task : TaskType}.
  Context `{TaskDeadline Task}.

  (** ...and jobs stemming from these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.

  (** DM is reflexive. *)
  Lemma DM_is_reflexive : reflexive_priorities.
  Proof. by move=> ?; rewrite /hep_job_at /JLFP_to_JLDP /hep_job /FP_to_JLFP /hep_task /DM. Qed.

  (** DM is transitive. *)
  Lemma DM_is_transitive : transitive_priorities.
  Proof. by intros t y x z; apply leq_trans. Qed.

  (** DM is total. *)
  Lemma DM_is_total : total_priorities.
 Proof. by move=> t j1 j2; apply leq_total. Qed.

End Properties.

(** We add the above lemmas into a "Hint Database" basic_facts, so Coq
    will be able to apply them automatically. *)
Hint Resolve
     DM_is_reflexive
     DM_is_transitive
     DM_is_total
  : basic_facts.


Require Import Coq.ZArith.BinInt.
Inductive type := Z | prod (A B : type) | arrow (s d : type).
Inductive expr {var:type -> Type} : type -> Type :=
| LetIn {s d} (x : expr s) (f : var s -> expr d) : expr d
| App {s d} (f : expr (arrow s d)) (x : expr s) : expr d
| Abs {s d} (f : var s -> expr d) : expr (arrow s d)
| Var {t} (v : var t) : expr t
| Pair {A B} (x : expr A) (y : expr B) : expr (prod A B)
| Fst {A B} (x : expr (prod A B)) : expr A
| Snd {A B} (x : expr (prod A B)) : expr B
| Add (x y : expr Z) : expr Z
| Mul (x y : expr Z) : expr Z
| Sub (x y : expr Z) : expr Z
| Opp (x : expr Z) : expr Z
| Literal (v : BinInt.Z) : expr Z
| AddWithGetCarry (x y c : expr Z) : expr (prod Z Z)
| CastToSize (lower upper : BinInt.Z) (v : expr Z) : expr Z.

(* Notation scopes, useful for overloading notations and selecting the right one automatically (\texttt{Bind Scope}, \texttt{Delimit Scope}, \texttt{Open Scope}) *)
Delimit Scope expr_scope with expr.
Bind Scope expr_scope with expr.
Delimit Scope etype_scope with etype.
Bind Scope etype_scope with type.
Open Scope expr_scope.
(* Syntax of notations (e.g., \texttt{Infix "+" := add.}; \texttt{Notation "a + b" := (add a b).}) *)
Infix "*" := prod : etype_scope.
Infix "->" := arrow : etype_scope.
Infix "*" := Mul : expr_scope.
Infix "+" := Add : expr_scope.
Infix "-" := Sub : expr_scope.
(* Notation bodies must be parenthesized *)
Notation "- x" := (Opp x) : expr_scope.
(* How to use levels and associativity, how to pick levels, how to discover levels of existing notations (\texttt{Print Grammar constr}) *)
(* Controlling display: \texttt{format}, extra spaces, quoting symbols, boxes in \texttt{format} for display of indentation, newlines, and whitespace *)
Fail Notation "# v" := (Literal v) : expr_scope.
Notation "# v" := (Literal v) (at level 10, format "# v") : expr_scope.
Notation "$ v" := (Var v) (at level 10, format "$ v") : expr_scope.
(* Recursive notations: \texttt{..} for pair- and $\lambda$-like things *)
Notation "( x , y , .. , z )" := (Pair .. (Pair x y) .. z) : expr_scope.
Notation "\ x .. y , f"
  := (Abs (fun x => .. (Abs (fun y => f%expr)) .. ))
       (at level 200, x binder, y binder, right associativity, format "'[  ' \  x  ..  y ']' ,  f") : expr_scope.
Notation "'expr_let' x := y 'in' f"
  := (LetIn y (fun x => f%expr))
       (at level 200, right associativity, format "'[' 'expr_let'  x  :=  y  'in' '//' f ']'") : expr_scope.
Check (expr_let x := #1 in expr_let y := $x + $x in $y + $y).
(* \texttt{Reserved Notation} and \texttt{only printing}, useful for ensuring that notations don't conflict *)
(* Using single-variable only-printing notations for hiding identifiers *)
Module ExtraPretty.
  Notation "x" := (Var x) (only printing, at level 10) : expr_scope.
  Notation "x" := (Literal x) (only printing, at level 10) : expr_scope.
  Notation "T x = y ; f"
    := (LetIn (s:=T) y (fun x => f%expr))
         (at level 200, right associativity, format "'[' T  x  =  y ; '//' f ']'") : expr_scope.
  (* Abbreviations vs notations (what it means when your \texttt{Notation} doesn't have quotes, and why you might want this) *)
  Notation int := Z.
  Check (expr_let x := #1 in expr_let y := $x + $x in $y + $y).
End ExtraPretty.
(* Using binders for destructuring pairs *)
(* Parenthesizing notations: when to use parentheses, and when to use levels *)
(* Deliberate ordering of notations: how to express wildcard and negation in notation matching *)


Require Import List Omega.
Import List.ListNotations.

Require Import Cecoa.Interface.
Require Import Cecoa.Lib.

Inductive variable := x | y.
Inductive function := plus | main | errF.
Inductive constructor := zero | succ | errC.

Scheme Equality for variable.
Scheme Equality for function.
Scheme Equality for constructor.

Module PlusSyntax <: Interface.SYNTAX.
  Definition variable := variable.
  Definition function := function.
  Definition constructor := constructor.

  Definition function_default := errF.
  Definition constructor_default := errC.

  Definition variable_eq_dec := variable_eq_dec.
  Definition function_eq_dec := function_eq_dec.
  Definition constructor_eq_dec := constructor_eq_dec.
End PlusSyntax.

Module Import Syn := Interface.MkSyn(PlusSyntax).
Import Syn.ProgramNotations.

Definition var_coercion : variable -> term := var_coercion_gen.
Coercion var_coercion : variable >-> term.

Notation " 'Z' " := (capply zero []).
Notation " x '.+1' " := (capply succ [x:term]) (at level 60).

Definition plus_prog : list rule :=
  [
    main (: x, y :)    --> plus (: plus (: x, y :), plus (: x, y :) :) ;

    plus (: Z, y :)    --> y ;
    plus (: x.+1, y :) --> (plus (: x, y :)) .+1
  ].

Module PlusProg <: Syn.PROGRAM.
  Definition prog := plus_prog.
End PlusProg.

Module Import Prog := Syn.MkProg (PlusProg).
Import Prog.QI Prog.Evaluator.
Definition rank : function -> nat := ltac:(autorank function_beq ranklist).

Fixpoint quote_value (n : nat) : value :=
  match n with
  | 0    => c_capply zero []
  | S n' => c_capply succ [quote_value n']
  end.

(* It's a program *)
Proposition UnaryAdd_is_wf: wf_prog.
Proof.
  cbv; repeat split; tauto.
Qed.

(* PPO *)
Proposition UnaryAdd_is_ppo : PPO_prog rank.
Proof.
  cbv.
  intros r H.
  decompose sum H; subst; ppo.
Qed.

(* QI *)
Definition cs (c : constructor) := 1. (* same for all *)
Lemma qic_nonzero : constructor_non_zero cs.
Proof. cbv; auto. Qed.

Definition mcs := 1.
Lemma qic_bounded : mcs_is_max_constructor_size mcs cs.
Proof. cbv; auto. Qed.

Definition qic (c : constructor) args := suml args + cs c.
Lemma qic_additivity : additive qic cs.
Proof. cbv; auto. Qed.

Definition qif (f : function) args := match f with
  | main => 2*(suml args)
  | plus => suml args
  | errF => suml args
  end.

Lemma qif_subterm : subterm qif.
Proof.
  intros f l x H.
  destruct f; unfold qif.
  - apply in_le_suml; trivial.
  - apply le_trans with (m:= suml l).
    + apply in_le_suml; trivial.
    + omega.
  - apply in_le_suml; trivial.
Qed.

Lemma qif_monotonic : monotonicity_qif qif.
Proof.
  intros f xs ys Hfor.
  destruct f; unfold qif; try apply Mult.mult_le_compat_l; apply forall2_le_suml; trivial.
Qed.

Lemma qi_is_compatible : compatible_QI qic qif.
Proof.
  intros f lp t s; cbn.
  intros [ H | [ H | [ H | H ]]];
    try tauto;
    injection H; clear H; intros; subst; trivial; cbn;
    omega.
Qed.

Proposition qi_is_valid : valid_QI mcs qic qif cs.
Proof.
  repeat split.
  apply qic_bounded.
  apply qic_nonzero.
  apply qif_subterm.
  apply qif_monotonic.
  apply qi_is_compatible.
Qed.

(* P-criterion *)
Theorem plus_polytime: forall i s p c f lv d v,
  let t := fapply f lv in
  let pi := cbv_update i s p c t d v in
  cbv_wf pi -> cache_bounded qic qif c ->
  cbv_size pi <= global_bound mcs qif f lv c.
Proof.
  intros.
  apply P_criterion with (rank:=rank) (cs:=cs) (qic:=qic);auto.
  - split; [ apply UnaryAdd_is_wf | trivial ].
  - intro g; destruct g; auto; simpl; apply le_0_n.
  - apply UnaryAdd_is_ppo.
  - apply qi_is_valid.
Qed.

Definition value_default := quote_value 0.

Theorem plus_correct n m :
  evaluates (fapply plus [term_from_value(quote_value n); term_from_value(quote_value m)]) (quote_value(n+m)).
Proof.
  revert m.
  induction n as [| n IH]; cbn; intro m.
  - reduce.
  - reduce. cbn. apply IH.
Qed.


Require Export Coq.Unicode.Utf8.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

(******************************************************************************)
(* Representation of types.                                                   *)
(******************************************************************************)

Inductive Ty : Set :=
  | tvar (X : nat)
  | top
  | tarr (T1 T2 : Ty)
  | tall (T1 : Ty) (T2 : Ty)
  | tprod (T1 T2 : Ty).

(******************************************************************************)
(* Representation of terms.                                                   *)
(******************************************************************************)

Inductive Pat : Set :=
  | pvar
  | pprod (p1 p2 : Pat).

Inductive Tm : Set :=
  | var  (x  : nat)
  | abs  (T  : Ty) (t  : Tm)
  | app  (t1 : Tm) (t2 : Tm)
  | tabs (T  : Ty) (t  : Tm)
  | tapp (t  : Tm) (T  : Ty)
  | prod (t1 : Tm) (t2 : Tm)
  | lett (p : Pat) (s : Tm) (t : Tm) .

(* Calculates the number of cariables bound in a pattern. *)
Fixpoint bindPat (p : Pat) : nat :=
  match p with
   | pvar        => 1
   | pprod p1 p2 => bindPat p2 + bindPat p1
  end.

Inductive Env : Set :=
  | empty
  | evar   (Γ : Env) (T : Ty)
  | etvar  (Γ : Env) (T : Ty).

(* A context extension holding the types of pattern variables. *)
Inductive Ext : Set :=
  | exempty
  | exvar   (Δ : Ext) (T : Ty).


Set Implicit Arguments.
Unset Strict Implicit.

Require Import configuration.

Parameter Ide : Set.

Inductive Actor (Id LS : Set) : Set :=
| actor' : Id -> LS -> Actor Id LS
| message' : Id -> LS -> Id -> Ide -> Actor Id LS.

Parameter LS0 : forall LS : Set, LS.
(* Arguments LS0 [LS]. *)

Definition actor {Id LS : Set} (id : Id) (ls : LS) := One (actor' id ls).
Definition message {Id LS : Set} (fr to : Id) (c : Ide) := One (message' fr (LS0 LS) to c).

(* The relation of actor name, configuration and the number of actors having the name *)
Inductive count {Id LS : Set} (id : Id) : Cfg (Actor Id LS) -> nat -> Prop :=
| count_empty : count id Null 0
| count_one : forall ls, count id (actor id ls) 1
| count_some_one : forall ls id', id <> id' -> count id (actor id' ls) 0
| count_ignore_message_one : forall fr ls to c, count id (One (message' fr ls to c)) 0
| count_more : forall s n ls, count id s n -> count id (s ++ (actor id ls)) (S n)
| count_some : forall s n ls id', count id s n -> id <> id' -> count id (s ++ (actor id' ls)) n
| count_ignore_message : forall s n fr ls to c, count id s n ->
                                             count id (s ++ One (message' fr ls to c)) n.

Definition mk_id_dec (Id : Set) :=
  forall id1 id2 : Id, { id1 = id2 } + { id1 <> id2 }.

Definition unique_ids {Id LS : Set} (s : Cfg (Actor Id LS)) : Prop :=
  forall id n, count id s n -> n <= 1.

Module Type ActorCfgTyp <: CfgTyp.
  Parameter Id : Set.
  Parameter LS : Set.
  Definition T := Actor Id LS.
  Definition t := Cfg T.
End ActorCfgTyp.

Module ActorCfgLemmas (P : ActorCfgTyp).

  Module ACAM := CfgAbelianMonoid P.
  Import P.
  Import ACAM.
  Module ACLemmas := CfgLemmas P.
  Import ACLemmas.

  Lemma count_equal : forall (id : Id) (s : Cfg (Actor Id LS)) n m,
                        count id s n ->
                        count id s m ->
                        n = m.
  Proof.
    intros id s n m.
    intros P.
    generalize dependent m.
    induction P; intros m Q;
    inversion Q; auto; subst; exfalso; auto.
  Qed.

  (* Lemma count_distr : forall (id : Id) (s1 s2 : Cfg (Actor Id LS)) n m l, *)
  (*                     mk_id_dec Id -> *)
  (*                     count id (s1 ++ s2) n -> *)
  (*                     count id s1 m -> *)
  (*                     count id s2 l -> *)
  (*                     n = m + l. *)
  (* Proof. *)
  (*   intros id s1 s2. *)
  (*   generalize dependent s1. *)
  (*   induction s2; *)
  (*     intros s1 n m l; *)
  (*     intros id_dec Cn Cm Cl; *)
  (*     unfold mk_id_dec in id_dec. *)

  (*   - inversion Cl; subst. *)
  (*     rewrite right_identity in Cn. *)
  (*     rewrite <- plus_n_O. *)
  (*     apply (count_equal Cn Cm). *)
  (*   - destruct t0. *)
  (*     + specialize (id_dec id i0). *)
  (*       destruct id_dec; subst. *)
  (*       * inversion Cl; subst; [ | exfalso; auto ]. *)
  (*         inversion Cn; subst; [ | exfalso; auto ]. *)
  (*         rewrite <- plus_n_Sm. *)
  (*         f_equal. *)
  (*         rewrite <- plus_n_O. *)
  (*         apply (count_equal H2 Cm). *)
  (*       * inversion Cl; subst; [ exfalso; auto | ]. *)
  (*         rewrite <- plus_n_O. *)
  (*         inversion Cn; subst; [ exfalso; auto | ]. *)
  (*         apply (count_equal H4 Cm). *)
  (*     + inversion Cl; inversion Cn; subst. *)
  (*       rewrite <- plus_n_O. *)
  (*       apply (count_equal H10 Cm). *)
  (*   - induction s2_2. *)
  (*     + rewrite right_identity in *. *)
  (*       apply (IHs2_1 s1 n m l id_dec Cn Cm Cl). *)
  (*     + destruct t0. *)
  (*       * assert (id_dec' : mk_id_dec Id); auto. *)
  (*         specialize (id_dec id i0). *)
  (*         destruct id_dec. *)
  (*         { *)
  (*           rewrite <- e in *. *)
  (*           inversion Cl; subst; [ | exfalso; auto ]. *)
  (*           rewrite <- associative in Cn. *)
  (*           inversion Cn; subst; [ | exfalso; auto ]. *)
  (*           rewrite <- plus_n_Sm. *)
  (*           f_equal. *)
  (*           eapply IHs2_1; auto. *)
  (*           apply H3. *)
  (*           apply Cm. *)
  (*         } *)
  (*         inversion Cl; subst; [ exfalso; auto | ]. *)
  (*         rewrite <- associative in Cn. *)
  (*         inversion Cn; subst; [ exfalso; auto | ]. *)
  (*         eapply IHs2_1; auto. *)
  (*         apply H5. *)
  (*         apply Cm. *)
  (*       * rewrite <- associative in Cn. *)
  (*         inversion Cn; inversion Cl; subst. *)
  (*         eapply IHs2_1 with s1; auto. *)
  (*     + Admitted. *)

  Lemma ignore_local_state : forall s n m (id id1 : Id) (ls1 ls2 : LS),
                               mk_id_dec Id ->
                               count id (s ++ actor id1 ls1) n ->
                               count id (s ++ actor id1 ls2) m ->
                               n = m.
  Proof.
    intros s n m id id1 ls1 ls2.
    intros id_dec C1 C2.
    unfold mk_id_dec in id_dec.
    specialize (id_dec id id1).
    destruct id_dec as [eq | neq].
    - rewrite eq in C1, C2.
      inversion C1; inversion C2; [ | exfalso; auto | exfalso; auto | exfalso; auto ]; subst.
      f_equal.
      apply (count_equal H2 H6).
    - inversion C1; inversion C2; subst; [ exfalso; auto | exfalso; auto | exfalso; auto | ].
      apply (count_equal H3 H9).
  Qed.

  Local Arguments Null : clear implicits.
  Lemma uids_empty : unique_ids (Null (Actor Id LS)).
  Proof.
    unfold unique_ids.
    intros id n H.
    inversion H.
    auto.
  Qed.
  Local Arguments Null [T].

  (* and more lemmas about unique_ids *)
End ActorCfgLemmas.