(* (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.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.Option.
Require Export Parser.List.
Require Export Parser.DescriptionToFunctionSoundness.
Require Export Parser.DescriptionToFunctionCompleteness.

Require Export  Parser.NullableFun.
Require Export Parser.ProductiveFun.
Require Export Parser.FirstFun.
Require Export Parser.ShouldNotFollowFun.
Require Export Parser.CommonRules.

Definition has_conflict_descr: Description (fun A => unit) := {|
  epsilon_descr := fun A a => [];
  failure_descr := fun A => [];
  token_descr := fun k => [];
  map_descr := fun _ _ _ _ _ => [ @id_rule unit ];
  disj_descr := fun _ s1 s2 =>
    left_rule :: right_rule ::
    when (negb (disjoint kind_eq_dec (first_fun s1) (first_fun s2))) [ some_rule tt ] ++
    when (is_some_b (nullable_fun s1) && is_some_b (nullable_fun s2)) [ some_rule tt ];
  seq_descr := fun _ _ s1 s2 =>
    left_rule :: right_rule ::
    when (negb (disjoint kind_eq_dec (should_not_follow_fun s1) (first_fun s2))) [ some_rule tt ];
  var_descr := fun _ _ => [ @id_rule unit ];
|}.


(** * 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.


Require Import Coq.Arith.Arith.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ptsto_bytes.
Require Import coqutil.Decidable.
Require Import coqutil.Word.Properties.
Require Import compiler.ExprImp.
Require Import compiler.NameGen.
Require Import coqutil.Tactics.Simp.
Require Import bedrock2.MetricLogging.
Require Import riscv.Platform.MinimalLogging.
Require Import riscv.Platform.MetricMinimal.
Require Import riscv.Platform.MetricLogging.
Require Import riscv.Utility.Utility.
Require Import riscv.Utility.Encode.
Require Import coqutil.Map.SortedList.
Require Import compiler.ZNameGen.
Require Import riscv.Utility.InstructionCoercions.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import compiler.GoFlatToRiscv.
Require Import compiler.FlatToRiscvCommon.
Require Import compiler.SeparationLogic.
Require Import bedrock2Examples.Demos.
Import Utility.

Section FibCompiled.

  Definition fib_ExprImp nl ns: cmd := Eval cbv in
    snd (snd (Demos.fibonacciServer nl ns)).

  Notation RiscvMachine := MetricRiscvMachine.

  Fixpoint fib (n: nat): Z :=
    match n with
    | O => 0
    | S x =>
      match x with
      | O => 1
      | S y => (fib x + fib y)
      end
    end.

  Definition fib_bounded (n: nat): Z :=
    if (n <? 47)%nat then fib (n + 1) else -1.

  Lemma fib_invert: forall n,
      fib (S (S n)) = fib n + fib (S n).
  Proof.
    induction n.
    - reflexivity.
    - simpl. destruct n.
      + reflexivity.
      + blia.
  Qed.

  Lemma fib_pos: forall n,
      0 <= fib n.
  Proof.
    cut (forall N n, (n < N)%nat -> 0 <= fib n).
    - eauto.
    - induction N.
      + intros. exfalso. apply Nat.nlt_0_r in H. exact H.
      + intros.
        destruct n; [simpl; blia|].
        destruct n; [simpl; blia|].
        rewrite fib_invert.
        generalize (IHN n) (IHN (S n)).
        blia.
  Qed.

  Lemma fib_inc: forall n m,
      (n <= m)%nat ->
      fib n <= fib m.
  Proof.
   induction 1.
   - apply Z.le_refl.
   - apply Z.le_trans with (fib m); [assumption|].
     destruct m.
     + simpl. blia.
     + rewrite fib_invert.
       pose proof (fib_pos m).
       blia.
  Qed.

  Ltac fib_next :=
    match goal with
    | H0: fib ?n0 = ?r0, H1: fib ?n1 = ?r1 |- _ =>
      let Ht := fresh "Ht" in
      let H := fresh "H" in
      assert (n1 = n0 + 1)%nat as Ht by reflexivity; clear Ht;
      assert (fib (S n1) = fib n0 + fib n1) as H by (rewrite fib_invert; reflexivity);
      rewrite H0 in H; rewrite H1 in H;
      match goal with
      | H: fib _ = ?x |- _ =>
        let r := fresh "r" in
        remember x as r;
        match goal with
        | Heqr: ?l = _ + _ |- _ => cbv in Heqr; subst r
        end
      end;
      clear H0
    end.

  Lemma fib_width_limit: forall n,
      (n < 48)%nat ->
      fib n < 2 ^ 32.
  Proof.
    intros.
    assert (fib 0 = 0) by reflexivity.
    assert (fib 1 = 1) by reflexivity.
    do 46 fib_next.
    assert (fib 47 < 2 ^ 32) by (rewrite H2; reflexivity).
    intros.
    induction n.
    - simpl. reflexivity.
    - pose proof (fib_inc (S n) 47%nat) as Hinc.
      apply Nat.lt_le_pred in H.
      simpl in H.
      specialize (Hinc H).
      blia.
  Qed.

  Local Notation instructionsH := (bedrock2.MetricLogging.instructions).

  (*
  Lemma load_word_sep: forall k (m: mem) v R,
      ((ptsto_word k v) * R)%sep m ->
      load access_size.four m k = Some v.
  Proof.
    intros.
    pose proof load_bytes_of_sep as Hload.
    specialize Hload with (1 := H).
    cbv [load load_Z].
    match goal with
    | H: ?y = ?v |- context[?x] =>
      match y with
      | bedrock2.Memory.load_bytes _ _ _ =>
        match x with
        | bedrock2.Memory.load_bytes _ _ _ => change x with y; rewrite H
        end
      end
    end.
    simpl. f_equal.
    rewrite LittleEndian.combine_split.
    change (BinInt.Z.of_nat (Pos.to_nat 4) * 8) with width.
    change width with 32.
    rewrite (Naive._unsigned_in_range v).
    rewrite (Naive.of_Z_unsigned).
    reflexivity.
  Qed.

  Lemma word_add_of_Z: forall width a b c,
      c < 2 ^ width ->
      0 <= a ->
      0 <= b ->
      a + b = c ->
      @word.add width _ (word.of_Z a) (word.of_Z b) = word.of_Z (c).
  Proof.
    intros.
    simpl.
    f_equal.
    repeat (rewrite Z.mod_small; [|blia]).
    assumption.
  Qed.
*)

  Fixpoint get_if s :=
    match s with
    | cmd.seq s1 s2 =>
      match s1 with
      | cmd.cond _ _ _ => s1
      | _ => get_if s2
      end
    | _ => s
    end.

  Definition fib_if ns nl := get_if (fib_ExprImp ns nl).

  Definition fib_while ns nl := Eval cbv in
        match fib_if ns nl with
        | cmd.cond _ w _ => w
        | _ => fib_if ns nl
        end.

  Definition fib_while_body ns nl := Eval cbv in
        match fib_while ns nl with
        | cmd.while _ b => b
        | _ => fib_while ns nl
        end.

  Ltac destruct_hyp :=
    repeat match goal with
           | H : _ /\ _ |- _ => destruct H
           end.

(*
  Ltac eval_fib_var_names :=
    cbv [FibonacciServer.a
           FibonacciServer.b
           Demos.FibonacciServer.c
           Demos.FibonacciServer.i
           Demos.FibonacciServer.n
           Demos.FibonacciServer.ZNames.Inst] in *.

  Ltac known_var :=
    match goal with
    | H: map.get ?l ?a = ?x |- context [?y] =>
      match x with
      | Some ?v =>
        match y with
        | map.get l a =>
          let Hp := fresh "Hp" in
          assert (y = x) as Hp by assumption;
          rewrite Hp; clear Hp
        end
      end
    end.

  Ltac fib_step_precondition :=
    match goal with
    | |- map.get (map.put _ _ _) _ = Some _ =>
      rewrite map.get_put_diff; [assumption|discriminate] || apply map.get_put_same
    | |- _ => assumption || simpl; blia
    end.

  Ltac eval_var_solve :=
    unfold eval_expr;
    eval_fib_var_names;
    repeat known_var;
    reflexivity.

  Ltac exec_set_solve :=
    intros; destruct_hyp;
    eapply @exec.set;
    [
      eval_var_solve |
      try (repeat split; fib_step_precondition)
    ].

  Ltac propogate_eq :=
    repeat match goal with
           | H0: ?x = ?y, H1: ?y = ?z |- _ => rewrite H1 in H0
           end; assumption.

  Lemma fib_correct_body: forall t m (l : locals) mc a b i n (R: mem -> Prop) ns nl,
      R m ->
      map.get l FibonacciServer.a = Some a ->
      map.get l FibonacciServer.b = Some b ->
      map.get l FibonacciServer.i = Some i ->
      map.get l FibonacciServer.n = Some n ->
      exec map.empty (fib_while_body ns nl) t m l mc (fun t' m' l' mc' =>
        t' = t /\
        R m' /\
        map.get l' FibonacciServer.a = Some b /\
        map.get l' FibonacciServer.b = Some (word.add a b) /\
        map.get l' FibonacciServer.i = Some (word.add i (word.of_Z 1)) /\
        map.get l' FibonacciServer.n = Some n /\
        instructionsH mc' - instructionsH mc = 21).
  Proof.
    intros.
    cbv [fib_while_body].
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      R m' /\
      map.get l' FibonacciServer.a = Some a /\
      map.get l' FibonacciServer.b = Some b /\
      map.get l' FibonacciServer.c = Some (word.add a b) /\
      map.get l' FibonacciServer.i = Some i /\
      map.get l' FibonacciServer.n = Some n /\
      instructionsH mc' = instructionsH mc + 5));
      [exec_set_solve|].
    intros.

    eapply @exec.seq with (mid := (fun t' m' (l': locals) mc' =>
      t' = t /\
      R m' /\
      map.get l' (@FibonacciServer.a Basic32Syntax _) = Some b /\
      map.get l' (@FibonacciServer.b Basic32Syntax _)  = Some b /\
      map.get l' (@FibonacciServer.c Basic32Syntax _)  = Some (word.add a b) /\
      map.get l' (@FibonacciServer.i Basic32Syntax _)  = Some i /\
      map.get l' (@FibonacciServer.n Basic32Syntax _)  = Some n /\
      instructionsH mc' = instructionsH mc + 7));
      [exec_set_solve|].
    intros.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      R m' /\
      map.get l' FibonacciServer.a = Some b /\
      map.get l' FibonacciServer.b = Some (word.add a b) /\
      map.get l' FibonacciServer.c = Some (word.add a b) /\
      map.get l' FibonacciServer.i = Some i /\
      map.get l' FibonacciServer.n = Some n /\
      instructionsH mc' = instructionsH mc + 9));
      exec_set_solve.
  Qed.

  Lemma fib_correct_while: forall n (iter : nat) t m (l : locals) mc i (R: mem -> Prop) nl ns,
      Z.of_nat n < 47 ->
      (iter <= n)%nat ->
      (i = n - iter)%nat ->
      R m ->
      map.get l FibonacciServer.a = Some (word.of_Z (fib i)) ->
      map.get l FibonacciServer.b = Some (word.of_Z (fib (S i))) ->
      map.get l FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) ->
      map.get l FibonacciServer.i = Some (word.of_Z (Z.of_nat i) : word) ->
      exec map.empty (fib_while nl ns) t m l mc (fun t' m' l' mc' =>
        t' = t /\
        R m' /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat iter) * 34 + 12 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (fib (n + 1)))).
  Proof.
    induction iter.
    - intros.
      eapply @exec.while_false.
      + eval_var_solve.
      + simpl. destruct_one_match.
        * rewrite H1 in E. rewrite Nat.sub_0_r in E.
          apply Z.lt_irrefl in E.
          exfalso. assumption.
        * reflexivity.
      + repeat split.
        * assumption.
        * simpl. blia.
        * replace n with i by blia.
          rewrite Nat.add_1_r.
          etransitivity; [ eassumption | reflexivity ].
    - intros.
      eapply @exec.while_true.
      + eval_var_solve.
      + simpl. destruct_one_match.
        * simpl. rewrite Zdiv.Zmod_1_l; [discriminate | cbv; reflexivity].
        * repeat match goal with
                 | H: context[_ mod _] |- _ => rewrite Z.mod_small in H; [|blia]
                 end.
          blia.
      + eapply fib_correct_body with (nl := nl) (ns := ns); eauto.
      + intros.
        eval_fib_var_names.
        destruct_hyp.
        eapply weaken_exec.
        * eapply IHiter with (nl := nl) (ns := ns); try (reflexivity || eassumption).
          -- blia.
          -- etransitivity; [eassumption|].
             f_equal. f_equal. f_equal. blia.
          -- etransitivity; [eassumption|].
             f_equal. replace (S i) with (n - iter)%nat by blia. rewrite H1.
             assert (n - iter > 0)%nat by blia.
             pose proof fib_invert as Hfib.
             specialize Hfib with (n := (n - S iter)%nat).
             apply word_add_of_Z; try apply fib_pos.
             ++ change Semantics.width with 32.
                apply fib_width_limit.
                blia.
             ++ replace (S (n - S iter))%nat with (n - iter)%nat in Hfib; [|blia].
                symmetry. apply Hfib.
          -- etransitivity; [eassumption|].
             f_equal. rewrite H1.
             simpl. f_equal.
             rewrite Z.mod_small; [|blia].
             rewrite Z.mod_small; [|blia].
             blia.
        * cbv beta. intros. destruct_hyp.
          repeat split.
          -- propogate_eq.
          -- assumption.
          -- unfold_MetricLog. simpl in *. blia.
          -- assumption.
  Qed.

  Lemma fib_if_true_correct: forall (n: nat) t m (l: locals) mc (R: mem -> Prop) nl ns,
      (n < 47)%nat ->
      R m ->
      map.get l FibonacciServer.a = Some (word.of_Z 0) ->
      map.get l FibonacciServer.b = Some (word.of_Z 1) ->
      map.get l FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) ->
      map.get l FibonacciServer.i = Some (word.of_Z 0)  ->
      exec map.empty (fib_if nl ns) t m l mc (fun t' m' l' mc' =>
        R m' /\
        t' = t /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 25 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (fib (n + 1)))).
  Proof.
    intros.
    eapply @exec.if_true.
    - eval_var_solve.
    - simpl.
      destruct_one_match; [discriminate|].
      repeat rewrite Z.mod_small in * by blia.
      exfalso. blia.
    - eapply weaken_exec.
      + destruct_hyp.
        eapply fib_correct_while with (iter := n) (i := 0%nat) (nl := nl) (ns := ns); try eassumption.
        * blia.
        * apply le_n.
        * rewrite Nat.sub_diag. reflexivity.
      + intros. cbv beta in *. destruct_hyp.
        repeat split; try assumption.
        unfold_MetricLog. simpl in *. blia.
  Qed.

  Lemma fib_if_false_correct: forall (n: nat) t m (l: locals) mc (R: mem -> Prop) nl ns,
      Z.of_nat n < 2 ^ 32 ->
      (n >= 47)%nat ->
      R m ->
      map.get l FibonacciServer.a = Some (word.of_Z 0) ->
      map.get l FibonacciServer.b = Some (word.of_Z 1) ->
      map.get l FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) ->
      map.get l FibonacciServer.i = Some (word.of_Z 0)  ->
      exec map.empty (fib_if nl ns) t m l mc (fun t' m' l' mc' =>
        t' = t /\
        R m' /\
        instructionsH mc' <= instructionsH mc + 22 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (-1))).
  Proof.
    intros.
    eapply @exec.if_false.
    + eval_var_solve.
    + simpl.
      destruct_one_match; [|reflexivity].
      repeat rewrite Z.mod_small in * by blia.
      exfalso. blia.
    + exec_set_solve.
  Qed.

  Lemma fib_correct: forall (n: nat) t (m: mem) (l : locals) mc v nl ns,
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m ->
      Z.of_nat n < 2 ^ 32 ->
      exec map.empty (fib_ExprImp nl ns) t m l mc (fun t' m' l' mc' =>
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 72 /\
        (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
         ptsto_word (word.of_Z ns) (word.of_Z (fib_bounded n)))%sep m').
  Proof.
    intros *. intro Hsep. intros.
    unfold fib_ExprImp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 10)).
    1: { eapply @exec.set.
         + simpl in *.
           pose proof load_word_sep as Hload.
           specialize Hload with (1 := Hsep).
           match goal with
           | H: ?x = ?r |- context[?y] =>
             match x with
             | load ?a ?m ?v =>
               match y with
               | load a m v => change y with x; rewrite H
               end
             end
           end.
           reflexivity.
         + repeat split; fib_step_precondition. }
    intros. destruct_hyp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.a = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 19));
      [exec_set_solve|].
    intros. destruct_hyp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.a = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.b = Some (word.of_Z 1) /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 28));
      [exec_set_solve|].
    intros. destruct_hyp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.a = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.b = Some (word.of_Z 1) /\
      map.get l' FibonacciServer.i = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 37));
      [exec_set_solve|].
    intros.
    destruct_hyp.
    unfold fib_bounded.
    destruct (n <? 47)%nat eqn:Hlt.
    - rewrite Nat.ltb_lt in *.
      eapply @exec.seq with (mid := (fun t' m' l' mc' =>
        t' = t /\
        (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
         ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 62 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (fib (n + 1))))).
        * eapply weaken_exec; [eapply fib_if_true_correct with (nl := nl) (ns := ns); eassumption|].
          cbv beta. intros. destruct_hyp.
          repeat split; try assumption.
          -- propogate_eq.
          -- blia.
        * intros. destruct_hyp.
          eapply @exec.store.
          -- reflexivity.
          -- eval_var_solve.
          -- pose proof load_word_sep as Hsepload.
             apply sep_comm in H23.
             specialize Hsepload with (1 := H23).
             cbv [store store_Z bedrock2.Memory.store_bytes].
             cbv [load load_Z] in Hsepload.
             destruct_one_match; [reflexivity|].
             match goal with
             | H0: ?x = ?v, H1: context[?y] |- _ =>
               match x with
               | bedrock2.Memory.load_bytes _ _ _ =>
                 match y with
                 | bedrock2.Memory.load_bytes _ _ _ => change y with x in H1; rewrite H0 in H1
                 end
               end
             end.
             discriminate.
          -- repeat split.
             ++ unfold_MetricLog. simpl in *. blia.
             ++ apply sep_comm in H23.
                pose proof unchecked_store_bytes_of_sep as HStore.
                specialize HStore with (1 := H23).
                match goal with
                | |- context[?x] =>
                  match x with
                  | LittleEndian.split _ _ => specialize HStore with (bs := x)
                  end
                end.
                wcancel_assumption.
    - rewrite Nat.ltb_ge in *.
      eapply @exec.seq with (mid := (fun t' m' l' mc' =>
        t' = t /\
        (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
         ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 62 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (-1)))).
      * eapply weaken_exec; [eapply fib_if_false_correct with (nl := nl) (ns := ns); eassumption|].
          cbv beta. intros. destruct_hyp.
          repeat split; try assumption.
          -- propogate_eq.
          -- blia.
        * intros. destruct_hyp.
          eapply @exec.store.
          -- reflexivity.
          -- eval_var_solve.
          -- pose proof load_word_sep as Hsepload.
             apply sep_comm in H23.
             specialize Hsepload with (1 := H23).
             cbv [store store_Z bedrock2.Memory.store_bytes].
             cbv [load load_Z] in Hsepload.
             destruct_one_match; [reflexivity|].
             match goal with
             | H0: ?x = ?v, H1: context[?y] |- _ =>
               match x with
               | bedrock2.Memory.load_bytes _ _ _ =>
                 match y with
                 | bedrock2.Memory.load_bytes _ _ _ => change y with x in H1; rewrite H0 in H1
                 end
               end
             end.
             discriminate.
          -- repeat split.
             ++ unfold_MetricLog. simpl in *. blia.
             ++ apply sep_comm in H23.
                pose proof unchecked_store_bytes_of_sep as HStore.
                specialize HStore with (1 := H23).
                match goal with
                | |- context[?x] =>
                  match x with
                  | LittleEndian.split _ _ => specialize HStore with (bs := x)
                  end
                end.
                wcancel_assumption.
  Qed.

  Definition run1 : Pipeline.M unit := @run1 _ _ _ _ Pipeline.RVM _ iset.
  Definition mcomp_sat := GoFlatToRiscv.mcomp_sat.

  Lemma fib_compiled: forall n (initialMachine: RiscvMachine) insts v nl ns R,
      0 <= n < 2 ^ 32 ->
      word.unsigned (getPc initialMachine) mod 4 = 0 ->
      getNextPc initialMachine = word.add (getPc initialMachine) (word.of_Z 4) ->
      insts = (ExprImp2Riscv (fib_ExprImp nl ns)) ->
      subset (footpr (program (getPc initialMachine) insts))
             (of_list initialMachine.(getXAddrs)) ->
      (program (getPc initialMachine) insts * R *
       (ptsto_word (word.of_Z ns) (word.of_Z v) *
        ptsto_word (word.of_Z nl) (word.of_Z n)))%sep initialMachine.(getMem) ->
      runsToNonDet.runsTo (mcomp_sat run1) initialMachine
        (fun (finalL: RiscvMachine) =>
           (program (getPc initialMachine) insts * R *
            (ptsto_word (word.of_Z ns) (word.of_Z (fib_bounded (Z.to_nat n))) *
             ptsto_word (word.of_Z nl) (word.of_Z n)))%sep finalL.(getMem) /\
           getPc finalL = add (getPc initialMachine) (mul (ZToReg 4) (ZToReg (Zlength insts))) /\
           getNextPc finalL = add (getPc finalL) (ZToReg 4) /\
           finalL.(getMetrics).(instructions) - initialMachine.(getMetrics).(instructions) <= n * 34 + 72).
  Proof.
    intros. subst.
    destruct H.

    rewrite <- sep_inline_eq in H4.
    destruct H4 as [initialMem Hsep]. destruct Hsep.

    eapply runsToNonDet.runsTo_weaken.
    - pose proof Pipeline.exprImp2Riscv_correct as Hp.
      specialize Hp with (sH := fib_ExprImp nl ns)
                         (mcH := bedrock2.MetricLogging.EmptyMetricLog).
      eapply Hp.
      + clear. intros. exact H.
      + simpl. blia.
      + cbv. intuition congruence.
      + reflexivity.
      + assumption.
      + assumption.
      + reflexivity.
      + assumption.
      + instantiate (2 := initialMem). instantiate (1 := R). seplog.
      + constructor.
      + eapply ExprImp.weaken_exec.
        * eapply fib_correct with (n := Z.to_nat n).
          -- rewrite Z2Nat.id; [|assumption]. instantiate (1 := v). wcancel_assumption.
          -- rewrite Z2Nat.id; assumption.
        * intros. eassumption.
    - intros.
      do 3 destruct H6.
      destruct_hyp.
      rewrite Z2Nat.id in *; try assumption.
      repeat split.
      + apply sep_inline_eq.
        eexists.
        split.
        * seplog.
        * wcancel_assumption.
      + assumption.
      + assumption.
      + repeat unfold_MetricLog. repeat simpl_MetricLog. simpl in *.
        destruct_hyp.
        eapply Z.le_trans.
        * eassumption.
        * blia.
  Qed.
  (*
  Print Assumptions fib_compiled.
  *)
*)

End FibCompiled.


From Coq Require Import
     ssreflect
     String
.

From ExtensibleCompiler.Passes Require Import
     RemoveUnaryIfs
.

From ExtensibleCompiler.Semantics.All Require Import
     Bool
     If1
     If2
     Lambda
     Unit
.

From ExtensibleCompiler.Syntax.Terms Require Import
     Bool
     If1
     If2
     Stuck
     Unit
.

From ExtensibleCompiler.Syntax.Types Require Import
     BoolType
     UnitType
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Environment
     Eval
     Functor
     IndexedAlgebra
     IndexedFunctor
     IndexedSum1
     ProgramAlgebra
     ProofAlgebra
     SubFunctor
     Sum1
     Types
     TypeSoundness
     UniversalProperty
.

Local Open Scope Sum1.
Local Open Scope SubFunctor.

(* Create a type language [T] *)
Definition T := (BoolType + UnitType).

(* Create an expression language [E] *)
Definition E := (Bool + If2 + Unit).

(* Create a value language [V] *)
Definition V := (Bool + Stuck + Unit).

(*
Create a concrete representation for the result of type-checking, so that it is
easy to inspect manually
 *)
Inductive Result :=
| BoolValue (b : bool)
| UnitValue
| EvalFailed
.

Variant ForComputeResult := .

(* Algebra to turn the extensible results into concrete results *)
Global Instance computeResult
  : forall R, ProgramAlgebra ForComputeResult V R Result
  := fun _ =>
       {|
         programAlgebra :=
           fun rec =>
             (fun   '(MkBool b) => BoolValue b)
             || (fun 'Stuck      => EvalFailed)
             || (fun 'Unit       => UnitValue)
         ;
       |}.

Definition eval'
           (e : WellFormedValue E)
  : Result
  := foldProgramAlgebra
       (Alg := computeResult)
       (proj1_sig (eval (L := E) (V := V) (proj1_sig e) (empty _))).

Theorem regression__unit : eval' unit = UnitValue.
Proof. reflexivity. Qed.

Theorem regression__true : eval' (boolean true) = BoolValue true.
Proof. reflexivity. Qed.

Theorem regression__false : eval' (boolean false) = BoolValue false.
Proof. reflexivity. Qed.

Theorem regression__if2True
  : eval' (if2 (boolean true) (boolean true) (boolean false)) = BoolValue true.
Proof. reflexivity. Qed.

Theorem regression__if2False
  : eval' (if2 (boolean false) (boolean true) (boolean false)) = BoolValue false.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedCondition
  : eval' (if2 unit (boolean true) (boolean false)) = EvalFailed.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedBranchStillWorksLeft
  : eval' (if2 (boolean true) (boolean true) unit) = BoolValue true.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedBranchStillWorksRight
  : eval' (if2 (boolean false) unit (boolean false)) = BoolValue false.
Proof. reflexivity. Qed.

(*
Let's make sure that we can instantiate the statement of type soundness through
evaluation.
 *)

Definition WellTyped__E
  : (TypedExpr T V)-indexedPropFunctor
  := (WellTypedValue__Bool).

(* Definition SourceExpr := Bool + If1 + Unit. *)
(* Definition TargetExpr := Bool + If2 + Unit. *)
(* Definition Value := Bool + Stuck + Unit. *)

(* Definition EvalRelation__Source *)
(*   : (WellFormedValue SourceExpr * WellFormedValue Value)-indexedPropFunctor *)
(*   := (EvalRelation__Bool + EvalRelation__If1 + EvalRelation__Unit)%IndexedSum1. *)

(* Definition EvalRelation__Target *)
(*   : (WellFormedValue TargetExpr * WellFormedValue Value)-indexedPropFunctor *)
(*   := (EvalRelation__Bool + EvalRelation__If2 + EvalRelation__Unit)%IndexedSum1. *)

(* Definition removeUnaryIfs' *)
(*            (e : WellFormedValue SourceExpr) *)
(*   : WellFormedValue TargetExpr *)
(*   := removeUnaryIfs (L := SourceExpr) (V := TargetExpr) (proj1_sig e). *)

(* Theorem test *)
(*   : removeUnaryIfs' (if1 (boolean true) unit) = if2 (boolean true) unit unit. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

Variant ForRemoveUnaryIfsCorrectness := .

Declare Scope Prod1.
Delimit Scope Prod1 with Prod1.
Open Scope Prod1.

Variant Prod1 (F G : Set -> Set) (A : Set) : Set :=
| prod1 : F A -> G A -> (F * G)%Sum1 A
where
"F * G" := (Prod1 F G) : Prod1.

Arguments prod1 {F G A}.

Global Instance Functor__Prod1
       {F G} `{Functor F} `{Functor G}
  : Functor (F * G).
Proof.
  refine
    {|
      fmap := fun A B f '(prod1 fa ga) => prod1 (fmap f fa) (fmap f ga);
    |}.
  {
    move => A [] f g /=.
    do 2 rewrite fmapId //.
  }
  {
    move => A B C f g [] fa ga /=.
    do 2 rewrite fmapFusion //.
  }
Defined.

(*
NOTE:

I was trying to do a [WellFormedProofAlgebra2], that took a (Source * Value)
pair and rebuilt it, but you end up wanting a product functor, and then you'd
end up with [A <= A * B] constraints, which might not be true or not be worth it.

It seems like it might be better to do a [WellFormedProofAlgebra] where you only
change one of the two elements ofthe pair at the time, kind of like if you do
induction one variable at a time rather than induction on the pair.

Probably want to do induction on the source term, with the value universally
quantified in the output.
 *)

Section Correctness.

  Context
    {S T V}
    `{Functor S} `{Functor T} `{Functor V}
    (EvalRelation__Source : (Fix S * Fix V)-indexedPropFunctor)
    (EvalRelation__Target : (Fix T * Fix V)-indexedPropFunctor)
  .

  Definition AbstractCorrectnessStatement
             `{removeUnaryIfs__S : forall {R}, MixinAlgebra S R (WellFormedValue T)}
             (recRemoveUnaryIfs : WellFormedValue S -> WellFormedValue T)
             (s : Fix S)
             (UP'__s : FoldUP' s)
    : Prop
    := forall (v : Fix V),
      IndexedFix EvalRelation__Source (s, v) ->
      IndexedFix EvalRelation__Target
                 ( proj1_sig (removeUnaryIfs__S recRemoveUnaryIfs (unwrapUP' s)),
                   v
                 ).

  Definition Correctness__ProofAlgebra
             `{RemoveUnaryIfs__S : forall {R}, ProgramAlgebra ForRemoveUnaryIfs S R (WellFormedValue T)}
    := forall recRemoveUnaryIfs,
      ProofAlgebra ForRemoveUnaryIfsCorrectness
                   S
                   (sig (UniversalPropertyP
                           (AbstractCorrectnessStatement
                              (removeUnaryIfs__S := fun _ => programAlgebra)
                              recRemoveUnaryIfs
                           )
                   )).

  Lemma Correctness
        `{RemoveUnaryIfs__S : forall R, ProgramAlgebra ForRemoveUnaryIfs S R (WellFormedValue T)}
        `{! WellFormedMendlerProgramAlgebra RemoveUnaryIfs__S}
        (PA : Correctness__ProofAlgebra)
        `{! forall rec, WellFormedProofAlgebra (PA rec)}
    : forall (s : Fix S)
        (v : Fix V),
      FoldUP' s ->
      IndexedFix EvalRelation__Source (s, v) ->
      IndexedFix EvalRelation__Target (proj1_sig (removeUnaryIfs s), v).
  Proof.
    move => s v UP'__s E__S.
    rewrite <- (wrapUP'_unwrapUP' s) => //.
    rewrite /= / removeUnaryIfs / mendlerFold / wrapF.
    rewrite wellFormedMendlerProgramAlgebra.
    case (Induction
            (PA := PA (fun s => removeUnaryIfs (proj1_sig s))) s _
         ) => [? C].
    apply C => //.
  Qed.

End Correctness.

(* Let's instantiate it *)

Definition SourceExpr := Bool + If1   + Unit.
Definition TargetExpr := Bool + If2   + Unit.
Definition Value      := Bool + Stuck + Unit.

Definition EvalRelation__Source
  : (Fix SourceExpr * Fix Value)-indexedPropFunctor
  := (EvalRelation__Bool + EvalRelation__If1 + EvalRelation__Unit)%IndexedSum1.

Definition EvalRelation__Target
  : (Fix TargetExpr * Fix Value)-indexedPropFunctor
  := (EvalRelation__Bool + EvalRelation__If2 + EvalRelation__Unit)%IndexedSum1.

Definition S' := If1.
Definition T' := BoolType.
Definition V' := If2.

(* Definition CorrectnessInstantiation *)
(*   := Correctness *)