(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype finfun finset.
Require Import groups.

(*****************************************************************************)
(* This file contains the definitions of:                                    *)
(*                                                                           *)
(*   {morphism A >-> gT} == the type of morphisms from domain set A of       *)
(*                          elements of a groupType, to groupType gT         *)
(*                                                                           *)
(* if p is a morphism of domain A:                                           *)
(*   'dom p                     == A                                         *)
(*   p @* B                     == the image of B, where defined             *)
(*                              := p @: (A :&: B)                            *)
(*   p @*^-1 C                  == the pre-image of C, where defined         *)
(*                              :=  A :&: p @^-1: B                          *)
(*   'ker p                     == the kernel of p                           *)
(*                              :=  p @^-1: 1                                *)
(*   'ker_H p                   ==  (p @^-1: 1), intersected with H          *)
(*   'injm p                    <=> p injective                              *)
(*                              <-> ker p \subset 1)                         *)
(*   invm p (H :'injm f)        == the inverse morphism for an injective p   *)
(*   idm B                      == the identity morphism on B                *)
(*   restrm p (H : A \subset B) == the morphism that coincides with p on its *)
(*                                 domain A                                  *)
(*   trivm B                    == the trivial morphism on B                 *)
(*                                                                           *)
(* if, moreover, q is a morphism of domain B:                                *)
(*   factm (H1 : A \subset B) (H2 : 'ker q \subset 'ker p) == the natural    *)
(*                                  surjection between the ranges of q and p *)
(*                                                                           *)
(* for any function f between groupTypes :                                   *)
(*   morphic A f              <=> forall x,y in A, f(x * y) = (f x) * (f y)  *)
(*   isom A B f               <=> f @: A^# = B^#                             *)
(*   misom A B f              <=> morphic A f && isom A B f                  *)
(*   A \isog B                <=> exists f, misom A B f                      *)
(*   morphm (H : morphic B f) == f with a canonical structure of morphism    *)
(*                               with domain B                               *)
(*****************************************************************************)

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

Import GroupScope.

Reserved Notation "x \isog y" (at level 70).

Section MorphismStructure.

Variables aT rT : finGroupType.

Structure morphism (A : {set aT}) : Type := Morphism {
  mfun :> aT -> FinGroup.sort rT;
  _ : {in A &, {morph mfun : x y / x * y}}
}.

(* We give the most 'lightweight' possible specification to define morphisms:*)
(* local congruence with the group law of aT. We then provide the properties *)
(* for the 'textbook' notion of morphism, when the required structures are   *)
(* available (e.g. its domain is a group).                                   *)

Definition morphism_for A of phant rT := morphism A.

Definition clone_morphism A f :=
  let: Morphism _ fM := f
    return {type of @Morphism A for f} -> morphism_for A (Phant rT)
  in fun k => k fM.

Variables (A B : {set aT}) (C : {set rT}) (x : aT) (y : rT) (f : aT -> rT).

CoInductive morphim_spec : Prop := MorphimSpec z & z \in A & z \in B & y = f z.

Lemma morphimP : reflect morphim_spec (y \in f @: (A :&: B)).
Proof.
apply: (iffP imsetP) => [] [z]; first by case/setIP; exists z.
by exists z; first apply/setIP.
Qed.

Lemma morphpreP : reflect (x \in A /\ f x \in C) (x \in A :&: f @^-1: C).
Proof. rewrite !inE; exact: andP. Qed.

End MorphismStructure.

Notation "{ 'morphism' A >-> T }" := (morphism_for A (Phant T))
  (at level 0, format "{ 'morphism'  A  >->  T }") : group_scope.
Notation "[ 'morphism' A 'of' f ]" :=
     (@clone_morphism _ _ A _ (fun fM => @Morphism _ _ A f fM))
   (at level 0, format "[ 'morphism'  A  'of'  f ]") : form_scope.
Notation "[ 'morphism' 'of' f ]" := (clone_morphism (@Morphism _ _ _ f))
   (at level 0, format "[ 'morphism'  'of'  f ]") : form_scope.

Implicit Arguments morphimP [aT rT A B f y].
Implicit Arguments morphpreP [aT rT A C f x].
Prenex Implicits morphimP morphpreP.

(* domain, image, preimage, kernel, using phantom types to infer the domain *)

Section MorphismOps1.

Variables (aT rT : finGroupType) (A : {set aT}) (f : {morphism A >-> rT}).

Lemma morphM : {in A &, {morph f : x y / x * y}}.
Proof. by case f. Qed.

Notation morPhantom := (phantom (aT -> rT)).
Definition MorPhantom := Phantom (aT -> rT).

Definition dom of morPhantom f := A.

Definition morphim of morPhantom f := fun B => f @: (A :&: B).

Definition morphpre of morPhantom f := fun C : {set rT} => A :&: f @^-1: C.

Definition ker mph := morphpre mph 1.

End MorphismOps1.

Notation "''dom' f" := (dom (MorPhantom f))
  (at level 10, f at level 8, format "''dom'  f") : group_scope.

Notation "''ker' f" := (ker (MorPhantom f))
  (at level 10, f at level 8, format "''ker'  f") : group_scope.

Notation "''ker_' H f" := (H :&: 'ker f)
  (at level 10, H at level 2, f at level 8, format "''ker_' H  f")
  : group_scope.

Notation "f @* H" := (morphim (MorPhantom f) H)
  (at level 24, format "f  @*  H") : group_scope.

Notation "f @*^-1 L" := (morphpre (MorPhantom f) L)
  (at level 24, format "f  @*^-1  L") : group_scope.

Notation "''injm' f" := (pred_of_set ('ker f) \subset pred_of_set 1)
  (at level 10, f at level 8, format "''injm'  f") : group_scope.

Section MorphismTheory.

Variables aT rT : finGroupType.
Implicit Types A B : {set aT}.
Implicit Types G H K : {group aT}.
Implicit Types C D : {set rT}.
Implicit Types L M : {group rT}.

Variables (G : {group aT}) (f : {morphism G >-> rT}).

(* the usual properties occur when the domain is a group. *)

Lemma morph1 : f 1 = 1.
Proof. by apply: (mulgI (f 1)); rewrite -morphM ?mulg1. Qed.

Lemma morphV : {in G, {morph f : x / x^-1}}.
Proof.
move=> x Gx; apply: (mulgI (f x)).
by rewrite -morphM ?groupV // !mulgV morph1.
Qed.

Lemma morphJ : {in G &, {morph f : x y / x ^ y}}.
Proof. by move=> * /=; rewrite !morphM ?morphV // ?groupM ?groupV. Qed.

Lemma morphX : forall n, {in G, {morph f : x / x ^+ n}}.
Proof.
by elim=> [|n IHn] x Dx; rewrite ?morph1 // !expgS morphM ?(groupX, IHn).
Qed.

Lemma morphR : {in G &, {morph f : x y / [~ x, y]}}.
Proof. by move=> * /=; rewrite morphM ?(groupV, groupJ) // morphJ ?morphV. Qed.

(* morphic image,preimage properties w.r.t. set-theoretic operations *)

Lemma morphimE : forall A, f @* A = f @: (G :&: A). Proof. by []. Qed.
Lemma morphpreE : forall C, f @*^-1 C = G :&: f @^-1: C. Proof. by []. Qed.
Lemma kerE : 'ker f = f @*^-1 1. Proof. by []. Qed.

Lemma morphimEsub : forall A, A \subset G -> f @* A = f @: A.
Proof. by move=> A sAG; rewrite /morphim (setIidPr sAG). Qed.

Lemma morphimEdom : f @* G = f @: G.
Proof. exact: morphimEsub. Qed.

Lemma morphimIdom : forall A, f @* (G :&: A) = f @* A.
Proof. by move=> A; rewrite /morphim setIA setIid. Qed.

Lemma morphpreIdom : forall C, G :&: f @*^-1 C = f @*^-1 C.
Proof. by move=> A; rewrite /morphim setIA setIid. Qed.

Lemma morphpreIim : forall C, f @*^-1 (f @* G :&: C) = f @*^-1 C.
Proof.
move=> C; apply/setP=> x; rewrite morphimEdom !inE.
by case Gx: (x \in G); rewrite // mem_imset.
Qed.

Lemma morphimIim : forall A, f @* G :&: f @* A = f @* A.
Proof. by move=> A; apply/setIidPr; rewrite imsetS // setIid subsetIl. Qed.

Lemma mem_morphim : forall A x, x \in G -> x \in A -> f x \in f @* A.
Proof. by move=> A x Gx Ax; apply/morphimP; exists x. Qed.

Lemma mem_morphpre : forall C x, x \in G -> f x \in C -> x \in f @*^-1 C.
Proof. by move=> C x Gx Cfx; exact/morphpreP. Qed.

Lemma morphimS : forall A B, A \subset B -> f @* A \subset f @* B.
Proof. by move=> A B sAB; rewrite imsetS ?setIS. Qed.

Lemma morphim_sub : forall A, f @* A \subset f @* G.
Proof. by move=> A; rewrite imsetS // setIid subsetIl. Qed.

Lemma morphpreS : forall C D, C \subset D -> f @*^-1 C \subset f @*^-1 D.
Proof. by move=> C D sCD; rewrite setIS ?preimsetS. Qed.

Lemma morphim0 : f @* set0 = set0.
Proof. by rewrite morphimE setI0 imset0. Qed.

Lemma morphim_set1 : forall x, x \in G -> f @* [set x] = [set f x].
Proof.
move=> x; rewrite /morphim -sub1set; move/setIidPr->; exact: imset_set1.
Qed.

Lemma morphim1 : f @* 1 = 1.
Proof. by rewrite morphim_set1 ?morph1. Qed.

Lemma morphimV : forall A, f @* A^-1 = (f @* A)^-1.
Proof.
have subV: forall A, f @* A^-1 \subset (f @* A)^-1.
  move=> A; apply/subsetP=> y; case/morphimP=> x Gx; rewrite !inE => Ax' ->{y}.
  by rewrite -morphV // mem_imset // inE groupV Gx.
by move=> A; apply/eqP; rewrite eqEsubset subV -invSg invgK -{1}(invgK A) subV.
Qed.

Lemma morphpreV : forall C, f @*^-1 C^-1 = (f @*^-1 C)^-1.
Proof.
move=> C; apply/setP=> x; rewrite !inE groupV; case Gx: (x \in G) => //=.
by rewrite morphV.
Qed.

Lemma morphimMl : forall A B, A \subset G -> f @* (A * B) = f @* A * f @* B.
Proof.
move=> A B sAG; rewrite /morphim setIC -group_modl // (setIidPr sAG).
apply/setP=> fxy; apply/idP/idP.
  case/imsetP=> xy; case/imset2P=> x y Ax; case/setIP=> Gy By -> -> {fxy xy}.
  by rewrite morphM // (subsetP sAG, mem_imset2) // mem_imset // inE By.
case/imset2P=> fx fy; case/imsetP=> x Ax -> {fx}.
case/morphimP=> y Gy By -> {fy} ->{fxy}.
by rewrite -morphM // (subsetP sAG, mem_imset) // mem_mulg // inE By.
Qed.

Lemma morphimMr : forall A B, B \subset G -> f @* (A * B) = f @* A * f @* B.
Proof.
move=> A B sBG; apply: invg_inj.
by rewrite invMg -!morphimV invMg morphimMl // -invGid invSg.
Qed.

Lemma morphpreMl : forall C D,
  C \subset f @* G -> f @*^-1 (C * D) = f @*^-1 C * f @*^-1 D.
Proof.
move=> C D sCfG; apply/setP=> x; rewrite !inE.
apply/andP/imset2P=> [[Gx] | [y z]]; last first.
  rewrite !inE; case/andP=> Gy Cfy; case/andP=> Gz Cfz ->.
  by rewrite ?(groupM, morphM, mem_imset2).
case/imset2P=> fy fz Cfy Cfz def_fx.
case/morphimP: (subsetP sCfG fy Cfy) => y Gy _ def_fy.
exists y (y^-1 * x); last by rewrite mulKVg.
  by rewrite !inE Gy -def_fy.
by rewrite !inE groupM ?(morphM, morphV, groupV) // def_fx -def_fy mulKg.
Qed.

Lemma morphimJ : forall A x, x \in G -> f @* (A :^ x) = f @* A :^ f x.
Proof.
move=> A x Gx; rewrite !conjsgE morphimMl ?(morphimMr, sub1set, groupV) //.
by rewrite !(morphim_set1, groupV, morphV).
Qed.

Lemma morphpreJ : forall C x, x \in G -> f @*^-1 (C :^ f x) = f @*^-1 C :^ x.
Proof.
move=> C x Gx; apply/setP=> y; rewrite conjIg !inE conjGid // !mem_conjg inE.
by case Gy: (y \in G); rewrite // morphJ ?(morphV, groupV).
Qed.

Lemma morphimU : forall A B, f @* (A :|: B) = f @* A :|: f @* B.
Proof. by move=> A B; rewrite -imsetU -setIUr. Qed.

Lemma morphimI : forall A B, f @* (A :&: B) \subset f @* A :&: f @* B.
Proof. by move=> A B; rewrite subsetI // ?morphimS ?(subsetIl, subsetIr). Qed.

Lemma morphpre0 : f @*^-1 set0 = set0.
Proof. by rewrite morphpreE preimset0 setI0. Qed.

Lemma morphpreT : f @*^-1 setT = G.
Proof. by rewrite morphpreE preimsetT setIT. Qed.

Lemma morphpreU : forall C D, f @*^-1 (C :|: D) = f @*^-1 C :|: f @*^-1 D.
Proof. by move=> C D; rewrite -setIUr -preimsetU. Qed.

Lemma morphpreI : forall C D, f @*^-1 (C :&: D) = f @*^-1 C :&: f @*^-1 D.
Proof. by move=> C D; rewrite -setIIr -preimsetI. Qed.

Lemma morphpreD : forall C D, f @*^-1 (C :\: D) = f @*^-1 C :\: f @*^-1 D.
Proof. by move=> C D; apply/setP=> x; rewrite !inE; case: (x \in G). Qed.

(* kernel, domain properties *)

Lemma kerP : forall x, x \in G -> reflect (f x = 1) (x \in 'ker f).
Proof. move=> x Gx; rewrite 2!inE Gx; exact: set1P. Qed.

Lemma dom_ker : {subset 'ker f <= G}.
Proof. by move=> x; case/morphpreP. Qed.

Lemma mker : forall x, x \in 'ker f -> f x = 1.
Proof. by move=> x Kx; apply/kerP=> //; exact: dom_ker. Qed.

Lemma mkerl : forall x y, x \in 'ker f -> y \in G -> f (x * y) = f y.
Proof. by move=> x y Kx Gy; rewrite morphM // ?(dom_ker, mker Kx, mul1g). Qed.

Lemma mkerr : forall x y, x \in G -> y \in 'ker f -> f (x * y) = f x.
Proof. by move=> x y Gx Ky; rewrite morphM // ?(dom_ker, mker Ky, mulg1). Qed.

Lemma rcoset_kerP : forall x y,
  x \in G -> y \in G -> reflect (f x = f y) (x \in 'ker f :* y).
Proof.
move=> x y Gx Gy; rewrite mem_rcoset !inE groupM ?morphM ?groupV //=.
rewrite morphV // -eq_mulgV1; exact: eqP.
Qed.

Lemma ker_rcoset : forall x y,
  x \in G -> y \in G -> f x = f y -> exists2 z, z \in 'ker f & x = z * y.
Proof. move=> x y Gx Gy eqfxy; apply/rcosetP; exact/rcoset_kerP. Qed.

Lemma ker_norm : G \subset 'N('ker f).
Proof.
apply/subsetP=> x Gx; rewrite inE; apply/subsetP=> yx.
case/imsetP=> y Ky -> {yx}.
by rewrite !inE groupJ ?morphJ // ?dom_ker //= mker ?conj1g.
Qed.

Lemma ker_normal : 'ker f <| G.
Proof. by rewrite /(_ <| G) subsetIl ker_norm. Qed.

Lemma morphimGI : forall H A,
  'ker f \subset H -> f @* (H :&: A) = f @* H :&: f @* A.
Proof.
move=> H A sKH; apply/eqP; rewrite eqEsubset morphimI setIC.
apply/subsetP=> y; case/setIP; case/morphimP=> x Gx Ax ->{y}.
case/morphimP=> z Gz Hz; case/ker_rcoset=> {Gz}// y Ky def_x.
have{z Hz y Ky def_x} Hx: x \in H by rewrite def_x groupMl // (subsetP sKH).
by rewrite mem_imset ?inE // Gx Hx Ax.
Qed.

Lemma morphimIG : forall (A : {set aT}) (H : {group aT}),
  'ker f \subset H -> f @* (A :&: H) = f @* A :&: f @* H.
Proof. by move=> A H sKH; rewrite setIC morphimGI // setIC. Qed.

Lemma morphimD : forall A B, f @* A :\: f @* B \subset f @* (A :\: B).
Proof.
move=> A B; rewrite subDset -morphimU morphimS //.
by rewrite setDE setUIr setUCr setIT subsetUr.
Qed.

Lemma morphimDG : forall A H,
  'ker f \subset H -> f @* (A :\: H) = f @* A :\: f @* H.
Proof.
move=> A H sKH; apply/eqP; rewrite eqEsubset morphimD andbT !setDE subsetI.
rewrite morphimS ?subsetIl // -[~: f @* H]setU0 -subDset setDE setCK.
by rewrite -morphimIG //= setIAC -setIA setICr setI0 morphim0.
Qed.

(* group structure preservation *)

Lemma morphpre_groupset : forall M, group_set (f @*^-1 M).
Proof.
move=> M; apply/group_setP; split=> [|x y]; rewrite !inE ?(morph1, group1) //.
by case/andP=> Gx Mfx; case/andP=> Gy Mfy; rewrite morphM ?groupM.
Qed.

Lemma morphim_groupset : forall H, group_set (f @* H).
Proof.
move=> H; apply/group_setP; split=> [|fx fy].
  by rewrite -morph1 mem_imset ?group1.
case/morphimP=> x Gx Hx ->; case/morphimP=> y Gy Hy ->.
by rewrite -morphM ?mem_imset ?inE ?groupM.
Qed.

Canonical Structure morphpre_group fPh M :=
  @group _ (morphpre fPh M) (morphpre_groupset M).
Canonical Structure morphim_group fPh H :=
  @group _ (morphim fPh H) (morphim_groupset H).
Canonical Structure ker_group fPh : {group aT} :=
  Eval hnf in [group of ker fPh].

Lemma morph_dom_groupset : group_set (f @: G).
Proof. by rewrite -morphimEdom groupP. Qed.

Canonical Structure morph_dom_group := group morph_dom_groupset.

Lemma morphpreMr : forall C D,
  D \subset f @* G -> f @*^-1 (C * D) = f @*^-1 C * f @*^-1 D.
Proof.
move=> C D sDfG; apply: invg_inj.
by rewrite invMg -!morphpreV invMg morphpreMl // -invSg invgK invGid.
Qed.

(* compatibility with inclusion *)

Lemma morphimK : forall A, A \subset G -> f @*^-1 (f @* A) = 'ker f * A.
Proof.
move=> A sAG; apply/setP=> x; rewrite !inE; apply/idP/idP.
  case/andP=> Gx; case/morphimP=> y Gy Ay eqxy.
  rewrite -(mulgKV y x) mem_mulg // !inE !(groupM, morphM, groupV) //.
  by rewrite morphV //= eqxy mulgV.
case/imset2P=> z y Kz Ay ->{x}.
have [Gy Gz]: y \in G /\ z \in G by rewrite (subsetP sAG) // dom_ker.
by rewrite groupM // morphM // mker // mul1g mem_imset // inE Gy.
Qed.

Lemma morphimGK : forall H,
 'ker f \subset H -> H \subset G -> f @*^-1 (f @* H) = H.
Proof. by move=> H sKH sHG; rewrite morphimK // mulSGid. Qed.

Lemma morphpre_set1 : forall x, x \in G -> f @*^-1 [set f x] = 'ker f :* x.
Proof. by move=> x Gx; rewrite -morphim_set1 // morphimK ?sub1set. Qed.

Lemma morphpreK : forall C, C \subset f @* G -> f @* (f @*^-1 C) = C.
Proof.
move=> C sCfG; apply/setP=> y; apply/morphimP/idP=> [[x _] | Cy].
  by rewrite !inE; case/andP=> _ Cfx ->.
case/morphimP: (subsetP sCfG y Cy) => x Gx _ defy.
by exists x; rewrite // !inE Gx -defy.
Qed.

Lemma morphim_ker : f @* 'ker f = 1.
Proof. by rewrite morphpreK ?sub1G. Qed.

Lemma ker_sub_pre : forall M, 'ker f \subset f @*^-1 M.
Proof. by move=> M; rewrite morphpreS ?sub1G. Qed.

Lemma ker_normal_pre : forall M, 'ker f <| f @*^-1 M.
Proof. by move=> H; rewrite /normal ker_sub_pre subIset ?ker_norm. Qed.

Lemma morphpreSK : forall C D,
  C \subset f @* G -> (f @*^-1 C \subset f @*^-1 D) = (C \subset D).
Proof.
move=> C D sCfG; apply/idP/idP=> [sf'CD|]; last exact: morphpreS.
suffices: C \subset f @* G :&: D by rewrite subsetI sCfG.
rewrite -(morphpreK sCfG) -[_ :&: D]morphpreK (morphimS, subsetIl) //.
by rewrite morphpreI morphimGK ?subsetIl // setIA setIid.
Qed.

Lemma sub_morphim_pre : forall A C,
  A \subset G -> (f @* A \subset C) = (A \subset f @*^-1 C).
Proof.
move=> A C sAG; rewrite -morphpreSK (morphimS, morphimK) //.
apply/idP/idP; first by apply: subset_trans; exact: mulG_subr.
by move/(mulgS ('ker f)); rewrite -morphpreMl ?(sub1G, mul1g).
Qed.

Lemma morphpre_proper : forall C D,
  C \subset f @* G -> D \subset f @* G ->
  (f @*^-1 C \proper f @*^-1 D) = (C \proper D).
Proof. by move=> Q R dQ dR; rewrite /proper !morphpreSK. Qed.

Lemma sub_morphpre_im : forall C H,
    'ker f \subset H -> H \subset G -> C \subset f @* G ->
  (f @*^-1 C \subset H) = (C \subset f @* H).
Proof. by symmetry; rewrite -morphpreSK ?morphimGK. Qed.

Lemma ker_trivg_morphim : forall A,
  (A \subset 'ker f) = (A \subset G) && (f @* A \subset [1]).
Proof.
move=> A; case sAG: (A \subset G); first by rewrite sub_morphim_pre.
by rewrite subsetI sAG.
Qed.

Lemma morphimSK : forall A B,
  A \subset G -> (f @* A \subset f @* B) = (A \subset 'ker f * B).
Proof.
move=> A B sAG; transitivity (A \subset 'ker f * (G :&: B)).
  by rewrite -morphimK ?subsetIl // -sub_morphim_pre // /morphim setIA setIid.
by rewrite setIC group_modl (subsetIl, subsetI) // andbC sAG.
Qed.

Lemma morphimSGK : forall A H,
  A \subset G -> 'ker f \subset H -> (f @* A \subset f @* H) = (A \subset H).
Proof. by move=> H K sHG skfK; rewrite morphimSK // mulSGid. Qed.

Lemma ltn_morphim : forall A, [1] \proper 'ker_A f -> #|f @* A| < #|A|.
Proof.
move=> A; case/properP; rewrite sub1set; case/setIP=> A1 _ [x].
case/setIP=> Ax kx; rewrite (cardsD1 1 A) A1 ltnS => x1.
rewrite -{1}(setD1K A1) morphimU morphim1 (setUidPr _) ?sub1set; last first.
  by rewrite -(mker kx) mem_morphim ?(dom_ker kx) // inE x1.
by rewrite (leq_trans (leq_imset_card _ _)) ?subset_leq_card ?subsetIr.
Qed.

(* injectivity of image and preimage *)

Lemma morphpre_inj :
  {in [pred C : {set _} | C \subset f @* G] &, injective (fun C => f @*^-1 C)}.
Proof. exact: can_in_inj morphpreK. Qed.

Lemma morphim_injG :
  {in [pred H : {group _} | ('ker f \subset H) && (H \subset G)] &,
   injective (fun H => f @* H)}.
Proof.
move=> H K; case/andP=> skH sHG; case/andP=> skK sKG eqfHK.
by apply: val_inj; rewrite /= -(morphimGK skH sHG) eqfHK morphimGK.
Qed.

Lemma morphim_inj : forall H1 H2,
    ('ker f \subset H1) &&  (H1 \subset G) ->
    ('ker f \subset H2) &&  (H2 \subset G) ->
  f @* H1 = f @* H2 -> H1 :=: H2.
Proof. by move=> H1 H2 nH1f nH2f; move/morphim_injG->. Qed.

(* commutation with generated groups and cycles *)

Lemma morphim_gen : forall A, A \subset G -> f @* <<A>> = <<f @* A>>.
Proof.
move=> A sAG; apply/eqP.
rewrite eqEsubset andbC gen_subG morphimS; last exact: subset_gen.
by rewrite sub_morphim_pre gen_subG // -sub_morphim_pre // subset_gen.
Qed.

Lemma morphim_cycle : forall x, x \in G -> f @* <[x]> = <[f x]>.
Proof. by move=> x Gx; rewrite morphim_gen (sub1set, morphim_set1). Qed.

Lemma morphpre_gen : forall C,
  1 \in C -> C \subset f @* G -> f @*^-1 <<C>> = <<f @*^-1 C>>.
Proof.
move=> C C1 sCG; apply/eqP.
rewrite eqEsubset andbC gen_subG morphpreS; last exact: subset_gen.
rewrite -{1}(morphpreK sCG) -morphim_gen ?subsetIl // morphimGK //=.
  by rewrite sub_gen // setIS // preimsetS ?sub1set.
by rewrite gen_subG subsetIl.
Qed.

(* commutator, normaliser, normal, center properties*)

Lemma morphimR : forall A B,
  A \subset G -> B \subset G -> f @* [~: A, B] = [~: f @* A, f @* B].
Proof.
move=> A B; move/subsetP=> sAG; move/subsetP=> sBG.
rewrite morphim_gen; last first; last congr <<_>>.
  by apply/subsetP=> z; case/imset2P=> x y Ax By ->; rewrite groupR; auto.
apply/setP=> fz; apply/morphimP/imset2P=> [[z _] | [fx fy]].
  case/imset2P=> x y Ax By -> -> {z fz}.
  have Gx := sAG x Ax; have Gy := sBG y By.
  by exists (f x) (f y); rewrite ?(mem_imset, morphR) // ?(inE, Gx, Gy).
case/morphimP=> x Gx Ax ->{fx}; case/morphimP=> y Gy By ->{fy} -> {fz}.
by exists [~ x, y]; rewrite ?(inE, morphR, groupR, mem_imset2).
Qed.

Lemma morphim_norm : forall A, f @* 'N(A) \subset 'N(f @* A).
Proof.
move=> A; apply/subsetP=> fx; case/morphimP=> x Gx Nx -> {fx}.
by rewrite inE -morphimJ ?(normP Nx).
Qed.

Lemma morphim_norms : forall A B,
  A \subset 'N(B) -> f @* A \subset 'N(f @* B).
Proof.
move=> A B nBA; apply: subset_trans (morphim_norm B); exact: morphimS.
Qed.

Lemma morphim_subnorm : forall A B, f @* 'N_A(B) \subset 'N_(f @* A)(f @* B).
Proof.
move=> A B; exact: subset_trans (morphimI A _) (setIS _ (morphim_norm B)).
Qed.

Lemma morphim_normal : forall A B, A <| B -> f @* A <| f @* B.
Proof.
move=> A B; case/andP=> sAB nAB.
by rewrite /(_ <| _) morphimS // morphim_norms.
Qed.

Lemma morphim_cent1 : forall x, x \in G -> f @* 'C[x] \subset 'C[f x].
Proof. by move=> x Gx; rewrite -(morphim_set1 Gx) morphim_norm. Qed.

Lemma morphim_cent1s : forall A x,
  x \in G -> A \subset 'C[x] -> f @* A \subset 'C[f x].
Proof.
move=> A x Gx cAx; apply: subset_trans (morphim_cent1 Gx); exact: morphimS.
Qed.

Lemma morphim_subcent1 : forall A x, x \in G ->
   f @* 'C_A[x] \subset 'C_(f @* A)[f x].
Proof. by move=> A x Gx; rewrite -(morphim_set1 Gx) morphim_subnorm. Qed.

Lemma morphim_cent : forall A, f @* 'C(A) \subset 'C(f @* A).
Proof.
move=> A; apply/bigcapsP=> fx; case/morphimP=> x Gx Ax ->{fx}.
apply: subset_trans (morphim_cent1 Gx); apply: morphimS; exact: bigcap_inf.
Qed.

Lemma morphim_cents : forall A B,
  A \subset 'C(B) -> f @* A \subset 'C(f @* B).
Proof.
move=> A B cBA; apply: subset_trans (morphim_cent B); exact: morphimS.
Qed.

Lemma morphim_subcent : forall A B, f @* 'C_A(B) \subset 'C_(f @* A)(f @* B).
Proof.
move=> A B; exact: subset_trans (morphimI A _) (setIS _ (morphim_cent B)).
Qed.

Lemma morphim_abelian : forall A, abelian A -> abelian (f @* A).
Proof. move=> A; exact: morphim_cents. Qed.

Lemma morphpre_norm : forall C, f @*^-1 'N(C) \subset 'N(f @*^-1 C).
Proof.
move=> C; apply/subsetP=> x; rewrite !inE; case/andP=> Gx Nfx.
by rewrite -morphpreJ ?morphpreS.
Qed.

Lemma morphpre_norms : forall C D,
  C \subset 'N(D) -> f @*^-1 C \subset 'N(f @*^-1 D).
Proof.
move=> C D nDC; apply: subset_trans (morphpre_norm D); exact: morphpreS.
Qed.

Lemma morphpre_normal :  forall C D,
  C \subset f @* G -> D \subset f @* G -> (f @*^-1 C <| f @*^-1 D) = (C <| D).
Proof.
move=> C D sCfG sDfG; apply/idP/andP=> [|[sCD nDC]].
  by move/morphim_normal; rewrite !morphpreK //; case/andP.
by rewrite /(_ <| _) (subset_trans _ (morphpre_norm _)) morphpreS.
Qed.

Lemma morphpre_subnorm : forall C D,
  f @*^-1 'N_C(D) \subset 'N_(f @*^-1 C)(f @*^-1 D).
Proof. by move=> C D; rewrite morphpreI setIS ?morphpre_norm. Qed.

Lemma morphim_normG : forall H,
  'ker f \subset H -> H \subset G -> f @* 'N(H) = 'N_(f @* G)(f @* H).
Proof.
move=> H sKH sHG; apply/eqP; rewrite eqEsubset -{1}morphimIdom morphim_subnorm.
rewrite -(morphpreK (subsetIl _ _)) morphimS //= morphpreI subIset // orbC.
by rewrite -{2}(morphimGK sKH sHG) morphpre_norm.
Qed.

Lemma morphim_subnormG : forall A H,
  'ker f \subset H -> H \subset G -> f @* 'N_A(H) = 'N_(f @* A)(f @* H).
Proof.
move=> A B sKB sBG; rewrite morphimIG ?normsG // morphim_normG //.
by rewrite setICA setIA morphimIim.
Qed.

Lemma morphpre_cent1 : forall x, x \in G -> 'C_G[x] \subset f @*^-1 'C[f x].
Proof.
move=> x Gx; rewrite -sub_morphim_pre ?subsetIl //.
by apply: subset_trans (morphim_cent1 Gx); rewrite morphimS ?subsetIr.
Qed.

Lemma morphpre_cent1s : forall C x,
  x \in G -> C \subset f @* G -> f @*^-1 C \subset 'C[x] -> C \subset 'C[f x].
Proof. by move=> C x Gx sCfG; move/(morphim_cent1s Gx); rewrite morphpreK. Qed.

Lemma morphpre_subcent1 : forall C x, x \in G ->
  'C_(f @*^-1 C)[x] \subset f @*^-1 'C_C[f x].
Proof.
move=> C x Gx; rewrite -morphpreIdom -setIA setICA morphpreI setIS //.
exact: morphpre_cent1.
Qed.

Lemma morphpre_cent : forall A, 'C_G(A) \subset f @*^-1 'C(f @* A).
Proof.
move=> C; rewrite -sub_morphim_pre ?subsetIl //.
rewrite morphimGI ?(subsetIl, subIset) // orbC.
by rewrite (subset_trans (morphim_cent _)).
Qed.

Lemma morphpre_cents : forall A C,
  C \subset f @* G -> f @*^-1 C \subset 'C(A) -> C \subset 'C(f @* A).
Proof. by move=> A C sCfG; move/morphim_cents; rewrite morphpreK. Qed.

Lemma morphpre_subcent : forall C A,
  'C_(f @*^-1 C)(A) \subset f @*^-1 'C_C(f @* A).
Proof.
move=> C A; rewrite -morphpreIdom -setIA setICA morphpreI setIS //.
exact: morphpre_cent.
Qed.

(* local injectivity properties *)

Lemma injmP : reflect {in G &, injective f} ('injm f).
Proof.
apply: (iffP subsetP) => [injf x y Gx Gy | injf x /= Kx].
  by case/ker_rcoset=> // z; move/injf; move/set1P->; rewrite mul1g.
have Gx := dom_ker Kx; apply/set1P; apply: injf => //.
by apply/rcoset_kerP; rewrite // mulg1.
Qed.

Section Injective.

Hypothesis injf : 'injm f.

Lemma ker_injm : 'ker f = 1.
Proof. exact/trivgP. Qed.

Lemma injmK : forall A, A \subset G -> f @*^-1 (f @* A) = A.
Proof. by move=> A sAG; rewrite morphimK // ker_injm // mul1g. Qed.

Lemma injm_morphim_inj : forall A B,
  A \subset G -> B \subset G -> f @* A = f @* B -> A = B.
Proof. by move=> A B sAG sBG eqAB; rewrite -(injmK sAG) eqAB injmK. Qed.

Lemma card_injm : forall A, A \subset G -> #|f @* A| = #|A|.
Proof.
move=> A sAG; rewrite morphimEsub // card_in_imset //.
exact: (sub_in2 (subsetP sAG) (injmP injf)).
Qed.

Lemma injm1 : forall x, x \in G -> f x = 1 -> x = 1.
Proof. by move=> x Gx; move/(kerP Gx); rewrite ker_injm; move/set1P. Qed.

Lemma injmSK : forall A B,
  A \subset G -> (f @* A \subset f @* B) = (A \subset B).
Proof. by move=> A B sAG; rewrite morphimSK // ker_injm mul1g. Qed.

Lemma sub_morphpre_injm : forall C A,
    A \subset G -> C \subset f @* G ->
  (f @*^-1 C \subset A) = (C \subset f @* A).
Proof. by move=> C A sAG sCfG; rewrite -morphpreSK ?injmK. Qed.

Lemma injmI : forall A B, f @* (A :&: B) = f @* A :&: f @* B.
Proof.
move=> A B; have sfI: f @* A :&: f @* B \subset f @* G.
  by apply/setIidPr; rewrite setIA morphimIim.
rewrite -(morphpreK sfI) morphpreI -(morphimIdom A) -(morphimIdom B).
by rewrite !injmK ?subsetIl // setICA -setIA !morphimIdom.
Qed.

Lemma injm_norm : forall A, A \subset G -> f @* 'N(A) = 'N_(f @* G)(f @* A).
Proof.
move=> A sAG; apply/eqP; rewrite -morphimIdom eqEsubset morphim_subnorm.
rewrite -sub_morphpre_injm ?subsetIl // morphpreI injmK // setIS //.
by rewrite -{2}(injmK sAG) morphpre_norm.
Qed.

Lemma injm_subnorm : forall A B,
  B \subset G -> f @* 'N_A(B) = 'N_(f @* A)(f @* B).
Proof.
by move=> A B sBG; rewrite injmI injm_norm // setICA setIA morphimIim.
Qed.

Lemma injm_cent1 : forall x, x \in G -> f @* 'C[x] = 'C_(f @* G)[f x].
Proof. by move=> x Gx; rewrite injm_norm ?morphim_set1 ?sub1set. Qed.

Lemma injm_subcent1 : forall A x, x \in G -> f @* 'C_A[x] = 'C_(f @* A)[f x].
Proof. by move=> A x Gx; rewrite injm_subnorm ?morphim_set1 ?sub1set. Qed.

Lemma injm_cent : forall A, A \subset G -> f @* 'C(A) = 'C_(f @* G)(f @* A).
Proof.
move=> A sAG; apply/eqP; rewrite -morphimIdom eqEsubset morphim_subcent.
apply/subsetP=> fx; case/setIP; case/morphimP=> x Gx _ ->{fx} cAfx.
rewrite mem_morphim // inE Gx -sub1set centsC cent_set1 -injmSK //.
by rewrite injm_cent1 // subsetI morphimS // -cent_set1 centsC sub1set.
Qed.

Lemma injm_subcent : forall A B,
  B \subset G -> f @* 'C_A(B) = 'C_(f @* A)(f @* B).
Proof.
by move=> A B sBG; rewrite injmI injm_cent // setICA setIA morphimIim.
Qed.

Lemma injm_abelian : forall A, A \subset G -> abelian (f @* A) = abelian A.
Proof.
move=> A sAG; rewrite /abelian !(sameP setIidPl eqP) -injm_subcent //.
by rewrite !eqEsubset !injmSK // subIset ?sAG.
Qed.

End Injective.

Variable g : {morphism G >-> rT}.

Lemma eq_morphim : {in G, f =1 g} -> forall A, f @* A = g @* A.
Proof.
by move=> efg A; apply: eq_in_imset; apply: sub_in1 efg => x; case/setIP.
Qed.

End MorphismTheory.

Notation "''ker' f" := (ker_group (MorPhantom f)) : subgroup_scope.
Notation "''ker_' H f" := (H :&: 'ker f)%G : subgroup_scope.
Notation "f @* H" := (morphim_group (MorPhantom f) H) : subgroup_scope.
Notation "f @*^-1 H" := (morphpre_group (MorPhantom f) H) : subgroup_scope.
Notation "f @: G" := (morph_dom_group f G) : subgroup_scope.

Section IdentityMorphism.

Variable gT : finGroupType.
Implicit Types A B : {set gT}.
Implicit Type G : {group gT}.

Definition idm of {set gT} := fun x : gT => x : FinGroup.sort gT.

Lemma idm_morphM : forall A, {in A & , {morph idm A : x y / x * y}}.
Proof. by []. Qed.

Canonical Structure idm_morphism A := Morphism (@idm_morphM A).

Lemma injm_idm : forall G, 'injm (idm G).
Proof. by move=> G; apply/injmP=> ?. Qed.

Lemma ker_idm : forall G, 'ker (idm G) = 1.
Proof. by move=> G; apply/trivgP; exact: injm_idm. Qed.

Lemma morphim_idm : forall A B, B \subset A -> idm A @* B = B.
Proof.
move=> A B; rewrite /morphim /= /idm; move/setIidPr->.
by apply/setP=> x; apply/imsetP/idP=> [[y By ->]|Bx]; last exists x.
Qed.

Lemma morphpre_idm : forall A B, idm A @*^-1 B = A :&: B.
Proof. by move=> A B; apply/setP=> x; rewrite !inE. Qed.

Lemma im_idm : forall A, idm A @* A = A.
Proof. move=> A; exact: morphim_idm. Qed.

End IdentityMorphism.

Prenex Implicits idm.

Section RestrictedMorphism.

Variables aT rT : finGroupType.
Variables A B : {set aT}.
Implicit Type C : {set aT}.
Implicit Type R : {set rT}.

Definition restrm of A \subset B := @id (aT -> FinGroup.sort rT).

Section Props.

Hypothesis sAB : A \subset B.
Variable f : {morphism B >-> rT}.
Notation fB := (restrm sAB (mfun f)).

Canonical Structure restrm_morphism :=
  @Morphism aT rT A fB (sub_in2 (subsetP sAB) (morphM f)).

Lemma morphim_restrm : forall C, fB @* C = f @* (A :&: C).
Proof. by move=> C; rewrite {2}/morphim setIA (setIidPr sAB). Qed.

Lemma morphpre_restrm : forall R, fB @*^-1 R = A :&: f @*^-1 R.
Proof. by move=> R; rewrite setIA (setIidPl sAB). Qed.

Lemma ker_restrm : 'ker (restrm sAB f) = 'ker_A f.
Proof. exact: morphpre_restrm. Qed.

Lemma injm_restrm : 'injm f -> 'injm (restrm sAB f).
Proof. by apply: subset_trans; rewrite ker_restrm subsetIr. Qed.

End Props.

Lemma restrmP : forall f : {morphism B >-> rT}, A \subset 'dom f ->
  {g : {morphism A >-> rT} | [/\ g = f :> (aT -> rT), 'ker g = 'ker_A f,
                                 forall R, g @*^-1 R = A :&: f @*^-1 R
                               & forall C, C \subset A -> g @* C = f @* C]}.
Proof.
move=> f sAB; exists (restrm_morphism sAB f).
split=> // [|R|C sCA]; first 1 [exact: ker_restrm | exact: morphpre_restrm].
by rewrite morphim_restrm (setIidPr sCA).
Qed.

Lemma domP : forall f : {morphism B >-> rT}, 'dom f = A ->
  {g : {morphism A >-> rT} | [/\ g = f :> (aT -> rT), 'ker g = 'ker f,
                                 forall R, g @*^-1 R = f @*^-1 R
                               & forall C, f @* C = g @* C]}.
Proof. by move=> f <-; exists f. Qed.

End RestrictedMorphism.

Prenex Implicits restrm.
Implicit Arguments restrmP [aT rT A B].
Implicit Arguments domP [aT rT A B].

Section TrivMorphism.

Variables aT rT : finGroupType.

Definition trivm of {set aT} & aT := 1 : FinGroup.sort rT.

Lemma trivm_morphM : forall A : {set aT},
  {in A & , {morph trivm A : x y / x * y}}.
Proof. by move=> A x y /=; rewrite mulg1. Qed.

Canonical Structure triv_morph A := Morphism (@trivm_morphM A).

Lemma morphim_trivm : forall (G H : {group aT}), trivm G @* H = 1.
Proof.
move=> G H; apply/setP=> /= y; rewrite inE.
apply/idP/eqP=> [|->]; first by case/morphimP.
by apply/morphimP; exists (1 : aT); rewrite /= ?group1.
Qed.

Lemma ker_trivm : forall G : {group aT}, 'ker (trivm G) = G.
Proof. by move=> G; apply/setIidPl; apply/subsetP=> x _; rewrite !inE /=. Qed.

End TrivMorphism.

Prenex Implicits trivm.

(* Canonical Structure of morphism for the composition of 2 morphisms. *)

Section MorphismComposition.

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

Variable f : {morphism G >-> hT}.
Variable g : {morphism H >-> rT}.

Notation Local gof := (mfun g \o mfun f).

Lemma comp_morphM : {in f @*^-1 H &, {morph gof: x y / x * y}}.
Proof.
by move=> x y; rewrite /= !inE; do 2!case/andP=> ? ?; rewrite !morphM.
Qed.

Canonical Structure comp_morphism := Morphism comp_morphM.

Lemma ker_comp : 'ker gof = f @*^-1 'ker g.
Proof. by apply/setP=> x; rewrite !inE andbA. Qed.

Lemma injm_comp : 'injm f -> 'injm g -> 'injm gof.
Proof. by move=> injf; rewrite ker_comp; case/trivgP=> ->. Qed.

Lemma morphim_comp : forall A : {set gT}, gof @* A = g @* (f @* A).
Proof.
move=> A; apply/setP=> z; apply/morphimP/morphimP=> [[x]|[y Hy fAy ->{z}]].
  rewrite !inE; case/andP=> Gx Hfx; exists (f x) => //.
  by apply/morphimP; exists x.
by case/morphimP: fAy Hy => x Gx Ax ->{y} Hfx; exists x; rewrite ?inE ?Gx.
Qed.

Lemma morphpre_comp : forall C : {set rT},
  gof @*^-1 C = f @*^-1 (g @*^-1 C).
Proof. by move=> C; apply/setP=> z; rewrite !inE andbA. Qed.

End MorphismComposition.

(* Canonical structure of morphism for the factor morphism *)

Section FactorMorphism.

Variables aT qT rT : finGroupType.

Variables G H : {group aT}.
Variable f : {morphism G >-> rT}.
Variable q : {morphism H >-> qT}.

Definition factm of 'ker q \subset 'ker f  & G \subset H :=
  fun x => f (repr (q @*^-1 [set x])).

Hypothesis sKqKf : 'ker q \subset 'ker f.
Hypothesis sGH : G \subset H.

Notation ff := (factm sKqKf sGH).

Lemma factmE : forall x, x \in G -> ff (q x) = f x.
Proof.
rewrite /ff => x Gx; have Hx := subsetP sGH x Gx.
have: x \in q @*^-1 [set q x] by rewrite !inE Hx /=.
move/mem_repr; case/morphpreP; move: (repr _) => y Hy; move/set1P.
by case/ker_rcoset=> // z Kz ->; rewrite mkerl ?(subsetP sKqKf).
Qed.

Lemma factm_morphM : {in q @* G &, {morph ff : x y / x * y}}.
Proof.
move=> xq yq; case/morphimP=> x Hx Gx ->{xq}.
by case/morphimP=> y Hy Gy ->{yq}; rewrite -morphM ?factmE ?groupM // morphM.
Qed.

Canonical Structure factm_morphism := Morphism factm_morphM.

Lemma morphim_factm : forall A : {set aT}, ff @* (q @* A) = f @* A.
Proof.
move=> A; rewrite -morphim_comp /= {1}/morphim /= morphimGK //; last first.
  by rewrite (subset_trans sKqKf) ?subsetIl.
apply/setP=> y; apply/morphimP/morphimP;
  by case=> x Gx Ax ->{y}; exists x; rewrite //= factmE.
Qed.

Lemma morphpre_factm : forall C : {set rT}, ff @*^-1 C =  q @* (f @*^-1 C).
Proof.
move=> C; apply/setP=> y; rewrite !inE /=.
apply/andP/morphimP=> [[]|[x Hx]]; last first.
  by case/morphpreP=> Gx Cfx ->; rewrite factmE ?mem_imset ?inE ?Hx.
case/morphimP=> x Hx Gx ->; rewrite factmE //.
by exists x; rewrite // !inE Gx.
Qed.

Lemma ker_factm : 'ker ff = q @* 'ker f.
Proof. exact: morphpre_factm. Qed.

Lemma injm_factm : 'injm f -> 'injm ff.
Proof. by rewrite ker_factm; case/trivgP=> ->; rewrite morphim1. Qed.

Lemma injm_factmP : reflect ('ker f = 'ker q) ('injm ff).
Proof.
rewrite ker_factm -morphimIdom sub_morphim_pre ?subsetIl //.
rewrite setIA (setIidPr sGH) (sameP setIidPr eqP) (setIidPl _) // eq_sym.
exact: eqP.
Qed.

Lemma ker_factm_loc : forall K : {group aT}, 'ker_(q @* K) ff = q @* 'ker_K f.
Proof. by move=> K; rewrite ker_factm -morphimIG. Qed.

End FactorMorphism.

Prenex Implicits factm.

Section InverseMorphism.

Variables aT rT : finGroupType.
Implicit Types A B : {set aT}.
Implicit Types C D : {set rT}.
Variables (G : {group aT}) (f : {morphism G >-> rT}).
Hypothesis injf : 'injm f.

Lemma invm_subker : 'ker f \subset 'ker (idm G).
Proof. by rewrite ker_idm. Qed.

Definition invm := factm invm_subker (subxx _).

Canonical Structure invm_morphism := Eval hnf in [morphism of invm].

Lemma invmE : {in G, cancel f invm}.
Proof. exact: factmE. Qed.

Lemma invmK : {in f @* G, cancel invm f}.
Proof. by move=> fx; case/morphimP=> x _ Gx ->; rewrite invmE. Qed.

Lemma morphpre_invm : forall A, invm @*^-1 A = f @* A.
Proof. by move=> A; rewrite morphpre_factm morphpre_idm morphimIdom. Qed.

Lemma morphim_invm : forall A, A \subset G -> invm @* (f @* A) = A.
Proof. by move=> A sAG; rewrite morphim_factm morphim_idm. Qed.

Lemma morphim_invmE : forall C, invm @* C = f @*^-1 C.
Proof.
move=> C; rewrite -morphpreIdom -(morphim_invm (subsetIl _ _)).
by rewrite morphimIdom -morphpreIim morphpreK (subsetIl, morphimIdom).
Qed.

Lemma injm_proper : forall A B,
  A \subset G -> B \subset G -> (f @* A \proper f @* B) = (A \proper B).
Proof.
move=> A B dA dB; rewrite -morphpre_invm -(morphpre_invm B).
by rewrite morphpre_proper ?morphim_invm.
Qed.

Lemma injm_invm : 'injm invm.
Proof. by move/can_in_inj: invmK; move/injmP. Qed.

Lemma ker_invm : 'ker invm = 1.
Proof. by move/trivgP: injm_invm. Qed.

Lemma im_invm : invm @* (f @* G) = G.
Proof. exact: morphim_invm. Qed.

End InverseMorphism.

Prenex Implicits invm.

(* Reflected (boolean) form of morphism and isomorphism properties *)

Section ReflectProp.

Variables aT rT : finGroupType.

Section Defs.

Variables (A : {set aT}) (B : {set rT}).

(* morphic is the morphM property of morphisms seen through morphicP *)
Definition morphic (f : aT -> rT) :=
  forallb u, (u \in [predX A & A]) ==> (f (u.1 * u.2) == f u.1 * f u.2).

Definition isom f := f @: A^# == B^#.

Definition misom f := morphic f && isom f.

Definition isog := existsb f : {ffun aT -> rT}, misom f.

Section MorphicProps.

Variable f : aT -> rT.

Lemma morphicP : reflect {in A &, {morph f : x y / x * y}} (morphic f).
Proof.
apply: (iffP forallP) => [fM x y Ax Ay | fM [x y] /=].
  by apply/eqP; have:= fM (x, y); rewrite inE /= Ax Ay.
by apply/implyP; case/andP=> Ax Ay; rewrite fM.
Qed.

Definition morphm of morphic f := f : aT -> FinGroup.sort rT.

Lemma morphmE : forall fM, morphm fM = f. Proof. by []. Qed.

Canonical Structure morphm_morphism fM :=
  @Morphism _ _ A (morphm fM) (morphicP fM).

End MorphicProps.

Lemma misomP : forall f, reflect {fM : morphic f & isom (morphm fM)} (misom f).
Proof. by move=> f; apply: (iffP andP) => [] [fM fiso] //; exists fM. Qed.

Lemma misom_isog : forall f, misom f -> isog.
Proof.
move=> f; case/andP=> fM iso_f; apply/existsP; exists (finfun f).
apply/andP; split; last by rewrite /misom /isom !(eq_imset _ (ffunE f)).
apply/forallP=> u; rewrite !ffunE; exact: forallP fM u.
Qed.

Lemma isom_isog : forall (D : {group aT}) (f : {morphism D >-> rT}),
  A \subset D -> isom f -> isog.
Proof.
move=> D f sAD isof; apply: (@misom_isog f); rewrite /misom isof andbT.
apply/morphicP; exact: (sub_in2 (subsetP sAD) (morphM f)).
Qed.

End Defs.

Implicit Arguments isom_isog [A B D].

Infix "\isog" := isog.

(* The real reflection properties only hold for true groups and morphisms. *)

Section Main.

Variables (G : {group aT}) (H : {group rT}).
Notation fMT := {morphism G >-> rT}.

Lemma isomP : forall f : fMT, reflect ('injm f /\ f @* G = H) (isom G H f).
Proof.
move=> f; apply: (iffP eqP) => [eqfGH | [injf <-]]; last first.
  by rewrite setDE -morphimEsub ?subsetIl // -setDE morphimDG // morphim1.
split.
  apply/subsetP=> x; rewrite !inE /=; case/andP=> Gx fx1; apply/idPn=> nx1.
  by move/setP: eqfGH; move/(_ (f x)); rewrite mem_imset ?inE (nx1, fx1).
rewrite morphimEdom -{2}(setD1K (group1 G)) imsetU eqfGH.
by rewrite imset_set1 morph1 setD1K.
Qed.

Lemma isom_card : forall f : fMT, isom G H f -> #|G| = #|H|.
Proof.
move=> f; case/isomP; move/injmP=> injf <-.
by rewrite morphimEdom card_in_imset.
Qed.

Lemma isogP : reflect (exists2 f : fMT, 'injm f & f @* G = H) (G \isog H).
Proof.
apply: (iffP idP) => [| [f *]]; last by apply: (isom_isog f); last exact/isomP.
by case/existsP=> f; case/misomP=> fM; case/isomP; exists (morphm_morphism fM).
Qed.

End Main.

Variables (G : {group aT}) (f : {morphism G >-> rT}).

Lemma morphim_isom : forall (H : {group aT}) (K : {group rT}),
  H \subset G -> isom H K f -> f @* H = K.
Proof.
by move=> H K; case/(restrmP f)=> g [gf _ _ <- //]; rewrite -gf; case/isomP.
Qed.

Lemma sub_isom : forall (A : {set aT}) (C : {set rT}),
  A \subset G -> f @* A = C -> 'injm f -> isom A C f.
Proof.
move=> A C sAG; case: (restrmP f sAG) => g [_ _ _ img] <-{C} injf.
rewrite /isom -morphimEsub ?morphimDG ?morphim1 //.
by rewrite subDset setUC subsetU ?sAG.
Qed.

Lemma sub_isog : forall (A : {set aT}),
  A \subset G -> 'injm f -> isog A (f @* A).
Proof. move=> A sAG injf; apply: (isom_isog f sAG); exact: sub_isom. Qed.

End ReflectProp.

Implicit Arguments morphicP [aT rT A f].
Implicit Arguments misomP [aT rT A B f].
Implicit Arguments isom_isog [aT rT A B D].
Implicit Arguments isomP [aT rT G H f].
Implicit Arguments isogP [aT rT G H].
Prenex Implicits morphic morphicP morphm isom isog isomP misomP isogP.
Notation "x \isog y":= (isog x y).

Section Isomorphisms.

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

Lemma isog_refl : G \isog G.
Proof.
by apply/isogP; exists [morphism of idm G]; rewrite /= ?injm_idm ?morphim_idm.
Qed.

Lemma isog_card : G \isog H -> #|G| = #|H|.
Proof. case/isogP=> f injf <-; apply: isom_card (f) _; exact/isomP. Qed.

Lemma trivial_isog : G :=: 1 -> H :=: 1 -> G \isog H.
Proof.
move=> -> ->; apply/isogP.
exists [morphism of @trivm gT hT 1]; rewrite /= ?morphim1 //.
rewrite ker_trivm; exact: subxx.
Qed.

Lemma isog_triv : G \isog H -> (G :==: 1) = (H :==: 1).
Proof. by move=> isoGH; rewrite !trivg_card1 isog_card. Qed.

Lemma isog_symr : G \isog H -> H \isog G.
Proof.
case/isogP=> f injf <-; apply/isogP.
by exists [morphism of invm injf]; rewrite /= ?injm_invm // im_invm.
Qed.

Lemma isog_trans : G \isog H -> H \isog K -> G \isog K.
Proof.
case/isogP=> f injf <-; case/isogP=> g injg <-.
have defG: f @*^-1 (f @* G) = G by rewrite morphimGK ?subsetIl.
rewrite -morphim_comp -{1 8}defG.
by apply/isogP; exists [morphism of g \o f]; rewrite ?injm_comp.
Qed.

End Isomorphisms.

Section IsoBoolEquiv.

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

Lemma isog_sym : (G \isog H) = (H \isog G).
Proof. apply/idP/idP; exact: isog_symr. Qed.

Lemma isog_transl : G \isog H -> (G \isog K) = (H \isog K).
Proof.
by move=> iso; apply/idP/idP; apply: isog_trans; rewrite // -isog_sym.
Qed.

Lemma isog_transr : G \isog H -> (K \isog G) = (K \isog H).
Proof.
by move=> iso; apply/idP/idP; move/isog_trans; apply; rewrite // -isog_sym.
Qed.

Lemma isog_abelian :  G \isog H -> abelian G = abelian H.
Proof. by case/isogP=> f injf <-; rewrite injm_abelian. Qed.

End IsoBoolEquiv.

(* Isomorphism between a group and its subtype. *)

Section SubMorphism.

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

Canonical Structure sgval_morphism := Morphism (@sgvalM _ G).
Canonical Structure subg_morphism := Morphism (@subgM _ G).

Lemma injm_sgval : 'injm sgval.
Proof. apply/injmP; apply: in2W; exact: subg_inj. Qed.

Lemma injm_subg : 'injm (subg G).
Proof. apply/injmP; exact: can_in_inj (@subgK _ _). Qed.
Hint Resolve injm_sgval injm_subg.

Lemma ker_sgval : 'ker sgval = 1. Proof. exact/trivgP. Qed.
Lemma ker_subg : 'ker (subg G) = 1. Proof. exact/trivgP. Qed.

Lemma subgEdom : subg G @* G = [subg G].
Proof.
apply/eqP; rewrite -subTset morphimEdom.
by apply/subsetP=> u _; rewrite -(sgvalK u) mem_imset ?subgP.
Qed.

Lemma sgval_sub : forall A, sgval @* A \subset G.
Proof. move=> A; apply/subsetP=> x; case/imsetP=> u _ ->; exact: subgP. Qed.

Lemma sgvalmK : forall A, subg G @* (sgval @* A) = A.
Proof.
move=> A; apply/eqP; rewrite eqEcard !card_injm ?subsetT ?sgval_sub //.
rewrite leqnn andbT -morphim_comp; apply/subsetP=> u /=.
by case/morphimP=> v _ Av ->; rewrite /= sgvalK.
Qed.

Lemma subgmK : forall A : {set gT}, A \subset G -> sgval @* (subg G @* A) = A.
Proof.
move=> A sAG; apply/eqP; rewrite eqEcard !card_injm ?subsetT //.
rewrite leqnn andbT -morphim_comp morphimE /= morphpreT.
by apply/subsetP=> u; case/morphimP=> v Gv Av -> /=; rewrite subgK.
Qed.

Lemma sgvalEdom : sgval @* [subg G] = G.
Proof. by rewrite -{2}subgEdom subgmK. Qed.

Lemma isom_subg : isom G [subg G] (subg G).
Proof. by apply/isomP; rewrite subgEdom. Qed.

Lemma isom_sgval : isom [subg G] G sgval.
Proof. by apply/isomP; rewrite sgvalEdom. Qed.

Lemma isog_subg : isog G [subg G].
Proof. exact: isom_isog isom_subg. Qed.

End SubMorphism.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.

From Coq Require Import Logic.FunctionalExtensionality.

Definition Assertion := state -> Prop.

Module ExAssertions.
  Definition assn1 : Assertion := fun st => st X <= st Y.
  Definition assn2 : Assertion := fun st => st X = 3 \/ st X <= st Y.
  Definition assn3 : Assertion := fun st => st Z * st Z <= st X /\ ~ (((S (st Z)) * (S (st Z))) <= st X).
  Definition assn4 : Assertion := fun st => st Z = max (st X) (st Y).
End ExAssertions.

Definition assert_implies (P Q : Assertion) : Prop := forall st, P st -> Q st.

Declare Scope hoare_spec_scope.
Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.
Notation "P <<->> Q" := (P ->> Q /\ Q ->> P)
                        (at level 80) : hoare_spec_scope.

Definition Aexp : Type := state -> nat.
Definition assert_of_Prop (P : Prop) : Assertion := fun _ => P.
Definition Aexp_of_nat (n : nat) : Aexp := fun _ => n.
Definition Aexp_of_aexp (a : aexp) : Aexp := fun st => aeval st a.

Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.

Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.

Declare Scope assertion_scope.
Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.
Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).
Notation "~ P"      := (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q"   := (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q"   := (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q"   := (fun st => assert P st -> assert Q st) : assertion_scope.
Notation "P <-> Q"  := (fun st => assert P st <-> assert Q st) : assertion_scope.
Notation "a = b"    := (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b"   := (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b"   := (fun st => mkAexp a st <= mkAexp b st) : assertion_scope.
Notation "a < b"    := (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b"   := (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b"    := (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b"    := (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b"    := (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b"    := (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

Definition ap {X} (f : nat -> X) (x : Aexp) := fun st => f (x st).
Definition ap2 {X} (f : nat -> nat -> X) (x : Aexp) (y : Aexp) (st : state) := f (x st) (y st).

Module ExPrettyAssertions.
  Definition ex1 : Assertion := X = 3.
  Definition ex2 : Assertion := True.
  Definition ex3 : Assertion := False.
  Definition assn1 : Assertion := X <= Y.
  Definition assn2 : Assertion := X = 3 \/ X <= Y.
  Definition assn3 : Assertion := Z * Z <= X /\ ~ (((ap S Z) * (ap S Z)) <= X).
  Definition assn4 : Assertion := Z = ap2 max X Y.
End ExPrettyAssertions.

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st', st =[ c ]=> st' -> P st -> Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c custom com at level 99)
  : hoare_spec_scope.

Check ({{True}} X := 0 {{True}}).

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) -> {{P}} c {{Q}}.
Proof.
  intros P Q c H.
  unfold hoare_triple.
  intros st st' cmd Hp.
  apply  (H st').
Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~ (P st)) -> {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple. intros st st' cmd Hp.
  exfalso.
  apply (H st).
  assumption.
Qed.

Definition assn_sub X a (P:Assertion) : Assertion :=
  fun (st : state) => P (X !-> aeval st a ; st).

Notation "P [ X |-> a ]" := (assn_sub X a P)
                           (at level 10, X at next level, a custom com).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X := a) {{Q}}.
Proof. intros Q X a. unfold hoare_triple. intros st st' cmd Hq.
  inversion cmd. subst.
  unfold assn_sub in Hq. apply Hq. Qed.

Example assn_sub_example :
  {{(X < 5) [X |-> X + 1]}} X := X + 1 {{X < 5}}.
Proof.
  apply hoare_asgn. Qed.

Example hoare_asgn_examples1 :
  exists P, {{ P }} X := 2 * X {{ X <= 10 }}.
Proof.
  exists (assert (X <= 5)).
  unfold hoare_triple. intros st st' cmd Hq.
  simpl in *.
  inversion cmd. subst. unfold t_update.
  simpl. lia.
Qed.

Example hoare_asgn_examples2 :
  exists P, {{ P }} X := 3 {{ 0 <= X /\ X <= 5 }}.
Proof.
  exists True.
  unfold hoare_triple. intros st st' cmd Hq.
  simpl.
  inversion cmd; subst; simpl in *.
  unfold t_update; simpl. lia.
Qed.

Example vice_versa_wrong:
  exists a, ~ ({{ True }} X := a {{ X = a }}).
Proof.
  exists (<{ X + 1 }>).
  unfold hoare_triple.
  intros H. simpl in H.
  assert (G: 1 = 1 + 1). {
    apply (H (X !-> 0) (X !-> 1; X !-> 0)).
    apply E_Asgn. simpl.
    reflexivity.
    apply I.
  }
  discriminate G.
Qed.

Lemma qwe: forall st X (n: nat),
  (X !-> st X; X !-> n; st) = st.
Proof.
  intros st X n.
  unfold t_update. unfold eqb_string.
  apply functional_extensionality.
  intros x.
  destruct (string_dec X x) as [E | E].
  - rewrite E. reflexivity.
  - reflexivity.
Qed.

Theorem hoare_asgn_fwd : forall m a P,
  {{fun st => P st /\ st X = m}}
    X := a
  {{fun st => P (X !-> m ; st) /\ st X = aeval (X !-> m ; st) a }}.
Proof.
  unfold hoare_triple.
  intros m a P st st' comm [Hpst Estx].
  inversion comm; subst.
  rewrite qwe. unfold t_update; simpl.
  split.
  - assumption.
  - reflexivity.
Qed.

Lemma asd: forall X a st st',
  st =[ X := a ]=> st' -> exists m, (X !-> m; st') = st.
Proof.
  intros X a st st' H.
  inversion H; subst; simpl in *.
  exists (st X).
  apply qwe.
Qed.

Theorem hoare_asgn_fwd_exists : forall a P,
  {{fun st => P st}}
    X := a
  {{fun st => exists m, P (X !-> m ; st) /\ st X = aeval (X !-> m ; st) a }}.
Proof.
  unfold hoare_triple.
  intros a P st st' comm Hp.
  inversion comm; subst; simpl in *.
  destruct (asd _ _ _ _ comm) as [m' Hst].
  exists m'.
  rewrite Hst.
  unfold t_update; simpl.
  split.
  - assumption.
  - reflexivity.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->  P ->> P'  -> {{P}} c {{Q}}.
Proof. intros P P' Q c H1 H2.
  unfold hoare_triple in *.
  intros st st' c' Hpst.
  apply (H1 st st' c' (H2 st Hpst)).
Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->  Q' ->> Q  -> {{P}} c {{Q}}.
Proof.
  intros P Q Q' c H1 H2.
  unfold hoare_triple in *.
  intros st st' c' Hpst.
  apply H2.
  apply (H1 st st' c' Hpst).
Qed.

Example hoare_asgn_example1 :
  {{True}} X := 1 {{X = 1}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_consequence_pre with (P' := (X = 1) [X |-> 1]).
  - apply hoare_asgn.
  - unfold "->>", assn_sub, t_update.
    intros st _. simpl. reflexivity.
Qed.

Example assn_sub_example2 :
  {{X < 4}} X := X + 1 {{X < 5}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_consequence_pre with (P' := (X < 5) [X |-> X + 1]).
  - apply hoare_asgn.
  - unfold "->>", assn_sub, t_update.
    intros st H. simpl in *. lia.
Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->  P ->> P' -> Q' ->> Q ->  {{P}} c {{Q}}.
Proof. intros.
  apply (hoare_consequence_pre) with (P' := P').
    - apply (hoare_consequence_post) with (Q' := Q').
      + apply H.
      + apply H1.
    - apply H0.
Qed.

(* Hints for auto tactic *)
Hint Unfold assert_implies hoare_triple assn_sub t_update : core.
Hint Unfold assert_of_Prop Aexp_of_nat Aexp_of_aexp : core.

Theorem hoare_consequence_pre''' : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->   P ->> P' ->  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple, "->>".
  intros P P' Q c Hhoare Himp st st' Heval Hpre.
  eapply Hhoare.
  - eassumption.
  - apply Himp. assumption.
Qed.

Theorem hoare_consequence_pre'''' : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->   P ->> P' ->  {{P}} c {{Q}}.
Proof. eauto. Qed.

Ltac assn_auto :=
  try auto; (* as in example 1, above *)
  try (unfold "->>", assn_sub, t_update;
       intros; simpl in *; lia). (* as in example 2 *)

Example assn_sub_ex1' :
  {{ X <= 5 }}  X := 2 * X  {{ X <= 10 }}.
Proof.
  eapply hoare_consequence_pre.
  - apply hoare_asgn.
  - assn_auto.
Qed.

Example assn_sub_ex2' :
  {{ 0 <= 3 /\ 3 <= 5 }}  X := 3  {{ 0 <= X /\ X <= 5 }}.
Proof.
  eapply hoare_consequence_pre.
  - apply hoare_asgn.
  - assn_auto.
Qed.

Theorem hoare_skip : forall P,
     {{P}} skip {{P}}.
Proof. unfold hoare_triple. intros P st st' Hcomm Hpst.
  inversion Hcomm; subst. assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} -> {{P}} c1 {{Q}} -> {{P}} c1; c2 {{R}}.
Proof. intros P Q R c1 c2 H1 H2. unfold hoare_triple in *. intros st st' Hcomm Hpst.
  inversion Hcomm; subst.
  eauto.
  (* eapply H1.
  apply H6.
  eapply H2.
  apply H3.
  apply Hpst. *)
Qed.

Example hoare_asgn_example3 : forall (a:aexp) (n:nat),
    {{a = n}}
  X := a;
  skip
    {{X = n}}.
Proof.
  intros a n.
  eapply hoare_seq.
  - (* right part of seq *)
    apply hoare_skip.
  - (* left part of seq *)
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + assn_auto.
Qed.

Example tst_seq_1 :
    {{ True }}
  X := 1;
  Y := 2
    {{X = 1 /\ Y = 2}}.
Proof.
  eapply hoare_seq with (Q := assert (X = 1)).
  - eapply hoare_consequence_pre with (P' := assert (X = 1 /\ Y = 2) [Y |-> 2]).
    + apply hoare_asgn.
    + assn_auto.
  - apply hoare_consequence_pre with (P' := (X = 1) [X |-> 1]).
    + apply hoare_asgn.
    + assn_auto.
Qed.

Definition swap_program : com :=
  <{ Z := X; X := Y; Y := Z }>.

Theorem swap_exercise :
  {{X <= Y}}
  swap_program
  {{Y <= X}}.
Proof.
  eapply hoare_seq with (Q := assert (Z <= Y)).
  - eapply hoare_seq with (Q := assert (Z <= X)).
    + apply hoare_consequence_pre with (P' := (Y <= X) [Y |-> Z]).
      * apply hoare_asgn.
      * assn_auto.
    + apply hoare_consequence_pre with (P' := (Z <= X) [X |-> Y]).
      * apply hoare_asgn.
      * assn_auto.
  - apply hoare_consequence_pre with (P' := (Z <= Y) [Z |-> X]).
    * apply hoare_asgn.
    * assn_auto.
Qed.

Theorem invalid_triple : ~ forall (a : aexp) (n : nat),
    {{ a = n }}
      X := 3; Y := a
    {{ Y = n }}.
Proof.
  unfold hoare_triple.
  intros H.
  specialize H with (a := X) (n := 0).
  simpl in *.
  assert (G: (X !-> 0) =[ X := 3; Y := X ]=> (Y !-> 3; X !-> 3; X !-> 0)). {
    eapply (E_Seq).
    apply E_Asgn.
    - simpl. reflexivity.
    - eapply E_Asgn.
      simpl. reflexivity.
  }
  assert (G': 3 = 0). {
    apply (H _ _ G).
    reflexivity.
  }
  discriminate G'.
Qed.

Definition bassn b : Assertion := fun st => (beval st b = true).
Coercion bassn : bexp >-> Assertion.
Arguments bassn /.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~((bassn b) st).
Proof. intros b st H. unfold not, bassn. intro H'.
  congruence. (* H and H' *) Qed.

Hint Resolve bexp_eval_false : core.

Theorem hoare_if : forall P Q (b:bexp) c1 c2,
  {{ P /\ b }} c1 {{Q}} ->
  {{ P /\ ~b}} c2 {{Q}} ->
  {{P}} if b then c1 else c2 end {{Q}}.
Proof. intros P Q b c1 c2. unfold hoare_triple.
  intros H1 H2 st st' Hif Hpst.
  inversion Hif; subst.
  - (* if true *)
    apply (H1 st st' H7). split; assumption.
  - (* if false *)
    apply (H2 st st' H7). split.
    + apply Hpst.
    + unfold not. simpl. intro Hcontra. congruence.
Qed.

Example if_example :
    {{True}}
  if (X = 0)
    then Y := 2
    else Y := X + 1
  end
    {{X <= Y}}.
Proof.
  apply hoare_if.
  - (* Then *)
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + assn_auto. (* no progress *)
      unfold "->>", assn_sub, t_update, bassn.
      simpl. intros st [_ H].
      apply eqb_eq in H.
      rewrite H. lia.
  - (* Else *)
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + assn_auto.
Qed.

Ltac assn_auto' :=
  unfold "->>", assn_sub, t_update, bassn;
  intros; simpl in *;
  try rewrite -> eqb_eq in *; (* for equalities *)
  auto; try lia.

Example if_example''' :
  {{True}}
  if X = 0
    then Y := 2
    else Y := X + 1
  end
  {{X <= Y}}.
Proof.
  apply hoare_if; eapply hoare_consequence_pre;
    try apply hoare_asgn; try assn_auto'.
Qed.

Ltac assn_auto'' :=
  unfold "->>", assn_sub, t_update, bassn;
  intros; simpl in *;
  try rewrite -> eqb_eq in *;
  try rewrite -> leb_le in *; (* for inequalities *)
  auto; try lia.

Theorem if_minus_plus :
  {{True}}
  if (X <= Y)
    then Z := Y - X
    else Y := X + Z
  end
  {{Y = X + Z}}.
Proof.
  apply hoare_if.
  - eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + assn_auto''.
  - eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + assn_auto''.
Qed.

Theorem hoare_while : forall P (b:bexp) c,
  {{P /\ b}} c {{P}} ->
  {{P}} while b do c end {{P /\ ~b}}.
Proof.
  intros P b c Hhoare st st' Heval HP.
  (* We proceed by induction on Heval, because, in the "keep looping" case,
     its hypotheses talk about the whole loop instead of just c. The
     remember is used to keep the original command in the hypotheses;
     otherwise, it would be lost in the induction. By using inversion
     we clear away all the cases except those involving while. *)
  remember <{while b do c end}> as original_command eqn:Horig.
  induction Heval;
    try (inversion Horig; subst; clear Horig);
    eauto.
Qed.

Module RepeatExercise.
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.

Notation "'repeat' e 'until' b 'end'" :=
     (CRepeat e b)
        (in custom com at level 0, e custom com at level 99, b custom com at level 99).
Notation "'skip'" :=
     (CSkip) (in custom com at level 0).
Notation "x := y" :=
     (CAsgn x y)
        (in custom com at level 0, x constr at level 0, y at level 85, no associativity).
Notation "x ; y" :=
     (CSeq x y)
        (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
     (CIf x y z)
        (in custom com at level 89, x at level 99, y at level 99, z at level 99).
Notation "'while' b 'do' e 'end'" :=
     (CWhile b e)
        (in custom com at level 89, b at level 99, e at level 99).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x := a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st =[ while b do c end ]=> st''
  | E_RepeatTrue : forall b st st' c,
      st =[ c ]=> st' ->
      beval st' b = true ->
      st =[ repeat c until b end ]=> st'
  | E_RepeatFalse : forall st st' st'' b c,
      st =[ c ]=> st' ->
      beval st' b = false ->
      st' =[ repeat c until b end ]=> st'' ->
      st =[ repeat c until b end ]=> st''

where "st '=[' c ']=>' st'" := (ceval st c st').

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st', st =[ c ]=> st' -> P st -> Q st'.

Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q) (at level 90, c custom com at level 99).

Definition ex1_repeat :=
  <{ repeat
       X := 1;
       Y := Y + 1
     until (X = 1) end }>.
Theorem ex1_repeat_works : empty_st =[ ex1_repeat ]=> (Y !-> 1 ; X !-> 1).
Proof.
  apply E_RepeatTrue.
  - apply (E_Seq) with (st' := (X !-> 1)).
    + constructor. reflexivity.
    + constructor. reflexivity.
  - reflexivity.
Qed.

Theorem hoare_repeat : forall P (b:bexp) c,
  {{P}} c {{P}} ->
  {{P}} repeat c until b end {{P /\ b}}.
Proof.
  intros P b c Hc st st' Hrepeat Hpst.
  remember <{ repeat c until b end }> as r eqn:Er.
  induction Hrepeat;
    try (discriminate Er);
    try (injection Er as Erc Erb; subst).
  - clear IHHrepeat. split.
    + apply (Hc st st' Hrepeat Hpst).
    + simpl. assumption.
  - apply IHHrepeat2.
    + reflexivity.
    + apply (Hc st st' Hrepeat1 Hpst).
Qed.

Search (?a /\ ?b <-> ?b /\ ?a).

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->   P ->> P' ->  {{P}} c {{Q}}.
Proof. Admitted.

Example tst:
 {{ X > 0 }}
  repeat
    Y := X;
    X := X - 1
  until X = 0 end
  {{ X = 0 /\ Y > 0 }}.
Proof. Admitted.
End RepeatExercise.

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

Notation "'havoc' l" := (CHavoc l)
                        (in custom com at level 60, l constr at level 0).
Notation "'skip'" := CSkip (in custom com at level 0).
Notation "x := y" :=
         (CAsgn x y)
          (in custom com at level 0, x constr at level 0, y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y)
          (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
          (in custom com at level 89, x at level 99, y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y)
          (in custom com at level 89, x at level 99, y at level 99).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x := a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st =[ while b do c end ]=> st''
  | E_Havoc : forall st X n,
      st =[ havoc X ]=> (X !-> n ; st)

where "st '=[' c ']=>' st'" := (ceval c st st').

Hint Constructors ceval : core.

Definition hoare_triple (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st', st =[ c ]=> st' -> P st -> Q st'.
Hint Unfold hoare_triple : core.

Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q) (at level 90, c custom com at level 99): hoare_spec_scope.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->  P ->> P' ->  {{P}} c {{Q}}.
Proof. eauto. Qed.

Definition havoc_pre (X : string) (Q : Assertion) (st : total_map nat) : Prop :=
  forall n, Q (X !-> n; st).

Theorem hoare_havoc : forall (Q : Assertion) (X : string),
  {{ havoc_pre X Q }} havoc X {{ Q }}.
Proof.
  intros Q X st st' Hhavok Hqpre.
  inversion Hhavok; subst.
  apply Hqpre.
Qed.

Theorem havoc_post : forall (P : Assertion) (X : string),
  {{ P }} havoc X {{ fun st => exists (n:nat), P [X |-> n] st }}.
Proof.
  intros P X. eapply hoare_consequence_pre.
  - apply hoare_havoc.
  - intros st Hpst npre.
    exists (st X).
    unfold assn_sub. simpl.
    assert (G: (X !-> st X; X !-> npre; st) = st). {
      apply functional_extensionality.
      intro x. unfold t_update, eqb_string.
      destruct (string_dec X x) as [ H | H ]; subst; reflexivity.
    }
    rewrite G. assumption.
Qed.

End Himp.

Module HoareAssertAssume.

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

Notation "'assert' l" := (CAssert l) (in custom com at level 8, l custom com at level 0).
Notation "'assume' l" := (CAssume l) (in custom com at level 8, l custom com at level 0).
Notation "'skip'" :=  CSkip (in custom com at level 0).
Notation "x := y" := (CAsgn x y)
           (in custom com at level 0, x constr at level 0, y at level 85, no associativity).
Notation "x ; y" := (CSeq x y)
           (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" := (CIf x y z)
           (in custom com at level 89, x at level 99, y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" := (CWhile x y)
           (in custom com at level 89, x at level 99, y at level 99).

Inductive result : Type :=
  | RNormal : state -> result
  | RError : result.

Inductive ceval : com -> state -> result -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> RNormal st
  | E_Asgn : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x := a1 ]=> RNormal (x !-> n ; st)
  | E_SeqNormal : forall c1 c2 st st' r,
      st =[ c1 ]=> RNormal st' ->
      st' =[ c2 ]=> r ->
      st =[ c1 ; c2 ]=> r
  | E_SeqError : forall c1 c2 st,
      st =[ c1 ]=> RError ->
      st =[ c1 ; c2 ]=> RError
  | E_IfTrue : forall st r b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> r ->
      st =[ if b then c1 else c2 end ]=> r
  | E_IfFalse : forall st r b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> r ->
      st =[ if b then c1 else c2 end ]=> r
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> RNormal st
  | E_WhileTrueNormal : forall st st' r b c,
      beval st b = true ->
      st =[ c ]=> RNormal st' ->
      st' =[ while b do c end ]=> r ->
      st =[ while b do c end ]=> r
  | E_WhileTrueError : forall st b c,
      beval st b = true ->
      st =[ c ]=> RError ->
      st =[ while b do c end ]=> RError
  | E_AssertTrue : forall st b,
      beval st b = true ->
      st =[ assert b ]=> RNormal st
  | E_AssertFalse : forall st b,
      beval st b = false ->
      st =[ assert b ]=> RError
  | E_Assume : forall st b,
      beval st b = true ->
      st =[ assume b ]=> RNormal st
where "st '=[' c ']=>' r" := (ceval c st r).

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st r, st =[ c ]=> r   ->   P st   ->   (exists st', r = RNormal st' /\ Q st').

Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q) (at level 90, c custom com at level 99) : hoare_spec_scope.

Theorem assert_assume_differ : exists (P:Assertion) b (Q:Assertion),
       ({{P}} assume b {{Q}}) /\ ~({{P}} assert b {{Q}}).
Proof.
  exists True.
  exists <{ false }>.
  exists True.
  split.
  - unfold hoare_triple. intros st r Hcom Ht.
    inversion Hcom; subst. simpl in *. (* Actually H0 is contra, but continue *)
    exists st.
    split; reflexivity.
  - unfold hoare_triple. intro H.
    assert (forall st r, st =[ assert false ]=> r -> r = RError). {
      intros st r H'.
      inversion H'; subst. simpl in *.
      - discriminate H1.
      - reflexivity.
    }

    destruct (H (t_empty 0) RError).
    + apply E_AssertFalse.
      simpl. reflexivity.
    + simpl. apply I.
    + destruct H1 as [Hcontr _ ].
      discriminate Hcontr.
Qed.

Theorem assert_implies_assume : forall P b Q,
     ({{P}} assert b {{Q}}) -> ({{P}} assume b {{Q}}).
Proof.
  intros P b Q H st st' Hcom Hpst.
  destruct (beval st b) eqn:Eb.
  - destruct (H st (RNormal st)).
    + apply E_AssertTrue.
      apply Eb.
    + assumption.
    + inversion Hcom; subst; simpl in *.
      destruct H0 as [H1' H2'].
      injection H1' as Hk.
      subst.
      exists x.
      split; try reflexivity.
      assumption.
  - inversion Hcom; subst; simpl in *.
    congruence.
Qed.

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} X := a {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  exists (X !-> aeval st a ; st). split; try reflexivity.
  assumption. Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} -> P ->> P' -> {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->  Q' ->> Q ->  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st r Hc HP.
  unfold hoare_triple in Hhoare.
  assert (exists st', r = RNormal st' /\ Q' st').
  { apply (Hhoare st); assumption. }
  destruct H as [st' [Hr HQ'] ].
  exists st'. split; try assumption.
  apply Himp. assumption.
Qed.

Theorem hoare_seq : forall P Q R c1 c2,
  {{Q}} c2 {{R}} ->  {{P}} c1 {{Q}} ->  {{P}} c1;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st r H12 Pre.
  inversion H12; subst.
  - eapply H1.
    + apply H6.
    + apply H2 in H3. apply H3 in Pre.
        destruct Pre as [st'0 [Heq HQ] ].
        inversion Heq; subst. assumption.
  - (* Find contradictory assumption *)
     apply H2 in H5. apply H5 in Pre.
     destruct Pre as [st' [C _] ].
     inversion C.
Qed.

Theorem hoare_assert: forall P (b: bexp), {{ b /\ P }} assert b {{ b /\ P }}.
Proof.
  intros P b st st' Hcom [Hb Hpst].
  inversion Hcom; subst. simpl in *.
  - exists st. split.
    + reflexivity.
    + split; assumption.
  - simpl in Hb. congruence.
Qed.

Theorem hoare_assume: forall P (b: bexp), {{ P }} assume b {{ b /\ P }}.
Proof.
  intros P b st st' Hcom Hpst.
  inversion Hcom; subst. simpl in *.
  exists st. split.
  + reflexivity.
  + split; assumption.
Qed.

Theorem hoare_skip : forall P, {{P}} skip {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  eexists. split. reflexivity. assumption.
Qed.

Theorem hoare_if : forall P Q (b:bexp) c1 c2,
  {{ P /\ b}} c1 {{Q}} ->
  {{ P /\ ~b}} c2 {{Q}} ->
  {{P}} if b then c1 else c2 end {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  - (* b is true *)
    apply (HTrue st st').
      assumption.
      split. assumption. assumption.
  - (* b is false *)
    apply (HFalse st st').
      assumption.
      split. assumption.
      apply bexp_eval_false. assumption. Qed.

Theorem hoare_while : forall P (b:bexp) c,
  {{P /\ b}} c {{P}} -> {{P}} while b do c end {{ P /\ ~b}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember <{while b do c end}> as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  - (* E_WhileFalse *)
    eexists. split. reflexivity. split.
    assumption. apply bexp_eval_false. assumption.
  - (* E_WhileTrueNormal *)
    clear IHHe1.
    apply IHHe2. reflexivity.
    clear IHHe2 He2 r.
    unfold hoare_triple in Hhoare.
    apply Hhoare in He1.
    + destruct He1 as [st1 [Heq Hst1] ].
        inversion Heq; subst.
        assumption.
    + split; assumption.
  - (* E_WhileTrueError *)
     exfalso. clear IHHe.
     unfold hoare_triple in Hhoare.
     apply Hhoare in He.
     + destruct He as [st' [C _] ]. inversion C.
     + split; assumption.
Qed.

Example assert_assume_example:
  {{True}}
  assume (X = 1);
  X := X + 1;
  assert (X = 2)
  {{True}}.
Proof.
  apply hoare_seq with (Q:= (X = 1 /\ True)%assertion).
  - apply hoare_seq with (Q:= (X = 2 /\ True)%assertion).
    + eapply hoare_consequence_pre.
      eapply hoare_consequence_post.
      apply (hoare_assert True <{X = 2}>).
      * intros st [_ H]. assumption.
      * intros st [H1 H2]. simpl in *. rewrite H1. split; reflexivity.
    + eapply hoare_consequence_pre.
      apply hoare_asgn.
      unfold "->>", assn_sub, t_update, bassn. simpl. intros st [H1 _]. rewrite H1. split; reflexivity.
  - eapply hoare_consequence_post.
    apply (hoare_assume True <{X = 1}>).
    intros st [H1 _].
    apply beq_nat_true in H1.
    split.
    + assumption.
    + apply I.
Qed.

End HoareAssertAssume.


Inductive list (X : Type) : Type :=
    | Nil
    | Cons (h : X) (t : list X).

Notation "[]" := Nil.
Notation "h :: t" := (Cons h t).

Inductive node (V : Type) : Type :=
    | None
    | Node (self : V) (n : list (node V)).

Inductive graph (V : Type) : Type :=
    | E
    | G (nodes : list (node V)).


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

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

Print Assumptions carry.


Parameter type : Type.
Parameter Bool : type.
Parameter Arrow : type -> type -> type.

Inductive term (V : type -> Type) : type -> Type :=
| Var : forall (tau : type), (V tau) -> (term V) tau
| Tr : (term V) Bool
| Fa : (term V) Bool
| App : forall (tau1 tau2 : type), (term V) (Arrow tau1 tau2) -> (term V) tau1 -> (term V) tau2
| Abs : forall (tau1 tau2 : type), (V tau1) -> term V tau2 -> term V (Arrow tau1 tau2).

Fixpoint even (n : nat) : Prop :=
  match n with
    | O => True
    | S n' => odd n'
  end
with
  odd (n : nat) : Prop :=
  match n with
    | O => False
    | S n' => even n'
  end.

Eval compute in (even 3).
Eval compute in (odd 3).

Fixpoint odd2 (n : nat) : bool :=
  match n with
    | O => false
    | S n' =>
      (fun (f : nat -> bool) (m : nat) =>
        match m with
          | O => true
          | S m => f m
        end) odd2 n'
  end.

Fixpoint even2 (n : nat) : bool :=
  match n with
    | O => true
    | S n' =>
      (fun (f : nat -> bool) (m : nat) =>
        match m with
          | O => false
          | S m => f m
        end) even2 n'
  end.

Extraction even2.

Eval compute in (odd2 4).

CoInductive T : Prop :=
| C : forall (A:Prop), A-> ~A ->T.

(* The type T is equivalent to (EX A | A & ~A), so it is empty *)
Lemma empty : ~T.
  unfold not ; intro H ; case H ; intros ; absurd A ; auto.
Qed.

(* But there is a circular proof of T resulting from the quantification over T
in the constructor of T. *)
Inductive n : Set :=
| z : n
| s : n -> n.

Extraction n_typ_ind.

CoFixpoint u : T := (C T u empty).

Parameter (A:Set) (P Q: (A -> Prop)).

Lemma lm3 : (exists x, (forall R: A -> Prop, R x)) -> 2 = 3.
Proof.
  intro H.


Require Import CT.Category.
Require Import CT.Functor.

(** Product category. *)
Program Definition ProductCategory (C D : Category) : Category :=
  {| ob := (@ob C * @ob D);
     mor := fun x y => (mor (fst x) (fst y) * mor (snd x) (snd y))%type;
     comp := fun _ _ _ x y => (comp (fst x) (fst y), comp (snd x) (snd y));
     id := fun x => (id (fst x), id (snd x))
  |}.
Next Obligation.
  rewrite assoc.
  rewrite assoc.
  reflexivity.
Qed.
Next Obligation.
  symmetry.
  apply ProductCategory_obligation_1.
Qed.
Next Obligation.
  rewrite id_left.
  rewrite id_left.
  reflexivity.
Qed.
Next Obligation.
  rewrite id_right.
  rewrite id_right.
  reflexivity.
Qed.

(** * Projection functors from [ProductCategory] to one of its components *)
Program Definition ProductCategory_p1 (C D : Category) :
  Functor (ProductCategory C D) C :=
  {| F_ob := fst; |}.

Program Definition ProductCategory_p2 (C D : Category) :
  Functor (ProductCategory C D) D :=
  {| F_ob := snd; |}.


Require Import Init.

Open Scope type_scope.

(** この定義は出来ない。prodはcoqでのタプル。 *)
Fail Inductive object (F G : Type -> Type) : Type :=
| obj_C : (forall A, F A -> G (prod A (object F G))) -> object F G.

(** 上記の定義ができない理由を示す。

もしこの型が定義出来てしまうと以下のような関数が書けてしまう。

Definition Ω (x : wrong) : nat :=
 match x with
 | wrong_C f => f x
 end.

これは停止しない。Coqは停止しない関数を定義することが出来ないように作られているからこれはいけない。

上記の型に対しても同様で、Gをうまく選ぶとwrongと同様に停止しない関数を定義することが出来てしまう。

*)
Fail Inductive wrong : Type :=
| wrong_C : (wrong -> nat) -> wrong.

(** 上記の減少を防ぐ方法を提案する。

上記の型が帰納的に使われている位置を見てみると、これはcontravariantな位置である。
つまり、functorな位置であればこの問題は発生しないことになる。
つまり、objectの場合ではGがfunctorしか受け取れないようにすればよい。
coyonedaを使ってたとえcontravariantな型が渡されても無理やりfunctorに変えればよい。

*)
Inductive coyoneda (F : Type -> Type) (A : Type) : Type :=
| coyoneda_C : forall X, (X -> A) -> F X -> coyoneda F A.

Definition coyoneda_map F A B : (A -> B) -> coyoneda F A -> coyoneda F B.
Proof.
 intros f [X g x].
 apply coyoneda_C with X; auto.
Defined.

(** coyonedaを使ってもまだ問題があることを示す。

重複した名前を使いたいため、Moduleを使う。

*)
Module WObject.
 (** coyonedaによる問題の解決 *)
 Inductive object (F G : Type -> Type) : Type :=
 | object_C : (forall A, coyoneda F A -> coyoneda G (A * object F G)) -> object F G.

 (** 合成が定義できない理由を示す。

 まず、この関数は妥協している。本当はこれをfix(Haskellでの)を使ったりして完成させたいのだが、
 出来ないようだ。

 さらにこの妥協の産物でさえ型の再帰が含まれるせいなのかUniverse Polymorphismが必要である。
 *)
 Definition object_compose_F F G H
  : (object F G -> object G H -> object F H) -> object F G -> object G H -> object F H.
 Proof.
  intros k [x] [y].
  apply object_C.
  intros A z.
  apply coyoneda_map with ((A * object F G) * object G H).
  -
   intros [[a m] n].
   split.
   +
    apply a.
   +
    apply k.
    *
     apply m.
    *
     apply n.
  -
   Fail apply y.
(* apply x.
   apply z.
  Defined. *)
  Abort.
End WObject.

(** 上で示した問題の解決策を示す。

上で示した問題はobjectに限らず、mealy machineでも発生する。その解決策としてStreamを使うことが出来る。 *)
CoInductive stream (A : Type) : Type :=
| s_cons : A -> stream A -> stream A.

(** objectに対するメッセージの列 *)
CoInductive messages (F : Type -> Type) : stream Type -> Type :=
| m_cons : forall (A : Type) (AS : stream Type),
           coyoneda F (A * messages F AS) -> messages F (s_cons Type A AS).

(** このようにobjectは定義される *)
Definition object F G S := messages F S -> messages G S.


Require Import ZArith.
Require Import List.
Require Import FMapPositive.
Require Import String.
Open Scope string_scope.

Require Import domains.

(*
Notation "'□' '+' e" := (Fplusl e) (at level 50) : k_scope.
Notation "e '+' '□'" := (Fplusr e) (at level 50) : k_scope.
 *)

Notation "[ x ; .. ; y ]" := (@cons Ast x .. (@cons Ast y (@nil Ast)) ..) (at level 0).

Notation FreezeL l e := (KFreezer (fun x => AApp l [x ; e])).
Notation FreezeR l e := (KFreezer (fun x => AApp l [e ; x])).

Notation "'□' '+' e" := (FreezeL EPlus e) (at level 50) : k_scope.
Notation "e '+' '□'" := (FreezeR EPlus e) (at level 50) : k_scope.
Notation "'□' '-' e" := (FreezeL EMinus e) (at level 50) : k_scope.
Notation "e '-' '□'" := (FreezeR EMinus e) (at level 50) : k_scope.
Notation "'□/' e" := (FreezeL EDiv e) (at level 50): k_scope.
Notation "e '/□'" := (FreezeR EDiv e) (at level 50): k_scope.
Notation "'□' '<=' e" := (FreezeL BLe e) (at level 70): k_scope.
Notation "i '<=' '□'" := (FreezeR BLe i) (at level 70): k_scope.
Notation "'□' '&&' e" := (FreezeL BAnd e) (at level 50): k_scope.
Notation "v ':=□'" := (FreezeR SAssign v) (at level 70): k_scope.
Notation "'if□then' s1 'else' s2" := (KFreezer (fun b => AApp SIf (b :: s1 :: s2 :: nil))) (at level 20): k_scope.

Delimit Scope k_scope with K.
Open Scope k_scope.

Coercion AApp : label >-> Funclass.
Coercion AId : string >-> Ast.
Coercion ABool : bool >-> Ast.
Coercion AInt : Z >-> Ast.
Coercion KAst : Ast >-> kitem.

Set Implicit Arguments.

Notation exp_step step a b :=
  (forall env henv lenv, step (KCfg a env henv lenv) (KCfg b env henv lenv)) (only parsing).

Notation exp1_step step a b := (forall rest, exp_step step (kra a rest) (kra b rest)) (only parsing).

Notation heat_step step cool hot ctx :=
  (forall rest, exp_step step (kra cool rest) (kra hot (kra ctx rest))).
Notation cool_step step hot ctx cool :=
  (forall rest, exp_step step (kra hot (kra ctx rest)) (kra cool rest)).

Generalizable Variables l f rest env erest henv lenv x y i j v r e es b s.
Inductive kstep : kcfg -> kcfg -> Prop :=
  (* evaluation rules *)
  | k_lookup : `(env ~= (x |-> i :* erest) ->
                 kstep (KCfg (kra (x : string) rest) env henv lenv)
                       (KCfg (kra (i : Z) rest) (x |-> i :* erest) henv lenv))
  | k_assign : `(env ~= (x |-> v :* erest) ->
                 kstep (KCfg (kra (SAssign [x : string ; i : Z]) rest) env henv lenv)
                       (KCfg (kra (Skip nil) rest) (x |-> i :* erest) henv lenv))
  | k_jump : `(forall (l : string),
                 lenv ~= (l |-> s :* erest) ->
                 kstep (KCfg (kra (Jump [l]) rest) env henv lenv)
                       (KCfg (kra s kdot) env henv lenv))
  | k_eval_hook_zzz : `(hook l = Some (Z_Z_Z f) ->
                        exp1_step kstep (AApp l [i : Z ; j : Z])
                                        (f i j))
  | k_eval_hook_zzb : `(hook l = Some (Z_Z_bool f) ->
                        exp1_step kstep (AApp l [i : Z ; j : Z])
                                        (f i j))
  | k_eval_hook_bb : `(hook l = Some (bool_bool f) ->
                        exp1_step kstep (AApp l [b : bool])
                                        (f b))
  | k_div : `(Zneq_bool 0%Z j = true ->
               exp1_step kstep (EDiv [i : Z ; j : Z])
                               (Zdiv i j))
  | k_and_t : `(exp1_step kstep (BAnd [true ; b])
                                b)
  | k_and_f : `(exp1_step kstep (BAnd [false ; b])
                                false)
  | k_skip: `(exp_step kstep (kra (Skip nil) rest)
                             rest)
  | k_if_t : `(exp1_step kstep (SIf [true ; s1 ; s2])
                               s1)
  | k_if_f : `(exp1_step kstep (SIf [false ; s1 ; s2])
                         s2)
  | k_while : `(exp1_step kstep (SWhile [b ;  s])
                                (SIf [b ; Seq [s ; SWhile [b ; s]] ; Skip nil]))
  | k_seq : `(heat_step kstep (Seq [s1; s2]) s1 s2)
  (* heating and cooling by label *)
  | k_cool_e : `(cool_step kstep (i : Z) (KFreezer e) (e i))
  | k_cool_b : `(cool_step kstep (b : bool) (KFreezer e) (e b))
  | k_heat_1 : `(isVal e = false -> is_strict1 l = true ->
                 heat_step kstep (AApp l (e :: es)) e (KFreezer (fun e' => AApp l (e' :: es))))
  | k_heat_2 : `(orb (negb (is_sequential l))
                     (orb (negb (is_strict1 l)) (isVal e)) = true ->
                 isVal e2 = false -> is_strict2 l = true ->
                 heat_step kstep (AApp l (e :: e2 :: es)) e2 (KFreezer (fun e2' => AApp l (e :: e2' :: es))))
  (* seq *)
  .

Fixpoint str_split k {V} m : option (V * Map string V) :=
  match m with
    | mapEmpty => None
    | (k' |-> v) => if string_dec k k' then Some (v, mapEmpty) else None
    | (l :* r) =>
      match str_split k l with
        | Some (v, mapEmpty) => Some (v, r)
        | Some (v, l') => Some (v, l' :* r)
        | None =>
          match str_split k r with
            | Some (v, r') => Some (v, l :* r')
            | None => None
          end
      end
  end.

Lemma str_split_sound k {V} (v : V) m m' :
  str_split k m = Some (v, m') -> m ~= k |-> v :* m'.
Proof with try discriminate.
revert m'; induction m; simpl; intros...
destruct (string_dec k k0) as [->|]...
injection H; intros; subst; clear H.
rewrite equivUnit; reflexivity.
destruct (str_split k m1) as [[v1 m'']|].
destruct m'';
(injection H; intros; subst; clear H);
rewrite (IHm1 _ (eq_refl _)), ?equivUnit, ?equivAssoc; reflexivity.
destruct (str_split k m2) as [[v1 m'']|];try discriminate.
destruct m'';
(injection H; intros; subst; clear H);
rewrite (IHm2 _ (eq_refl _)), equivComAssoc, ?equivUnit; reflexivity.
Qed.

Fixpoint notFree' {K} (used : list K) {V} (m : Map K V) (cont : list K -> Prop) {struct m} : Prop :=
  match m with
    | mapEmpty => cont used
    | k' |-> _ => ~ In k' used /\ cont (k' :: used)
    | l :* r => notFree' used l (fun used' => notFree' used' r cont)
  end.
Definition defined {K V} (m : Map K V) : Prop := notFree' nil m (fun _ => True).

(* want to show completeness on defined maps
Lemma str_split_complete : forall k {V} (v : V) m m', m ~= k |-> v :* m' ->
                                                      exists m'', str_split k m = Some (v, m')
                                                                  /\ m'' ~= m'.
 *)
(*
Definition eval cfg : option kcfg :=
  match cfg with
    | KCfg nil env heap lenv => None
    | KCfg (item1 :: rest) env heap lenv =>
      let exp_step e' := Some (KCfg e' env heap lenv) in
      let heat_step e' f := exp_step (kra e' (kra f rest)) in
      let exp1_step e' := exp_step (e' :: rest) in
      match item1 with
        | AInt i =>
          match rest with
            | (KFreezer f :: rest') => exp_step (f (AInt i) :: rest')
            | _ => None
          end
        | ABool b =>
          match rest with
            | (KFreezer f :: rest') => exp_step (f (ABool b) :: rest')
            | _ => None
          end
        | AId x =>
          match str_split x env with
            | None => None
            | Some (v,env') => Some (KCfg (kra v rest) (x |-> v :* env') heap lenv)
          end
        | AApp SAssign (AId x :: AInt i :: nil) =>
          match str_split x env with
            | None => None
            | Some (_, env') => Some (KCfg (kra (Skip nil) rest) (x |-> i :* env') heap lenv)
          end
        | AApp SAssign (x  :: e :: nil) => heat_step e (x :=□)
        | AApp Jump (AId l :: nil) =>
          match str_split l lenv with
            | None => None
            | Some (s, _) => Some (KCfg (kra s kdot) env heap lenv)
          end
        | AApp EPlus (AInt i :: AInt j :: nil) => exp1_step (Zplus i j)
        | AApp EPlus (AInt i :: e2 :: nil)     => heat_step e2 (i + □)
        | AApp EPlus (e1 :: e2 :: nil)         => heat_step e1 (□ + e2)
        | AApp EMinus (AInt i :: AInt j :: nil) => exp1_step (Zminus i j)
        | AApp EMinus (AInt i :: e2 :: nil)     => heat_step e2 (i - □)
        | AApp EMinus (e1 :: e2 :: nil)         => heat_step e1 (□ - e2)
        | AApp EDiv (AInt i :: AInt j :: nil) =>
          if Zneq_bool 0%Z j then exp1_step (Zdiv i j) else None
        | AApp EDiv (AInt i :: e2 :: nil)       => heat_step e2 (i /□)
        | AApp EDiv (e1 :: e2 :: nil)           => heat_step e1 (□/ e2)
        | AApp BLe (AInt i :: AInt j :: nil) => exp1_step (Zle_bool i j)
        | AApp BLe (AInt i :: e2 :: nil)     => heat_step e2 (i <= □)
        | AApp BLe (e1 :: e2 :: nil)         => heat_step e1 (□ <= e2)
        | AApp BAnd (ABool b :: be2 :: nil) => if b then exp1_step be2 else exp1_step false
        | AApp BAnd (be1 :: be2 :: nil) => heat_step be1 (□ && be2)
        | AApp Skip nil => exp_step rest
        | AApp SIf (ABool b :: s1 :: s2 :: nil) => if b then exp1_step s1 else exp1_step s2
        | AApp SIf (be :: s1 :: s2 :: nil) => heat_step be (if□then s1 else s2)
        | AApp SWhile (b :: s :: nil) => exp1_step (SIf [b; Seq [s; SWhile [b; s]]; Skip nil])
        | AApp Seq (s1 :: s2 :: nil)=> heat_step s1 s2

        | _ => None
         (* unimplemented *)
      end
end.

(*
(* Way slower in labled form! Perhaps completeness is easier? *)
Functional Scheme eval_ind := Induction for eval Sort Prop.

Lemma eval_sound : forall cfg, match eval cfg with Some cfg' => kstep cfg cfg' | None => True end.
Proof.
intros.
functional induction (eval cfg);try econstructor(reflexivity || assumption ||
match goal with [H : str_split _ _ = _ |- _] => apply str_split_sound in H;eassumption end).
Qed.
*)

Axiom str_split_complete : forall V h (x : string) (v : V) h', h ~= x |-> v :* h' -> str_split x h = Some (v, h').

Lemma eval_complete : forall cfg cfg', kstep cfg cfg' -> eval cfg <> None.
destruct 1; simpl; try discriminate;
try (match goal with [H : _ ~= _|-_] => apply str_split_complete in H;rewrite H end);
try match goal with [H : ?l = _ |- context [?l]] => rewrite H end;
try discriminate;
try solve[match goal with [H : isVal ?e = false |- _] => destruct e;discriminate end].
destruct e; try discriminate; destruct e2; discriminate.
destruct e; try discriminate; destruct e2; discriminate.
destruct e; try discriminate; destruct e2; discriminate.
destruct x; try discriminate; destruct e; discriminate.
Qed.

*)

Definition kequiv (k1 k2 : kcfg) : Prop :=
  match k1, k2 with
    | KCfg k1 store1 heap1 labels1,
      KCfg k2 store2 heap2 labels2 =>
      k1 = k2 /\ store1 ~= store2 /\ heap1 ~= heap2 /\ labels1 ~= labels2
  end.

CoInductive steps : kcfg -> kcfg -> Prop :=
  | done : forall c1 c2, kequiv c1 c2 -> steps c1 c2
  | more : forall c1 c2 c3, kstep c1 c2 -> steps c2 c3 -> steps c1 c3
  .

Ltac find x map k :=
  match map with
    | (x |-> _ :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* (x |-> ?v)) => let pf := constr:(equivComm mapl (x |-> v)) in k pf
    | ?mapl :* ?mapr =>
           find x mapl ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc (x |-> _) _ mapr))
                                        in k pf)
        || find x mapr ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl (x |-> _) _))
                                        in k pf)
  end.
Ltac find_submap map submap k :=
  match map with
    | (submap :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* submap) => let pf := constr:(equivComm mapl submap) in k pf
    | ?mapl :* ?mapr =>
           find_submap mapl submap

                       ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc submap _ mapr))
                                        in k pf)
        || find_submap mapr submap
                       ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl submap _))
                                        in k pf)
  end.

Ltac find_map_entry :=
  match goal with
    | [|- ?map ~= _ ] =>
      ((is_var map;
       match goal with
         | [H : ?map ~= ?mapr |- ?map ~= _] =>
           match mapr with
             | map => fail
             | _ => rewrite H
           end
       end)
        || (try (unfold map)));
      match goal with
        | [|- ?x |-> ?v ~= ?x |-> _ :* _] => rewrite (equivUnit (x |-> v)); reflexivity
        | [|- ?map ~= ?x |-> ?v :* ?map2 ] =>
          find x map ltac:(fun pf => exact pf)
      end
  end.

Ltac equate_maps := rewrite ?equivAssoc, ?equivUnitL, ?equivUnit;
 repeat (rewrite ?f_equal;
         match goal with
           | [|- (?x |-> ?v1 :* _) ~= (?x |-> ?v2 :* _)] => apply equivJoin;[replace v1 with v2 by omega|]
           | [|- MapEquiv ?map (?x |-> _ :* _)] => find x map ltac:(fun pf => rewrite pf)
           | [|- MapEquiv ?map (?submap :* _)] => find_submap map submap ltac:(fun pf => rewrite pf)
           | [|- MapEquiv ?map ?map ] => reflexivity
         end).

Ltac finish :=
  apply done;repeat (apply conj);[reflexivity|simpl;equate_maps ..].

Ltac step_rule := eapply more;[econstructor (reflexivity || find_map_entry)|].

Lemma eval_happy : forall env,
  steps (KCfg (kra (SAssign ["x" ; EPlus [ "x" ; "y" ]]) nil)
            (env :* "x" |-> 12%Z :* "y" |-> 13%Z) mapEmpty mapEmpty)
        (KCfg nil (env :* "x" |-> 25%Z :* "y" |-> 13%Z) mapEmpty mapEmpty).
intros; repeat step_rule; finish.
Qed.

(* Try "quote" on the env *)
(* Use a mixed coinductive sequencing to use loop invariants? *)

Lemma eval_happy' : forall env,
  steps (KCfg (kra (SAssign "x" (EPlus (EVar "x") (EVar "y"))) nil)
            ("x" |-> 12%Z :* "y" |-> 13%Z :* env) mapEmpty mapEmpty)
        (KCfg nil ("x" |-> 25%Z :* "y" |-> 13%Z :* env) mapEmpty mapEmpty).
intros;
repeat (eapply more;[match goal with [|- kstep ?l _] => eapply (eval_sound l) end|]);
simpl Zplus; finish.
Qed.

Lemma loop_test':
  steps (KCfg (kra (SWhile (BLe (ECon 0) (EVar "x"))
    (SAssign "x" (EPlus (EVar "x") (ECon (-1)%Z))))
  nil) ("x" |-> 25%Z) mapEmpty mapEmpty)
  (KCfg nil ("x" |-> (-1)%Z) mapEmpty mapEmpty).
Proof.
Ltac step_eval :=eapply more;[match goal with [|- kstep ?l _] => eapply (eval_sound l) end|].
intros;repeat step_eval;simpl;finish.
Qed.

Function evals n kcfg :=
  match n with
    | 0 => kcfg
    | S n =>
      match eval kcfg with
      | Some kcfg' => evals n kcfg'
      | None => kcfg
     end
  end.
Lemma evals_sound :
  forall n c1 c2,
    kequiv (evals n c1) c2 -> steps c1 c2.
Proof.
induction n; simpl; intros c1 c2.
apply done.
pose proof (eval_sound c1).
destruct (eval c1).
intro.
apply more with k.
assumption. apply IHn. assumption.
apply done.
Qed.

Lemma loop_test'':
  steps (KCfg (kra (SWhile (BLe (ECon 0) (EVar "x"))
    (SAssign "x" (EPlus (EVar "x") (ECon (-1)%Z))))
  nil) ("x" |-> 25%Z) mapEmpty mapEmpty)
  (KCfg nil ("x" |-> (-1)%Z) mapEmpty mapEmpty).
Proof.
intros;apply (evals_sound 1000);lazy;repeat (apply conj);[reflexivity|simpl;equate_maps ..].
Qed.

Lemma loop_test:
  steps (KCfg (kra (SWhile (BLe (ECon 0) (EVar "x"))
    (SAssign "x" (EPlus (EVar "x") (ECon (-1)%Z))))
  nil) ("x" |-> 25%Z) mapEmpty mapEmpty)
  (KCfg nil ("x" |-> (-1)%Z) mapEmpty mapEmpty).
Proof.
intros;
repeat (eapply more;[econstructor (reflexivity || find_map_entry)|];instantiate;simpl Zplus);
finish.
Qed.

Ltac split_if :=
  match goal with
      | [|- steps (KCfg (kra (KStmt (SIf (BCon (?x <=? ?y)%Z) _ _)) _) _ _ _) _] =>
        pose proof (Zle_cases x y); destruct (x <=? y)%Z
  end.

(* Either solve immediately by using the circularity,
   or bail out for manual intervention if the
   circularity matches structurally *)
Ltac use_circ circ :=
  solve[eapply circ;
  try (match goal with [|- _ ~= _] => equate_maps;reflexivity end);
  instantiate;  omega]
  || (eapply circ;fail 1).

Ltac run_circ circ := repeat (use_circ circ || (step_rule || split_if || finish)).

CoFixpoint sum :
  forall (x y z : Z) erest env heap labels,
    (0 <= x)%Z ->
    z = (x + y)%Z ->
    env ~= ("i" |-> x :* "j" |-> y :* erest) ->
  steps
    (KCfg (kra (SWhile (BLe (ECon 1%Z) (EVar "i"))
                       (Seq
                          (SAssign "i" (EPlus (EVar "i") (ECon (-1)%Z)))
                          (SAssign "j" (EPlus (EVar "j") (ECon 1%Z)))))
               kdot)
                env heap labels)
    (KCfg kdot
          ("i" |-> 0%Z :* "j" |-> z%Z :* erest) heap labels).
intros;step_rule;run_circ sum.
Qed.

Coercion EVar : string >-> Exp.

Definition gcdProg : Map string Stmt :=
  "gcd" |->
        SIf (BLe "a" "b")
          (SIf (BLe "b" "a")
               (Jump "done")
               (Seq (SAssign "b" (EMinus "b" "a"))
                    (Jump "gcd")))
          (Seq (SAssign "a" (EMinus "a" "b"))
               (Jump "gcd")).

Lemma label_eval : forall env,
  steps (KCfg (kra (Jump "gcd") kdot)
            (env :* "a" |-> 12%Z :* "b" |-> 13%Z) mapEmpty gcdProg)
        (KCfg (kra (Jump "done") kdot)
             (env :* "a" |-> 1%Z :* "b" |-> 1%Z) mapEmpty gcdProg).
intros; do 307 step_rule;simpl Zminus; finish.
Qed.