From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Coq.Program Require Import Wf.
From Coq.Arith Require Import Wf_nat.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From Coq.micromega Require Import Lia.
From ShortLogrels Require Import prelude language systemF_rec_cbv.

Inductive type_lt : type → type → Prop :=
| TProd_lt1 τ τ' : type_lt τ (TProd τ τ')
| TProd_lt2 τ τ' : type_lt τ' (TProd τ τ')
| TFun_lt1 τ τ' : type_lt τ (TFun τ τ')
| TFun_lt2 τ τ' : type_lt τ' (TFun τ τ').

Definition wf_rel (nτ nτ' : nat * type) : Prop :=
  fst nτ < fst nτ' ∨ (fst nτ ≤ fst nτ' ∧ type_lt (snd nτ) (snd nτ')).

Lemma wf_rel_well_founded : well_founded wf_rel.
Proof.
  intros [n τ].
  revert τ; induction (lt_wf n) as [n Hn IHn]; intros τ.
  assert (∃ k, k = n ∧ k ≤ n) as [k [Heq Hk]] by (exists n; lia).
  rewrite <- Heq; clear Heq.
  revert k Hk; induction τ; intros k Hk.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'; subst.
    + eapply IHτ1; lia.
    + eapply IHτ2; lia.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'; subst.
    + eapply IHτ1; lia.
    + eapply IHτ2; lia.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
  - constructor; intros [] Hlt.
    inversion Hlt as [|[? Hlt']]; simpl in *; [apply IHn; lia|subst].
    inversion Hlt'.
Qed.

Ltac solve_wf_rel := solve [left; simpl; lia|right; split; [simpl; lia|simpl; constructor]].

Program Definition SISafe' (n : nat) (P : ∀ k, k < n → expr → Prop) (e : expr) :=
    ∀ k e' (Hle : k ≤ n),
      nsteps k e e' → (is_val e' ∧ ∀ (Hpos : 0 < k), P (n - k) _ e') ∨ ∃ e'', step e' e''.
Next Obligation.
Proof. lia. Qed.

Lemma SISafe'_ext (n : nat) (P Q : ∀ k, k < n → expr → Prop) (e : expr) :
  (∀ k Hle v, P k Hle v ↔ Q k Hle v) → SISafe' n P e ↔ SISafe' n Q e.
Proof.
  intros Hext; split; intros Hsf ????.
  - edestruct Hsf as [[]|]; [eassumption|left|right; assumption].
    split; [assumption|intros; apply Hext; auto].
  - edestruct Hsf as [[]|]; [eassumption|left|right; assumption].
    split; [assumption|intros; apply Hext; auto].
Qed.

Lemma SISafe'_SISafe P n e : ¬ is_val e → SISafe' n (λ k _ v, P k v) e ↔ SISafe P n e.
Proof.
  intros Hniv; split.
  - intros Hsf; intros k e' Hk Hstps.
    destruct k as [|k].
    + inversion Hstps; subst.
      destruct (Hsf 0 e' Hk Hstps) as [[]|]; tauto.
    + destruct (Hsf (S k) e' Hk Hstps) as [[? HP]|]; [|tauto].
      left; split; [assumption|].
      apply HP; lia.
  - intros Hsf; intros k e' Hk Hstps.
    destruct (Hsf k e' Hk Hstps) as [[? HP]|]; tauto.
Qed.

Lemma lt_le_le {n m l} : n < m → m ≤ l → n ≤ l.
Proof. lia. Qed.

Lemma prod_lt1 {k τ1 τ2} : wf_rel (k, τ1) (k, TProd τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma prod_lt2 {k τ1 τ2} : wf_rel (k, τ2) (k, TProd τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma fun_lt1 {n τ1 τ2 k} : k ≤ n → wf_rel (k, τ1) (n, TFun τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma fun_lt2 {n τ1 τ2 k} : k ≤ n → wf_rel (k, τ2) (n, TFun τ1 τ2).
Proof. solve_wf_rel. Qed.
Lemma si_lt {n τ τ' z} : z < n → wf_rel (z, τ') (n, τ).
Proof. solve_wf_rel. Qed.

Lemma pos_sub_lt {n m} : 0 < m → m ≤ n → n - m < n.
Proof. lia. Qed.
Lemma lt_eq_S n m : S n = m → n < m.
Proof. lia. Qed.

Definition val_rel_aux_prod {k τ1 τ2}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TProd τ1 τ2) → expr → Prop) v :=
  ∃ v1 v2, v = Pair v1 v2 ∧ vlrl (k, τ1) prod_lt1 v1 ∧ vlrl (k, τ2) prod_lt2 v2.

Lemma val_rel_aux_prod_ext n τ1 τ2 (f g : ∀ nτ', wf_rel nτ' (n, TProd τ1 τ2) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_prod f e ↔ val_rel_aux_prod g e.
Proof.
  intros Hfg; split; intros (?&?&->&?&?); (eexists _, _; split; [reflexivity|]; split);
    (apply Hfg; assumption).
Qed.

Definition val_rel_aux_fun {k τ1 τ2}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TFun τ1 τ2) → expr → Prop) v :=
  is_val v ∧
  ∀ m w (Hle : m ≤ k),
    vlrl (m, τ1) (fun_lt1 Hle) w →
    SISafe' m (λ z Hlt u, vlrl (z, τ2) (fun_lt2 (lt_le_le Hlt Hle)) u) (App v w).

Lemma val_rel_aux_fun_ext n τ1 τ2 (f g : ∀ nτ', wf_rel nτ' (n, TFun τ1 τ2) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_fun f e ↔ val_rel_aux_fun g e.
Proof.
  intros Hfg; split; intros [Hiv Hrl]; (split; [assumption|]).
  - intros m w Hle Hvrl.
    eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; symmetry; apply Hfg.
  - intros m w Hle Hvrl.
    eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; apply Hfg.
Qed.

Definition val_rel_aux_forall {k τ}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TForAll τ) → expr → Prop) v :=
  is_val v ∧ ∀ τ', SISafe' k (λ z Hlt u, vlrl (z, τ.[τ'/]) (si_lt Hlt) u) (TApp v).

Lemma val_rel_aux_forall_ext n τ (f g : ∀ nτ', wf_rel nτ' (n, TForAll τ) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_forall f e ↔ val_rel_aux_forall g e.
Proof.
  intros Hfg; split; intros [Hiv Hrl]; (split; [assumption|]);
    intros τ'.
  - eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; symmetry; apply Hfg.
  - eapply SISafe'_ext; [|apply Hrl; apply Hfg; eassumption].
    intros; apply Hfg.
Qed.

Definition val_rel_aux_rec {k τ}
  (vlrl : ∀ nτ', wf_rel nτ' (k, TRec τ) → expr → Prop) v :=
  is_val v ∧
    ∃ w, v = Fold w ∧
      match k as u return u = k → Prop with
      | 0 => λ _, True
      | S n' => λ Heq, vlrl (n', τ.[TRec τ/]) (si_lt (lt_eq_S _ _ Heq)) w
      end eq_refl.

Lemma val_rel_aux_rec_ext n τ (f g : ∀ nτ', wf_rel nτ' (n, TRec τ) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux_rec f e ↔ val_rel_aux_rec g e.
Proof.
  intros Hfg; split; intros [Hiv (w & -> & Hw)]; (split; [assumption|]).
  - eexists _; split; [reflexivity|].
    destruct n; [tauto|].
    apply Hfg; assumption.
  - eexists _; split; [reflexivity|].
    destruct n; [tauto|].
    apply Hfg; assumption.
Qed.

Definition val_rel_aux
  (nτ : nat * type) (vlrl : ∀ nτ', wf_rel nτ' nτ → expr → Prop) (v : expr) : Prop :=
  match snd nτ as u return (∀ nτ', wf_rel nτ' (fst nτ, u) → expr → Prop) → Prop with
  | TUnit => λ _, v = TT
  | TVar X => λ _, False
  | TProd τ1 τ2 => λ vlrl', val_rel_aux_prod vlrl' v
  | TFun τ1 τ2 => λ vlrl', val_rel_aux_fun vlrl' v
  | TForAll τ => λ vlrl', val_rel_aux_forall vlrl' v
  | TRec τ => λ vlrl', val_rel_aux_rec vlrl' v
  end vlrl.

Lemma val_rel_aux_ext n τ (f g : ∀ nτ', wf_rel nτ' (n, τ) → expr → Prop) e :
  (∀ m τ Hrl e, f (m, τ) Hrl e ↔ g (m, τ) Hrl e) →
  val_rel_aux (n, τ) f e ↔ val_rel_aux (n, τ) g e.
Proof.
  intros Hfg.
  induction τ; simpl; [tauto|tauto| | | |].
  - apply val_rel_aux_prod_ext; auto.
  - apply val_rel_aux_fun_ext; auto.
  - apply val_rel_aux_forall_ext; auto.
  - apply val_rel_aux_rec_ext; auto.
Qed.

Fixpoint val_rel_aux' (nτ : nat * type) (Hacc : Acc wf_rel nτ) (v : expr) : Prop :=
  match Hacc return Prop with
  | Acc_intro _ MkAcc => val_rel_aux nτ (λ nτ' Hnτ', val_rel_aux' nτ' (MkAcc _ Hnτ')) v
  end.

Lemma val_rel_aux'_irrel (nτ : nat * type) (Hacc Hacc' : Acc wf_rel nτ) (v : expr) :
  val_rel_aux' nτ Hacc v ↔ val_rel_aux' nτ Hacc' v.
Proof.
  revert Hacc Hacc' v.
  induction (wf_rel_well_founded nτ) as [[n τ] ? IH]; intros Hacc Hacc' v.
  destruct Hacc; destruct Hacc'; simpl.
  apply val_rel_aux_ext.
  intros m τ' Hrl e'; simpl.
  apply IH; assumption.
Qed.

Definition val_rel (τ : type) (n : nat) (v : expr) :=
  val_rel_aux' (n, τ) (wf_rel_well_founded (n, τ)) v.

Lemma val_rel_unfold n τ e :
  val_rel τ n e ↔ val_rel_aux (n, τ) (λ nτ' _ e', val_rel (snd nτ') (fst nτ') e') e.
Proof.
  remember (n, τ) as nτ; symmetry in Heqnτ.
  revert n τ Heqnτ e.
  induction (wf_rel_well_founded nτ) as [[n τ] ? IH]; intros n' τ' Heqnτ e.
  inversion Heqnτ; subst; clear Heqnτ.
  unfold val_rel.
  destruct wf_rel_well_founded; simpl.
  apply val_rel_aux_ext.
  intros m τ' Hrl e'; simpl.
  apply val_rel_aux'_irrel.
Qed.

Opaque val_rel.

Definition expr_rel (τ : type) (n : nat) (e : expr) := SISafe (val_rel τ) n e.

Lemma val_rel_unit n e : val_rel TUnit n e ↔ e = TT.
Proof. rewrite val_rel_unfold; destruct n; simpl; tauto. Qed.

Lemma val_rel_var X n e : val_rel (TVar X) n e ↔ False.
Proof. rewrite val_rel_unfold; destruct n; simpl; tauto. Qed.

Lemma val_rel_prod τ1 τ2 n e :
  val_rel (TProd τ1 τ2) n e ↔ ∃ v1 v2, e = Pair v1 v2 ∧ val_rel τ1 n v1 ∧ val_rel τ2 n v2.
Proof. rewrite val_rel_unfold; simpl; tauto. Qed.

Lemma val_rel_fun τ1 τ2 n e :
  val_rel (TFun τ1 τ2) n e ↔ is_val e ∧ ∀ k w, k ≤ n → val_rel τ1 k w → expr_rel τ2 k (App e w).
Proof.
  rewrite val_rel_unfold; unfold val_rel_aux; simpl; unfold val_rel_aux_fun.
  split; intros [? Her]; (split; [assumption|]);
    intros; (apply SISafe'_SISafe; [inversion 1|apply Her; eauto]).
Qed.

Lemma val_rel_tforall τ n e :
  val_rel (TForAll τ) n e ↔ is_val e ∧ ∀ τ', expr_rel τ.[τ'/] n (TApp e).
Proof.
  rewrite val_rel_unfold; simpl.
  split; intros [? Her]; (split; [assumption|]);
    intros; (apply SISafe'_SISafe; [inversion 1|apply Her]).
Qed.

Lemma val_rel_trec τ n e :
  val_rel (TRec τ) n e ↔
  is_val e ∧ ∃ w, e = Fold w ∧ match n with 0 => True | S n' => val_rel τ.[TRec τ/] n' w end.
Proof.
  rewrite val_rel_unfold.
  unfold val_rel_aux; simpl; unfold val_rel_aux_rec; simpl.
  destruct n; firstorder.
Qed.

Ltac simpl_val_rel := rewrite ?val_rel_unit, ?val_rel_var,
    ?val_rel_prod, ?val_rel_fun, ?val_rel_tforall, ?val_rel_trec.

Lemma val_rel_is_val τ n v : val_rel τ n v → is_val v.
Proof. revert n v; induction τ; intros n v; simpl_val_rel; firstorder; subst; constructor; eauto. Qed.

Lemma val_rel_down_closed τ n n' v : n' ≤ n → val_rel τ n v → val_rel τ n' v.
Proof.
  remember (n, τ) as nτ; symmetry in Heqnτ.
  revert n' v n τ Heqnτ.
  induction (wf_rel_well_founded nτ) as [[n τ] ? IH]; intros n' v ? ?.
  inversion 1; subst.
  intros Hn'.
  destruct τ; simpl_val_rel; [tauto|tauto| | | |].
  - firstorder; subst; eexists _, _; split; [reflexivity|];
      split; eapply IH; eauto; solve_wf_rel.
  - intros [? Hsf]; split; [assumption|].
    intros; eapply SISafe_mono; [|apply Hsf; [lia|assumption]].
    intros; eapply IH; [| | |eassumption]; [|reflexivity|lia]; solve_wf_rel.
  - intros [? Hsf]; split; [assumption|].
    intros; eapply SISafe_down_closed'; [inversion 1| | |eapply Hsf]; [assumption|].
    intros ?????; eapply IH; [|reflexivity|assumption]; solve_wf_rel.
  - intros [? (?&->&Hsf)]; split; [assumption|].
    eexists _; split; [reflexivity|].
    destruct n; destruct n'; [tauto|lia|tauto|].
    eapply IH; [|reflexivity| |eassumption]; [|lia]; solve_wf_rel.
Qed.

Definition expr_rel_down_closed τ n n' e : n' ≤ n → expr_rel τ n e → expr_rel τ n' e.
Proof.
  intros; eapply SISafe_down_closed; [eassumption| |eassumption].
  intros; eapply val_rel_down_closed; eauto.
Qed.

Local Notation env_rel n Γ env := (env_rel (λ τ, val_rel τ n) Γ env).

Lemma env_rel_down_closed n n' Γ env : n' ≤ n → env_rel n Γ env → env_rel n' Γ env.
Proof.
  revert env.
  induction Γ as [|τ Γ IHΓ]; intros env ?.
  - intros ->%env_rel_inv_nil_l; apply env_rel_nil.
  - simpl.
    intros (?&?&->&?&?)%env_rel_inv_cons_l.
    apply env_rel_cons; [|apply IHΓ; eauto; fail].
    eapply val_rel_down_closed; eauto.
Qed.

Theorem Fundamental Γ e τ f :
  typed Γ e τ → ∀ n env, env_rel n (map (subst f) Γ) env → expr_rel τ.[f] n e.[env_subst env].
Proof.
  intros Htp; revert f.
  induction Htp; intros f n env Henv; simpl.
  - assert (val_rel τ.[f] n (env_subst env v)).
    { eapply env_rel_lookup1 in Henv as [? [? ?]]; [|apply lookup_map; eassumption].
      erewrite env_subst_lookup; eauto. }
    apply SISafe_val; [eapply val_rel_is_val; eauto|assumption].
  - apply SISafe_val; [constructor|].
    simpl_val_rel; destruct n; [constructor|reflexivity].
  - eapply (SISafe_bind _ _ _ (λ e, Pair e _));
      [repeat econstructor; fail|apply IHHtp1; eassumption; fail|].
    intros ? v1 ? Hv11 Hv12.
    eapply (SISafe_bind _ _ _ (λ e, Pair _ e));
      [|eapply IHHtp2; eapply env_rel_down_closed; eauto; fail|].
    { repeat econstructor; trivial. }
    intros z v2 ? Hv21 Hv22.
    apply SISafe_val; [constructor; trivial|].
    simpl_val_rel.
    eexists _, _; split; [reflexivity|];
    split; (eapply val_rel_down_closed; [|eauto]); lia.
  - eapply (SISafe_bind _ _ _ (λ e, Fst e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros k v ? Hv1; simpl.
    simpl_val_rel.
    intros (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros ?.
    destruct k; [lia|]; simpl in *.
    apply SISafe_val; [assumption|].
    eapply val_rel_down_closed; [|eassumption]; lia.
  - eapply (SISafe_bind _ _ _ (λ e, Snd e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros k v ? Hv1; simpl.
    simpl_val_rel.
    intros (v1 & v2 & -> & Hv1r & Hv2r).
    inversion Hv1; subst.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros.
    apply SISafe_val; [assumption|].
    eapply val_rel_down_closed; [|eassumption]; lia.
  - apply SISafe_val; [constructor; fail|].
    simpl_val_rel.
    split; [constructor; fail|].
    intros k w ? Hw.
    assert (is_val w) by (eapply val_rel_is_val; eauto).
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros ?.
    asimpl.
    apply (IHHtp _ _ (_ :: _)).
    apply env_rel_cons;
      [eapply val_rel_down_closed; [|eassumption]|eapply env_rel_down_closed; [|eassumption]];
      lia.
  - eapply (SISafe_bind _ _ _ (λ e, App e _));
      [repeat econstructor; fail|apply IHHtp1; eassumption; fail|].
    intros ? v1 ? Hv11.
    simpl; simpl_val_rel; intros Hv12.
    eapply (SISafe_bind _ _ _ (λ e, App _ e));
      [|apply IHHtp2; eapply env_rel_down_closed; eauto; fail|].
    { repeat econstructor; trivial. }
    intros ? v2 ? Hv21 Hv22.
    eapply Hv12 ; trivial.
  - apply SISafe_val; [constructor; fail|].
    simpl_val_rel.
    split; [constructor; fail|].
    intros τ'.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros.
    eapply (expr_rel_down_closed _ n); [lia|].
    asimpl; apply IHHtp.
    erewrite map_map, map_ext; [eassumption|].
    intros ?; asimpl; reflexivity.
  - eapply (SISafe_bind _ _ _ (λ e, TApp e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros ? v ? ?.
    simpl; simpl_val_rel; intros [? Hv].
    eapply SISafe_mono; [|apply Hv].
    intros ???. asimpl; eauto.
  - eapply (SISafe_bind _ _ _ (λ e, Fold e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros ? v ? ? Hv.
    apply SISafe_val; [constructor; assumption|].
    simpl_val_rel.
    split; [constructor; assumption|].
    eexists _; split; [reflexivity|].
    destruct k as [|k]; [tauto|].
    asimpl in *.
    eapply val_rel_down_closed; [|eassumption]; lia.
  - eapply (SISafe_bind _ _ _ (λ e, Unfold e));
      [repeat econstructor; fail|apply IHHtp; eassumption; fail|].
    intros ? v ? ?.
    simpl; simpl_val_rel; intros [Hiv (?&->&Hv)].
    inversion Hiv; subst.
    eapply SISafe_head_step_back; [solve_det_head_step|]; intros.
    destruct k as [|k]; [lia|]; asimpl in *.
    apply SISafe_val; [assumption|].
    eapply val_rel_down_closed; [|eassumption]; lia.
Qed.

Corollary type_safety e τ : typed nil e τ → Safe (λ _, True) e.
Proof.
  intros Htp.
  apply SISafe_adequacy; intros n.
  replace e with e.[env_subst nil] by (asimpl; reflexivity).
  eapply SISafe_mono; [tauto|].
  pose proof (Fundamental nil _ _ ids Htp n nil) as Hfm.
  replace τ.[ids] with τ in Hfm by (asimpl; reflexivity).
  eapply Hfm.
  apply env_rel_nil.
Qed.


(** * Auto: More Automation *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.

(** Up to now, we've used the more manual part of Coq's tactic
    facilities.  In this chapter, we'll learn more about some of Coq's
    powerful automation features: proof search via the [auto] tactic,
    automated forward reasoning via the [Ltac] hypothesis matching
    machinery, and deferred instantiation of existential variables
    using [eapply] and [eauto].  Using these features together with
    Ltac's scripting facilities will enable us to make our proofs
    startlingly short!  Used properly, they can also make proofs more
    maintainable and robust to changes in underlying definitions.  A
    deeper treatment of [auto] and [eauto] can be found in the
    [UseAuto] chapter in _Programming Language Foundations_.

    There's another major category of automation we haven't discussed
    much yet, namely built-in decision procedures for specific kinds
    of problems: [omega] is one example, but there are others.  This
    topic will be deferred for a while longer.

    Our motivating example will be this proof, repeated with just a
    few small changes from the [Imp] chapter.  We will simplify
    this proof in several stages. *)

(** First, define a little Ltac macro to compress a common
    pattern into a single command. *)
Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.  Qed.

(* ################################################################# *)
(** * The [auto] Tactic *)

(** Thus far, our proof scripts mostly apply relevant hypotheses or
    lemmas by name, and one at a time. *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

(** The [auto] tactic frees us from this drudgery by _searching_ for a
    sequence of applications that will prove the goal: *)

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

(** The [auto] tactic solves goals that are solvable by any combination of
     - [intros] and
     - [apply] (of hypotheses from the local context, by default). *)

(** Using [auto] is always "safe" in the sense that it will never fail
    and will never change the proof state: either it completely solves
    the current goal, or it does nothing. *)

(** Here is a more interesting example showing [auto]'s power: *)

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

(** Proof search could, in principle, take an arbitrarily long time,
    so there are limits to how far [auto] will search by default. *)

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, [auto] does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

(** When searching for potential proofs of the current goal,
    [auto] considers the hypotheses in the current context together
    with a _hint database_ of other lemmas and constructors.  Some
    common lemmas about equality and logical operators are installed
    in this hint database by default. *)

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

(** We can extend the hint database just for the purposes of one
    application of [auto] by writing "[auto using ...]". *)

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

(** Of course, in any given development there will probably be
    some specific constructors and lemmas that are used very often in
    proofs.  We can add these to the global hint database by writing

      Hint Resolve T.

    at the top level, where [T] is a top-level theorem or a
    constructor of an inductively defined proposition (i.e., anything
    whose type is an implication).  As a shorthand, we can write

      Hint Constructors c.

    to tell Coq to do a [Hint Resolve] for _all_ of the constructors
    from the inductive definition of [c].

    It is also sometimes necessary to add

      Hint Unfold d.

    where [d] is a defined symbol, so that [auto] knows to expand uses
    of [d], thus enabling further possibilities for applying lemmas that
    it knows about. *)

(** It is also possible to define specialized hint databases that can
    be activated only when needed.  See the Coq reference manual for
    more. *)

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.  (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

(** Let's take a first pass over [ceval_deterministic] to simplify the
    proof script. *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

(** When we are using a particular tactic many times in a proof, we
    can use a variant of the [Proof] command to make that tactic into
    a default within the proof.  Saying [Proof with t] (where [t] is
    an arbitrary tactic) allows us to use [t1...] as a shorthand for
    [t1;t] within the proof.  As an illustration, here is an alternate
    version of the previous proof, using [Proof with auto]. *)

Theorem ceval_deterministic'_alt: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* ################################################################# *)
(** * Searching For Hypotheses *)

(** The proof has become simpler, but there is still an annoying
    amount of repetition. Let's start by tackling the contradiction
    cases. Each of them occurs in a situation where we have both

      H1: beval st b = false

    and

      H2: beval st b = true

    as hypotheses.  The contradiction is evident, but demonstrating it
    is a little complicated: we have to locate the two hypotheses [H1]
    and [H2] and do a [rewrite] following by an [inversion].  We'd
    like to automate this process.

    (In fact, Coq has a built-in tactic [congruence] that will do the
    job in this case.  But we'll ignore the existence of this tactic
    for now, in order to demonstrate how to build forward search
    tactics by hand.)

    As a first step, we can abstract out the piece of script in
    question by writing a little function in Ltac. *)

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

(** That was is a bit better, but we really want Coq to discover the
    relevant hypotheses for us.  We can do this by using the [match
    goal] facility of Ltac. *)

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

(** This [match goal] looks for two distinct hypotheses that
    have the form of equalities, with the same arbitrary expression
    [E] on the left and with conflicting boolean values on the right.
    If such hypotheses are found, it binds [H1] and [H2] to their
    names and applies the [rwinv] tactic to [H1] and [H2].

    Adding this tactic to the ones that we invoke in each case of the
    induction handles all of the contradictory cases. *)

Theorem ceval_deterministic''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

(** Let's see about the remaining cases. Each of them involves
    applying a conditional hypothesis to extract an equality.
    Currently we have phrased these as assertions, so that we have to
    predict what the resulting equality will be (although we can then
    use [auto] to prove it).  An alternative is to pick the relevant
    hypotheses to use and then [rewrite] with them, as follows: *)

Theorem ceval_deterministic'''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

(** Now we can automate the task of finding the relevant hypotheses to
    rewrite with. *)

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

(** The pattern [forall x, ?P x -> ?L = ?R] matches any hypothesis of
    the form "for all [x], _some property of [x]_ implies _some
    equality_."  The property of [x] is bound to the pattern variable
    [P], and the left- and right-hand sides of the equality are bound
    to [L] and [R].  The name of this hypothesis is bound to [H1].
    Then the pattern [?P ?X] matches any hypothesis that provides
    evidence that [P] holds for some concrete [X].  If both patterns
    succeed, we apply the [rewrite] tactic (instantiating the
    quantified [x] with [X] and providing [H2] as the required
    evidence for [P X]) in all hypotheses and the goal.

    One problem remains: in general, there may be several pairs of
    hypotheses that have the right general form, and it seems tricky
    to pick out the ones we actually need.  A key trick is to realize
    that we can _try them all_!  Here's how this works:

    - each execution of [match goal] will keep trying to find a valid
      pair of hypotheses until the tactic on the RHS of the match
      succeeds; if there are no such pairs, it fails;
    - [rewrite] will fail given a trivial equation of the form [X = X];
    - we can wrap the whole thing in a [repeat], which will keep doing
      useful rewrites until only trivial ones are left. *)

Theorem ceval_deterministic''''': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

(** The big payoff in this approach is that our proof script should be
    more robust in the face of modest changes to our language.  To
    test whether it really is, let's try adding a [REPEAT] command to
    the language. *)

Module Repeat.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (IFB b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "c1 '/' st '\\' st'" := (ceval st c1 st')
                                 (at level 40, st at level 39).

(** Our first attempt at the determinacy proof does not quite succeed:
    the [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our
    previous automation. *)

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't [find_rwinv] solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

(** Fortunately, to fix this, we just have to swap the invocations of
    [find_eqn] and [find_rwinv]. *)

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

(** These examples just give a flavor of what "hyper-automation"
    can achieve in Coq.  The details of [match goal] are a bit
    tricky (and debugging scripts using it is, frankly, not very
    pleasant).  But it is well worth adding at least simple uses to
    your proofs, both to avoid tedium and to "future proof" them. *)

(* ================================================================= *)
(** ** The [eapply] and [eauto] variants *)

(** To close the chapter, we'll introduce one more convenient feature
    of Coq: its ability to delay instantiation of quantifiers.  To
    motivate this feature, recall this example from the [Imp]
    chapter: *)

Example ceval_example1:
    (X ::= 2;;
     IFB X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 }
   \\ { X --> 2 ; Z --> 4 }.
Proof.
  (* We supply the intermediate state [st']... *)
  apply E_Seq with { X --> 2 }.
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** In the first step of the proof, we had to explicitly provide a
    longish expression to help Coq instantiate a "hidden" argument to
    the [E_Seq] constructor.  This was needed because the definition
    of [E_Seq]...

          E_Seq : forall c1 c2 st st' st'',
            c1 / st  \\ st' ->
            c2 / st' \\ st'' ->
            (c1 ;; c2) / st \\ st''

   is quantified over a variable, [st'], that does not appear in its
   conclusion, so unifying its conclusion with the goal state doesn't
   help Coq find a suitable value for this variable.  If we leave
   out the [with], this step fails ("Error: Unable to find an
   instance for the variable [st']").

   What's silly about this error is that the appropriate value for [st']
   will actually become obvious in the very next step, where we apply
   [E_Ass].  If Coq could just wait until we get to this step, there
   would be no need to give the value explicitly.  This is exactly what
   the [eapply] tactic gives us: *)

Example ceval'_example1:
    (X ::= 2;;
     IFB X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 }
   \\ { X --> 2 ; Z --> 4 }.
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** The [eapply H] tactic behaves just like [apply H] except
    that, after it finishes unifying the goal state with the
    conclusion of [H], it does not bother to check whether all the
    variables that were introduced in the process have been given
    concrete values during unification.

    If you step through the proof above, you'll see that the goal
    state at position [1] mentions the _existential variable_ [?st']
    in both of the generated subgoals.  The next step (which gets us
    to position [2]) replaces [?st'] with a concrete value.  This new
    value contains a new existential variable [?n], which is
    instantiated in its turn by the following [reflexivity] step,
    position [3].  When we start working on the second
    subgoal (position [4]), we observe that the occurrence of [?st']
    in this subgoal has been replaced by the value that it was given
    during the first subgoal. *)

(** Several of the tactics that we've seen so far, including [exists],
    [constructor], and [auto], have [e...] variants.  For example,
    here's a proof using [eauto]: *)

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := { X --> 1 ; Y --> 2 }.
Definition st21 := { X --> 2 ; Y --> 1 }.

Example eauto_example : exists s',
  (IFB X <= Y
    THEN Z ::= Y - X
    ELSE Y ::= X + Z
  FI) / st21 \\ s'.
Proof. eauto. Qed.

(** The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply].

    Pro tip: One might think that, since [eapply] and [eauto] are more
    powerful than [apply] and [auto], it would be a good idea to use
    them all the time.  Unfortunately, they are also significantly
    slower -- especially [eauto].  Coq experts tend to use [apply] and
    [auto] most of the time, only switching to the [e] variants when
    the ordinary variants don't do the job. *)


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

(** Author: Bruno Barras *)

Require Import Relation_Operators.
Require Import Relation_Definitions.
Require Import Transitive_Closure.

Section WfUnion.
  Variable A : Type.
  Variables R1 R2 : relation A.

  Notation Union := (union A R1 R2).

  Remark strip_commut :
    commut A R1 R2 ->
    forall x y:A,
      clos_trans A R1 y x ->
      forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
  Proof.
    induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
    elim H with y x z; auto with sets; intros x0 H2 H3.
    exists x0; auto with sets.

    elim IH1 with z0; auto with sets; intros.
    elim IH2 with x0; auto with sets; intros.
    exists x1; auto with sets.
    apply t_trans with x0; auto with sets.
  Qed.

  Lemma Acc_union :
    commut A R1 R2 ->
    (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
  Proof.
    induction 3 as [x H1 H2].
    apply Acc_intro; intros.
    elim H3; intros; auto with sets.
    cut (clos_trans A R1 y x); auto with sets.
    elimtype (Acc (clos_trans A R1) y); intros.
    apply Acc_intro; intros.
    elim H8; intros.
    apply H6; auto with sets.
    apply t_trans with x0; auto with sets.

    elim strip_commut with x x0 y0; auto with sets; intros.
    apply Acc_inv_trans with x1; auto with sets.
    unfold union in |- *.
    elim H11; auto with sets; intros.
    apply t_trans with y1; auto with sets.

    apply (Acc_clos_trans A).
    apply Acc_inv with x; auto with sets.
    apply H0.
    apply Acc_intro; auto with sets.
  Qed.

  Theorem wf_union :
    commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
  Proof.
    unfold well_founded in |- *.
    intros.
    apply Acc_union; auto with sets.
  Qed.

End WfUnion.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div.
From mathcomp Require Import choice fintype prime finset fingroup morphism.
From mathcomp Require Import automorphism.

(******************************************************************************)
(* This file contains the definitions of:                                     *)
(*          coset_of H == the (sub)type of bilateral cosets of H (see below). *)
(*             coset H == the canonical projection into coset_of H.           *)
(*               A / H == the quotient of A by H, that is, the morphic image  *)
(*                        of A by coset H. We do not require H <| A, so in a  *)
(*                        textbook A / H would be written 'N_A(H) * H / H.    *)
(*   quotm f (nHG : H <| G) == the quotient morphism induced by f,            *)
(*                             mapping G / H onto f @* G / f @* H.            *)
(*   qisom f (eqHG : H = G) == the identity isomorphism between               *)
(*                            [set: coset_of G] and [set: coset_of H].        *)
(* We also prove the three isomorphism theorems, and counting lemmas for      *)
(* morphisms.                                                                 *)
(******************************************************************************)

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

Import GroupScope.

Section Cosets.

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

(******************************************************************************)
(* Cosets are right cosets of elements in the normaliser.                     *)
(* We let cosets coerce to GroupSet.sort, so they inherit the group subset    *)
(* base group structure. Later we will define a proper group structure on     *)
(* cosets, which will then hide the inherited structure once coset_of unifies *)
(* with FinGroup.sort; the coercion to GroupSet.sort will no longer be used.  *)
(*   Note that for Hx Hy : coset_of H, Hx * Hy : {set gT} can mean either     *)
(*    set_of_coset (mulg Hx Hy) OR mulg (set_of_coset Hx) (set_of_coset Hy).  *)
(* However, since the two terms are actually convertible, we can live with    *)
(* this ambiguity.                                                            *)
(*   We take great care that neither the type coset_of H, nor its Canonical   *)
(* finGroupType structure, nor the coset H morphism depend on the actual      *)
(* group structure of H. Otherwise, rewriting would be extremely awkward      *)
(* because all our equalities are stated at the set level.                    *)
(*   The trick we use is to interpret coset_of A, when A is any set, as the   *)
(* type of cosets of the group <<A>> generated by A, in the group A <*> N(A)  *)
(* generated by A and its normaliser. This coincides with the type of         *)
(* bilateral cosets of A when A is a group. We restrict the domain of coset A *)
(* to 'N(A), so that we get almost all the same conversion equalities as if   *)
(* we had forced A to be a group in the first place; the only exception, that *)
(* 1 : coset_of A : {set gT} = <<A>> rather than A, can be handled by genGid. *)
(******************************************************************************)

Notation H := <<A>>.
Definition coset_range := [pred B in rcosets H 'N(A)].

Record coset_of : Type :=
  Coset { set_of_coset :> GroupSet.sort gT; _ : coset_range set_of_coset }.

Canonical coset_subType := Eval hnf in [subType for set_of_coset].
Definition coset_eqMixin := Eval hnf in [eqMixin of coset_of by <:].
Canonical coset_eqType := Eval hnf in EqType coset_of coset_eqMixin.
Definition coset_choiceMixin := [choiceMixin of coset_of by <:].
Canonical coset_choiceType := Eval hnf in ChoiceType coset_of coset_choiceMixin.
Definition coset_countMixin := [countMixin of coset_of by <:].
Canonical coset_countType := Eval hnf in CountType coset_of coset_countMixin.
Canonical coset_subCountType := Eval hnf in [subCountType of coset_of].
Definition coset_finMixin := [finMixin of coset_of by <:].
Canonical coset_finType := Eval hnf in FinType coset_of coset_finMixin.
Canonical coset_subFinType := Eval hnf in [subFinType of coset_of].

(* We build a new (canonical) structure of groupType for cosets.              *)
(* When A is a group, this is the largest possible quotient 'N(A) / A.        *)

Lemma coset_one_proof : coset_range H.
Proof. by apply/rcosetsP; exists (1 : gT); rewrite (group1, mulg1). Qed.
Definition coset_one := Coset coset_one_proof.

Let nNH := subsetP (norm_gen A).

Lemma coset_range_mul (B C : coset_of) : coset_range (B * C).
Proof.
case: B C => _ /= /rcosetsP[x Nx ->] [_ /= /rcosetsP[y Ny ->]].
by apply/rcosetsP; exists (x * y); rewrite !(groupM, rcoset_mul, nNH).
Qed.

Definition coset_mul B C := Coset (coset_range_mul B C).

Lemma coset_range_inv (B : coset_of) : coset_range B^-1.
Proof.
case: B => _ /= /rcosetsP[x Nx ->]; rewrite norm_rlcoset ?nNH // invg_lcoset.
by apply/rcosetsP; exists x^-1; rewrite ?groupV.
Qed.

Definition coset_inv B := Coset (coset_range_inv B).

Lemma coset_mulP : associative coset_mul.
Proof. by move=> B C D; apply: val_inj; rewrite /= mulgA. Qed.

Lemma coset_oneP : left_id coset_one coset_mul.
Proof.
case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}.
by rewrite mulgA mulGid.
Qed.

Lemma coset_invP : left_inverse coset_one coset_inv coset_mul.
Proof.
case=> B coB; apply: val_inj => /=; case/rcosetsP: coB => x Hx ->{B}.
rewrite invg_rcoset -mulgA (mulgA H) mulGid.
by rewrite norm_rlcoset ?nNH // -lcosetM mulVg mul1g.
Qed.

Definition coset_of_groupMixin :=
  FinGroup.Mixin coset_mulP coset_oneP coset_invP.

Canonical coset_baseGroupType :=
  Eval hnf in BaseFinGroupType coset_of coset_of_groupMixin.
Canonical coset_groupType := FinGroupType coset_invP.

(* Projection of the initial group type over the cosets groupType.  *)

Definition coset x : coset_of := insubd (1 : coset_of) (H :* x).

(* This is a primitive lemma -- we'll need to restate it for *)
(* the case where A is a group. *)
Lemma val_coset_prim x : x \in 'N(A) -> coset x :=: H :* x.
Proof.
by move=> Nx; rewrite val_insubd /= mem_rcosets -{1}(mul1g x) mem_mulg.
Qed.

Lemma coset_morphM : {in 'N(A) &, {morph coset : x y / x * y}}.
Proof.
move=> x y Nx Ny; apply: val_inj.
by rewrite /= !val_coset_prim ?groupM //= rcoset_mul ?nNH.
Qed.

Canonical coset_morphism := Morphism coset_morphM.

Lemma ker_coset_prim : 'ker coset = 'N_H(A).
Proof.
apply/setP=> z; rewrite !in_setI andbC 2!inE -val_eqE /=.
case Nz: (z \in 'N(A)); rewrite ?andbF ?val_coset_prim // !andbT.
by apply/eqP/idP=> [<-| Az]; rewrite (rcoset_refl, rcoset_id).
Qed.

Implicit Type xbar : coset_of.

Lemma coset_mem y xbar : y \in xbar -> coset y = xbar.
Proof.
case: xbar => /= Hx NHx Hxy; apply: val_inj=> /=.
case/rcosetsP: NHx (NHx) Hxy => x Nx -> NHx Hxy.
by rewrite val_insubd /= (rcoset_eqP Hxy) NHx.
Qed.

(* coset is an inverse to repr *)

Lemma mem_repr_coset xbar : repr xbar \in xbar.
Proof. by case: xbar => /= _ /rcosetsP[x _ ->]; apply: mem_repr_rcoset. Qed.

Lemma repr_coset1 : repr (1 : coset_of) = 1.
Proof. exact: repr_group. Qed.

Lemma coset_reprK : cancel (fun xbar => repr xbar) coset.
Proof. by move=> xbar; apply: coset_mem (mem_repr_coset xbar). Qed.

(* cosetP is slightly stronger than using repr because we only *)
(* guarantee  repr xbar \in 'N(A) when A is a group.           *)
Lemma cosetP xbar : {x | x \in 'N(A) & xbar = coset x}.
Proof.
pose x := repr 'N_xbar(A).
have [xbar_x Nx]: x \in xbar /\ x \in 'N(A).
  apply/setIP; rewrite {}/x; case: xbar => /= _ /rcosetsP[y Ny ->].
  by apply: (mem_repr y); rewrite inE rcoset_refl.
by exists x; last rewrite (coset_mem xbar_x).
Qed.

Lemma coset_id x : x \in A -> coset x = 1.
Proof. by move=> Ax; apply: coset_mem; apply: mem_gen. Qed.

Lemma im_coset : coset @* 'N(A) = setT.
Proof.
by apply/setP=> xbar; case: (cosetP xbar) => x Nx ->; rewrite inE mem_morphim.
Qed.

Lemma sub_im_coset (C : {set coset_of}) : C \subset coset @* 'N(A).
Proof. by rewrite im_coset subsetT. Qed.

Lemma cosetpre_proper C D :
  (coset @*^-1 C \proper coset @*^-1 D) = (C \proper D).
Proof. by rewrite morphpre_proper ?sub_im_coset. Qed.

Definition quotient : {set coset_of} := coset @* Q.

Lemma quotientE : quotient = coset @* Q. Proof. by []. Qed.

End Cosets.

Arguments coset_of {gT} H%g : rename.
Arguments coset {gT} H%g x%g : rename.
Arguments quotient {gT} A%g H%g : rename.
Arguments coset_reprK {gT H%g} xbar%g : rename.

Bind Scope group_scope with coset_of.

Notation "A / H" := (quotient A H) : group_scope.

Section CosetOfGroupTheory.

Variables (gT : finGroupType) (H : {group gT}).
Implicit Types (A B : {set gT}) (G K : {group gT}) (xbar yb : coset_of H).
Implicit Types (C D : {set coset_of H}) (L M : {group coset_of H}).

Canonical quotient_group G A : {group coset_of A} :=
  Eval hnf in [group of G / A].

Infix "/" := quotient_group : Group_scope.

Lemma val_coset x : x \in 'N(H) -> coset H x :=: H :* x.
Proof. by move=> Nx; rewrite val_coset_prim // genGid. Qed.

Lemma coset_default x : (x \in 'N(H)) = false -> coset H x = 1.
Proof.
move=> Nx; apply: val_inj.
by rewrite val_insubd /= mem_rcosets /= genGid mulSGid ?normG ?Nx.
Qed.

Lemma coset_norm xbar : xbar \subset 'N(H).
Proof.
case: xbar => /= _ /rcosetsP[x Nx ->].
by rewrite genGid mul_subG ?sub1set ?normG.
Qed.

Lemma ker_coset : 'ker (coset H) = H.
Proof. by rewrite ker_coset_prim genGid (setIidPl _) ?normG. Qed.

Lemma coset_idr x : x \in 'N(H) -> coset H x = 1 -> x \in H.
Proof. by move=> Nx Hx1; rewrite -ker_coset mem_morphpre //= Hx1 set11. Qed.

Lemma repr_coset_norm xbar : repr xbar \in 'N(H).
Proof. exact: subsetP (coset_norm _) _ (mem_repr_coset _). Qed.

Lemma imset_coset G : coset H @: G = G / H.
Proof.
apply/eqP; rewrite eqEsubset andbC imsetS ?subsetIr //=.
apply/subsetP=> _ /imsetP[x Gx ->].
by case Nx: (x \in 'N(H)); rewrite ?(coset_default Nx) ?mem_morphim ?group1.
Qed.

Lemma val_quotient A : val @: (A / H) = rcosets H 'N_A(H).
Proof.
apply/setP=> B; apply/imsetP/rcosetsP=> [[xbar Axbar]|[x /setIP[Ax Nx]]] ->{B}.
  case/morphimP: Axbar => x Nx Ax ->{xbar}.
  by exists x; [rewrite inE Ax | rewrite /= val_coset].
by exists (coset H x); [apply/morphimP; exists x | rewrite /= val_coset].
Qed.

Lemma card_quotient_subnorm A : #|A / H| = #|'N_A(H) : H|.
Proof. by rewrite -(card_imset _ val_inj) val_quotient. Qed.

Lemma leq_quotient A : #|A / H| <= #|A|.
Proof. exact: leq_morphim. Qed.

Lemma ltn_quotient A : H :!=: 1 -> H \subset A -> #|A / H| < #|A|.
Proof.
by move=> ntH sHA; rewrite ltn_morphim // ker_coset (setIidPr sHA) proper1G.
Qed.

Lemma card_quotient A : A \subset 'N(H) -> #|A / H| = #|A : H|.
Proof. by move=> nHA; rewrite card_quotient_subnorm (setIidPl nHA). Qed.

Lemma divg_normal G : H <| G -> #|G| %/ #|H| = #|G / H|.
Proof. by case/andP=> sHG nHG; rewrite divgS ?card_quotient. Qed.

(* Specializing all the morphisms lemmas that have different assumptions    *)
(* (e.g., because 'ker (coset H) = H), or conclusions (e.g., because we use *)
(* A / H rather than coset H @* A). We may want to reevaluate later, and    *)
(* eliminate variants that aren't used                                  .   *)

(* Variant of morph1; no specialization for other morph lemmas. *)
Lemma coset1 : coset H 1 :=: H.
Proof. by rewrite morph1 /= genGid. Qed.

(* Variant of kerE. *)
Lemma cosetpre1 : coset H @*^-1 1 = H.
Proof. by rewrite -kerE ker_coset. Qed.

(* Variant of morphimEdom; mophimE[sub] covered by imset_coset.   *)
(* morph[im|pre]Iim are also covered by im_quotient.              *)
Lemma im_quotient : 'N(H) / H = setT.
Proof. exact: im_coset. Qed.

Lemma quotientT : setT / H = setT.
Proof. by rewrite -im_quotient; apply: morphimT. Qed.

(* Variant of morphimIdom. *)
Lemma quotientInorm A : 'N_A(H) / H = A / H.
Proof. by rewrite /quotient setIC morphimIdom. Qed.

Lemma quotient_setIpre A D : (A :&: coset H @*^-1 D) / H = A / H :&: D.
Proof. exact: morphim_setIpre. Qed.

Lemma mem_quotient x G : x \in G -> coset H x \in G / H.
Proof. by move=> Gx; rewrite -imset_coset imset_f. Qed.

Lemma quotientS A B : A \subset B -> A / H \subset B / H.
Proof. exact: morphimS. Qed.

Lemma quotient0 : set0 / H = set0.
Proof. exact: morphim0. Qed.

Lemma quotient_set1 x : x \in 'N(H) -> [set x] / H = [set coset H x].
Proof. exact: morphim_set1. Qed.

Lemma quotient1 : 1 / H = 1.
Proof. exact: morphim1. Qed.

Lemma quotientV A : A^-1 / H = (A / H)^-1.
Proof. exact: morphimV. Qed.

Lemma quotientMl A B : A \subset 'N(H) -> A * B / H = (A / H) * (B / H).
Proof. exact: morphimMl. Qed.

Lemma quotientMr A B : B \subset 'N(H) -> A * B / H = (A / H) * (B / H).
Proof. exact: morphimMr. Qed.

Lemma cosetpreM C D : coset H @*^-1 (C * D) = coset H @*^-1 C * coset H @*^-1 D.
Proof. by rewrite morphpreMl ?sub_im_coset. Qed.

Lemma quotientJ A x : x \in 'N(H) -> A :^ x / H = (A / H) :^ coset H x.
Proof. exact: morphimJ. Qed.

Lemma quotientU A B : (A :|: B) / H = A / H :|: B / H.
Proof. exact: morphimU. Qed.

Lemma quotientI A B : (A :&: B) / H \subset A / H :&: B / H.
Proof. exact: morphimI. Qed.

Lemma quotientY A B :
  A \subset 'N(H) -> B \subset 'N(H) -> (A <*> B) / H = (A / H) <*> (B / H).
Proof. exact: morphimY. Qed.

Lemma quotient_homg A : A \subset 'N(H) -> homg (A / H) A.
Proof. exact: morphim_homg. Qed.

Lemma coset_kerl x y : x \in H -> coset H (x * y) = coset H y.
Proof.
move=> Hx; case Ny: (y \in 'N(H)); first by rewrite mkerl ?ker_coset.
by rewrite !coset_default ?groupMl // (subsetP (normG H)).
Qed.

Lemma coset_kerr x y : y \in H -> coset H (x * y) = coset H x.
Proof.
move=> Hy; case Nx: (x \in 'N(H)); first by rewrite mkerr ?ker_coset.
by rewrite !coset_default ?groupMr // (subsetP (normG H)).
Qed.

Lemma rcoset_kercosetP x y :
  x \in 'N(H) -> y \in 'N(H) -> reflect (coset H x = coset H y) (x \in H :* y).
Proof. by rewrite -{6}ker_coset; apply: rcoset_kerP. Qed.

Lemma kercoset_rcoset x y :
    x \in 'N(H) -> y \in 'N(H) ->
  coset H x = coset H y -> exists2 z, z \in H & x = z * y.
Proof. by move=> Nx Ny eqfxy; rewrite -ker_coset; apply: ker_rcoset. Qed.

Lemma quotientGI G A : H \subset G -> (G :&: A) / H = G / H :&: A / H.
Proof. by rewrite -{1}ker_coset; apply: morphimGI. Qed.

Lemma quotientIG A G : H \subset G -> (A :&: G) / H = A / H :&: G / H.
Proof. by rewrite -{1}ker_coset; apply: morphimIG. Qed.

Lemma quotientD A B : A / H :\: B / H \subset (A :\: B) / H.
Proof. exact: morphimD. Qed.

Lemma quotientD1 A : (A / H)^# \subset A^# / H.
Proof. exact: morphimD1. Qed.

Lemma quotientDG A G : H \subset G -> (A :\: G) / H = A / H :\: G / H.
Proof. by rewrite -{1}ker_coset; apply: morphimDG. Qed.

Lemma quotientK A : A \subset 'N(H) -> coset H @*^-1 (A / H) = H * A.
Proof. by rewrite -{8}ker_coset; apply: morphimK. Qed.

Lemma quotientYK G : G \subset 'N(H) -> coset H @*^-1 (G / H) = H <*> G.
Proof. by move=> nHG; rewrite quotientK ?norm_joinEr. Qed.

Lemma quotientGK G : H <| G -> coset H @*^-1 (G / H) = G.
Proof. by case/andP; rewrite -{1}ker_coset; apply: morphimGK. Qed.

Lemma quotient_class x A :
  x \in 'N(H) -> A \subset 'N(H) -> x ^: A / H  = coset H x ^: (A / H).
Proof. exact: morphim_class. Qed.

Lemma classes_quotient A :
  A \subset 'N(H) -> classes (A / H) = [set xA / H | xA in classes A].
Proof. exact: classes_morphim. Qed.

Lemma cosetpre_set1 x :
  x \in 'N(H) -> coset H @*^-1 [set coset H x] = H :* x.
Proof. by rewrite -{9}ker_coset; apply: morphpre_set1. Qed.

Lemma cosetpre_set1_coset xbar : coset H @*^-1 [set xbar] = xbar.
Proof. by case: (cosetP xbar) => x Nx ->; rewrite cosetpre_set1 ?val_coset. Qed.

Lemma cosetpreK C : coset H @*^-1 C / H = C.
Proof. by rewrite /quotient morphpreK ?sub_im_coset. Qed.

(* Variant of morhphim_ker *)
Lemma trivg_quotient : H / H = 1.
Proof. by rewrite -{3}ker_coset /quotient morphim_ker. Qed.

Lemma quotientS1 G : G \subset H -> G / H = 1.
Proof. by move=> sGH; apply/trivgP; rewrite -trivg_quotient quotientS. Qed.

Lemma sub_cosetpre M : H \subset coset H @*^-1 M.
Proof. by rewrite -{1}ker_coset; apply: ker_sub_pre. Qed.

Lemma quotient_proper G K :
  H <| G -> H <| K -> (G / H \proper K / H) = (G \proper K).
Proof. by move=> nHG nHK; rewrite -cosetpre_proper ?quotientGK. Qed.

Lemma normal_cosetpre M : H <| coset H @*^-1 M.
Proof. by rewrite -{1}ker_coset; apply: ker_normal_pre. Qed.

Lemma cosetpreSK C D :
  (coset H @*^-1 C \subset coset H @*^-1 D) = (C \subset D).
Proof. by rewrite morphpreSK ?sub_im_coset. Qed.

Lemma sub_quotient_pre A C :
  A \subset 'N(H) -> (A / H \subset C) = (A \subset coset H @*^-1 C).
Proof. exact: sub_morphim_pre. Qed.

Lemma sub_cosetpre_quo C G :
  H <| G -> (coset H @*^-1 C \subset G) = (C \subset G / H).
Proof. by move=> nHG; rewrite -cosetpreSK quotientGK. Qed.

(* Variant of ker_trivg_morphim. *)
Lemma quotient_sub1 A : A \subset 'N(H) -> (A / H \subset [1]) = (A \subset H).
Proof. by move=> nHA /=; rewrite -{10}ker_coset ker_trivg_morphim nHA. Qed.

Lemma quotientSK A B :
  A \subset 'N(H) -> (A / H \subset B / H) = (A \subset H * B).
Proof. by move=> nHA; rewrite morphimSK ?ker_coset. Qed.

Lemma quotientSGK A G :
  A \subset 'N(H) -> H \subset G -> (A / H \subset G / H) = (A \subset G).
Proof. by rewrite -{2}ker_coset; apply: morphimSGK. Qed.

Lemma quotient_injG :
  {in [pred G : {group gT} | H <| G] &, injective (fun G => G / H)}.
Proof. by rewrite /normal -{1}ker_coset; apply: morphim_injG. Qed.

Lemma quotient_inj G1 G2 :
   H <| G1 -> H <| G2 -> G1 / H = G2 / H -> G1 :=: G2.
Proof. by rewrite /normal -[in mem H]ker_coset; apply: morphim_inj. Qed.

Lemma quotient_neq1 A : H <| A -> (A / H != 1) = (H \proper A).
Proof.
case/andP=> sHA  nHA; rewrite /proper sHA -trivg_quotient eqEsubset andbC.
by rewrite quotientS //= quotientSGK.
Qed.

Lemma quotient_gen A : A \subset 'N(H) -> <<A>> / H = <<A / H>>.
Proof. exact: morphim_gen. Qed.

Lemma cosetpre_gen C :
  1 \in C -> coset H @*^-1 <<C>> = <<coset H @*^-1 C>>.
Proof. by move=> C1; rewrite morphpre_gen ?sub_im_coset. Qed.

Lemma quotientR A B :
  A \subset 'N(H) -> B \subset 'N(H) -> [~: A, B] / H = [~: A / H, B / H].
Proof. exact: morphimR. Qed.

Lemma quotient_norm A : 'N(A) / H \subset 'N(A / H).
Proof. exact: morphim_norm. Qed.

Lemma quotient_norms A B : A \subset 'N(B) -> A / H \subset 'N(B / H).
Proof. exact: morphim_norms. Qed.

Lemma quotient_subnorm A B : 'N_A(B) / H \subset 'N_(A / H)(B / H).
Proof. exact: morphim_subnorm. Qed.

Lemma quotient_normal A B : A <| B -> A / H <| B / H.
Proof. exact: morphim_normal. Qed.

Lemma quotient_cent1 x : 'C[x] / H \subset 'C[coset H x].
Proof.
case Nx: (x \in 'N(H)); first exact: morphim_cent1.
by rewrite coset_default // cent11T subsetT.
Qed.

Lemma quotient_cent1s A x : A \subset 'C[x] -> A / H \subset 'C[coset H x].
Proof.
by move=> sAC; apply: subset_trans (quotientS sAC) (quotient_cent1 x).
Qed.

Lemma quotient_subcent1 A x : 'C_A[x] / H \subset 'C_(A / H)[coset H x].
Proof. exact: subset_trans (quotientI _ _) (setIS _ (quotient_cent1 x)). Qed.

Lemma quotient_cent A : 'C(A) / H \subset 'C(A / H).
Proof. exact: morphim_cent. Qed.

Lemma quotient_cents A B : A \subset 'C(B) -> A / H \subset 'C(B / H).
Proof. exact: morphim_cents. Qed.

Lemma quotient_abelian A : abelian A -> abelian (A / H).
Proof. exact: morphim_abelian. Qed.

Lemma quotient_subcent A B : 'C_A(B) / H \subset 'C_(A / H)(B / H).
Proof. exact: morphim_subcent. Qed.

Lemma norm_quotient_pre A C :
  A \subset 'N(H) -> A / H \subset 'N(C) -> A \subset 'N(coset H @*^-1 C).
Proof.
by move/sub_quotient_pre=> -> /subset_trans-> //; apply: morphpre_norm.
Qed.

Lemma cosetpre_normal C D : (coset H @*^-1 C <| coset H @*^-1 D) = (C <| D).
Proof. by rewrite morphpre_normal ?sub_im_coset. Qed.

Lemma quotient_normG G : H <| G -> 'N(G) / H = 'N(G / H).
Proof.
case/andP=> sHG nHG.
by rewrite [_ / _]morphim_normG ?ker_coset // im_coset setTI.
Qed.

Lemma quotient_subnormG A G : H <| G -> 'N_A(G) / H = 'N_(A / H)(G / H).
Proof. by case/andP=> sHG nHG; rewrite -morphim_subnormG ?ker_coset. Qed.

Lemma cosetpre_cent1 x : 'C_('N(H))[x] \subset coset H @*^-1 'C[coset H x].
Proof.
case Nx: (x \in 'N(H)); first by rewrite morphpre_cent1.
by rewrite coset_default // cent11T morphpreT subsetIl.
Qed.

Lemma cosetpre_cent1s C x :
  coset H @*^-1 C \subset 'C[x] -> C \subset 'C[coset H x].
Proof.
move=> sC; rewrite -cosetpreSK; apply: subset_trans (cosetpre_cent1 x).
by rewrite subsetI subsetIl.
Qed.

Lemma cosetpre_subcent1 C x :
  'C_(coset H @*^-1 C)[x] \subset coset H @*^-1 'C_C[coset H x].
Proof.
by rewrite -morphpreIdom -setIA setICA morphpreI setIS // cosetpre_cent1.
Qed.

Lemma cosetpre_cent A : 'C_('N(H))(A) \subset coset H @*^-1 'C(A / H).
Proof. exact: morphpre_cent. Qed.

Lemma cosetpre_cents A C : coset H @*^-1 C \subset 'C(A) -> C \subset 'C(A / H).
Proof. by apply: morphpre_cents; rewrite ?sub_im_coset. Qed.

Lemma cosetpre_subcent C A :
  'C_(coset H @*^-1 C)(A) \subset coset H @*^-1 'C_C(A / H).
Proof. exact: morphpre_subcent. Qed.

Lemma restrm_quotientE G A (nHG : G \subset 'N(H)) :
  A \subset G -> restrm nHG (coset H) @* A = A / H.
Proof. exact: restrmEsub. Qed.

Section InverseImage.

Variables (G : {group gT}) (Kbar : {group coset_of H}).

Hypothesis nHG : H <| G.

Variant inv_quotient_spec (P : pred {group gT}) : Prop :=
  InvQuotientSpec K of Kbar :=: K / H & H \subset K & P K.

Lemma inv_quotientS :
  Kbar \subset G / H -> inv_quotient_spec (fun K => K \subset G).
Proof.
case/andP: nHG => sHG nHG' sKbarG.
have sKdH: Kbar \subset 'N(H) / H by rewrite (subset_trans sKbarG) ?morphimS.
exists (coset H @*^-1 Kbar)%G; first by rewrite cosetpreK.
  by rewrite -{1}ker_coset morphpreS ?sub1G.
by rewrite sub_cosetpre_quo.
Qed.

Lemma inv_quotientN : Kbar <| G / H -> inv_quotient_spec (fun K => K <| G).
Proof.
move=> nKbar; case/inv_quotientS: (normal_sub nKbar) => K defKbar sHK sKG.
exists K => //; rewrite defKbar -cosetpre_normal !quotientGK // in nKbar.
exact: normalS nHG.
Qed.

End InverseImage.

Lemma quotientMidr A : A * H / H = A / H.
Proof.
by rewrite [_ /_]morphimMr ?normG //= -!quotientE trivg_quotient mulg1.
Qed.

Lemma quotientMidl A : H * A / H = A / H.
Proof.
by rewrite [_ /_]morphimMl ?normG //= -!quotientE trivg_quotient mul1g.
Qed.

Lemma quotientYidr G : G \subset 'N(H) -> G <*> H / H = G / H.
Proof.
move=> nHG; rewrite -genM_join quotient_gen ?mul_subG ?normG //.
by rewrite quotientMidr genGid.
Qed.

Lemma quotientYidl G : G \subset 'N(H) -> H <*> G / H = G / H.
Proof. by move=> nHG; rewrite joingC quotientYidr. Qed.

Section Injective.

Variables (G : {group gT}).
Hypotheses (nHG : G \subset 'N(H)) (tiHG : H :&: G = 1).

Lemma quotient_isom : isom G (G / H) (restrm nHG (coset H)).
Proof. by apply/isomP; rewrite ker_restrm setIC ker_coset tiHG im_restrm. Qed.

Lemma quotient_isog : isog G (G / H).
Proof. exact: isom_isog quotient_isom. Qed.

End Injective.

End CosetOfGroupTheory.

Notation "A / H" := (quotient_group A H) : Group_scope.

Section Quotient1.

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

Lemma coset1_injm : 'injm (@coset gT 1).
Proof. by rewrite ker_coset /=. Qed.

Lemma quotient1_isom : isom A (A / 1) (coset 1).
Proof. by apply: sub_isom coset1_injm; rewrite ?norms1. Qed.

Lemma quotient1_isog : isog A (A / 1).
Proof. by apply: isom_isog quotient1_isom; apply: norms1. Qed.

End Quotient1.

Section QuotientMorphism.

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

Implicit Types A : {set gT}.
Implicit Types B : {set (coset_of H)}.
Hypotheses (nsHG : H <| G).
Let sHG : H \subset G := normal_sub nsHG.
Let nHG : G \subset 'N(H) := normal_norm nsHG.
Let nfHfG : f @* G \subset 'N(f @* H) := morphim_norms f nHG.

Notation fH := (coset (f @* H) \o f).

Lemma quotm_dom_proof : G \subset 'dom fH.
Proof. by rewrite -sub_morphim_pre. Qed.

Notation fH_G := (restrm quotm_dom_proof fH).

Lemma quotm_ker_proof : 'ker (coset H) \subset 'ker fH_G.
Proof.
by rewrite ker_restrm ker_comp !ker_coset morphpreIdom morphimK ?mulG_subr.
Qed.

Definition quotm := factm quotm_ker_proof nHG.

Canonical quotm_morphism := [morphism G / H of quotm].

Lemma quotmE x : x \in G -> quotm (coset H x) = coset (f @* H) (f x).
Proof. exact: factmE. Qed.

Lemma morphim_quotm A : quotm @* (A / H) = f @* A / f @* H.
Proof. by rewrite morphim_factm morphim_restrm morphim_comp morphimIdom. Qed.

Lemma morphpre_quotm Abar : quotm @*^-1 (Abar / f @* H) = f @*^-1 Abar / H.
Proof.
rewrite morphpre_factm morphpre_restrm morphpre_comp /=.
rewrite morphpreIdom -[Abar / _]quotientInorm quotientK ?subsetIr //=.
rewrite morphpreMl ?morphimS // morphimK // [_ * H]normC ?subIset ?nHG //.
rewrite -quotientE -mulgA quotientMidl /= setIC -morphpreIim setIA.
by rewrite (setIidPl nfHfG) morphpreIim -morphpreMl ?sub1G ?mul1g.
Qed.

Lemma ker_quotm : 'ker quotm = 'ker f / H.
Proof. by rewrite -morphpre_quotm /quotient morphim1. Qed.

Lemma injm_quotm : 'injm f -> 'injm quotm.
Proof. by move/trivgP=> /= kf1; rewrite ker_quotm kf1 quotientE morphim1. Qed.

End QuotientMorphism.

Section EqIso.

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

Hypothesis (eqGH : G :=: H).

Lemma im_qisom_proof : 'N(H) \subset 'N(G). Proof. by rewrite eqGH. Qed.
Lemma qisom_ker_proof : 'ker (coset G) \subset 'ker (coset H).
Proof. by rewrite eqGH. Qed.
Lemma qisom_restr_proof : setT \subset 'N(H) / G.
Proof. by rewrite eqGH im_quotient. Qed.

Definition qisom :=
  restrm qisom_restr_proof (factm qisom_ker_proof im_qisom_proof).

Canonical qisom_morphism := Eval hnf in [morphism of qisom].

Lemma qisomE x : qisom (coset G x) = coset H x.
Proof.
case Nx: (x \in 'N(H)); first exact: factmE.
by rewrite !coset_default ?eqGH ?morph1.
Qed.

Lemma val_qisom Gx : val (qisom Gx) = val Gx.
Proof.
by case: (cosetP Gx) => x Nx ->{Gx}; rewrite qisomE /= !val_coset -?eqGH.
Qed.

Lemma morphim_qisom A : qisom @* (A / G) = A / H.
Proof. by rewrite morphim_restrm setTI morphim_factm. Qed.

Lemma morphpre_qisom A : qisom @*^-1 (A / H) = A / G.
Proof.
rewrite morphpre_restrm setTI morphpre_factm eqGH.
by rewrite morphpreK // im_coset subsetT.
Qed.

Lemma injm_qisom : 'injm qisom.
Proof. by rewrite -quotient1 -morphpre_qisom morphpreS ?sub1G. Qed.

Lemma im_qisom : qisom @* setT = setT.
Proof. by rewrite -{2}im_quotient morphim_qisom eqGH im_quotient. Qed.

Lemma qisom_isom : isom setT setT qisom.
Proof. by apply/isomP; rewrite injm_qisom im_qisom. Qed.

Lemma qisom_isog : [set: coset_of G] \isog [set: coset_of H].
Proof. exact: isom_isog qisom_isom. Qed.

Lemma qisom_inj : injective qisom.
Proof. by move=> x y; apply: (injmP injm_qisom); rewrite inE. Qed.

Lemma morphim_qisom_inj : injective (fun Gx => qisom @* Gx).
Proof.
by move=> Gx Gy; apply: injm_morphim_inj; rewrite (injm_qisom, subsetT).
Qed.

End EqIso.

Arguments qisom_inj {gT G H} eqGH [x1 x2].
Arguments morphim_qisom_inj {gT G H} eqGH [x1 x2].

Section FirstIsomorphism.

Variables aT rT : finGroupType.

Lemma first_isom (G : {group aT}) (f : {morphism G >-> rT}) :
  {g : {morphism G / 'ker f >-> rT} | 'injm g &
      forall A : {set aT}, g @* (A / 'ker f) = f @* A}.
Proof.
have nkG := ker_norm f.
have skk: 'ker (coset ('ker f)) \subset 'ker f by rewrite ker_coset.
exists (factm_morphism skk nkG) => /=; last exact: morphim_factm.
by rewrite ker_factm -quotientE trivg_quotient.
Qed.

Variables (G H : {group aT}) (f : {morphism G >-> rT}).
Hypothesis sHG : H \subset G.

Lemma first_isog : (G / 'ker f) \isog (f @* G).
Proof.
by case: (first_isom f) => g injg im_g; apply/isogP; exists g; rewrite ?im_g.
Qed.

Lemma first_isom_loc : {g : {morphism H / 'ker_H f >-> rT} |
 'injm g & forall A : {set aT}, A \subset H -> g @* (A / 'ker_H f) = f @* A}.
Proof.
case: (first_isom (restrm_morphism sHG f)).
rewrite ker_restrm => g injg im_g; exists g => // A sAH.
by rewrite im_g morphim_restrm (setIidPr sAH).
Qed.

Lemma first_isog_loc : (H / 'ker_H f) \isog (f @* H).
Proof.
by case: first_isom_loc => g injg im_g; apply/isogP; exists g; rewrite ?im_g.
Qed.

End FirstIsomorphism.

Section SecondIsomorphism.

Variables (gT : finGroupType) (H K : {group gT}).

Hypothesis nKH : H \subset 'N(K).

Lemma second_isom : {f : {morphism H / (K :&: H) >-> coset_of K} |
  'injm f & forall A : {set gT}, A \subset H -> f @* (A / (K :&: H)) = A / K}.
Proof.
have ->: K :&: H = 'ker_H (coset K) by rewrite ker_coset setIC.
exact: first_isom_loc.
Qed.

Lemma second_isog : H / (K :&: H) \isog H / K.
Proof. by rewrite setIC -{1 3}(ker_coset K); apply: first_isog_loc. Qed.

Lemma weak_second_isog : H / (K :&: H) \isog H * K / K.
Proof. by rewrite quotientMidr; apply: second_isog. Qed.

End SecondIsomorphism.

Section ThirdIsomorphism.

Variables (gT : finGroupType) (G H K : {group gT}).

Lemma homg_quotientS (A : {set gT}) :
  A \subset 'N(H) -> A \subset 'N(K) -> H \subset K -> A / K \homg A / H.
Proof.
rewrite -!(gen_subG A) /=; set L := <<A>> => nHL nKL sKH.
have sub_ker: 'ker (restrm nHL (coset H)) \subset 'ker (restrm nKL (coset K)).
  by rewrite !ker_restrm !ker_coset setIS.
have sAL: A \subset L := subset_gen A; rewrite -(setIidPr sAL).
rewrite -[_ / H](morphim_restrm nHL) -[_ / K](morphim_restrm nKL) /=.
by rewrite -(morphim_factm sub_ker (subxx L)) morphim_homg ?morphimS.
Qed.

Hypothesis sHK : H \subset K.
Hypothesis snHG : H <| G.
Hypothesis snKG : K <| G.

Theorem third_isom : {f : {morphism (G / H) / (K / H) >-> coset_of K} | 'injm f
   & forall A : {set gT}, A \subset G -> f @* (A / H / (K / H)) = A / K}.
Proof.
have [[sKG nKG] [sHG nHG]] := (andP snKG, andP snHG).
have sHker: 'ker (coset H) \subset 'ker (restrm nKG (coset K)).
  by rewrite ker_restrm !ker_coset subsetI sHG.
have:= first_isom_loc (factm_morphism sHker nHG) (subxx _) => /=.
rewrite ker_factm_loc ker_restrm ker_coset !(setIidPr sKG) /= -!quotientE.
case=> f injf im_f; exists f => // A sAG; rewrite im_f ?morphimS //.
by rewrite morphim_factm morphim_restrm (setIidPr sAG).
Qed.

Theorem third_isog : (G / H / (K / H)) \isog (G / K).
Proof.
by case: third_isom => f inj_f im_f; apply/isogP; exists f; rewrite ?im_f.
Qed.

End ThirdIsomorphism.

Lemma char_from_quotient (gT : finGroupType) (G H K : {group gT}) :
  H <| K -> H \char G -> K / H \char G / H -> K \char G.
Proof.
case/andP=> sHK nHK chHG.
have nsHG := char_normal chHG; have [sHG nHG] := andP nsHG.
case/charP; rewrite quotientSGK // => sKG /= chKG.
apply/charP; split=> // f injf Gf; apply/morphim_fixP => //.
rewrite -(quotientSGK _ sHK); last by rewrite -morphimIim Gf subIset ?nHG.
have{chHG} Hf: f @* H = H by case/charP: chHG => _; apply.
set q := quotm_morphism f nsHG; have{injf}: 'injm q by apply: injm_quotm.
have: q @* _ = _ := morphim_quotm _ _ _; move: q; rewrite Hf => q im_q injq.
by rewrite -im_q chKG // im_q Gf.
Qed.

(* Counting lemmas for morphisms. *)

Section CardMorphism.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Implicit Types G H : {group aT}.
Implicit Types L M : {group rT}.

Lemma card_morphim G : #|f @* G| = #|D :&: G : 'ker f|.
Proof.
rewrite -morphimIdom -indexgI -card_quotient; last first.
  by rewrite normsI ?normG ?subIset ?ker_norm.
by apply: esym (card_isog _); rewrite first_isog_loc ?subsetIl.
Qed.

Lemma dvdn_morphim G : #|f @* G| %| #|G|.
Proof.
rewrite card_morphim (dvdn_trans (dvdn_indexg _ _)) //.
by rewrite cardSg ?subsetIr.
Qed.

Lemma logn_morphim p G : logn p #|f @* G| <= logn p #|G|.
Proof. by rewrite dvdn_leq_log ?dvdn_morphim. Qed.

Lemma coprime_morphl G p : coprime #|G| p -> coprime #|f @* G| p.
Proof. exact: coprime_dvdl (dvdn_morphim G). Qed.

Lemma coprime_morphr G p : coprime p #|G| -> coprime p #|f @* G|.
Proof. exact: coprime_dvdr (dvdn_morphim G). Qed.

Lemma coprime_morph G H : coprime #|G| #|H| -> coprime #|f @* G| #|f @* H|.
Proof. by move=> coGH; rewrite coprime_morphl // coprime_morphr. Qed.

Lemma index_morphim_ker G H :
    H \subset G -> G \subset D ->
  (#|f @* G : f @* H| * #|'ker_G f : H|)%N = #|G : H|.
Proof.
move=> sHG sGD; apply/eqP.
rewrite -(eqn_pmul2l (cardG_gt0 (f @* H))) mulnA Lagrange ?morphimS //.
rewrite !card_morphim (setIidPr sGD) (setIidPr (subset_trans sHG sGD)).
rewrite -(eqn_pmul2l (cardG_gt0 ('ker_H f))) /=.
by rewrite -{1}(setIidPr sHG) setIAC mulnCA mulnC mulnA !LagrangeI Lagrange.
Qed.

Lemma index_morphim G H : G :&: H \subset D -> #|f @* G : f @* H| %| #|G : H|.
Proof.
move=> dGH; rewrite -(indexgI G) -(setIidPr dGH) setIA.
apply: dvdn_trans (indexSg (subsetIl _ H) (subsetIr D G)).
rewrite -index_morphim_ker ?subsetIl ?subsetIr ?dvdn_mulr //= morphimIdom.
by rewrite indexgS ?morphimS ?subsetIr.
Qed.

Lemma index_injm G H : 'injm f -> G \subset D -> #|f @* G : f @* H| = #|G : H|.
Proof.
move=> injf dG; rewrite -{2}(setIidPr dG) -(indexgI _ H) /=.
rewrite -index_morphim_ker ?subsetIl ?subsetIr //= setIAC morphimIdom setIC.
rewrite injmI ?subsetIr // indexgI /= morphimIdom setIC ker_injm //.
by rewrite -(indexgI (1 :&: _)) /= -setIA !(setIidPl (sub1G _)) indexgg muln1.
Qed.

Lemma card_morphpre L : L \subset f @* D -> #|f @*^-1 L| = (#|'ker f| * #|L|)%N.
Proof.
move/morphpreK=> {2} <-; rewrite card_morphim morphpreIdom.
by rewrite Lagrange // morphpreS ?sub1G.
Qed.

Lemma index_morphpre L M :
  L \subset f @* D -> #|f @*^-1 L : f @*^-1 M| = #|L : M|.
Proof.
move=> dL; rewrite -!divgI -morphpreI card_morphpre //.
have: L :&: M \subset f @* D by rewrite subIset ?dL.
by move/card_morphpre->; rewrite divnMl ?cardG_gt0.
Qed.

End CardMorphism.

Lemma card_homg (aT rT : finGroupType) (G : {group aT}) (R : {group rT}) :
  G \homg R -> #|G| %| #|R|.
Proof. by case/homgP=> f <-; rewrite card_morphim setIid dvdn_indexg. Qed.

Section CardCosetpre.

Variables (gT : finGroupType) (G H K : {group gT}) (L M : {group coset_of H}).

Lemma dvdn_quotient : #|G / H| %| #|G|.
Proof. exact: dvdn_morphim. Qed.

Lemma index_quotient_ker :
     K \subset G -> G \subset 'N(H) ->
  (#|G / H : K / H| * #|G :&: H : K|)%N = #|G : K|.
Proof. by rewrite -{5}(ker_coset H); apply: index_morphim_ker. Qed.

Lemma index_quotient : G :&: K \subset 'N(H) -> #|G / H : K / H| %| #|G : K|.
Proof. exact: index_morphim. Qed.

Lemma index_quotient_eq :
    G :&: H \subset K -> K \subset G -> G \subset 'N(H) ->
  #|G / H : K / H| = #|G : K|.
Proof.
move=> sGH_K sKG sGN; rewrite -index_quotient_ker {sKG sGN}//.
by rewrite -(indexgI _ K) (setIidPl sGH_K) indexgg muln1.
Qed.

Lemma card_cosetpre : #|coset H @*^-1 L| = (#|H| * #|L|)%N.
Proof. by rewrite card_morphpre ?ker_coset ?sub_im_coset. Qed.

Lemma index_cosetpre : #|coset H @*^-1 L : coset H @*^-1 M| = #|L : M|.
Proof. by rewrite index_morphpre ?sub_im_coset. Qed.

End CardCosetpre.


(** * PreCategories [set_cat] and [prop_cat] *)
Require Import Category.Strict.
Require Import HoTT.Basics HoTT.Types TruncType.

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

Notation cat_of obj :=
  (@Build_PreCategory obj
                      (fun x y => x -> y)
                      (fun _ x => x)
                      (fun _ _ _ f g => f o g)%core
                      (fun _ _ _ _ _ _ _ => idpath)
                      (fun _ _ _ => idpath)
                      (fun _ _ _ => idpath)
                      _).

(** There is a category [Set], where the objects are sets and the
    morphisms are set morphisms *)

Definition prop_cat `{Funext} : PreCategory := cat_of HProp.
Definition set_cat `{Funext} : PreCategory := cat_of HSet.

(** ** [Prop] is a strict category *)
Global Instance isstrict_prop_cat `{Univalence}
: IsStrictCategory prop_cat
  := _.

(** Because, e.g., [@identity set_cat x ≡ x], and we want [rewrite] to
    notice this, we must inform it that it can try treating [identity]
    as [idmap]. *)
Declare Equivalent Keys identity idmap.


From iris.algebra Require Export auth.
From iris.algebra Require Import numbers updates.
From iris.prelude Require Import options.

(** Authoritative CMRA over [max_nat]. The authoritative element is a
monotonically increasing [nat], while a fragment is a lower bound. *)

Definition mono_nat   := auth max_natUR.
Definition mono_natR  := authR max_natUR.
Definition mono_natUR := authUR max_natUR.

(** [mono_nat_auth] is the authoritative element. The definition includes the
fragment at the same value so that lemma [mono_nat_included], which states that
[mono_nat_lb n ≼ mono_nat_auth q n], does not require a frame-preserving
update. *)
Definition mono_nat_auth (q : Qp) (n : nat) : mono_nat :=
  ●{q} MaxNat n ⋅ ◯ MaxNat n.
Definition mono_nat_lb (n : nat) : mono_nat := ◯ MaxNat n.

Section mono_nat.
  Implicit Types (n : nat).

  Global Instance mono_nat_lb_core_id n : CoreId (mono_nat_lb n).
  Proof. apply _. Qed.

  Lemma mono_nat_auth_frac_op q1 q2 n :
    mono_nat_auth q1 n ⋅ mono_nat_auth q2 n ≡ mono_nat_auth (q1 + q2) n.
  Proof.
    rewrite /mono_nat_auth auth_auth_frac_op.
    rewrite (comm _ (●{q2} _)) -!assoc (assoc _ (◯ _)).
    by rewrite -core_id_dup (comm _ (◯ _)).
  Qed.

  Lemma mono_nat_lb_op n1 n2 :
    mono_nat_lb n1 ⋅ mono_nat_lb n2 = mono_nat_lb (n1 `max` n2).
  Proof. rewrite -auth_frag_op max_nat_op //. Qed.

  Lemma mono_nat_auth_lb_op q n :
    mono_nat_auth q n ≡ mono_nat_auth q n ⋅ mono_nat_lb n.
  Proof.
    rewrite /mono_nat_auth /mono_nat_lb.
    rewrite -!assoc -auth_frag_op max_nat_op.
    rewrite Nat.max_id //.
  Qed.

  (** rephrasing of [mono_nat_lb_op] useful for weakening a fragment to a
  smaller lower-bound *)
  Lemma mono_nat_lb_op_le_l n n' :
    n' ≤ n →
    mono_nat_lb n = mono_nat_lb n' ⋅ mono_nat_lb n.
  Proof. intros. rewrite mono_nat_lb_op Nat.max_r //. Qed.

  Lemma mono_nat_auth_frac_valid q n : ✓ mono_nat_auth q n ↔ (q ≤ 1)%Qp.
  Proof.
    rewrite /mono_nat_auth auth_both_frac_valid_discrete /=. naive_solver.
  Qed.
  Lemma mono_nat_auth_valid n : ✓ mono_nat_auth 1 n.
  Proof. by apply auth_both_valid. Qed.

  Lemma mono_nat_auth_frac_op_valid q1 q2 n1 n2 :
    ✓ (mono_nat_auth q1 n1 ⋅ mono_nat_auth q2 n2) ↔ (q1 + q2 ≤ 1)%Qp ∧ n1 = n2.
  Proof.
    rewrite /mono_nat_auth (comm _ (●{q2} _)) -!assoc (assoc _ (◯ _)).
    rewrite -auth_frag_op (comm _ (◯ _)) assoc. split.
    - move=> /cmra_valid_op_l /auth_auth_frac_op_valid. naive_solver.
    - intros [? ->]. rewrite -core_id_dup -auth_auth_frac_op.
      by apply auth_both_frac_valid_discrete.
  Qed.
  Lemma mono_nat_auth_op_valid n1 n2 :
    ✓ (mono_nat_auth 1 n1 ⋅ mono_nat_auth 1 n2) ↔ False.
  Proof. rewrite mono_nat_auth_frac_op_valid. naive_solver. Qed.

  Lemma mono_nat_both_frac_valid q n m :
    ✓ (mono_nat_auth q n ⋅ mono_nat_lb m) ↔ (q ≤ 1)%Qp ∧ m ≤ n.
  Proof.
    rewrite /mono_nat_auth /mono_nat_lb -assoc -auth_frag_op.
    rewrite auth_both_frac_valid_discrete max_nat_included /=.
    naive_solver lia.
  Qed.
  Lemma mono_nat_both_valid n m :
    ✓ (mono_nat_auth 1 n ⋅ mono_nat_lb m) ↔ m ≤ n.
  Proof. rewrite mono_nat_both_frac_valid. naive_solver. Qed.

  Lemma mono_nat_lb_mono n1 n2 : n1 ≤ n2 → mono_nat_lb n1 ≼ mono_nat_lb n2.
  Proof. intros. by apply auth_frag_mono, max_nat_included. Qed.

  Lemma mono_nat_included q n : mono_nat_lb n ≼ mono_nat_auth q n.
  Proof. apply cmra_included_r. Qed.

  Lemma mono_nat_update {n} n' :
    n ≤ n' →
    mono_nat_auth 1 n ~~> mono_nat_auth 1 n'.
  Proof.
    intros. rewrite /mono_nat_auth /mono_nat_lb.
    by apply auth_update, max_nat_local_update.
  Qed.
End mono_nat.

Typeclasses Opaque mono_nat_auth mono_nat_lb.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


Require Import sepcomp.compcert. Import CompcertLibraries.

Require Import sepcomp.core_semantics.

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

Section closed_safety.

Variable (G C D Z M : Type).

Variable sem : CoreSemantics G C M.

Variable ge : G.

Fixpoint safeN (n : nat) (c : C) (m : M) : Prop :=
  match n with
    | O => True
    | S n' =>
      match halted sem c with
        | None =>
          exists c', exists m',
            corestep sem ge c m c' m' /\
            safeN n' c' m'
        | Some i => True
      end
  end.

Lemma safe_downward1 n c m : safeN (S n) c m -> safeN n c m.
Proof.
revert c m; induction n; simpl; intros; auto.
destruct (halted sem c); auto.
destruct H as [c' [m' [? ?]]].
exists c', m'; split; auto.
Qed.

Lemma safe_downward (n n' : nat) c m :
  le n' n -> safeN n c m -> safeN n' c m.
Proof.
do 2 intro. revert c m H0. induction H; auto.
intros. apply IHle. apply safe_downward1. auto.
Qed.

Lemma safe_corestep_forward c m c' m' n :
  corestep_fun sem ->
  corestep sem ge c m c' m' -> safeN (S n) c m ->
  safeN n c' m'.
Proof.
simpl; intros.
erewrite corestep_not_halted in H1; eauto.
destruct H1 as [c'' [m'' [? ?]]].
assert ((c',m') = (c'',m'')).
destruct (H _ _ _ _ _ _ _ H0 H1).
subst; auto.
inv H3; auto.
Qed.

Lemma safe_corestepN_forward c m c' m' n n0 :
  corestep_fun sem ->
  corestepN sem ge n0 c m c' m' ->
  safeN (n + S n0) c m -> safeN n c' m'.
Proof.
intros.
revert c m c' m' n H0 H1.
induction n0; intros; auto.
simpl in H0; inv H0.
eapply safe_downward in H1; eauto. omega.
simpl in H0. destruct H0 as [c2 [m2 [STEP STEPN]]].
apply (IHn0 _ _ _ _ n STEPN).
assert (Heq: (n + S (S n0) = S (n + S n0))%nat) by omega.
rewrite Heq in H1.
eapply safe_corestep_forward in H1; eauto.
Qed.

Lemma safe_corestep_backward c m c' m' n :
  corestep sem ge c m c' m' ->
  safeN (n - 1) c' m' ->
  safeN n c m.
Proof.
simpl; intros.
induction n; simpl; auto.
erewrite corestep_not_halted; eauto.
exists c', m'; split; auto.
assert (Heq: (n = S n - 1)%nat) by omega.
rewrite Heq; auto.
Qed.

Lemma safe_corestepN_backward c m c' m' n n0 :
  corestepN sem ge n0 c m c' m' ->
  safeN (n - n0) c' m' ->
  safeN n c m.
Proof.
simpl; intros.
revert c m c' m' n H H0.
induction n0; intros; auto.
simpl in H; inv H.
solve[assert (Heq: (n = n - 0)%nat) by omega; rewrite Heq; auto].
simpl in H. destruct H as [c2 [m2 [STEP STEPN]]].
assert (H: safeN (n - 1 - n0) c' m').
eapply safe_downward in H0; eauto. omega.
specialize (IHn0 _ _ _ _ (n - 1)%nat STEPN H).
eapply safe_corestep_backward; eauto.
Qed.

End closed_safety.


Fixpoint iter {A} (n : nat) (f : A -> A) (x : A) :=
match n with
| 0 => x
| S n => iter n f (f x)
end.

Goal nat -> True.
Proof.
intros n.
evar (f : nat -> nat).
cut (iter 10 f 0 = 0).
vm_compute.
intros; constructor.
instantiate (f := (fun x => x)).
reflexivity.
Qed.

Goal exists x, x = 5 + 5.
Proof.
  eexists.
  vm_compute.
  reflexivity.
Qed.


Require Forcing.

Section Bool.

Variable Obj : Type.
Variable Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Forcing Translate bool using Obj Hom.

Definition bool_rec : forall P, P -> P -> bool -> P :=
  fun P Ptt Pff b => match b with true => Ptt | false => Pff end.

Forcing Translate bool_rec using Obj Hom.

Definition bool_mem : forall R, bool -> (bool -> R) -> R :=
  fun R b => bool_rec ((bool -> R) -> R) (fun k => k true) (fun k => k false) b.

Forcing Translate bool_mem using Obj Hom.

Forcing Translate eq using Obj Hom.

Definition eta_eq : forall (b : bool), b = b :=
fun b => match b return b = b with true => eq_refl | false => eq_refl end.

Fail Forcing Translate eta_eq using Obj Hom.

Definition bool_rect : forall P,
    P true -> P false -> forall (b : bool), bool_mem _ b P :=
  fun P pt pf b => match b with
                | true => pt
                | false => pf
                end.

Forcing Translate bool_rect using Obj Hom.

End Bool.


(*
  This file contains the main soundness proof allowing
  the reachability logic proof strategy to be used in Coq.

  'reaches x P' holds
  if any execution path from configuration x is either infinite or
  reaches a configuration satisfying P.

  'reaches' is shown to be the greatest fixpoint of the 'step' function.

  'stable_sound' is plain coinduction theorem for 'reaches' and 'step',
  'proved_sound' is the generalized coinduction theorem also allowing
  the "proof" rules defined in 'trans'.
 *)
Set Implicit Arguments.

Section relations.
Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).

Definition Spec : Type := cfg -> (cfg -> Prop) -> Prop.

(* Soundness *)
CoInductive reaches (k : cfg) (P : cfg -> Prop) : Prop :=
  (* reaches : Spec, but defining k and P as parameters
     gives a cleaner definition and induction principle. *)
| rdone : P k -> reaches k P
| rstep : forall k', cstep k k' -> reaches k' P -> reaches k P.

Definition sound (Rules : Spec) : Prop :=
  forall x P, Rules x P -> reaches x P.

Inductive step (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
  (* step : Spec -> Spec *)
| sdone : P k -> step X k P
| sstep : forall k', cstep k k' -> X k' P -> step X k P.

Lemma reaches_stable :
  (forall x P, reaches x P -> step reaches x P).
Proof. destruct 1;econstructor;eassumption. Qed.

CoFixpoint stable_sound (Rules : Spec)
  (Hstable : forall x P, Rules x P -> step Rules x P)
  : sound Rules :=
  fun x P H =>
  match Hstable _ _ H with
    | sdone _ _ _ pf => rdone _ _ pf
    | sstep _ _ Hstep H' =>
        rstep Hstep (stable_sound Hstable _ _ H')
  end.

(*
Inductive derived (X : Spec) k P : Prop :=
| dclaim : X k P -> derived X k P
| ddone : P k -> derived X k P
| dstep : forall k', cstep k k' -> derived X k' P -> derived X k P
| dtrans' : forall Q, derived X k Q -> (forall k', Q k' -> derived X k' P)
    -> derived X k P
| dproved : reaches k P -> derived X k P.
*)

Inductive trans (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
  (* trans : Spec -> Spec *)
  | ddone : P k -> trans X k P
  | dtrans' : forall Q, trans X k Q -> (forall k', Q k' -> trans X k' P) -> trans X k P
  | drule : X k P -> trans X k P
  | dstep : forall k', cstep k k' -> trans X k' P -> trans X k P
  | dvalid : reaches k P -> trans X k P
  .
Definition dtrans_valid (X : Spec) (k : cfg) (P Q : cfg -> Prop)
  (rule : reaches k Q) (rest : forall k', Q k' -> trans X k' P) : trans X k P :=
  @dtrans' X k P Q (dvalid _ rule) rest.
Definition dtrans (X : Spec) (k : cfg) (P Q : cfg -> Prop)
  (rule : X k Q) (rest : forall k', Q k' -> trans X k' P) : trans X k P :=
  @dtrans' X k P Q (drule _ _ _ rule) rest.

Lemma trans_stable (Rules : Spec) :
  (forall x P, Rules x P -> step (trans Rules) x P)
  -> (forall x P, trans Rules x P -> step (trans Rules) x P).
induction 2;eauto using step.
destruct IHtrans; eauto using step, dtrans'.
destruct H0; eauto using step,dvalid.
Qed.

Lemma proved_sound (Rules : Spec) :
  (forall x P, Rules x P -> step (trans Rules) x P)
  -> sound Rules.
unfold sound.
intros H x P R.
eapply stable_sound.
apply trans_stable. eassumption.
apply drule. assumption.
Qed.

End relations.