Require Import Reals Psatz Omega.
From discprob.measure Require Export measures borel.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.

Record outer_measure (A: Type)  :=
  { outer_measure_fun :> (A → Prop) → R;
    outer_measure_mono : Proper (@le_prop A ==> Rle) outer_measure_fun;
    outer_measure_empty : outer_measure_fun ∅ = 0;
    outer_measure_subadditivity : ∀ U: nat → (A → Prop),
        ex_series (λ n, outer_measure_fun (U n)) →
        outer_measure_fun (unionF U) <= Series (λ n, outer_measure_fun (U n))
  }.

Arguments outer_measure_empty {_} _.
Arguments outer_measure_subadditivity {_}.

Global Instance outer_measure_proper {A: Type} (μ: outer_measure A) :
  Proper (@eq_prop A ==> eq) (@outer_measure_fun _ μ).
Proof.
  intros U U' Heq.
  apply Rle_antisym; apply outer_measure_mono; rewrite Heq; done.
Qed.

Definition outer_measurable {A} (μ: outer_measure A) (U: A → Prop) :=
  ∀ V, μ V = μ (V ∩ U) + μ (V ∩ (compl U)).

Global Instance outer_measurable_proper {A: Type} (μ: outer_measure A) :
  Proper (@eq_prop A ==> iff) (@outer_measurable _ μ).
Proof.
  intros U V Heq.
  rewrite /outer_measurable; split.
  - intros ??. rewrite -Heq. eauto.
  - intros ??. rewrite Heq. eauto.
Qed.

Hint Resolve outer_measure_empty.

Section outer_measure_props.
  Context {A: Type}.
  Context (μ : @outer_measure A).

  Lemma outer_measure_nonneg U:
    0 <= μ U.
  Proof.
    rewrite -(outer_measure_empty μ). apply outer_measure_mono. intros x [].
  Qed.

  Hint Resolve outer_measure_nonneg Rle_ge Rge_le.

  Lemma outer_measure_finite_sub_additivity X Y:
    μ (X ∪ Y) <= μ X + μ Y.
  Proof.
    rewrite union_pair_unionF.
    assert (ex_series (λ n : nat, μ match n with
                          | 0%nat => X
                          | 1%nat => Y
                          | S (S _) => empty_set
                          end)).
    { do 2 apply ex_series_incr_1. exists 0. rewrite outer_measure_empty.
      apply is_series_0 => //=. }

    etransitivity; first eapply outer_measure_subadditivity; auto.
    rewrite Series_incr_1 // Series_incr_1; last first.
    { apply ex_series_incr_1; exists 0; rewrite outer_measure_empty; apply is_series_0 => //=. }
    rewrite outer_measure_empty. rewrite Series_0 => //=. nra.
  Qed.

  Lemma outer_measurable_ge U :
    (∀ V, μ V >= μ (V ∩ U) + μ (V ∩ (compl U))) →
    outer_measurable μ U.
  Proof.
    intros Hge V. apply Rle_antisym; last by (apply Rge_le, Hge).
    setoid_rewrite <-outer_measure_finite_sub_additivity.
    right. apply outer_measure_proper.
    rewrite -intersect_union_l union_compl intersect_top. done.
  Qed.

  Lemma null_outer_measurable U:
    μ U = 0 → outer_measurable μ U.
  Proof.
    intros HU. apply outer_measurable_ge => V.
    assert (μ (V ∩ U) = 0) as ->.
    { apply Rle_antisym; auto. rewrite -HU. apply outer_measure_mono.
      firstorder. }
    rewrite Rplus_0_l. apply Rle_ge, outer_measure_mono.
    firstorder.
  Qed.

  Lemma null_compl_outer_measurable U:
    μ (compl U) = 0 → outer_measurable μ U.
  Proof.
    intros HU. apply outer_measurable_ge => V.
    assert (μ (V ∩ (compl U)) = 0) as ->.
    { apply Rle_antisym; auto. rewrite -HU. apply outer_measure_mono.
      firstorder. }
    rewrite Rplus_0_r. apply Rle_ge, outer_measure_mono.
    firstorder.
  Qed.

  Lemma top_outer_measurable:
    outer_measurable μ (λ _, True).
  Proof. apply null_compl_outer_measurable. by rewrite compl_top. Qed.

  Lemma empty_outer_measurable:
    outer_measurable μ ∅.
  Proof. by apply null_outer_measurable. Qed.

  Lemma compl_outer_measurable U:
    outer_measurable μ U → outer_measurable μ (compl U).
  Proof.
    rewrite /outer_measurable => HU V.
    rewrite HU. rewrite compl_involutive Rplus_comm //.
  Qed.

  Lemma union_outer_measurable U1 U2:
    outer_measurable μ U1 → outer_measurable μ U2 → outer_measurable μ (U1 ∪ U2).
  Proof.
    rewrite /outer_measurable => HU1 HU2 V.
    generalize (HU1 (V ∩ (U1 ∪ U2))).
    assert ((V ∩ (U1 ∪ U2)) ∩ U1 ≡ V ∩ U1) as Hsimpl1
           by firstorder.
    assert ((V ∩ (U1 ∪ U2)) ∩ compl U1 ≡
            ((V ∩ (compl U1)) ∩ U2)) as Hsimpl2
        by firstorder.
    rewrite compl_union.
    rewrite Hsimpl1 Hsimpl2 => ->.
    rewrite Rplus_assoc ?assoc.
    rewrite -HU2. apply HU1.
  Qed.

  Lemma intersect_outer_measurable U1 U2:
    outer_measurable μ U1 → outer_measurable μ U2 → outer_measurable μ (U1 ∩ U2).
  Proof.
    intros. rewrite -(compl_involutive (U1 ∩ U2)) compl_intersect.
    by apply compl_outer_measurable, union_outer_measurable; apply compl_outer_measurable.
  Qed.

  Hint Resolve intersect_outer_measurable union_outer_measurable
               top_outer_measurable empty_outer_measurable compl_outer_measurable.

  Lemma disjoint_unionF_outer_measurable_inequality_sum_n Us:
    disjointF Us →
    (∀ i : nat, outer_measurable μ (Us i)) →
    ∀ V n, sum_n (λ i, μ (V ∩ (Us i))) n <= μ V - μ (V ∩ (compl (unionF Us))).
  Proof.
    intros Hdisj Houter.
    assert (Hind: ∀ n, ∀ V, μ V = sum_n (λ i, μ (V ∩ (Us i))) n
                            + μ (V ∩ (λ x, ∀ i, i ≤ n → ¬ Us i x))).
    { induction n => V.
      - rewrite sum_O. rewrite (Houter O V). f_equal.
        apply outer_measure_proper. intros a.
        split.
        * intros [Hv Hcompl]; split; auto => i' Hle. by inversion Hle; subst.
        * intros [Hv Hcompl]; split; auto. by apply Hcompl.
      - rewrite IHn. rewrite sum_Sn /plus//= Rplus_assoc. f_equal.
        rewrite (Houter (S n) (V ∩ (λ x : A, ∀ i : nat, i ≤ n → ¬ Us i x))).
        f_equal; apply outer_measure_proper.
        * rewrite -assoc. apply intersect_proper; first by reflexivity.
          intros x; split; first by firstorder.
          intros Hin; split; auto. intros i Hle.
          eapply disjoint_elim; try eassumption. apply Hdisj. omega.
        * rewrite -assoc. apply intersect_proper; first by reflexivity.
          intros x; split.
          ** intros [Hin1 Hin2] i. inversion 1; subst; eauto.
          ** intros Hin; split; auto. by apply Hin.
    }
    assert (Hind': ∀ n, ∀ V, μ V >= sum_n (λ i, μ (V ∩ (Us i))) n
                            + μ (V ∩ (compl (unionF Us)))).
    { intros. rewrite (Hind n). apply Rle_ge.
      apply Rplus_le_compat; first reflexivity.
      apply outer_measure_mono. apply intersect_mono; first done.
      firstorder.
    }
    intros. specialize (Hind' n V). nra.
  Qed.

  Lemma disjoint_unionF_outer_measurable_inequality Us:
    disjointF Us →
    (∀ i : nat, outer_measurable μ (Us i)) →
    ∀ V, ex_series (λ i : nat, μ (V ∩ Us i)) ∧
         Series (λ i : nat, μ (V ∩ Us i)) <= μ V - μ (V ∩ compl (unionF Us)).
  Proof.
    intros Hdisj Hmeasurable.
    specialize (disjoint_unionF_outer_measurable_inequality_sum_n Us Hdisj Hmeasurable) => Hind''.
    intros V.
    eapply (ex_series_non_neg_le_const (λ i, μ (V ∩ Us i))) in Hind'' as (Hex&?); auto.
  Qed.

  Lemma disjoint_unionF_outer_measurable Us:
    disjointF Us →
    (∀ i : nat, outer_measurable μ (Us i)) →
    outer_measurable μ (unionF Us).
  Proof.
    intros Hdisj Hmeasurable.
    apply outer_measurable_ge => V.
    edestruct (disjoint_unionF_outer_measurable_inequality Us) as (Hex&?); eauto.
    specialize (outer_measure_subadditivity μ (λ i, V ∩ Us i) Hex); eauto.
    intros Hle. rewrite intersect_unionF_l. nra.
  Qed.

  Lemma unionF_outer_measurable Us:
    (∀ i : nat, outer_measurable μ (Us i)) →
    outer_measurable μ (unionF Us).
  Proof.
    intros Hmeasure.
    rewrite diff_below_unionF.
    apply disjoint_unionF_outer_measurable.
    - apply diff_below_disjoint.
    - apply diff_below_measurable'.
      * auto.
      * apply outer_measurable_proper.
      * apply empty_outer_measurable.
      * apply compl_outer_measurable.
      * apply intersect_outer_measurable.
  Qed.

  Definition outer_measure_sigma : sigma_algebra A.
    refine {| sigma_sets := outer_measurable μ |}.
    - apply top_outer_measurable.
    - apply compl_outer_measurable.
    - apply unionF_outer_measurable.
  Defined.

  Lemma outer_measurable_additivity Us:
    (∀ i, outer_measurable μ (Us i)) →
    disjointF Us →
    is_series (λ n, μ (Us n)) (μ (unionF Us)).
  Proof.
    intros Hmeasur Hdisj.
    assert (Hsimpl1: ∀ i, (unionF Us ∩ Us i) ≡ Us i).
    {
      intros i x; split.
      * intros (?&H); done.
      * intros; split; auto. exists i; auto.
    }
    assert (Hsimpl2: (unionF Us ∩ compl (unionF Us)) ≡ ∅).
    {
      intros x; split; firstorder.
    }
    cut (ex_series (λ i, μ (Us i)) ∧ (Series (λ i, μ (Us i)) = (μ (unionF Us)))).
    { intros (?&<-). by apply Series_correct. }
    specialize (disjoint_unionF_outer_measurable_inequality Us Hdisj Hmeasur (unionF Us)).
    intros (Hex&Hseries). split; auto.
    - eapply ex_series_ext; try eassumption.
      intros n. apply outer_measure_proper, Hsimpl1.
    - rewrite Hsimpl2 outer_measure_empty Rminus_0_r in Hseries * => Hseries.
      apply Rle_antisym.
      * etransitivity; last eapply Hseries.
        right. apply Series_ext => n. by rewrite Hsimpl1.
      * apply outer_measure_subadditivity.
        eapply ex_series_ext; try eassumption.
        intros n. apply outer_measure_proper, Hsimpl1.
  Qed.

  Definition outer_measure_measure : measure (outer_measure_sigma).
    refine {| measure_fun := μ |}.
    - abstract (auto).
    - apply outer_measure_empty.
    - apply outer_measurable_additivity.
  Defined.

End outer_measure_props.

Definition full_measure_is_outer {A: Type} (F: sigma_algebra A) (μ: measure F)
          (Hfull: eq_prop F (λ _, True)) : outer_measure A.
Proof.
  refine {| outer_measure_fun := measure_fun _ μ |}.
  - abstract (intros ?? Hle; apply measure_mono; eauto; try eapply Hfull; done).
  - apply measure_empty.
  - abstract (intros; by apply measure_countable_subadditivity; eauto; intros i; eapply Hfull).
Defined.

Definition outer_pt_measure : outer_measure ().
Proof.
  refine (full_measure_is_outer _ pt_measure _).
  { rewrite //=. }
Defined.

Lemma outer_pt_measure_sigma_full : ∀ U, outer_measurable (outer_pt_measure) U.
Proof.
  intros U. rewrite /outer_measurable => V //=.
  destruct ClassicalEpsilon.excluded_middle_informative as [HVfull|HVempty].
  {
    destruct (ClassicalEpsilon.excluded_middle_informative (eq_prop U (λ _, True))) as
        [HUfull|HUempty].
    * assert (eq_prop (V ∩ U) (λ _, True)).
      { firstorder. }
      assert (¬ (eq_prop (V ∩ compl U) (λ _, True))).
      { firstorder. exact tt.  }
      do 2 destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra;
        intuition.
    * assert (¬ (eq_prop (V ∩ U) (λ _, True))).
      { firstorder. }
      assert (eq_prop (compl U) (λ _, True)) as Heq0.
      { intros []; split; auto. intros ? HU. apply HUempty. intros []. split; eauto. }
      assert ((eq_prop (V ∩ compl U) (λ _, True))).
      { rewrite Heq0. firstorder. }
      do 2 destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra;
        intuition.
  }
  {
    assert (¬ (eq_prop (V ∩ U) (λ _, True))).
    { firstorder. }
    assert (¬ (eq_prop (V ∩ compl U) (λ _, True))).
    { firstorder. }
      do 2 destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra;
        intuition.
  }
Qed.


Set Implicit Arguments.

Require Import
        Syntax.Regex
        Derivatives.Brzozowski
        Derivatives.Smart.

(** simple parsing algoritm using Brzozowski derivatives *)

Fixpoint brzozowski (s : string)(e : regex) : regex :=
  match s with
  | "" => e
  | (String a s') =>
    brzozowski s' (deriv a e)
  end.

Theorem brzozowski_sound
  :  forall s e
  ,  "" <<- (brzozowski s e)
  -> s <<- e.
Proof.
  induction s ; destruct e ; intros ; simpl in * ;
    repeat (match goal with
            (** empty *)
            | [H : _ <<- #0 |- _] =>
              inverts* H
            (** lambda *)
            | [H : _ <<- #1 |- _] =>
              inverts* H
            (** character *)
            | [H : _ <<- ($ _) |- _] =>
              inverts* H
            | [H : ?a <> ?a |- _] =>
              elim H ; reflexivity
            (** concatenation and choice *)
            | [IHs : forall e, "" <<- brzozowski _ e -> _ <<- e
               , H : "" <<- _ |- _] =>
              lets J : IHs H ; try solve [ inverts* H ] ; clear H
            | [H : _ <<- (_ :++: _) |- _] =>
              lets K : choice_smart_sound H ; clear H
            | [H : _ <<- (_ :+: _) |- _] => inverts* H
            | [H : _ <<- (_ :@: _) |- _] =>
              lets M : cat_smart_sound H ; try inverts* M
            end ; substs* ; simpl in *) ; eauto.
Qed.

Theorem brzozowski_complete
  :  forall s e
  ,  s <<- e
  -> "" <<- (brzozowski s e).
Proof.
  Local Hint Immediate
        cat_smart_sound
        cat_smart_complete
        choice_smart_sound
        choice_smart_complete
        star_smart_sound
        star_smart_complete.
  induction s ; destruct e ; intros ; simpl in * ;
    repeat (match goal with
            (* empty *)
            | [H : _ <<- #0 |- _] =>
              inverts* H
            (* lambda *)
            | [H : _ <<- #1 |- _] =>
              inverts* H
            (* characters *)
            | [H : _ <<- ($ _) |- _] =>
              inverts* H
            | [H : ?a <> ?a |- _] =>
              elim H ; reflexivity
            (* induction hypothesis *)
            | [H : forall e, _ <<- e -> "" <<- brzozowski _ e |- _] =>
              eapply IHs
            (* concatenation *)
            | [H : _ <<- (_ @ _) |- _ ] => inverts* H
            | [H : String _ _ = ?s ++ _ |- _ <<- ((_ :@: _) :++: _)] =>
              eapply choice_smart_complete ; destruct* s ;
              simpl in * ; try inverts* H
            | [H : String ?a ?s <<- ?e1,
               H1 : ?s1 <<- ?e2 |- (?s ++ ?s1) <<- _ :+: _] =>
              apply InLeft ; apply cat_smart_complete ; eauto
            | [H : String _ _ = ?s ++ _ |- _ <<- ( _ @ _ )] =>
              destruct* s ; simpl in * ; try contradiction ; inverts* H
            (* choice *)
            | [H : _ <<- (_ :+: _) |- _] => inverts* H
            | [|- _ <<- (_ :++: _)] =>
              eapply choice_smart_complete ; eauto
            | [|- _ <<- (_ :@: _)] =>
              eapply cat_smart_complete ; eauto
            (* star *)
            | [H : (String _ _) <<- (_ ^*) |- _] => inverts* H
            | [H : String _ _ = String _ _ |- _] => inverts* H
               end ; substs* ; eauto) ; eauto.
  +
    destruct (ascii_dec a0 a0) eqn:Heqn ; auto.
    contradiction.
  +
    destruct (null e1) eqn :Heqn.
    apply choice_smart_complete.
    destruct s0 ; simpl in * ; substs.
    apply deriv_complete in H4. auto.
    injects H5. apply deriv_complete in H2.
    apply InLeft. apply cat_smart_complete.
    eapply InCat ; eauto.
    destruct s0 ; simpl in * ; substs.
    apply null_complete in H2. unfolds in H2.
    rewrite Heqn in H2. contradiction.
    injects H5. apply cat_smart_complete.
    apply deriv_complete in H2.
    eapply InCat ; eauto.
Qed.


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

Require Import ssreflect.
Require Import ssrbool.
Require Import ssrfun.
Require Import eqtype.
Require Import ssrnat.
Require Import seq.
Require Import fintype.
Require Import paths.
Require Import bigops.
Require Import finset.
Require Import finfun.
Require Import groups.
Import GroupScope.
Require Import morphisms.
Require Import normal.

Require Import automorphism.

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

Section MaxNormal.

Open Scope group_scope.

Variables (gT : finGroupType).
Notation gTg := {group gT}.
Notation sT := {set gT}.

Definition maxnormal (A B : sT) := [max B of G | (G <| A) && ~~ (A \subset G)].

(* si on garde une defintion, penser au PI *)

Section MaxNormalElemProps.

Variables G N : gTg.

Lemma maxnormalP :
  reflect [/\ N <| G , (N \proper G) &
    (forall H : gTg, H <| G -> G :!=: H -> N \subset H -> H :=: N)]
  (maxnormal G N).
Proof.
apply: (iffP maxgroupP) => [[]|[nNG]].
  case/andP=> nNG nsGN max; rewrite nNG /= properE nsGN.
  rewrite normal_sub //; split=> // H nHG neGH; move/max=> -> //.
  by move: neGH; rewrite eqEsubset nHG (normal_sub nHG) andbT.
rewrite properE; case/andP=> sNG pNG max; rewrite /= nNG pNG; split=> [//|H].
by case/andP=> nHG nsGH; apply: max; rewrite // eqEsubset negb_and nsGH.
Qed.

Lemma maxN_norm : maxnormal G N -> N <| G.
Proof. by move/maxgroupp; case/andP. Qed.

Lemma maxN_proper : maxnormal G N -> N \proper G.
Proof.
by move/maxgroupp; case/andP; rewrite properE; move/normal_sub->.
Qed.

Lemma maxNS : maxnormal G N -> N \subset G.
Proof. by move=> pNN; rewrite proper_sub // maxN_proper. Qed.

Lemma maxN_exists : G :!=: 1-> {N : gTg | maxnormal G N}.
Proof.
by move=> nt; apply: ex_maxgroup; exists [1 gT]%G; rewrite /= normal1 subG1.
Qed.

Lemma maxN_sub :
  N <| G -> N \proper G -> {H : gTg | maxnormal G H & N \subset H}.
Proof.
by move=> nNG; case/andP=> _ pNGl; apply: maxgroup_exists; rewrite nNG.
Qed.

End MaxNormalElemProps.

Lemma maxN_prod : forall G N1 N2 : gTg,
  maxnormal G N1 -> maxnormal G N2 -> N1 :<>: N2 -> N1 * N2 = G.
Proof.
move=> G N1 N2 pmN1 pmN2 neN12.
have cN12 : commute N1 N2.
  by apply: normC; rewrite (subset_trans (maxNS pmN1)) ?normal_norm ?maxN_norm.
wlog nsN21 : G N1 N2 pmN1 pmN2 neN12 cN12/ ~~(N1 \subset N2).
  move/eqP: (neN12); rewrite eqEsubset negb_and; case/orP=> ns; first by apply.
  by rewrite cN12; apply=> //; apply: sym_not_eq.
have nP : N1 * N2 <| G by rewrite normalM ?maxN_norm //.
have sN2P : N2 \subset N1 * N2 by rewrite mulg_subr ?group1.
case/maxnormalP:(pmN2)=> nN2G pN2G mN2.
have contr : (G != (N1 <*> N2)%G -> (N1 <*> N2) == N2).
  by move => ne; apply/eqP=> /=; apply: mN2 => //=; rewrite comm_mulgenE.
apply/eqP; rewrite eq_sym; rewrite -[_ == _]negb_involutive -comm_mulgenE //.
have nsPN2 : ~~ (N1 * N2 \subset N2).
case/subsetPn: nsN21=> x N2x nN1x; apply/subsetPn; exists x=> //.
apply: (subsetP (mulg_subl _ _ )); rewrite // group1.
by apply: (contra contr); rewrite comm_mulgenE // eqEsubset negb_and nsPN2.
Qed.

End MaxNormal.

Prenex Implicits maxnormal.

Section Simple.

Variables (T : finGroupType).
Notation sT := {set T}.
Notation gT := {group T}.

Implicit Types G : gT.
(* Warning! This overloads the definition still present in normal ! *)

Definition simple (A : sT) := maxnormal A 1%G.

Lemma simpleP : forall G,
  reflect (G :!=: 1 /\ forall H : gT, H <| G -> H :=: 1 \/ H :=: G)
          (simple G).
Proof.
move=> G; rewrite -proper1G.
apply: (iffP (maxnormalP _ _)) => [[_ -> maxG] | [nt maxG]].
  split=> // N nNG.
  case NGe: (N :==: G); first by right; rewrite (eqP NGe).
  by left; apply: maxG; rewrite // ?sub1set ?group1 // eq_sym NGe.
split; rewrite ?normal1 // => H nHG GHne _; case: (maxG H)=> // HGe.
by case/eqP: GHne.
Qed.

(* penser au Prenex Implicit *)

End Simple.

Prenex Implicits simple.

Lemma isog_simpl : forall (gT1 gT2 : finGroupType)(G : {group gT1})(H : {group gT2}),
   G \isog H -> simple G -> simple H.
Proof.
move=> gT1 gT2 G H; move/isog_symr; case/isogP=> f injf <-.
case/simpleP=> ntH simH; apply/simpleP; split=> [|L nLH].
  by apply: contra ntH; move/eqP=> H1; rewrite /= {3}H1 morphim1.
case: (andP nLH); move/(morphim_invm injf); move/group_inj=> <- _.
have: f @* L <| f @* H by rewrite morphim_normal.
by case/simH=> /= ->; [left | right]; rewrite (morphim1, morphim_invm).
Qed.

Section SimpleMaxNormal.

Variables (gT : finGroupType).
Notation gt := {group gT}.
Notation st := {set gT}.

Variables G N : {group gT}.

Lemma maxN_simple_quo : maxnormal G N -> simple (G / N).
Proof.
case/maxnormalP=> nNG pNG Nmax; apply/simpleP; split; last move=> K' nK'Q.
  by rewrite -subG1 quotient_sub1 ?normal_norm ?proper_subn.
have : (K' \proper (G / N)) || (G / N == K').
  by rewrite properE eqEsubset andbC (normal_sub nK'Q) !andbT orbC orb_negb_r.
case/orP=> [ pHQ | eQH]; last by right; apply sym_eq; apply/eqP.
left; pose K := (coset N @*^-1 K')%G.
have eK'I : K' \subset coset N @* 'N(N).
  by rewrite (subset_trans (normal_sub nK'Q)) ?morphimS ?normal_norm.
have eKK' : K' :=: K / N by rewrite /(K / N) morphpreK //=.
suff eKN : K :=: N by rewrite -trivg_quotient eKK' eKN.
have nKG : K <| G by rewrite -(quotientGK nNG) cosetpre_normal.
apply: Nmax=> //; last by rewrite -(ker_coset N) kerE morphpreSK sub1G.
suff : ~~ (G \subset K) by rewrite eqEsubset negb_and (normal_sub nKG) orbF.
by rewrite -(quotientGK nNG) morphpreSK /= ?proper_subn // ?morphimS ?normal_norm.
Qed.

Lemma normal_simple_quo_maxN_ : N <| G -> simple (G / N) -> maxnormal G N.
Proof.
move=> nNG; move/simpleP=> [nt sQ]; apply/maxnormalP; rewrite nNG properE.
rewrite normal_sub // -quotient_sub1 ?normal_norm // subG1.
split=> // K nKG neGK sNK.
pose K':= (coset N @* K)%G.
have K'dQ : K' <| (G / N)%G by apply: morphim_normal.
have nKN : N <| K by rewrite (normalS _ _ nNG) // normal_sub.
case: (sQ K' K'dQ)=> /=; last first.
  by move/quotient_injG; rewrite !inE /=; move/(_ nKN nNG)=> c; rewrite c eqxx in neGK.
rewrite -trivg_quotient; move=> tK'; apply:(congr1 (@gval _)); move: tK'.
apply: (@quotient_injG _ N); rewrite ?inE /= ?normal_refl /normal ?sNK //.
by rewrite ?(subset_trans sKG) ?normal_norm.
Qed.

Lemma maxN__is_simple_quo : N <| G -> maxnormal G N = simple (G / N).
Proof.
by move=> nNG; apply/idP/idP; [apply:maxN_simple_quo|apply:normal_simple_quo_maxN_].
Qed.

End SimpleMaxNormal.

Section SectionSeries.

Variables (gT : finGroupType).

Inductive section : Type := Sec of {group gT} * {group gT}.

Delimit Scope section_scope with sec.
Bind Scope section_scope with section.

Definition mkSec G H := Sec (G, H).

Infix "/" := mkSec : section_scope.

Coercion pair_of_section s := let: Sec u := s in u.
Coercion quotient_of_section (u : section) : GroupSet.sort _ := u.1 / u.2.

Canonical Structure section_subType :=
  NewType pair_of_section section_rect vrefl.
Canonical Structure section_eqType :=
  Eval hnf in [subEqType for pair_of_section].
Canonical Structure section_finType :=
  Eval hnf in [finType of section by :>].
Canonical Structure section_subFinType :=
  Eval hnf in [subFinType of section].
Canonical Structure section_group (u : section) : {group coset_of u.2} :=
  Eval hnf in [group of u].

Coercion section_group : section >-> group_of.

(* Isomophic sections *)
Definition sisog := [rel x y : section | x \isog y].

(* A representant of the isomorphism class of a section *)
Definition srepr (H : section) :=
  if (pick (sisog ^~ H)) is Some s then s else (mkSec 1 1)%sec.

Definition mksrepr G1 G2 := srepr (mkSec G1 G2).

Lemma sreprP : forall H : section, (srepr H) \isog H.
Proof.
move=> H; rewrite /srepr; case: pickP; first by move=> x; rewrite /sisog.
by move/(_ H); rewrite /= isog_refl.
Qed.

Lemma srepr_isog : forall H1 H2 : section, H1 \isog H2 -> srepr H1 = srepr H2.
Proof.
move=> H1 H2 iH12; rewrite /srepr.
suff siso12 : (sisog ^~ H1) =1 (sisog ^~ H2) by rewrite (eq_pick siso12).
by move=> x /=; apply:isog_transr.
Qed.

Definition mapsrepr (s : seq section) := maps srepr s.

Notation gTg := {group gT}.

(*From a seq of groups to the associated seq of representatives of factors *)
Definition mkfactors (G : gTg) (s : seq gTg) :=
  mapsrepr (pairmap mkSec G s).

End SectionSeries.

Infix "/" := mkSec : section_scope.

Prenex Implicits perm_eq.

Section CompositionSeries.

Variables (gT : finGroupType).

Notation gTsec := (section gT).
Notation gTg := {group gT}.

Implicit Type G : gTg.
Implicit Type s : seq gTg.

(* Composition series for G :
- successive proper maxnormal subgroups
- starts with a proper max for G
- ends with 1
*)

Definition comps G s :=
  ((last G s) == 1%G) && path [rel x y : gTg | maxnormal x y] G s.

Lemma compsP : forall G s, reflect
  (last G s = 1%G /\  path [rel x y : gTg | maxnormal x y] G s) (comps G s).
Proof. by move=> G s; apply: (iffP andP); case; move/eqP. Qed.

Lemma trivg_comps : forall G s, comps G s -> (G :==: 1) = (s == [::]).
Proof.
move=> G s; case/andP=> ls cs; apply/eqP/eqP; last first.
  by move=> se; rewrite se /= in ls; apply/eqP.
move=> G1; case: s ls cs => // H s _ /=; case/andP; case/maxnormalP=> _.
by rewrite G1 /proper sub1set group1 andbF.
Qed.

Lemma comps_adds : forall G H s, comps G (H :: s) -> comps H s.
Proof.
by move=> G H s; case/andP => /= ls; case/andP=> _ p; rewrite /comps ls.
Qed.

Lemma simple_compsP : forall G s, comps G s ->
  reflect (s = [:: (1%G : gTg) ]) (simple G).
Proof.
move=> G s cs; apply: (iffP idP); last first.
  by move=> se; move: cs; rewrite se /=; case/andP=> /=; rewrite andbT.
case: s cs; first by rewrite /comps /= andbT; move/eqP->; case/simpleP; rewrite eqxx.
move=> H s cs sG; apply/eqP; rewrite eqseq_adds -(trivg_comps (comps_adds cs)).
suff H1: H :=: 1 by rewrite H1 eqxx andbT; apply/eqP; apply: val_inj=> /=.
case/compsP: cs=> /= ls; case/andP=> mH ps; case/maxnormalP: sG=> _ _.
by apply; rewrite ?sub1set ?group1 ?maxN_norm // eq_sym proper_neq ?maxN_proper.
Qed.

(* Existence of a composition serie for a finite group,
by recursion of the cardinal.
*)
Lemma exists_comps : forall G : gTg, exists s, comps G s.
Proof.
move=> G; elim: {G} #|G| {1 3}G (leqnn #|G|) => [G | n Hi G cG].
  by rewrite leqNgt ltn_0group.
case/orP: (orbN (simple G)) => [sG | nsG].
  by exists [:: (1%G : gTg) ]; rewrite /comps eqxx /= -/(simple G) sG.
case/orP: (orbN (G :==: 1))=> [tG | ntG].
  by exists (Seq0 gTg); rewrite /comps /= andbT.
case: (maxN_exists ntG)=> N pmN.
have cN: #|N| <= n.
  by rewrite -ltnS (leq_trans _ cG) // proper_card // maxN_proper.
case: (Hi _ cN)=> s; case/andP=> lasts ps; exists [:: N & s]; rewrite /comps.
by rewrite last_adds lasts /= pmN.
Qed.

(* The factors associated to two
composition series of the same group are the same up to
isomophism and permutation *)

Lemma JordanHolderUniqueness : forall (G : gTg) (s1 s2 : seq gTg),
  comps G s1 -> comps G s2 -> perm_eq (mkfactors G s1) (mkfactors G s2).
Proof.
move=> G; elim: {G} #|G| {-2}G (leqnn #|G|) => [G | n Hi G cG].
  by rewrite leqNgt ltn_0group.
move=> s1 s2 cs1 cs2; case/orP: (orbN (G :==: 1)) => [tG | ntG].
  have -> : s1 = [::] by apply/eqP; rewrite -(trivg_comps cs1).
  have -> : s2 = [::] by apply/eqP; rewrite -(trivg_comps cs2).
  by rewrite /= perm_eq_refl.
case/orP: (orbN (simple G))=> [sG | nsG].
  have -> : s1 = [:: 1%G ] by apply/(simple_compsP cs1).
  have -> : s2 = [:: 1%G ] by apply/(simple_compsP cs2).
  by rewrite /= perm_eq_refl.
case es1: s1 cs1 => [|N1 st1] cs1.
  by move: (trivg_comps cs1); rewrite eqxx; move/negP:ntG.
case es2: s2 cs2 => [|N2 st2] cs2 {s1 es1}.
  by move: (trivg_comps cs2); rewrite eqxx; move/negP:ntG.
case/andP: cs1 => /= lst1; case/andP=> maxN_1 pst1.
case/andP: cs2 => /= lst2; case/andP=> maxN_2 pst2.
have cN1 : #|N1| <= n.
  by rewrite -ltnS (leq_trans _ cG) ?proper_card ?maxN_proper.
have cN2 : #|N2| <= n.
  by rewrite -ltnS (leq_trans _ cG) ?proper_card ?maxN_proper.
case: (N1 =P N2) {s2 es2} => [eN12 |].
  by rewrite eN12 /= perm_adds Hi // /comps ?lst2 //= -eN12 lst1.
move/eqP; rewrite -val_eqE /=; move/eqP=> neN12.
have nN1G : N1 <| G by apply maxN_norm.
have nN2G : N2 <| G by apply maxN_norm.
pose N := (N1 :&: N2)%G.
have nNG : N <| G.
  by rewrite /normal subIset ?(normal_sub nN1G) //= normsI ?normal_norm.
have iso1 : (G / N1)%G \isog (N2 / N)%G.
  rewrite isog_sym /= -(maxN_prod maxN_1 maxN_2) //.
  rewrite (@normC _ N1 N2) ?(subset_trans (normal_sub nN1G)) ?normal_norm //.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN2G)) ?normal_norm.
have iso2 : (G / N2)%G \isog (N1 / N)%G.
  rewrite isog_sym /= -(maxN_prod maxN_1 maxN_2) // setIC.
  by rewrite weak_second_isog ?(subset_trans (normal_sub nN1G)) ?normal_norm.
case: (exists_comps N)=> sN; case/andP=> lsN csN.
have i1 : perm_eq (mksrepr G N1 :: mkfactors N1 st1)
                  [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
  rewrite perm_adds -[mksrepr _ _ :: _]/(mkfactors N1 [:: N & sN]).
  apply: Hi=> //; rewrite /comps ?lst1 //= lsN csN andbT /=.
  apply: normal_simple_quo_maxN_.
  rewrite (normalS (subsetIl N1 N2) (normal_sub nN1G)) //.
  by apply: (isog_simpl iso2); apply: maxN_simple_quo.
have i2 : perm_eq (mksrepr G N2 :: mkfactors N2 st2)
                  [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
  rewrite perm_adds -[mksrepr _ _ :: _]/(mkfactors N2 [:: N & sN]).
  apply: Hi=> //; rewrite /comps ?lst2 //= lsN csN andbT /=.
  apply: normal_simple_quo_maxN_.
  rewrite (normalS (subsetIr N1 N2) (normal_sub nN2G)) //.
  by apply: (isog_simpl iso1); apply: maxN_simple_quo.
pose fG1 := [:: mksrepr G N1, mksrepr N1 N & mkfactors N sN].
pose fG2 := [:: mksrepr G N2, mksrepr N2 N & mkfactors N sN].
have i3 : perm_eq fG1 fG2.
  rewrite (@perm_catCA _ [::_] [::_]) /mksrepr.
  rewrite (@srepr_isog _ (mkSec _ _) (mkSec _ _) iso1).
  rewrite -(@srepr_isog _ (mkSec _ _) (mkSec _ _) iso2).
  exact: perm_eq_refl.
apply: (perm_eq_trans i1); apply: (perm_eq_trans i3); rewrite perm_eq_sym.
apply: perm_eq_trans i2; exact: perm_eq_refl.
Qed.

End CompositionSeries.

Section GeneralJordanHolder.

Variables (gT : finGroupType).

Definition ainvar(A G : {set gT}) := A \subset 'N(G).

Lemma ainvar1 : forall A, ainvar A 1%G.
Proof. rewrite /ainvar norm1; exact: subsetT. Qed.

Lemma ainvar1G : forall A : {group gT}, ainvar 1%G A.
Proof. by move=> A; rewrite /ainvar sub1set group1. Qed.

Lemma ainvar_refl : forall A : {group gT}, ainvar A A.
Proof. rewrite /ainvar; exact: normG. Qed.

Definition maxainv (A B C : {set gT}) :=
  [max C of G | [&& (G <| B), ~~ (B \subset G) & ainvar A G]].

(* garder le != pour aller avec maxnormalP ou bien changer les deux en  ~\subset*)
Lemma maxainvP : forall A G H : {group gT},
  reflect [/\ H <| G, H \proper G, ainvar A H &
    (forall K : {group gT}, K <| G -> K \proper G -> ainvar A K -> H \subset K -> K :=: H)]
  (maxainv A G H).
Proof.
move=> A G H; apply: (iffP idP).
  case/maxgroupP; case/and3P=> nHG pH aiH iH; split=> //; rewrite /proper ?(normal_sub nHG) //.
  by move=>  K nKH neKH iK; apply: iH; rewrite nKH; case/andP: neKH => _ ->.
case=> nHG pHG aH Hm; apply/maxgroupP.
rewrite nHG proper_subn //=; split=> // K; case/and3P=> nKG nsGK aKs HK; apply: Hm=> //.
by rewrite /proper (normal_sub nKG).
Qed.

Section MaxAinvProps.

Variables A G N : {group gT}.

Lemma maxainv_norm : maxainv A G N -> N <| G.
Proof. by move/maxgroupp; case/andP. Qed.

Lemma maxainv_proper : maxainv A G N -> N \proper G.
Proof.
by move/maxgroupp; case/andP; rewrite properE; move/normal_sub->; case/andP.
Qed.

Lemma maxainv_ainvar : maxainv A G N -> ainvar A N.
Proof. by move/maxgroupp; case/and3P. Qed.

Lemma maxainvS : maxainv A G N -> N \subset G.
Proof. by move=> pNN; rewrite proper_sub // maxainv_proper. Qed.

Lemma maxainv_exists : G :!=: 1 -> {N : {group gT} | maxainv A G N}.
Proof.
move=> nt; apply: ex_maxgroup; exists [1 gT]%G.
by rewrite /= normal1 ainvar1 subG1 nt.
Qed.

Lemma maxainv_sub :
  N <| G -> N \proper G -> ainvar A N -> {H : {group gT} | maxainv A G H & N \subset H}.
Proof.
by move=> nNG; case/andP=> _ pNGl aN; apply: maxgroup_exists; rewrite nNG pNGl.
Qed.

End MaxAinvProps.

Definition asimple (A G : {set gT}) := maxainv A G 1.

Lemma asimpleP : forall A G : {group gT},
  reflect (G :!=: 1 /\ (forall H : {group gT}, H <| G -> ainvar A H -> H :=: 1 \/ H :=: G)) (asimple A G).
Proof.
move=> A G; apply: (iffP idP).
  case; case/maxainvP=> _ ntG ainvG mG; split; first by rewrite  -proper1G.
  move=> H nHG ainvH; case eHG : (H == G); first by rewrite (eqP eHG) /=; right.
  left; apply: mG=> //; rewrite ?sub1set ?group1 // properEneq normal_sub // andbT.
  by move/negbT:eHG.
rewrite -proper1G; case=> ntG; move=> h; apply/maxainvP.
rewrite normal1 ntG ainvar1; split=> // K nKG pKG ainvK _.
by case: (h _ nKG ainvK)=> //; move/eqP; move/negbET: (proper_neq pKG)->.
Qed.

Lemma asimple1 : forall G : {group gT}, (G :!=: 1) && asimple 1 G = simple G.
Proof.
move=> G; apply/andP/simpleP.
  by case=> ntG; case/asimpleP=> ntH asH; split=> // H nHG; apply: asH; rewrite // ainvar1G.
by  case=> ntG sG; split=> //; apply/asimpleP; split => // H sHG _; apply: (sG).
Qed.

Section RelativeCompositionSeries.

Notation gTsec := (section gT).
Notation gTg := {group gT}.

Implicit Type G : gTg.
Implicit Type s : seq gTg.

Variable A : gTg.

Definition acomps G s :=
  ((last G s) == 1%G) && path [rel x y : gTg | maxainv A x y] G s.

Lemma acompsP : forall G s, reflect
  (last G s = 1%G /\  path [rel x y : gTg | maxainv A x y] G s) (acomps G s).
Proof. by move=> G s; apply: (iffP andP); case; move/eqP. Qed.

Lemma trivg_acomps : forall G s, acomps G s -> (G :==: 1) = (s == [::]).
Proof.
move=> G s; case/andP=> ls cs; apply/eqP/eqP; last first.
  by move=> se; rewrite se /= in ls; apply/eqP.
move=> G1; case: s ls cs => // H s _ /=; case/andP; case/maxainvP=> _.
by rewrite G1 /proper sub1set group1 andbF.
Qed.

Lemma acomps_adds : forall G H s, acomps G (H :: s) -> acomps H s.
Proof.
by move=> G H s; case/andP => /= ls; case/andP=> _ p; rewrite /acomps ls.
Qed.

Lemma asimple_acompsP : forall G s,
  acomps G s -> reflect (s = [:: 1%G]) (asimple A G).
Proof.
move=> G s cs; apply: (iffP idP); last first.
  by move=> se; move: cs; rewrite se /=; case/andP=> /=; rewrite andbT.
case: s cs; first by rewrite /acomps /= andbT; move/eqP->; case/asimpleP; rewrite eqxx.
move=> H s cs sG; apply/eqP.
rewrite eqseq_adds -(trivg_acomps (acomps_adds cs)) andbC andbb.
case/acompsP: cs => /= ls; case/andP=> mH ps.
case/maxainvP: sG => _ ntG _ -> //; rewrite ?sub1G  ?(maxainv_norm mH) ?(maxainv_proper mH) //.
exact: (maxainv_ainvar mH).
Qed.

(* Existence of a composition serie for a finite group,
by recursion of the cardinal.
*)
Lemma exists_acomps : forall G : gTg, exists s, acomps G s.
Proof.
move=> G; elim: {G} #|G| {1 3}G (leqnn #|G|) => [G | n Hi G cG].
  by rewrite leqNgt ltn_0group.
case/orP: (orbN (asimple A G)) => [sG | nsG].
  by exists [:: (1%G : gTg) ]; rewrite /acomps eqxx /= andbT; rewrite /asimple in sG.
case/orP: (orbN (G :==: 1))=> [tG | ntG].
  by exists (Seq0 gTg); rewrite /acomps /= andbT.
case: (maxainv_exists A ntG)=> N pmN.
have cN: #|N| <= n.
  by rewrite -ltnS (leq_trans _ cG) // proper_card // (maxainv_proper pmN).
case: (Hi _ cN)=> s; case/andP=> lasts ps; exists [:: N & s]; rewrite /acomps.
by rewrite last_adds lasts /= pmN.
Qed.

End RelativeCompositionSeries.

End GeneralJordanHolder.

Prenex Implicits ainvar.

Section RelativeSimpleMaxInv.

Variable (gT : finGroupType).
Notation gt := {group gT}.
Notation st := {set gT}.

Variables A G N : {group gT}.

Lemma maxainv_asimple_quo : maxainv A G N -> asimple (A / N) (G / N).
Proof.
case/maxainvP=> nNG pNG Ninv Nmax; apply/asimpleP; split; last move=> K' nK'Q.
  by rewrite -subG1 quotient_sub1 ?normal_norm ?proper_subn.
have : (K' \proper (G / N)) || (G / N == K').
  by rewrite properE eqEsubset andbC (normal_sub nK'Q) !andbT orbC orb_negb_r.
case/orP=> [ pHQ | eQH]; last by right; apply sym_eq; apply/eqP.
left; pose K := ((coset N) @*^-1 K')%G.
have eK'I : K' \subset (coset N) @* 'N(N).
  by rewrite (subset_trans (normal_sub nK'Q)) ?morphimS ?normal_norm.
have eKK' : K' :=: K / N by rewrite /(K / N) morphpreK //=.
suff eKN : K :=: N by rewrite -trivg_quotient eKK' eKN.
have nKG : K <| G by rewrite -(quotientGK nNG) cosetpre_normal.
have sNK : N \subset K by rewrite -ker_coset kerE morphpreS // sub1set group1.
have {sNK} nNK : N <| K by rewrite (@normalS _ G) // normal_sub.
have iK : ainvar A K.
  move: {Nmax pNG} H; rewrite eKK' /ainvar -quotient_normG //.
  by rewrite quotientSGK // (subset_trans (normal_sub nNG)) // normal_norm.
apply: Nmax=> //; last by rewrite -(ker_coset N) kerE morphpreSK sub1G.
suff : ~~ (G \subset K) by rewrite properE (normal_sub nKG).
by rewrite -(quotientGK nNG) morphpreSK /= ?proper_subn // ?morphimS ?normal_norm.
Qed.

Lemma asimple_quo_maxainv :
  ainvar A N -> N <| G -> asimple (A / N) (G / N) -> maxainv A G N.
Proof.
move=> aiN nNG; move/asimpleP=> [nt sQ]; apply/maxainvP; rewrite nNG properE.
rewrite normal_sub // -quotient_sub1 ?normal_norm // subG1 nt aiN.
split=> // K nKG neGK aiK sNK.
pose K':= (K / N)%G.
have K'dQ : K' <| (G / N)%G by apply: morphim_normal.
have nKN : N <| K by rewrite (normalS _ _ nNG) // normal_sub.
have aiK' : ainvar (A / N) K' by rewrite /ainvar /K' -quotient_normG // quotientS.
case: (sQ K' K'dQ aiK')=> /=; last first.
  move/quotient_injG; rewrite !inE /=; move/(_ nKN nNG)=> c; move: neGK.
  by rewrite c properE subxx.
rewrite -trivg_quotient; move=> tK'; apply:(congr1 (@gval _)); move: tK'.
apply: (@quotient_injG _ N); rewrite ?inE /= ?normal_refl /normal ?sNK //.
by rewrite ?(subset_trans sKG) ?normal_norm.
Qed.

End RelativeSimpleMaxInv.


From Undecidability.MuRec Require Export MuRec.

From Coq Require Import List Vector Nat.
Import ListNotations Vector.VectorNotations.

Definition functional {X Y} (R : X -> Y -> Prop) :=
  forall x y1 y2, R x y1 -> R x y2 -> y1 = y2.

Lemma MuRec_computable_functional_iff {k} (R : Vector.t nat k -> nat -> Prop) :
  functional R ->
   MuRec_computable R <->
    exists f : recalg k,
      (forall v m, ra_bs f v m -> R v m) /\
      (forall v m, R v m -> exists m, ra_bs f v m).
Proof.
  intros HR. split.
  - intros [f Hf]. exists f. split.
    + intros v m. eapply Hf.
    + intros. eexists. eapply Hf. eauto.
  - intros [f [Hf1 Hf2]]. exists f. intros v. split.
    + intros Hm. specialize (Hf2 _ _ Hm) as [m' Hm'].
      specialize (Hf1 _ _ Hm').
      enough (m = m') as -> by eauto.
      firstorder.
    + eauto.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.
Require number.Divisibility.

Import Znumtheory.

(* Why3 assumption *)
Definition prime (p:Z): Prop :=
  (2%Z <= p)%Z
  /\ forall (n:Z),
      ((1%Z < n)%Z /\ (n < p)%Z) -> ~ (number.Divisibility.divides n p).

Lemma prime_is_Zprime :
  forall p, prime p <-> Znumtheory.prime p.
Proof.
intros p.
apply iff_trans with (2 := prime_alt p).
unfold prime, prime'.
intuition.
Qed.

(* Why3 goal *)
Lemma not_prime_1 :
~ (prime 1%Z).
intros (H1,_).
now elim H1.
Qed.

(* Why3 goal *)
Lemma prime_2 :
(prime
2%Z).
Proof.
apply <- prime_is_Zprime.
apply prime_2.
Qed.

(* Why3 goal *)
Lemma prime_3 :
(prime
3%Z).
Proof.
apply <- prime_is_Zprime.
apply prime_3.
Qed.

(* Why3 goal *)
Lemma prime_divisors :
forall (p:Z),
 (prime p) ->
 forall (d:Z),
  (number.Divisibility.divides d p) ->
  ((d = 1%Z) \/ ((d = (-1%Z)%Z) \/ ((d = p) \/ (d = (-p)%Z)))).
Proof.
intros p Hp d Hd.
apply -> prime_is_Zprime in Hp.
destruct (prime_divisors p Hp d Hd) ; intuition.
Qed.

(* Why3 goal *)
Lemma small_divisors :
forall (p:Z),
 (2%Z <= p)%Z ->
 ((forall (d:Z),
    (2%Z <= d)%Z ->
    ((prime d) ->
     (((1%Z < (d * d)%Z)%Z /\ ((d * d)%Z <= p)%Z) ->
      ~ (number.Divisibility.divides d p)))) -> (prime p)).
Proof.
intros p Hp H.
apply <- prime_is_Zprime.
destruct (prime_dec p) as [Pp|Pp].
exact Pp.
elimtype False.
(* *)
assert (exists d, (2 <= d)%Z /\ (d * d <= p)%Z /\ prime d /\ Zdivide d p).
clear H.
assert (Hp' : (0 <= p)%Z) by omega.
revert p Hp' Hp Pp.
apply (Zlt_0_ind (fun p => 2 <= p -> ~ Znumtheory.prime p -> (exists d : Z, 2 <= d /\ d * d <= p /\ prime d /\ (d | p)))%Z).
intros p IH _ Hp Pp.
destruct (not_prime_divide p) as (x,(Hx1,Hx2)).
clear -Hp ; omega.
exact Pp.
destruct (Zle_or_lt (x * x) p) as [Hx|Hx].
destruct (prime_dec x) as [Px|Px].
exists x.
split.
clear -Hx1 ; omega.
split.
exact Hx.
split.
now apply <- prime_is_Zprime.
exact Hx2.
destruct (IH x) as (y&Hy1&Hy2&Hy3&Hy4).
clear -Hx1 ; omega.
clear -Hx1 ; omega.
exact Px.
exists y.
refine (conj Hy1 (conj _ (conj Hy3 _))).
apply Zle_trans with (1 := Hy2).
apply Zle_trans with (2 := Hx).
rewrite <- (Zmult_1_r x) at 1.
apply Zmult_le_compat_l.
now apply Zlt_le_weak.
clear -Hx1 ; omega.
now apply Zdivide_trans with x.
case Hx2.
intros q Hq1.
assert (Hq2 : (2 <= q)%Z).
apply (Zlt_le_succ 1).
apply Zmult_lt_reg_r with x.
clear -Hx1 ; omega.
now rewrite Zmult_1_l, <- Hq1.
destruct (prime_dec q) as [Pq|Pq].
exists q.
split.
exact Hq2.
split.
rewrite Hq1.
apply Zmult_le_compat_l.
apply Zlt_le_weak.
apply Zmult_lt_reg_r with x.
clear -Hx1 ; omega.
now rewrite <- Hq1.
clear -Hq2 ; omega.
split.
now apply <- prime_is_Zprime.
exists x.
now rewrite Zmult_comm.
destruct (IH q) as (y&Hy1&Hy2&Hy3&Hy4).
split.
clear -Hq2 ; omega.
rewrite <- (Zmult_1_r q), Hq1.
apply Zmult_lt_compat_l.
clear -Hq2 ; omega.
clear -Hx1 ; omega.
exact Hq2.
exact Pq.
exists y.
refine (conj Hy1 (conj _ (conj Hy3 _))).
apply Zle_trans with (1 := Hy2).
rewrite <- (Zmult_1_r q), Hq1.
apply Zmult_le_compat_l.
clear -Hx1 ; omega.
clear -Hq2 ; omega.
apply Zdivide_trans with (1 := Hy4).
exists x.
now rewrite Zmult_comm.
destruct H0 as (y&Hy1&Hy2&Hy3&Hy4).
apply (H y) ; try easy.
split.
apply Zlt_le_trans with (2 * 2)%Z.
easy.
now apply Zmult_le_compat.
exact Hy2.
Qed.

(* Why3 goal *)
Lemma even_prime :
forall (p:Z), (prime p) -> ((number.Parity.even p) -> (p = 2%Z)).
Proof.
intros p Pp (q,Hq).
generalize (proj2 Pp q).
assert (Zdivide q p).
now exists 2%Z.
intros.
refine (_ (fun H1 => H0 H1 H) (proj1 Pp)).
(* ??? omega fails to solve this goal ??? *)
clear -Hq.
intros H Hp.
destruct (Zle_lt_or_eq 2 p Hp) as [Hp'|Hp'].
elim H.
omega.
easy.
Qed.

(* Why3 goal *)
Lemma odd_prime :
forall (p:Z), (prime p) -> ((3%Z <= p)%Z -> (number.Parity.odd p)).
Proof.
intros p Pp Hp.
apply <- Divisibility.odd_divides.
apply proj2 in Pp.
apply Pp.
omega.
Qed.


Require Import HoTT.
Require Import hit_structure polynomial.

Local Ltac compute_rank := split ; intros [ ] ; repeat constructor.

(* Example: circle *)
Section Circle.
  Definition circle_signature :=
    {|
      sig_point_index := Unit ;
      sig_point := (fun _ => poly_const Unit) ;
      sig_path_index := Unit ;
      sig_path_param := (fun _ => poly_const Unit) ;
      sig_path_lhs := (fun _ => endpoint_constr tt (endpoint_const tt)) ;
      sig_path_rhs := (fun _ => endpoint_constr tt (endpoint_const tt))
    |}.

  Definition circle_guarded_signature :=
  {|
    guarded_sig_point_index := Unit ;
    guarded_sig_point := (fun _ => poly_const Unit) ;
    guarded_sig_path_index := Unit ;
    guarded_sig_path_param := (fun _ => poly_const Unit) ;
    guarded_sig_path_lhs := (fun _ => (tt; endpoint_const tt)) ;
    guarded_sig_path_rhs := (fun _ => (tt; endpoint_const tt))
  |}.

  Definition circle_rank : hit_rank circle_signature 1.
  Proof.
    compute_rank.
  Defined.

  (* Example: the HoTT library circle is a HIT *)
  Definition circle_hit : HIT circle_signature.
  Proof.
    simple refine {| hit_carrier := S1 ;
                     hit_point := (fun _ _ => base) ;
                     hit_path := (fun _ _ => _ ) |}.
    - exact loop.
    - intros F c f x.
      apply (S1_ind F (c tt tt tt) (f tt tt tt)).
    - intros F c p [] [] ; reflexivity.
    - intros F [] c p [] [].
      apply S1_ind_beta_loop.
  Defined.

  Definition S1_rec (A : Type) (a : A) (p : a = a) : S1 -> A
    := hit_rec circle_signature circle_hit A (fun _ _ => a) (fun _ _ => p).

  Lemma S1_rec_beta_point (A : Type) (a : A) (p : a = a)
    : S1_rec A a p base = a.
  Proof.
    unfold S1_rec.
    rewrite (@hit_point_rec_beta circle_signature circle_hit A _ _ tt tt).
    reflexivity.
  Defined.

  Lemma circle_rec_beta_loop (A : Type) (x : A) (p : x = x) :
    ap (S1_rec A x p) (@hit_path circle_signature circle_hit tt tt) = p.
  Proof.
    unfold S1_rec.
    rewrite (@hit_rec_beta_path circle_signature circle_hit A _ _ tt tt).
    unfold t5, t6.
    hott_simpl.
  Defined.
End Circle.

(* Example: natural numbers *)
Section NaturalNumbers.
  Definition nat_signature :=
    {|
      sig_point_index := Bool ;
      sig_point := (fun b => if b then poly_const Unit else poly_var) ;
      sig_path_index := Empty ;
      sig_path_param := Empty_rect _ ;
      sig_path_lhs := Empty_rect _ ;
      sig_path_rhs := Empty_rect _
    |}.

  Definition nat_rank : hit_rank nat_signature 1.
  Proof.
    compute_rank.
  Defined.

  (* Example: nat is a hit. *)
  Definition nat_hit : HIT nat_signature.
  Proof.
    simple refine {| hit_carrier := nat |}.
    - intros [ | ]; cbn.
      + intros _ ; exact 0.
      + exact S.
    - intros i ; elim i.
    - intros F c p x.
      induction x as [| n y].
      + exact (c true tt tt).
      + apply (c false n y).
    - intros F c p [ | ] [] ; reflexivity.
    - intros _ [].
  Defined.

  (* The usual recursion principle for numbers is indeed just `hit_rec`. *)
  Lemma nat_rec (A : Type) (x : A) (f : A -> A) : nat -> A.
  Proof.
    simple refine (hit_rec nat_signature nat_hit A _ _).
    - unfold point_over_rec.
      intros [ | ] ; simpl.
      * apply (fun _ => x).
      * apply f.
    - unfold path_over_rec.
      intros [].
  Defined.

  Lemma nat_rec_beta_Z (A : Type) (x : A) (f : A -> A)
    : nat_rec A x f 0 = x.
  Proof.
    unfold nat_rec.
    rewrite (@hit_point_rec_beta nat_signature nat_hit A _ _ true tt).
    reflexivity.
  Defined.

  Lemma nat_rec_beta_S (A : Type) (x : A) (f : A -> A) (n : nat)
    : nat_rec A x f (S n) = f(nat_rec A x f n).
  Proof.
    unfold nat_rec.
    rewrite (@hit_point_rec_beta nat_signature nat_hit A _ _ false n).
    reflexivity.
  Defined.
End NaturalNumbers.

(* Example: susupension *)
Section Suspension.
  Variable (A : Type).

  Definition suspension_signature :=
    {|
      sig_point_index := Bool ;
      sig_point := (fun _ => poly_const Unit) ;
      sig_path_index := Unit ;
      sig_path_param := (fun _ => poly_const A) ;
      sig_path_lhs := (fun _ => endpoint_constr false (endpoint_const tt)) ;
      sig_path_rhs := (fun _ => endpoint_constr true (endpoint_const tt))
    |}.

  Definition suspension_guarded_signature (A : Type) :=
    {|
      guarded_sig_point_index := Bool ;
      guarded_sig_point := (fun _ => poly_const Unit) ;
      guarded_sig_path_index := Unit ;
      guarded_sig_path_param := (fun _ => poly_const A) ;
      guarded_sig_path_lhs := (fun _ => (false; endpoint_const tt)) ;
      guarded_sig_path_rhs := (fun _ => (true; endpoint_const tt))
    |}.

  Definition suspension_rank : hit_rank suspension_signature 1.
  Proof.
    compute_rank.
  Defined.

  Definition suspension_hit : HIT suspension_signature.
  Proof.
    simple refine {| hit_carrier := Susp A |}.
    - intros [_|_] ; [exact South | exact North].
    - intros [] x ; exact (merid x).
    - intros F c f x.
      apply (Susp_ind F (c false tt tt) (c true tt tt)).
      intro a.
      apply (f tt _ a).
    - intros F c p [|] [] ; reflexivity.
    - intros F [] c p [] a.
      simpl in *.
      apply Susp_ind_beta_merid with (x := a).
  Defined.

  Variable (Y : Type)
           (n : Y) (s : Y)
           (m : A -> n = s).

  Definition suspension_rec : Susp A -> Y.
  Proof.
    simple refine (hit_rec suspension_signature suspension_hit Y _ _).
    - intros i x ; simpl in *.
      destruct i.
      * apply s.
      * apply n.
    - intros j x ; simpl in *.
      apply (m x).
  Defined.

  Lemma suspension_beta_n : suspension_rec North = n.
  Proof.
    unfold suspension_rec.
    rewrite (@hit_point_rec_beta suspension_signature suspension_hit Y _ _ false tt).
    reflexivity.
  Defined.

  Lemma suspension_beta_s : suspension_rec South = s.
  Proof.
    unfold suspension_rec.
    rewrite (@hit_point_rec_beta suspension_signature suspension_hit Y _ _ true tt).
    reflexivity.
  Defined.

  Lemma suspension_beta_m (a : A)
    : ap suspension_rec (@hit_path suspension_signature suspension_hit tt a) = m a.
  Proof.
    unfold suspension_rec.
    rewrite (@hit_rec_beta_path suspension_signature suspension_hit Y _ _ tt a).
    unfold t5, t6.
    hott_simpl.
  Defined.
End Suspension.

(* Example: propositional truncation *)
Section Propositional_Truncation.
  Variable (A : Type).

  Definition trunc_signature :=
    {|
      sig_point_index := Unit ;
      sig_point := (fun _ => poly_const A) ;
      sig_path_index := Unit ;
      sig_path_param := (fun _ => poly_times poly_var poly_var) ;
      sig_path_lhs := (fun _ => endpoint_fst endpoint_var) ;
      sig_path_rhs := (fun _ => endpoint_snd endpoint_var)
    |}.

  Definition trunc_rank : hit_rank trunc_signature 0.
  Proof.
    compute_rank.
  Defined.

  Definition trunc_hit : HIT trunc_signature.
  Proof.
    simple refine {| hit_carrier := Trunc (-1) A |}.
    - intros [ ] ; simpl.
      apply tr.
    - intros [] x ; simpl in *.
      apply path_ishprop.
    - intros F c f x ; simpl in *.
      simple refine (Trunc_ind F _ _).
      * intros a.
        apply hprop_allpath.
        intros y1 y2.
        specialize (f tt (a, a) (y1, y2)).
        simpl in f.
        assert (path_ishprop a a = idpath) as X.
        { apply path_ishprop. }
        rewrite X in f.
        apply f.
      * intros a.
        refine (c tt _ a).
    - intros F c p [] t.
      reflexivity.
    - intros F [] c p [] a.
      simpl in *.
      assert (IsHProp (F (snd a))).
      {
        apply hprop_allpath.
        intros y1 y2.
        specialize (p tt (snd a, snd a) (y1, y2)).
        simpl in p.
        assert (path_ishprop (snd a) (snd a) = idpath) as X.
        { apply path_ishprop. }
        rewrite X in p.
        apply p.
      }
      refine (path_ishprop _ _).
  Defined.

  Variable (Y : Type)
           (trY : A -> Y)
           (pY : forall (x y : Y), x = y).

  Definition trunc_rec : Trunc (-1) A -> Y.
  Proof.
    simple refine (hit_rec trunc_signature trunc_hit Y _ _).
    - intros i ; simpl in *.
      apply trY.
    - intros j x ; simpl in *.
      apply pY.
  Defined.

  Lemma trunc_beta_n (a : A) : trunc_rec (tr a) = trY a.
  Proof.
    unfold trunc_rec.
    rewrite (@hit_point_rec_beta trunc_signature trunc_hit Y _ _ tt a).
    reflexivity.
  Defined.

  Lemma trunc_beta_m (x y : Trunc (-1) A)
    : ap trunc_rec (@hit_path trunc_signature trunc_hit tt (x,y))
      = pY (trunc_rec x) (trunc_rec y).
  Proof.
    unfold trunc_rec.
    rewrite (@hit_rec_beta_path trunc_signature trunc_hit Y _ _ tt (x,y)).
    unfold t5, t6.
    hott_simpl.
  Defined.
End Propositional_Truncation.

(* Example: natural numbers modulo 2. This one is not in the HoTT library *)
Section NatMod2.
  Definition nat_mod2_signature :=
    {|
      sig_point_index := Bool ;
      sig_point := (fun b => if b then poly_const Unit else poly_var) ;
      sig_path_index := Unit ;
      sig_path_param := (fun _ => poly_const Unit) ;
      sig_path_lhs := (fun _ =>  endpoint_constr false
                                (endpoint_constr false
                                (endpoint_constr true endpoint_var))) ;
      sig_path_rhs := (fun _ => endpoint_constr true endpoint_var)
    |}.

  Definition nat_mod2_rank : hit_rank nat_mod2_signature 3.
  Proof.
    compute_rank.
  Defined.
End NatMod2.


Require Import ZArith List FMapPositive Bool Mergesort Orders.

(* Linear congruential generator. This is used to produce a low quality
  sequence of random numbers. *)

Definition lcg_step (modulus a c seed : Z) := ((a * seed + c) mod modulus)%Z.

Definition iterates (modulus a c seed len : Z) :=
 Z.iter len
   (fun p : list Z * Z => let acc := fst p in let seed := snd p in
       let seed' := lcg_step modulus a c seed in
       (seed'::acc, seed')) (nil, seed).

(* We settle with a list of 2000 elements, taken between 0 and 2 ^ 32.
  The randomness is quite weak, as they alternate between odd and even
  numbers. *)
Definition rnd_list :=
    Eval compute in fst (iterates (2 ^ 32) 1664525 1013904223 33 2000).

Definition rnd_list2 :=
    Eval compute in fst (iterates (2 ^ 32) 1664525 1013904223 1937 2000).

(* For better randomness, we take only the higher 16 bits.  Then we can
  use a modulo operation to bring this inside a chosen interval. *)
Definition randp16 (rand : list Z) :=
  let p16 := (2 ^ 16)%Z in map (fun z => (z / p16)%Z) rand.

Definition nums := Eval compute in randp16 rnd_list.

Definition nums2 := Eval compute in randp16 rnd_list2.

Definition ZtoPos z :=
  match z with Z.pos x => x | Z.neg x => x | Z0 => 1%positive end.

Definition pnums := map ZtoPos nums.

Definition pnums2 := map ZtoPos nums2.

Module ZOrder <: TotalLeBool.
  Definition t := Z.
  Definition leb := Z.leb.

Theorem leb_total : forall x y, leb x y = true \/ leb y x = true.
Proof.
now intros x y; case (Zle_bool_total x y); auto.
Qed.

End ZOrder.

Module Import ZSort := Sort ZOrder.

Compute sort nums.

Fixpoint adjacent {A : Type} (l : list A) :=
  match l with
  | nil => nil
  | _ :: nil => nil
  | a :: (b :: _ as tl) => (a,b) :: adjacent tl
  end.

Compute adjacent (sort nums).

Compute length (filter (fun p => (fst p =? snd p)%Z) (adjacent (sort nums))).

Definition inter (l1 l2 : list Z) :=
  filter (fun x => existsb (fun y => x =? y)%Z l2) l1.

Compute existsb (fun x => (x =? 0)%Z) nums.

Compute existsb (fun x => (x =? 1)%positive) pnums.

Definition subtract (l1 l2 : list Z) :=
  filter (fun x => negb (existsb (fun y => x =? y)%Z l2)) l1.

Definition union (l1 l2 : list Z) := l1 ++ subtract l2 l1.

Time Compute length (inter nums2 nums).

Compute length (inter nums2 nums).

Compute length nums2.

Definition pnums_tree :=
  Eval vm_compute in  fold_right (fun e m => PositiveMap.add e true m)
   (PositiveMap.empty bool) pnums.

Definition pnums_card := Eval compute in PositiveMap.cardinal pnums_tree.

Compute pnums_card.

Definition pnums2_tree :=
  Eval vm_compute in  fold_right (fun e m => PositiveMap.add e true m)
   (PositiveMap.empty bool) pnums2.

Definition pnums2_card := Eval compute in PositiveMap.cardinal pnums2_tree.

Compute pnums2_card.

Import PositiveMap.

Fixpoint interm (s1 s2 : PositiveMap.tree bool) : PositiveMap.tree bool :=
  match s1, s2 with
  | Node s1_1 o1 s1_2, Node s2_1 o2 s2_2 =>
    Node (interm s1_1 s2_1)
         (match o1, o2 with
            Some v1, Some v2 => Some v1
          | _, _ => None
          end)
         (interm s1_2 s2_2)
  | _, _ => Leaf bool
  end.

Fixpoint unionm (s1 s2 : PositiveMap.tree bool) : PositiveMap.tree bool :=
  match s1, s2 with
  | Node s1_1 o1 s1_2, Node s2_1 o2 s2_2 =>
    Node (unionm s1_1 s2_1)
         (match o1, o2 with
            None, None => None
          | _, _ => Some true
          end)
         (unionm s1_2 s2_2)
  | Leaf _, t => t
  | t, Leaf _ => t
  end.

Fixpoint subtractm (s1 s2 : PositiveMap.tree bool) : PositiveMap.tree bool :=
  match s1, s2 with
  | Node s1_1 o1 s1_2, Leaf _ => s1
  | Node s1_1 o1 s1_2, Node s2_1 o2 s2_2 =>
    Node (subtractm s1_1 s2_1)
         (match o1, o2 with
            V, None => V
          | _, Some _ => None
          end)
         (subtractm s1_2 s2_2)
  | Leaf _, _ => Leaf bool
  end.

Definition inter2 (s1 s2 : PositiveMap.tree bool) :=
  PositiveMap.fold
   (fun k v t =>
       if PositiveMap.mem k s2 then PositiveMap.add k true t else t)
   s1 (PositiveMap.empty bool).

Definition inter_card := Eval compute in PositiveMap.cardinal
  (interm pnums_tree pnums2_tree).

Compute inter_card.

Import PositiveMap.

Lemma intermP :
  forall s1 s2 x, mem x s1 = true /\ mem x s2 = true <->
                  mem x (interm s1 s2) = true.
Proof.
induction s1 as [ | s1_1 IH1 o1 s1_2 IH2]; destruct s2 as [ | s2_1 o2 s2_2];
  intros x;
  try (destruct o1 as [v1 | ]; destruct o2 as [v2 | ]; simpl); simpl;
  try (rewrite mem_find; destruct x; simpl; intuition discriminate);
  try (destruct x as [x1 | x1 | ]; simpl;
       [ rewrite <- IH2 | rewrite <- IH1 | ]; tauto).
Qed.

Lemma unionmP :
  forall s1 s2 x, mem x s1 = true \/ mem x s2 = true <->
                  mem x (unionm s1 s2) = true.
Proof.
induction s1 as [ | s1_1 IH1 o1 s1_2 IH2]; destruct s2 as [ | s2_1 o2 s2_2];
  intros x;
  try (destruct o1 as [v1 | ]; destruct o2 as [v2 | ]; simpl); simpl;
  try (rewrite mem_find; destruct x; simpl; intuition discriminate);
  try (destruct x as [x1 | x1 | ]; simpl;
       [ rewrite <- IH2 | rewrite <- IH1 | ]; tauto).
Qed.

Lemma subtractmP :
  forall s1 s2 x, mem x s1 = true /\ mem x s2 = false <->
                  mem x (subtractm s1 s2) = true.
Proof.
induction s1 as [ | s1_1 IH1 o1 s1_2 IH2]; destruct s2 as [ | s2_1 o2 s2_2];
  intros x;
  try (destruct o1 as [v1 | ]; destruct o2 as [v2 | ]; simpl); simpl;
  try (rewrite mem_find; destruct x; simpl; intuition discriminate);
  try (destruct x as [x1 | x1 | ]; simpl;
       [ rewrite <- IH2 | rewrite <- IH1 | ]; tauto || intuition discriminate).
Qed.

Time Compute cardinal (inter2 pnums_tree pnums2_tree).
Time Compute cardinal (interm pnums_tree pnums2_tree).

Compute cardinal (unionm pnums_tree pnums2_tree).
Compute cardinal (subtractm pnums_tree pnums2_tree).

Definition selectm (test : positive -> bool) s :=
  fold (fun k v t => if test k then add k v t else t)
       s (empty bool).

Lemma fold_left_add (s : list (positive * bool)) x s2 (test : _ -> bool) :
  mem x s2 = true ->
  mem x (fold_left (fun t (p : positive * bool) =>
        if test (fst p) then add (fst p) (snd p) t else t) s s2) = true.
Proof.
revert s2; induction s as [| [y w] l IH].
  now simpl.
intros s2 mem2; simpl; case (test y); apply IH;[ | easy].
destruct (Pos.eq_dec x y) as [xisy | xny].
  now rewrite xisy, mem_find, gss.
now rewrite mem_find, gso, <- mem_find.
Qed.

Lemma selectmP test s x :
  mem x s = true /\ test x = true <-> mem x (selectm test s) = true.
Proof.
unfold selectm.
enough (main : forall s2, (mem x s = true /\ test x = true) \/
                                mem x s2 = true <->
                   mem x (fold (fun k v t => if test k then add k v t else t)
                                s s2) = true).
  rewrite <- main; split;[intros it; left | intros [it | abs];
     try (destruct x; discriminate)]; exact it.
assert (equiv :mem x s = true <-> Exists (fun p => fst p = x) (elements s)).
  split.
    rewrite mem_find; destruct (find x s) as [v | ] eqn:fxs; try discriminate.
    intros _; rewrite Exists_exists.
    exists (x, v); split;[ | easy].
    now apply elements_correct.
  rewrite Exists_exists; intros [[x' v] [inlist xisx']].
  simpl in xisx'; rewrite xisx' in inlist; rewrite mem_find.
  now apply elements_complete in inlist; rewrite inlist.
intros s2; rewrite equiv, fold_1; generalize (elements_3w s).
clear equiv.
revert s2.
induction (elements s) as [ | [y w] l IH].
  intros s2 _.
  split.
    intros [[abs1 _] | ].
      now rewrite Exists_nil in abs1.
    now rewrite fold_left_add.
  now simpl; right.
intros s2 nodup.
assert (~SetoidList.InA (eq_key (A := bool)) (y, w) l /\
             SetoidList.NoDupA (eq_key (A:=bool)) l) as [yninl nodupl].
  inversion nodup; tauto.
clear nodup.
split.
  rewrite Exists_cons.
  intros [[[yx | xin] tx] | xs2]; simpl.
      simpl in yx; rewrite yx, tx, fold_left_add; auto.
      now rewrite mem_find, gss.
    rewrite <- IH; tauto.
  destruct (test y); rewrite fold_left_add; auto.
  rewrite mem_find.
  destruct (Pos.eq_dec x y) as [xisy | xny].
    rewrite xisy, gss; easy.
  rewrite gso, <- mem_find; easy.
simpl; rewrite <- IH; auto.
intros [[exl tx]| xys2].
  now left; rewrite Exists_cons; split;[right |].
destruct (test y) eqn:ty.
  destruct (Pos.eq_dec x y) as [xisy | xny].
    rewrite xisy; left; split;[apply Exists_cons_hd |]; easy.
  now right; rewrite mem_find; rewrite mem_find, gso in xys2.
tauto.
Qed.

Lemma selectm_2 s p1 p2 x :
  mem x (selectm p1 (selectm p2 s)) =
  mem x (selectm (fun y => p1 y && p2 y) s).
Proof.
destruct (mem x (selectm p1 (selectm p2 s))) eqn:sl1then2.
  rewrite <- selectmP in sl1then2; destruct sl1then2 as [sl2 test1].
  symmetry; rewrite <- selectmP.
  rewrite <- selectmP in sl2.
  rewrite andb_true_iff; tauto.
assert (tech : forall u : bool, u = false <-> not (u = true)).
  now intros [|]; split; auto; intros h; try discriminate; case h.
symmetry; rewrite tech; intros sl1and2; rewrite tech in sl1then2; case sl1then2.
rewrite <- !selectmP; rewrite <- selectmP in sl1and2.
rewrite andb_true_iff in sl1and2; tauto.
Qed.


(** * The Structure Identity Principle *)
Require Import Category.Core Category.Univalent Category.Morphisms.
Require Import Structure.Core.
Require Import Types.Sigma Trunc Equivalences.
Require Import Basics.Tactics.

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

Local Open Scope path_scope.
Local Open Scope category_scope.
Local Open Scope morphism_scope.
Local Open Scope structure_scope.

(** Quoting the Homotopy Type Theory Book (with slight changes for
    notational consistency): *)

(** Theorem (Structure identity principle): If [X] is a category and
    [(P, H)] is a standard notion of structure over [X], then the
    precategory [Str_{(P, H)}(X)] is a category. *)
Section sip.
  Variable X : PreCategory.
  Variable P : NotionOfStructure X.
  Context `{IsCategory X}.
  Context `{@IsStandardNotionOfStructure X P}.

  Let StrX := @precategory_of_structures X P.

  Definition sip_isotoid_helper (xa yb : StrX)
             (f : xa <~=~> yb)
  : xa.1 <~=~> yb.1.
  Proof.
    exists (PreCategoryOfStructures.f (f : morphism _ _ _)).
    exists (PreCategoryOfStructures.f f^-1).
    - exact (ap (@PreCategoryOfStructures.f _ _ _ _) (@left_inverse _ _ _ _ f)).
    - exact (ap (@PreCategoryOfStructures.f _ _ _ _) (@right_inverse _ _ _ _ f)).
  Defined.

  Lemma sip_isotoid_helper_refl (xa : StrX)
  : @sip_isotoid_helper xa xa (reflexivity _) = reflexivity _.
  Proof.
    unfold sip_isotoid_helper, reflexivity, isomorphic_refl.
    apply ap.
    apply path_ishprop.
  Defined.

  Lemma sip_helper x y (p : x = y) (a : P x) (b : P y)
  : transport P p a = b
    <-> is_structure_homomorphism P _ _ (idtoiso X p) a b *
        is_structure_homomorphism P _ _ (idtoiso X p)^-1 b a.
  Proof.
    split.
    - intros; path_induction; split; apply reflexivity.
    - intros [H0 H1]; path_induction; simpl in *.
      apply antisymmetry_structure; assumption.
  Defined.

  Definition sip_isotoid (xa yb : StrX)
             (f : xa <~=~> yb)
  : xa = yb.
  Proof.
    refine (path_sigma_uncurried
              _ _ _
              (isotoid
                 X
                 xa.1
                 yb.1
                 (sip_isotoid_helper f);
               _)).
    apply sip_helper; simpl.
    split;
      lazymatch goal with
        | [ |- context[idtoiso ?X ((isotoid ?X ?x ?y) ?m)] ]
          => pose proof (eisretr (@idtoiso X x y) m) as H';
             pattern (idtoiso X ((isotoid X x y) m))
      end;
      refine (transport _ H'^ _); clear H'; simpl;
      apply PreCategoryOfStructures.h.
  Defined.

  Lemma sip_isotoid_refl xa
  : @sip_isotoid xa xa (reflexivity _) = reflexivity _.
  Proof.
    refine (_ @ eta_path_sigma_uncurried _).
    refine (ap (path_sigma_uncurried _ _ _) _).
    apply equiv_path_sigma_hprop.
    simpl.
    refine (_ @ eisretr (isotoid X xa.1 xa.1) 1%path).
    apply ap.
    apply sip_isotoid_helper_refl.
  Defined.

  Lemma path_f_idtoiso_precategory_of_structures xa yb (p : xa = yb)
  : PreCategoryOfStructures.f (idtoiso (precategory_of_structures P) p : morphism _ _ _)
    = idtoiso X p..1.
  Proof.
    induction p; reflexivity.
  Defined.

  Lemma structure_identity_principle_helper
        (xa yb : StrX)
        (x : xa <~=~> yb)
  : PreCategoryOfStructures.f
      (idtoiso (precategory_of_structures P) (sip_isotoid x) : morphism _ _ _)
    = PreCategoryOfStructures.f (x : morphism _ _ _).
  Proof.
    refine (path_f_idtoiso_precategory_of_structures _ @ _).
    refine ((ap _ (ap _ _))
              @ (ap (@morphism_isomorphic _ _ _)
                    (eisretr (@idtoiso X xa.1 yb.1) (sip_isotoid_helper _)))).
    exact (pr1_path_sigma_uncurried _).
  Defined.

  Global Instance structure_identity_principle
  : IsCategory (precategory_of_structures P).
  Proof.
    intros xa yb.
    refine (isequiv_adjointify
              _ (@sip_isotoid xa yb)
              _ _);
      intro; simpl in *.
    - abstract (
          apply path_isomorphic; simpl;
          apply PreCategoryOfStructures.path_morphism;
          apply structure_identity_principle_helper
        ).
    - abstract (induction x; apply sip_isotoid_refl).
  Defined.
End sip.