From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime P A B C D A1 B1 C1 D1 C1prime K : Universe, ((wd_ O E /\ (wd_ P B /\ (wd_ A B /\ (wd_ K O /\ (wd_ O A1 /\ (wd_ K A1 /\ (wd_ C1prime O /\ (wd_ C1prime A1 /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ A C /\ (wd_ P C /\ (wd_ O C1 /\ (wd_ O B1 /\ (wd_ A1 Eprime /\ (wd_ Eprime K /\ (col_ P A B /\ (col_ P C D /\ (col_ O E A1 /\ (col_ O E B1 /\ (col_ O E C1 /\ (col_ O E D1 /\ col_ O C1 C1prime))))))))))))))))))))))) -> col_ O C1 A1)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Cprime P Q : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ P Q /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ C Cprime /\ (wd_ A P /\ (wd_ A Q /\ (wd_ Aprime Aprime /\ (wd_ B Cprime /\ (wd_ Aprime C /\ (col_ Aprime P Q /\ (col_ Cprime P Q /\ (col_ A B C /\ col_ A B Aprime)))))))))))))))) -> col_ Aprime B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Strings.String.
Import Coq.Lists.List.ListNotations.

Open Scope string_scope.
Open Scope list_scope.
Close Scope nat_scope.

Definition Name := string.

(* Non-empty list is a pair: an element and a list of elements *)
Definition nelist A := (A * list A)%type.

Inductive Span :=
| SSpan : Name -> Name -> Span.

Inductive SpanExp :=
| SESpan : Span -> SpanExp
| SEName : Name -> SpanExp.

Inductive WriteableTree :=
| WTRoot : WriteableTree
| WTTree : WriteableTree -> nelist SpanExp -> WriteableTree.

Inductive Tree :=
| RTree : ReadableTree -> Tree
| WTree : WriteableTree -> Tree

with ReadableTree :=
     | RTTree : Tree -> nelist SpanExp -> ReadableTree.

Inductive RRef :=
| RRRef : Tree -> nelist Name -> RRef.

Inductive Request :=
| Get : RRef -> Request.

Inductive BindableValue :=
| BVRef : RRef -> BindableValue
| BVTree : ReadableTree -> BindableValue
| BVName : Name -> BindableValue.

Inductive WRef :=
| WRRef : WriteableTree -> nelist Name -> WRef.

Inductive WriteableReference :=
| WRWRef : WRef -> WriteableReference
| WRWTree : WriteableTree -> WriteableReference.

Inductive Expression :=
| EWR : WriteableReference -> Expression
| EBV : BindableValue -> Expression
| ER : Request -> Expression
| EN : Name -> Expression.

Inductive Command : Type :=
| Run : nelist Expression -> Command
| Bind : WRef -> BindableValue -> Command.

Definition Program := list Command.


Require Import CertiGraph.graph.SpaceAdjMatGraph1.
Require Import CertiGraph.dijkstra.dijkstra_env.

(* A separate file with the underlying PQ spec-ed out *)
Require Export CertiGraph.binheap.binary_heap_malloc_spec.
Require Export CertiGraph.binheap.spec_binary_heap_pro.

(* Dijkstra-specific imports *)
Require Import CertiGraph.dijkstra.MathDijkGraph.
Require Export CertiGraph.dijkstra.dijkstra_spec_pure.

(* The first moment we become implementation-specific *)
Require Export CertiGraph.dijkstra.dijkstra1.

Local Open Scope Z_scope.

Section DijkstraSpec.

  Context {size : Z}.
  Context {inf : Z}.
  Context {Z_EqDec : EquivDec.EqDec Z eq}.

  Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
  Definition Vprog : varspecs. mk_varspecs prog. Defined.
  Global Existing Instance CompSpecs.

  (*
  Definition freeN_spec {CS: compspecs} :=
    DECLARE _freeN
    WITH sh: share, p: pointer_val, n: Z, contents: list Z
    PRE [tptr tvoid]
    PROP ()
    PARAMS (pointer_val_val p)
    GLOBALS ()
    SEP (data_at sh (tarray tint n)
                 (map Vint (map Int.repr contents))
                 (pointer_val_val p) *
        free_tok (pointer_val_val p) (sizeof tint * n))
  POST [tvoid]
    PROP () LOCAL () SEP (emp).
   *)

  Definition getCell_spec :=
    DECLARE _getCell
    WITH sh: wshare,
         g: @DijkGG size inf,
         graph_ptr: pointer_val,
         addresses: list val,
         u: V,
         i : V
    PRE [tptr (tptr tint), tint, tint]
      PROP (0 <= i < size;
            0 <= u < size)
      PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g
                             (pointer_val_val graph_ptr) addresses)
    POST [tint]
      PROP ()
      RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_mat size g id)))))
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g
                             (pointer_val_val graph_ptr) addresses).

  Definition dijkstra_spec :=
    DECLARE _dijkstra
    WITH sh: wshare,
         g: DijkGG,
         graph_ptr : pointer_val,
         addresses : list val,
         dist_ptr : pointer_val,
         prev_ptr : pointer_val,
         src : V
    PRE [tptr (tptr tint), tint, tptr tint, tptr tint, tint, tint]
      PROP (0 <= src < size;
           Forall (fun list => Zlength list = size) (@graph_to_mat size g id);
           12 * size <= Int.max_unsigned)
      PARAMS (pointer_val_val graph_ptr;
             Vint (Int.repr src);
             pointer_val_val dist_ptr;
             pointer_val_val prev_ptr;
             Vint (Int.repr size);
             Vint (Int.repr inf))
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g
                             (pointer_val_val graph_ptr) addresses;
          data_at_ Tsh (tarray tint size) (pointer_val_val dist_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val prev_ptr))
    POST [tvoid]
      EX prev: list V,
      EX dist: list V,
      EX popped: list V,
      PROP (forall dst,
               vvalid g dst ->
               @inv_popped size inf g src popped prev dist dst)
      LOCAL ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g
                             (pointer_val_val graph_ptr) addresses;
          data_at Tsh (tarray tint size) (map Vint (map Int.repr prev)) (pointer_val_val prev_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr dist)) (pointer_val_val dist_ptr)).

  Definition Gprog : funspecs :=
    ltac:(with_library prog [
                       getCell_spec;
                       dijkstra_spec;
                       mallocN_spec;
                       freeN_spec;
                       pq_remove_min_nc_spec;
                       pq_insert_nc_spec;
                       pq_size_spec;
                       pq_make_spec;
                       pq_edit_priority_spec;
                       pq_free_spec]).

End DijkstraSpec.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq div fintype finset.
From mathcomp
Require Import prime fingroup morphism automorphism quotient gproduct gfunctor.
From mathcomp
Require Import cyclic center commutator pgroup nilpotent sylow abelian hall.
From mathcomp
Require Import maximal.
From odd_order
Require Import BGsection1 BGappendixAB.

(******************************************************************************)
(*   This file covers most of B & G section 6.                                *)
(* Theorem 6.4 is not proved, since it is not needed for the revised proof of *)
(* the odd order theorem.                                                     *)
(******************************************************************************)

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

Import GroupScope.

Section Six.

Implicit Type gT : finGroupType.
Implicit Type p : nat.

Section OneType.

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

(* This is B & G, Theorem A.4(b) and 6.1, or Gorenstein 6.5.2, the main Hall- *)
(* Higman style p-stability result used in the proof of the Odd Order Theorem *)
Theorem odd_p_abelian_constrained p G :
  odd #|G| -> solvable G -> p.-abelian_constrained G.
Proof.
move/odd_p_stable=> stabG /solvable_p_constrained constrG.
exact: p_stable_abelian_constrained.
Qed.

(* Auxiliary results from AppendixAB, necessary to exploit the results below. *)
Definition center_Puig_char := BGappendixAB.center_Puig_char.
Definition trivg_center_Puig_pgroup := BGappendixAB.trivg_center_Puig_pgroup.

(* The two parts of B & G, Theorem 6.2 are established in BGappendixAB. *)
Theorem Puig_factorisation p G S :
  odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) * 'N_G('Z('L(S))) = G.
Proof. exact: BGappendixAB.Puig_factorization. Qed.

(* This is the main statement of B & G, Theorem 6.2. It is not used in the    *)
(* actual proof.                                                              *)
Theorem Puig_center_p'core_normal p G S :
  odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) * 'Z('L(S)) <| G.
Proof.
move=> oddG solG sylS; rewrite -{2}(Puig_factorisation _ _ sylS) //.
have sZL_G: 'Z('L(S)) \subset G by rewrite !gFsub_trans ?(pHall_sub sylS).
rewrite -!quotientK ?(subset_trans sZL_G) ?subIset ?gFnorm //=.
by rewrite cosetpre_normal quotient_normal // normalSG.
Qed.

(* This is the second part (special case) of B & G, Theorem 6.2.              *)
Theorem Puig_center_normal p G S :
  odd #|G| -> solvable G -> p.-Sylow(G) S -> 'O_p^'(G) = 1 -> 'Z('L(S)) <| G.
Proof. exact: BGappendixAB.Puig_center_normal. Qed.

(* This is B & G, Lemma 6.3(a). *)
Lemma coprime_der1_sdprod K H G :
    K ><| H = G -> coprime #|K| #|H| -> solvable K -> K \subset G^`(1) ->
  [~: K, H] = K /\ 'C_K(H) \subset K^`(1).
Proof.
case/sdprodP=> _ defG nKH tiKH coKH solK sKG'.
set K' := K^`(1); have [sK'K nK'K] := andP (der_normal 1 K : K' <| K).
have nK'H: H \subset 'N(K') := gFnorm_trans _ nKH.
set R := [~: K, H]; have sRK: R \subset K by rewrite commg_subl.
have [nRK nRH] := joing_subP (commg_norm K H : K <*> H \subset 'N(R)).
have sKbK'H': K / R \subset (K / R)^`(1) * (H / R)^`(1).
  have defGb: (K / R) \* (H / R) = G / R.
    by rewrite -defG quotientMl ?cprodE // centsC quotient_cents2r.
  have [_ -> _ /=] := cprodP (der_cprod 1 defGb).
  by rewrite -quotient_der ?quotientS // -defG mul_subG.
have tiKbHb': K / R :&: (H / R)^`(1) = 1.
  by rewrite coprime_TIg // (coprimegS (der_sub 1 _)) ?coprime_morph.
have{sKbK'H' tiKbHb'} derKb: (K / R)^`(1) = K / R.
  by rewrite -{2}(setIidPr sKbK'H') -group_modl ?der_sub // setIC tiKbHb' mulg1.
have{derKb} Kb1: K / R = 1.
  rewrite (contraNeq (sol_der1_proper _ (subxx (K / R)))) ?quotient_sol //.
  by rewrite derKb properxx.
have{Kb1 sRK} defKH: [~: K, H] = K.
  by apply/eqP; rewrite eqEsubset sRK -quotient_sub1 ?Kb1 //=.
split=> //; rewrite -quotient_sub1 ?subIset ?nK'K //= -/K'.
have cKaKa: abelian (K / K') := der_abelian 0 K.
rewrite coprime_quotient_cent ?quotient_norms ?coprime_morph //= -/K' -defKH.
by rewrite quotientR // coprime_abel_cent_TI ?quotient_norms ?coprime_morph.
Qed.

(* This is B & G, Lemma 6.3(b). It is apparently not used later. *)
Lemma prime_nil_der1_factor G :
    nilpotent G^`(1) -> prime #|G / G^`(1)| ->
  Hall G G^`(1) /\ (forall H, G^`(1) ><| H = G -> G^`(1) = [~: G, H]).
Proof.
move=> nilG' /=; set G' := G^`(1); set p := #|G / G'| => p_pr.
have nsG'G: G' <| G := der_normal 1 G; have [sG'G nG'G] := andP nsG'G.
have nsG'p'G: 'O_p^'(G') <| G := gFnormal_trans _ nsG'G.
have nG'p'G := normal_norm nsG'p'G; have solG' := nilpotent_sol nilG'.
have{nilG'} pGb: p.-group (G / 'O_p^'(G')).
  rewrite /pgroup card_quotient -?(Lagrange_index sG'G (pcore_sub _ _)) //=.
  rewrite pnatM // -card_quotient // pnat_id //= -pnatNK.
  by case/and3P: (nilpotent_pcore_Hall p^' nilG').
have{pGb} cycGb: cyclic (G / 'O_p^'(G')).
  apply: (cyclic_nilpotent_quo_der1_cyclic (pgroup_nil pGb)).
  rewrite -quotient_der // (isog_cyclic (third_isog _ _ _)) ?pcore_sub //.
  by apply: prime_cyclic.
have defG': G' = 'O_p^'(G').
  by apply/eqP; rewrite eqEsubset pcore_sub der1_min ?cyclic_abelian.
have hallG': Hall G G'.
  rewrite /Hall sG'G -?card_quotient // defG' //= -/p.
  by rewrite (p'nat_coprime (pcore_pgroup _ _)) ?pnat_id.
split=> // H defG; have [_ mulG'H nG'H tiG'H] := sdprodP defG.
rewrite -mulG'H commMG ?commg_normr // -derg1 (derG1P _) ?mulg1 //.
  by case/coprime_der1_sdprod: (defG); rewrite ?(coprime_sdprod_Hall_l defG).
rewrite (isog_abelian (quotient_isog nG'H tiG'H)) /= -/G'.
by rewrite -quotientMidl mulG'H der_abelian.
Qed.

Section PprodSubCoprime.

Variables K U H G : {group gT}.
Hypotheses (defG : K * U = G) (nsKG : K <| G).
Hypotheses (sHU : H \subset U) (coKH : coprime #|K| #|H|).
Let nKG : G \subset 'N(K). Proof. by case/andP: nsKG. Qed.
Let sKG : K \subset G. Proof. by case/mulG_sub: defG. Qed.
Let sUG : U \subset G. Proof. by case/mulG_sub: defG. Qed.
Let nKU : U \subset 'N(K). Proof. exact: subset_trans sUG nKG. Qed.
Let nKH : H \subset 'N(K). Proof. exact: subset_trans sHU nKU. Qed.

(* This is B & G, Lemma 6.5(a); note that we do not assume solvability. *)
Lemma pprod_focal_coprime : H :&: G^`(1) = H :&: U^`(1).
Proof.
set G' :=  G^`(1); set U' := U^`(1).
have [sU'U nU'U] := andP (der_normal 1 U : U' <| U).
have{nU'U} nU_U': U :&: _ \subset 'N(U') by move=> A; rewrite subIset ?nU'U.
suffices sHG'U': H :&: G' \subset U'.
  by rewrite -(setIidPl sHG'U') -setIA (setIidPr (dergS 1 sUG)).
rewrite -(setIidPr sHU) -setIA -quotient_sub1 // setICA setIC.
rewrite quotientGI ?subsetI ?sU'U ?dergS ?coprime_TIg //= -/G' -/U'.
have sUG'_UKb: (U :&: G') / U' \subset (U :&: K) / U'.
  rewrite quotientSK // -normC ?group_modr ?setIS //.
  by rewrite -quotientSK ?comm_subG ?quotient_der // -defG quotientMidl.
rewrite (coprimeSg sUG'_UKb) // -(card_isog (second_isog _)) //=.
rewrite setIA (setIidPl sU'U) coprime_morphl ?coprime_morphr //.
exact: coprimeSg (subsetIr U K) coKH.
Qed.

Hypothesis solG : solvable G.

(* This is B & G, Lemma 6.5(c). *)
Lemma pprod_trans_coprime g :
    g \in G -> H :^ g \subset U ->
  exists2 c, c \in 'C_K(H) & exists2 u, u \in U & g = c * u.
Proof.
rewrite -{1}defG => /mulsgP[k u Kk Uu defg] sHgU.
have [sK_KH sH_KH] := joing_sub (erefl (K <*> H)).
have hallH: \pi(H).-Hall(K <*> H :&: U) H.
  rewrite (pHall_subl _ (subsetIl _ _)) ?subsetI ?sH_KH //.
  rewrite /pHall sH_KH pgroup_pi /= joingC norm_joinEl // indexMg -indexgI.
  by rewrite -coprime_pi' ?cardG_gt0 //= coprime_sym coprime_TIg ?indexg1.
have{sHgU} hallHk: \pi(H).-Hall(K <*> H :&: U) (H :^ k).
  rewrite pHallE cardJg (card_Hall hallH) eqxx andbT subsetI andbC.
  rewrite -(conjSg _ _ u) (conjGid Uu) -conjsgM -defg sHgU.
  by rewrite sub_conjg conjGid // groupV (subsetP sK_KH).
have{hallH hallHk} [w KUw defHk]: exists2 w, w \in K :&: U & H :^ k = H :^ w.
  have sKHU_G: K <*> H :&: U \subset G by rewrite setIC subIset ?sUG.
  have [hw KHUhw ->] := Hall_trans (solvableS sKHU_G solG) hallHk hallH.
  have: hw \in H * (K :&: U) by rewrite group_modl // -norm_joinEl // joingC.
  by case/mulsgP=> h w Hh KUw ->; exists w; rewrite // conjsgM (conjGid Hh).
have{KUw} [Kw Uw] := setIP KUw.
exists (k * w^-1); last by exists (w * u); rewrite ?groupM // -mulgA mulKg.
by rewrite -coprime_norm_cent // !inE groupM ?groupV //= conjsgM defHk conjsgK.
Qed.

(* This is B & G, Lemma 6.5(b). *)
Lemma pprod_norm_coprime_prod : 'C_K(H) * 'N_U(H) = 'N_G(H).
Proof.
apply/eqP; rewrite eqEsubset mul_subG ?setISS ?cent_sub //=.
apply/subsetP=> g /setIP[Gg /normP nHg].
have [|c Cc [u Uu defg]] := pprod_trans_coprime Gg; first by rewrite nHg.
rewrite defg mem_mulg // !inE Uu -{2}nHg defg conjsgM conjSg (normP _) //=.
by case/setIP: Cc => _; apply: (subsetP (cent_sub H)).
Qed.

End PprodSubCoprime.

Section Plength1Prod.

Variables (p : nat) (G S : {group gT}).
Hypotheses (sylS : p.-Sylow(G) S) (pl1G : p.-length_1 G).
Let K := 'O_p^'(G).
Let sSG : S \subset G. Proof. by case/andP: sylS. Qed.
Let nsKG : K <| G. Proof. apply: pcore_normal. Qed.
Let sKG : K \subset G. Proof. by case/andP: nsKG. Qed.
Let nKG : G \subset 'N(K). Proof. by case/andP: nsKG. Qed.
Let nKS : S \subset 'N(K). Proof. apply: subset_trans sSG nKG. Qed.
Let coKS : coprime #|K| #|S|.
Proof. exact: p'nat_coprime (pcore_pgroup _ G) (pHall_pgroup sylS). Qed.
Let sSN : S \subset 'N_G(S). Proof. by rewrite subsetI sSG normG. Qed.

Let sylGbp : p.-Sylow(G / K) 'O_p(G / K).
Proof. by rewrite -plength1_pcore_quo_Sylow. Qed.

(* This is B & G, Lemma 6.6(a1); note that we do not assume solvability. *)
Lemma plength1_Sylow_prod : K * S = 'O_{p^',p}(G).
Proof.
by rewrite -quotientK 1?(eq_Hall_pcore sylGbp) ?quotient_pHall //= /K -pseries1.
Qed.

Let sylS_Gp'p : p.-Sylow('O_{p^',p}(G)) S.
Proof.
have [_ sSGp'p] := mulG_sub plength1_Sylow_prod.
exact: pHall_subl sSGp'p (pseries_sub _ _) sylS.
Qed.

(* This is B & G, Lemma 6.6(a2); note that we do not assume solvability. *)
Lemma plength1_Frattini : K * 'N_G(S) = G.
Proof.
rewrite -{2}(Frattini_arg _ sylS_Gp'p) ?pseries_normal //= -plength1_Sylow_prod.
by rewrite -mulgA [S * _]mulSGid // subsetI sSG normG.
Qed.
Local Notation defG := plength1_Frattini.

(* This is B & G, Lemma 6.6(b); note that we do not assume solvability. *)
Lemma plength1_Sylow_sub_der1 : S \subset G^`(1) -> S \subset ('N_G(S))^`(1).
Proof.
by move/setIidPl=> sSG'; apply/setIidPl; rewrite -(pprod_focal_coprime defG).
Qed.

Hypothesis solG : solvable G.

(* This is B & G, Lemma 6.6(c). *)
Lemma plength1_Sylow_trans (Y : {set gT}) g :
    Y \subset S -> g \in G -> Y :^ g \subset S ->
  exists2 c, c \in 'C_G(Y) & exists2 u, u \in 'N_G(S) & g = c * u.
Proof.
rewrite -gen_subG -(gen_subG (Y :^ g)) genJ => sYS Gg sYgS.
have coKY := coprimegS sYS coKS.
have [sYN sYgN] := (subset_trans sYS sSN, subset_trans sYgS sSN).
have [c Cc defg] := pprod_trans_coprime defG nsKG sYN coKY solG Gg sYgN.
by exists c => //; apply: subsetP Cc; rewrite cent_gen setSI.
Qed.

(* This is B & G, Lemma 6.6(d). *)
Lemma plength1_Sylow_Jsub (Q : {group gT}) :
    Q \subset G -> p.-group Q ->
  exists2 x, x \in 'C_G(Q :&: S) & Q :^ x \subset S.
Proof.
move=> sQG pQ; have sQ_Gp'p: Q \subset 'O_{p^',p}(G).
  rewrite -sub_quotient_pre /= pcore_mod1 ?(subset_trans sQG) //.
  by rewrite (sub_Hall_pcore sylGbp) ?quotientS ?quotient_pgroup.
have [xy /= KSxy sQxyS] := Sylow_Jsub sylS_Gp'p sQ_Gp'p pQ.
rewrite -plength1_Sylow_prod in KSxy; have [x y Kx Sy def_xy] := mulsgP KSxy.
have{sQxyS} sQxS: Q :^ x \subset S.
  by rewrite -(conjSg _ _ y) (conjGid Sy) -conjsgM -def_xy.
exists x; rewrite // inE (subsetP sKG) //; apply/centP=> z; case/setIP=> Qz Sz.
apply/commgP; rewrite -in_set1 -set1gE -(coprime_TIg coKS) inE.
rewrite groupMl ?groupV ?memJ_norm ?(subsetP nKS) ?Kx //=.
by rewrite commgEr groupMr // (subsetP sQxS) ?memJ_conjg ?groupV.
Qed.

End Plength1Prod.

End OneType.

(* This is B & G, Theorem 6.7 *)
Theorem plength1_norm_pmaxElem gT p (G E L : {group gT}) :
    E \in 'E*_p(G) -> odd p -> solvable G -> p.-length_1 G ->
    L \subset G -> E \subset 'N(L) -> p^'.-group L ->
  L \subset 'O_p^'(G).
Proof.
move=> maxE p_odd solG pl1G sLG nEL p'L.
case p_pr: (prime p); last first.
  by rewrite pcore_pgroup_id // p'groupEpi mem_primes p_pr.
wlog Gp'1: gT G E L maxE solG pl1G sLG nEL p'L / 'O_p^'(G) = 1.
  set K := 'O_p^'(G); have [sKG nKG] := andP (pcore_normal _ G : K <| G).
  move/(_ _ (G / K) (E / K) (L / K))%G; rewrite morphim_sol ?plength1_quo //.
  rewrite morphimS ?morphim_norms ?quotient_pgroup // trivg_pcore_quotient.
  rewrite (quotient_sub1 (subset_trans sLG nKG)) => -> //.
  have [EpE _] := pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE.
  apply/pmaxElemP; rewrite inE quotient_abelem ?quotientS //.
  split=> // Fb; case/pElemP=> sFbG abelFb; have [pFb _ _] := and3P abelFb.
  have [S sylS sES] := Sylow_superset sEG (abelem_pgroup abelE).
  have [sSG pS _] := and3P sylS; have nKS := subset_trans sSG nKG.
  have: (E / K)%G \in 'E*_p(S / K).
    have: E \in 'E*_p(S) by rewrite (subsetP (pmaxElemS p sSG)) // inE maxE inE.
    have coKS: coprime #|K| #|S| := p'nat_coprime (pcore_pgroup _ _) pS.
    have [injK imK] := isomP (quotient_isom nKS (coprime_TIg coKS)).
    by rewrite -(injm_pmaxElem injK) ?imK ?inE //= morphim_restrm (setIidPr _).
  case/pmaxElemP=> _; apply; rewrite inE abelFb andbT.
  rewrite (sub_normal_Hall (quotient_pHall _ sylS)) //= -quotientMidl /= -/K.
  by rewrite plength1_Sylow_prod // quotient_pseries2 pcore_normal.
have [EpE _] := pmaxElemP maxE; have{EpE} [sEG abelE] := pElemP EpE.
have [S sylS sES] := Sylow_superset sEG (abelem_pgroup abelE).
have [sSG pS _] := and3P sylS; have oddS: odd #|S| := odd_pgroup_odd p_odd pS.
have defS: S :=: 'O_p(G) by apply eq_Hall_pcore; rewrite -?plength1_pcore_Sylow.
have coSL: coprime #|S| #|L| := pnat_coprime pS p'L.
have tiSL: S :&: L = 1 := coprime_TIg coSL.
have{solG} scSG: 'C_G(S) \subset S.
  by rewrite defS -Fitting_eq_pcore ?cent_sub_Fitting.
rewrite Gp'1 -tiSL subsetIidr (subset_trans _ scSG) // subsetI sLG /=.
have nSL: L \subset 'N(S) by rewrite (subset_trans sLG) // defS gFnorm.
have cLE: L \subset 'C(E).
  by rewrite (sameP commG1P trivgP) -tiSL setIC commg_subI ?(introT subsetIP).
have maxES: E \in 'E*_p(S) by rewrite (subsetP (pmaxElemS p sSG)) ?(maxE, inE).
have EpE: E \in 'E_p(S) by apply/setIdP.
by rewrite (coprime_odd_faithful_cent_abelem EpE) ?(pmaxElem_LdivP p_pr maxES).
Qed.

End Six.


(** * Env: Environments *)

(* -------------------------------------------------------------------------- *
 *                     Vellvm - the Verified LLVM project                     *
 *                                                                            *
 *     Copyright (c) 2017 Steve Zdancewic <stevez@cis.upenn.edu>              *
 *                                                                            *
 *   This file is distributed under the terms of the GNU General Public       *
 *   License as published by the Free Software Foundation, either version     *
 *   3 of the License, or (at your option) any later version.                 *
 ---------------------------------------------------------------------------- *)

Require Import Equalities List.
Set Implicit Arguments.

(* ################################################################# *)
(** * Environments *)
(** An _environment_ maps values of type [K.t] to values of type
    V. This module implements updateable environments using Coq
    functions and proves some simple facts about equality. *)

Module Make_Env (K:UsualDecidableType).
Section WithV.
  Variable V : Type.

  Definition t := K.t -> V.

  Definition empty (init:V) : t := fun _ => init.

  Definition update (st:t) (k:K.t) (v:V) : t :=
    fun k' => if K.eq_dec k k' then v else st k'.

  (* Properties *)
  Theorem update_eq : forall v k1 k2 st,
    K.eq k1 k2 -> (update st k1 v) k2 = v.
  Proof.
    intros. unfold update.
    destruct (K.eq_dec k1 k2); intuition.
  Qed.

  Theorem update_neq : forall k1 k2 v st,
    ~ K.eq k1 k2 -> (update st k1 v) k2 = st k2.
  Proof.
    intros. unfold update.
    destruct (K.eq_dec k1 k2); intuition.
  Qed.

  Theorem update_shadow : forall v1 v2 k1 k2 st,
    K.eq k1 k2 ->
    (update (update st k1 v1) k1 v2) k2 = (update st k1 v2) k2.
  Proof.
    intros. unfold update.
    destruct (K.eq_dec k1 k2); reflexivity.
  Qed.

  Theorem update_same : forall v1 k1 k2 (st : t),
    st k2 = v1 -> (update st k1 v1) k2 = st k2.
  Proof.
    intros. unfold update.
    destruct (K.eq_dec k1 k2); subst; reflexivity.
  Qed.

End WithV.
End Make_Env.


(* Copland terms, events, and annotated terms *)

(* LICENSE NOTICE

Copyright (c) 2018 The MITRE Corporation.
All Rights Reserved.

This proof script is free software: you can redistribute it and/or
modify it under the terms of the BSD License as published by the
University of California.  See license.txt for details. *)

(** This module contains the basic definitions for Copland terms,
    events, and annotated terms. *)

Require Import PeanoNat Compare_dec Lia.
Require Import Preamble StructTactics.

(** * Terms and Evidence

    A term is either an atomic ASP, a remote call, a sequence of terms
    with data a dependency, a sequence of terms with no data
    dependency, or parallel terms. *)

(** [Plc] represents a place. *)

Notation Plc := nat (only parsing).
Notation ASP_ID := nat (only parsing).
Notation N_ID := nat (only parsing).
Notation Arg := nat (only parsing).

Inductive ASP: Set :=
| CPY: ASP
| ASPC: ASP_ID -> list Arg -> ASP
| SIG: ASP
(*| HSH: ASP*) .

Inductive SP: Set :=
| ALL
| NONE.

Definition Split: Set := (SP * SP).

Inductive Term: Set :=
| asp: ASP -> Term
| att: Plc -> Term -> Term
| lseq: Term -> Term -> Term
| bseq: Split -> Term -> Term -> Term
| bpar: Split -> Term -> Term -> Term.

(** The structure of evidence. *)

Inductive Evidence: Set :=
| mt: Evidence
| uu: ASP_ID -> list Arg -> Plc -> Evidence -> Evidence
| gg: Plc -> Evidence -> Evidence
(*| hh: Plc -> Evidence -> Evidence *)
                         (*
| nn: N_ID -> Evidence -> Evidence *)
| ss: Evidence -> Evidence -> Evidence
| pp: Evidence -> Evidence -> Evidence.

Definition splitEv_T (sp:SP) (e:Evidence) : Evidence :=
  match sp with
  | ALL => e
  | NONE => mt
  end.

Definition eval_asp t p e :=
  match t with
  | CPY => e
  | ASPC i args => uu i args p e
  | SIG => gg p e
  (*| HSH => hh p e *)
  end.

(** The evidence associated with a term, a place, and some initial evidence. *)

Fixpoint eval (t:Term) (p:Plc) (e:Evidence) : Evidence :=
  match t with
  | asp a => eval_asp a p e
  | att q t1 => eval t1 q e
  | lseq t1 t2 => eval t2 p (eval t1 p e)
  | bseq s t1 t2 => ss (eval t1 p (splitEv_T (fst s) e))
                       (eval t2 p (splitEv_T (snd s) e))
  | bpar s t1 t2 => pp (eval t1 p (splitEv_T (fst s) e))
                      (eval t2 p (splitEv_T (snd s) e))
  end.

(** * Events

    There are events for each kind of action. This includes ASP
    actions such as measurement or data processing. It also includes
    control flow actions: a [split] occurs when a thread of control
    splits, and a [join] occurs when two threads join.  Each event is
    distinguished using a unique natural number.

 *)

Inductive Ev: Set :=
| copy: nat -> Plc -> Ev
| umeas: nat -> Plc -> ASP_ID -> list Arg -> Ev
| sign: nat -> Plc -> Ev
(*| hash: nat -> Plc -> Ev *)
| req: nat -> Plc -> Plc -> Term -> Ev
| rpy: nat -> Plc -> Plc -> Ev
| split: nat -> Plc -> Ev
| join:  nat -> Plc -> Ev.

Definition eq_ev_dec:
  forall x y: Ev, {x = y} + {x <> y}.
Proof.
  intros;
    repeat decide equality.
Defined.
Hint Resolve eq_ev_dec : core.

(** The natural number used to distinguish evidence. *)

Definition ev x :=
  match x with
  | copy i _ => i
  | umeas i _ _ _  => i
  | sign i _ => i
  (*| hash i _ => i  *)
  | req i _ _ _ => i
  | rpy i _ _ => i
  | split i _ => i
  | join i _ => i
  end.

(** Events are used in a manner that ensures that
[[
    forall e0 e1, ev e0 = ev e1 -> e0 = e1.
]]
See Lemma [events_injective].
 *)

Definition asp_event i x p :=
  match x with
  | CPY => copy i p
  | ASPC id args => umeas i p id args
  | SIG => sign i p
  (*| HSH => hash i p  *)
  end.

(** * Annotated Terms

    Annotated terms are used to ensure that each distinct event has a
    distinct natural number.  To do so, each term is annotated by a
    pair of numbers called a range.  Let [(i, k)] be the label for
    term [t].  The labels will be chosen to have the property such
    that for each event in the set of events associated with term [t],
    its number [j] will be in the range [i <= j < k].  *)

Definition Range: Set := nat * nat.

Inductive AnnoTerm: Set :=
| aasp: Range -> ASP -> AnnoTerm
| aatt: Range -> Plc -> AnnoTerm -> AnnoTerm
| alseq: Range -> AnnoTerm -> AnnoTerm -> AnnoTerm
| abseq: Range -> Split -> AnnoTerm -> AnnoTerm -> AnnoTerm
| abpar: Range -> Split -> AnnoTerm -> AnnoTerm -> AnnoTerm.

(*
Inductive AnnoEvidence: Set :=
| amt: AnnoEvidence
| auu: nat -> ASP_ID -> Plc -> AnnoEvidence -> AnnoEvidence
| agg: nat -> Plc -> AnnoEvidence -> AnnoEvidence
| ahh: nat -> Plc -> AnnoEvidence -> AnnoEvidence
| ann: (*nat ->*) N_ID -> AnnoEvidence -> AnnoEvidence
| ass: AnnoEvidence -> AnnoEvidence -> AnnoEvidence
| app: AnnoEvidence -> AnnoEvidence -> AnnoEvidence.

Fixpoint eval_asp_i t p e i :=
  match t with
  | CPY => e
  | ASPC x args => auu i x p e
  | SIG => agg i p e
  | HSH => ahh i p e
  end.

Definition splitEv_T_i (sp:SP) (e:AnnoEvidence) : AnnoEvidence :=
  match sp with
  | ALL => e
  | NONE => amt
  end.

Fixpoint annoeval t p (e:AnnoEvidence) :=
  match t with
  | aasp (i,_) x => eval_asp_i x p e i
  | aatt _ q x => annoeval x q e
  | alseq _ t1 t2 => annoeval t2 p (annoeval t1 p e)
  | abseq _ s t1 t2 => ass (annoeval t1 p ((splitEv_T_i (fst s)) e))
                         (annoeval t2 p ((splitEv_T_i (snd s)) e))
  | abpar _ s t1 t2 => app (annoeval t1 p ((splitEv_T_i (fst s)) e))
                         (annoeval t2 p ((splitEv_T_i (snd s)) e))
  end.
*)

(** The number of events associated with a term.  The branching terms
add a split and a join to the events of their subterms. Similarly, the
remote calls add a request and receive to the events of their subterm.
*)

Fixpoint esize t :=
  match t with
  | aasp _ _ => 1
  | aatt _ _ t1 => 2 + esize t1
  | alseq _ t1 t2 => esize t1 + esize t2
  | abseq _ _ t1 t2 => 2 + esize t1 + esize t2
  | abpar _ _ t1 t2 => 2 + esize t1 + esize t2
  end.

Definition range x :=
  match x with
  | aasp r _ => r
  | aatt r _ _ => r
  | alseq r _ _ => r
  | abseq r _ _ _ => r
  | abpar r _ _ _ => r
  end.

(** This function annotates a term.  It feeds a natural number
    throughout the computation so as to ensure each event has a unique
    natural number. *)

Fixpoint anno (t: Term) i: nat * AnnoTerm :=
  match t with
  | asp x => (S i, aasp (i, S i) x)
  | att p x =>
    let (j, a) := anno x (S i) in
    (S j, aatt (i, S j) p a)
  | lseq x y =>
    let (j, a) := anno x i in
    let (k, b) := anno y j in
    (k, alseq (i, k) a b)
  | bseq s x y =>
    let (j, a) := anno x (S i) in
    let (k, b) := anno y j in
    (S k, abseq (i, S k) s a b)
  | bpar s x y =>
    let (j, a) := anno x (S i) in
    let (k, b) := anno y j in
    (S k, abpar (i, S k) s a b)
  end.

Ltac asdf :=
  match goal with
  | [H: _, H2: _ |- _] => apply H in H2
  end.

Lemma anno_mono : forall (t:Term) (i j:nat) (t':AnnoTerm),
  anno t i = (j, t') ->
  j > i.
Proof.
  induction t; intros i j t' H;
    try (
        simpl in *;
        repeat break_let;
        find_inversion;
        repeat find_apply_hyp_hyp;
        lia).
Defined.
Hint Resolve anno_mono : core.

Lemma anno_range:
  forall x i,
    range (snd (anno x i)) = (i, fst (anno x i)).
Proof.
  induction x; intros; simpl; auto;
    repeat expand_let_pairs;
    simpl; auto.
Qed.

Definition annotated x :=
  snd (anno x 0).

Lemma pairsinv : forall (a a' b b':nat),
    a <> a' -> (a,b) <> (a',b').
Proof.
  intros.
  congruence.
Defined.

Ltac fail_if_in_hyps H :=
  let t := type of H in
  lazymatch goal with
  | [G : t |- _ ] => fail "There is already a hypothesis of this proof"
  | [_ : _ |- _ ] => idtac
  end.

Ltac pose_new_proof H :=
  fail_if_in_hyps H;
  pose proof H.

Ltac fail_if_in_hyps_type t :=
  lazymatch goal with
  | [G : t |- _ ] => fail "There is already a hypothesis of this type"
  | [_ : _ |- _ ] => idtac
  end.

Ltac assert_new_proof_by H tac :=
  fail_if_in_hyps_type H;
  assert H by tac.

Ltac haha :=
  let asdff := eapply anno_mono; eauto in
  match goal with
  | [H: anno _ ?x = (?y,_) |- _] => assert_new_proof_by (y > x) (asdff)
  end.

Ltac hehe :=
  match goal with
  | [H: anno ?x ?y = (_,_) |- _] => pose_new_proof (anno_range x y)
  end.

Ltac hehe' :=
  match goal with
  | [x: Term, y:nat |- _] => pose_new_proof (anno_range x (S y))
  end.

Ltac hehe'' :=
  match goal with
  | [x: Term, y:nat |- _] => pose_new_proof (anno_range x y)
  end.

Ltac afa :=
  match goal with
  | [H : forall _, _, H2: Term, H3: nat |- _] => pose_new_proof (H H2 H3)
  end.

Ltac afa' :=
  match goal with
  | [H : forall _, _, H2: Term, H3: nat |- _] => pose_new_proof (H H2 (S H3))
  end.

Ltac afa'' :=
  match goal with
  | [H : forall _, _, H2: Term, H3: nat, H4:nat, H5: AnnoTerm |- _] =>
    pose_new_proof (H H2 (H3)(H4) H5)
  end.

Ltac find_apply_hyp_hyp' :=
  match goal with
  | [ H : _ -> _ , H' : _ |- _ ] =>
    (*let x := fresh in *)
    pose_new_proof (H H')
  end.

Ltac find_apply_lem_hyp lem :=
  match goal with
    | [ H : _ |- _ ] => apply lem in H
  end.

Ltac find_apply_lem_hyp_new lem :=
  match goal with
    | [ H : _ |- _ ] => pose_new_proof (lem H) (*apply lem in H *)
  end.

Ltac jkjk :=
  match goal with
  | [H: ?X = _ |-  context[?X] ] => rewrite H
  end.

Ltac jkjk' :=
  match goal with
  | [H: ?X = _ |-  context[?X] ] => rewrite <- H
  end.

Fixpoint unanno a :=
  match a with
  | aasp _ a => asp a
  | aatt _ p t => att p (unanno t)
  | alseq _ a1 a2 => lseq (unanno a1) (unanno a2)

  | abseq _ spl a1 a2 => bseq spl (unanno a1) (unanno a2)
  | abpar _ spl a1 a2 => bpar spl (unanno a1) (unanno a2)
  end.

(** This predicate determines if an annotated term is well formed,
    that is if its ranges correctly capture the relations between a
    term and its associated events. *)

Inductive well_formed: AnnoTerm -> Prop :=
| wf_asp: forall r x,
    snd r = S (fst r) ->
    well_formed (aasp r x)
| wf_att: forall r p x,
    well_formed x ->
    S (fst r) = fst (range x) ->
    snd r = S (snd (range x)) ->
    well_formed (aatt r p x)
| wf_lseq: forall r x y,
    well_formed x -> well_formed y ->
    fst r = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = snd (range y) ->
    well_formed (alseq r x y)
| wf_bseq: forall r s x y,
    well_formed x -> well_formed y ->
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = S (snd (range y)) ->
    well_formed (abseq r s x y)
| wf_bpar: forall r s x y,
    well_formed x -> well_formed y ->
    (*(rx1,rx2) = (range x) ->
    (ry1,ry2) = (range y) -> *)
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    (snd r) = S (snd (range y)) ->
    fst (range y) > fst (range x) ->
    (*r2 > r1 -> *)
    well_formed (abpar r s x y).

                (*
| wf_bpar: forall r s x y,
    well_formed x -> well_formed y ->
    S (fst r) = fst (range x) ->
    snd (range x) = fst (range y) ->
    snd r = S (snd (range y)) ->
    well_formed (abpar r s x y). *)
Hint Constructors well_formed : core.

Lemma wf_lseq_pieces: forall r t1 t2,
    well_formed (alseq r t1 t2) ->
    well_formed t1 /\ well_formed t2.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Lemma wf_at_pieces: forall t r p,
    well_formed (aatt r p t) ->
    well_formed t.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Lemma wf_bseq_pieces: forall r s t1 t2,
    well_formed (abseq r s t1 t2) ->
    well_formed t1 /\ well_formed t2.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Lemma wf_bpar_pieces: forall r s t1 t2,
    well_formed (abpar r s t1 t2) ->
    well_formed t1 /\ well_formed t2.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Ltac do_wf_pieces :=
  match goal with
  | [H: well_formed (alseq _ _ _) |- _] =>
    (edestruct wf_lseq_pieces; eauto)
  | [H: well_formed (aatt _ _ ?t) |- _] =>
    assert (well_formed t)
      by (eapply wf_at_pieces; eauto)
  | [H: well_formed (abseq _ _ _ _ ) |- _] =>
    (edestruct wf_bseq_pieces; eauto)
  | [H: well_formed (abpar _ _ _ _ ) |- _] =>
    (edestruct wf_bpar_pieces; eauto)
  end.

Lemma well_formed_range:
  forall t,
    well_formed t ->
    snd (range t) = fst (range t) + esize t.
Proof.
  induction t; intros H; simpl; inv H; simpl;
    repeat find_apply_hyp_hyp; lia.
Defined.

Lemma anno_well_formed:
  forall t i,
    well_formed (snd (anno t i)).
Proof.
  induction t; intros; simpl;
    try (auto;
    repeat expand_let_pairs;
    econstructor; simpl; auto;
    repeat rewrite anno_range; simpl; reflexivity).
  -
    auto.
    repeat expand_let_pairs.
    simpl.
    destruct (anno t1 (S i)) eqn:hey.

    econstructor.
    +
    pose (IHt1 (S i)).
    rewrite hey in *. eassumption.
    +
      eauto.
    +
      simpl.
      assert (a = snd (anno t1 (S i))) by (rewrite hey; tauto).
      subst.

      rewrite anno_range.
      simpl.
      reflexivity.
    +
      rewrite anno_range.
      simpl.
      assert (a = snd (anno t1 (S i))) by (rewrite hey; tauto).
      subst.
      rewrite anno_range.
      rewrite hey.
      simpl.
      tauto.
    +
      simpl.
      rewrite anno_range.
      simpl.
      reflexivity.
    +

      (*
      pose (IHt1 (S i)).
      rewrite hey in *.
      eauto.
      simpl.
    rewrite anno_range.
    reflexivity.
    rewrite anno_range.
    simpl.
    rewrite anno_range.
    reflexivity.
    simpl.
    rewrite anno_range.
    reflexivity.
    simpl.
    rewrite anno_range.
    simpl.
    eapply anno_mono.
    rewrite anno_range.
    simpl.

    rewrite hey.
    simpl.
    reflexivity. *)
    (*Check anno_mono. *)
    rewrite anno_range.
    simpl.
    assert (a = snd (anno t1 (S i))) by (rewrite hey; tauto).
    subst.
    eapply anno_mono.
    rewrite hey.
    simpl.
    rewrite anno_range.
    simpl.
    eassumption.
Defined.

Lemma anno_well_formed':
  forall t,
    well_formed (annotated t).
Proof.
  intros.
  unfold annotated.
  eapply anno_well_formed.
Defined.

(*
Lemma afaf : forall r s a b,
    well_formed (abpar r s a b) ->
    (fst (range a)) <> (fst (range b)).
Proof.
  intros.
  inversion H.
  subst.
  rewrite <- H6.
  rewrite <- H7.
  simpl.
  lia.
Defined.

Lemma afaf2' : forall r s a b,
    well_formed (abpar r s a b) ->
    (fst (range b)) <> (snd (range a)) - 1.
Proof.
  intros.
  inversion H.
  subst.
  rewrite <- H7.
  lia.
Defined.
*)

(*
(*TODO: not true, pick different index for st_store in bpar case *)
Lemma afaf2 : forall r s a b,
    well_formed (abpar r s a b) ->
    (*(abpar (i, k) s a b) = snd (anno t' n) -> *)
    (fst (range b)) <> (snd (range a)).
Proof.
  intros.
  inversion H.
  subst.
  rewrite <- H7
  rewrite <- H6.
  rewrite <- H7.
  simpl.
  lia.
Defined.
*)

(*
Lemma afaf : forall i k s a b,
    well_formed (abpar (i,k) s a b) ->
    (*(abpar (i, k) s a b) = snd (anno t' n) -> *)
    (fst (range a)) <> (fst (range b)).
Proof.
  intros.
  destruct t';

    (* Bogus cases *)
    cbn in *;
    repeat (break_let);
    simpl in *;
    try solve_by_inversion.

  (* Some automation + insight *)
    repeat find_inversion;
      repeat hehe'; repeat hehe'';
      (*repeat hehe;*)
      repeat haha;
      repeat (
          find_rewrite;
          simpl in * );
      lia.

(*
  (* High automation, very little insight (but much slower) *)
   repeat find_inversion.

    pose proof anno_range.
    pose proof anno_mono.
    cbn in *.
    repeat break_let.
    simpl in *.
    (*repeat afa'. *)
    repeat afa.
    repeat afa'.
    repeat afa''.
    subst.

    repeat find_apply_hyp_hyp'.
    repeat find_rewrite.
    simpl in *.

    repeat jkjk.
    simpl.
    lia.
*)

(*
  (* Manual *)
  inv H.
  assert (n0 > (S n)).
  eapply anno_mono; eauto.
  assert (n1 > n0).
  eapply anno_mono; eauto.
  assert ( range (snd (anno t'1 (S n))) = ((S n), fst (anno t'1 (S n)))).
  eapply anno_range; eauto.
  subst.
  rewrite Heqp in H2.
  simpl in *.

  assert ( range (snd (anno t'2 n0)) = (n0, fst (anno t'2 n0))).
  eapply anno_range; eauto.
  rewrite Heqp0 in H3.
  simpl in *.
  rewrite H2.
  rewrite H3.
  simpl.
  lia.
*)
Defined.
*)

(** Eval for annotated terms. *)

Fixpoint aeval t p e :=
  match t with
  | aasp _ x => eval (asp x) p e
  | aatt _ q x => aeval x q e
  | alseq _ t1 t2 => aeval t2 p (aeval t1 p e)
  | abseq _ s t1 t2 => ss (aeval t1 p ((splitEv_T (fst s)) e))
                         (aeval t2 p ((splitEv_T (snd s)) e))
  | abpar _ s t1 t2 => pp (aeval t1 p ((splitEv_T (fst s)) e))
                         (aeval t2 p ((splitEv_T (snd s)) e))
  end.

Lemma eval_aeval:
  forall t p e i,
    eval t p e = aeval (snd (anno t i)) p e.
Proof.
  induction t; intros; simpl; auto;
    repeat expand_let_pairs; simpl;
      try (repeat jkjk; auto;congruence);
      try (repeat jkjk'; auto).
Defined.

(** This predicate specifies when a term, a place, and some initial
    evidence is related to an event.  In other words, it specifies the
    set of events associated with a term, a place, and some initial
    evidence. *)

Inductive events: AnnoTerm -> Plc -> Ev -> Prop :=
| evtscpy:
    forall r i p,
      fst r = i ->
      events (aasp r CPY) p (copy i p)
| evtsusm:
    forall i id args r p,
      fst r = i ->
      events (aasp r (ASPC id args)) p (umeas i p id args)
| evtssig:
    forall r i p,
      fst r = i ->
      events (aasp r SIG) p (sign i p)
(*| evtshsh:
    forall r i p,
      fst r = i ->
      events (aasp r HSH) p (hash i p) *)

| evtsattreq:
    forall r q t i p,
      fst r = i ->
      events (aatt r q t) p (req i p q (unanno t))
| evtsatt:
    forall r q t ev p,
      events t q ev ->
      events (aatt r q t) p ev
| evtsattrpy:
    forall r q t i p,
      snd r = S i ->
      events (aatt r q t) p (rpy i p q)
| evtslseql:
    forall r t1 t2 ev p,
      events t1 p ev ->
      events (alseq r t1 t2) p ev
| evtslseqr:
    forall r t1 t2 ev p,
      events t2 p ev ->
      events (alseq r t1 t2) p ev
| evtsbseqsplit:
    forall r i s t1 t2 p,
      fst r = i ->
      events (abseq r s t1 t2) p
             (split i p)
| evtsbseql:
    forall r s t1 t2 ev p,
      events t1 p ev ->
      events (abseq r s t1 t2) p ev
| evtsbseqr:
    forall r s t1 t2 ev p,
      events t2 p ev ->
      events (abseq r s t1 t2) p ev
| evtsbseqjoin:
    forall r i s t1 t2 p,
      snd r = S i ->
      events (abseq r s t1 t2) p
             (join i p)

| evtsbparsplit:
    forall r i s t1 t2 p,
      fst r = i ->
      events (abpar r s t1 t2) p
             (split i p)
| evtsbparl:
    forall r s t1 t2 ev p,
      events t1 p ev ->
      events (abpar r s t1 t2) p ev
| evtsbparr:
    forall r s t1 t2 ev p,
      events t2 p ev ->
      events (abpar r s t1 t2) p ev
| evtsbparjoin:
    forall r i s t1 t2 p,
      snd r = S i ->
      events (abpar r s t1 t2) p
             (join i p).
Hint Constructors events : core.

Lemma events_range:
  forall t v p,
    well_formed t ->
    events t p v ->
    fst (range t) <= ev v < snd (range t).
Proof.

  intros t v p H H0.
  pose proof H as G.
  apply well_formed_range in G.
  rewrite G.
  clear G.
  induction H0; inv H; simpl in *; auto;
    try (repeat find_apply_hyp_hyp;
         repeat (find_apply_lem_hyp well_formed_range); lia).
Defined.

Lemma at_range:
  forall x r i,
    S (fst r) = fst x ->
    snd r = S (snd x) ->
    fst r <= i < snd r ->
    i = fst r \/
    fst x <= i < snd x \/
    i = snd x.
Proof.
  intros.
  pose proof lt_dec i (S (fst r)) as G.
  destruct G as [G|G]; [left; lia| right].
  pose proof lt_dec i (snd x) as F.
  destruct F as [F|F]; [left; lia| right].
  lia.
Qed.

Lemma lin_range:
  forall x y i,
    snd x = fst y ->
    fst x <= i < snd y ->
    fst x <= i < snd x \/
    fst y <= i < snd y.
Proof.
  intros.
  pose proof lt_dec i (snd x) as G.
  destruct G; lia.
Qed.

Lemma bra_range:
  forall x y r i,
    S (fst r) = fst x ->
    snd x = fst y ->
    snd r = S (snd y) ->
    fst r <= i < snd r ->
    i = fst r \/
    fst x <= i < snd x \/
    fst y <= i < snd y \/
    i = snd y.
Proof.
  intros.
  pose proof lt_dec i (S (fst r)) as G.
  destruct G as [G|G]; [left; lia| right].
  pose proof lt_dec i (snd x) as F.
  destruct F as [F|F]; [left; lia| right].
  pose proof lt_dec i (snd y) as E.
  destruct E; lia.
Qed.

Require Import Coq.Program.Tactics.
(** Properties of events. *)

Lemma events_range_event:
  forall t p i,
    well_formed t ->
    fst (range t) <= i < snd (range t) ->
    exists v, events t p v /\ ev v = i.
Proof.
  intros t p i H; revert i; revert p.
  induction H; intros; simpl in *.
  - destruct x; eapply ex_intro; split; auto;
      (*destruct r as [j k];*) simpl in *; lia.
  - find_eapply_lem_hyp at_range; eauto.
    (*eapply at_range in H2; eauto. *)
    repeat destruct_disjunct; subst; eauto.
    (* + eapply ex_intro; split; auto. *)
    Ltac find_eapply_hyp_hyp :=
      match goal with
      | [ H : forall _, _ -> _,
            H' : _ |- _ ] =>
        eapply H in H'; [idtac]
      | [ H : _ -> _ , H' : _ |- _ ] =>
        eapply H in H'; auto; [idtac]
      end.
    + find_eapply_hyp_hyp.
      (*apply IHwell_formed with (p:=p) in H2. *)
      destruct_conjs.
      eauto.
      (*
      destruct H2 as [v].
      destruct H2; subst.
      exists v; split; eauto.
    + eapply ex_intro; split.
      apply evtsattrpy; auto.
      * rewrite H1; auto.
      * simpl; auto.
      *)

  - eapply lin_range with (i:=i) in H2; eauto;
    repeat destruct_disjunct;
      try lia;
      try (find_eapply_hyp_hyp; eauto;
        destruct_conjs;
        eauto).

  -
    apply bra_range with (i:=i) (r:=r) in H2; eauto;
      repeat destruct_disjunct; subst;
        try lia;
        try (find_eapply_hyp_hyp; eauto;
             destruct_conjs;
             eauto; tauto).

    + eapply ex_intro; split; try (auto; eauto;tauto).
    + eapply ex_intro; split; try (eauto; auto; tauto).

  -
    apply bra_range with (i:=i) (r:=r) in H2; eauto;
      repeat destruct_disjunct; subst;
        try lia;
        try (find_eapply_hyp_hyp; eauto;
             destruct_conjs;
             eauto; tauto).

    + eapply ex_intro; split; auto.
    + eapply ex_intro; split; eauto.
Qed.

Ltac events_event_range :=
  repeat match goal with
         | [ H: events _ _ _ |- _ ] =>
           apply events_range in H; auto
         end; lia.

Ltac aba :=
  match goal with
  | [H: events _ _ _, H': events _ _ _ |- _] => inv H; inv H'
  end.

Ltac wfr :=
  match goal with
  | [H: AnnoTerm, H': well_formed ?H |- _] => pose_new_proof (well_formed_range H H')
  end.

Lemma events_injective:
  forall t p v1 v2,
    well_formed t ->
    events t p v1 ->
    events t p v2 ->
    ev v1 = ev v2 ->
    v1 = v2.
Proof.
  intros t p v1 v2 H; revert v2; revert v1;
    revert p.
  induction H; intros;
    try (
        repeat wfr;
        aba; simpl in *; subst; auto;
        try (events_event_range; tauto);
        try (find_eapply_hyp_hyp; eauto);
        eauto).
Qed.

(*
repeat find_apply_lem_hyp well_formed_range.

find_apply_lem_hyp well_formed_range.
find_apply_lem_hyp well_formed_range
apply well_formed_range in G.
apply well_formed_range in G0.
Check well_formed_range.
 *)

Inductive splitEv_T_R : SP -> Evidence -> Evidence -> Prop :=
| spAll: forall e, splitEv_T_R ALL e e
| spNone: forall e, splitEv_T_R NONE e mt.

Inductive evalR : Term -> Plc -> Evidence -> Evidence -> Prop :=
| evalR_asp: forall a p e,
    evalR (asp a) p e (eval_asp a p e)
| evalR_att: forall t1 q e e' p,
    evalR t1 q e e' ->
    evalR (att q t1) p e e'
| evalR_lseq: forall t1 t2 p e e' e'',
    evalR t1 p e e' ->
    evalR t2 p e' e'' ->
    evalR (lseq t1 t2) p e e''
| evalR_bseq: forall s e e1 e2 e1' e2' p t1 t2,
    splitEv_T_R (fst s) e e1 ->
    splitEv_T_R (snd s) e e2 ->
    evalR t1 p e1 e1' ->
    evalR t2 p e2 e2' ->
    evalR (bseq s t1 t2) p e (ss e1' e2')
| evalR_bpar: forall s e e1 e2 e1' e2' p t1 t2,
    splitEv_T_R (fst s) e e1 ->
    splitEv_T_R (snd s) e e2 ->
    evalR t1 p e1 e1' ->
    evalR t2 p e2 e2' ->
    evalR (bpar s t1 t2) p e (pp e1' e2').

Ltac jkjke :=
  match goal with
  | [H: _ |-  _ ] => erewrite H; eauto
  end.
Ltac kjkj :=
  match goal with
  | [H: evalR ?t ?p ?e ?e' |- _] => assert_new_proof_by (eval t p e = e') eauto
  end.

Ltac do_split :=
  match goal with
  | [H: Split |- _] => destruct H
  end.

Ltac do_sp :=
  match goal with
  | [H: SP |- _] => destruct H
  end.

Lemma eval_iff_evalR: forall t p e e',
    evalR t p e e' <-> eval t p e = e'.
Proof.
  split.
  - (* -> case *)
    intros.
    generalize dependent p.
    generalize dependent e.
    generalize dependent e'.

    induction t; intros;
      try (
          inv H;
          simpl;
          repeat kjkj;

          try (do_split;
               repeat do_sp);
          try (inv H3; inv H4; reflexivity);
          repeat jkjk;
          eauto).

  (*try (
    inv H;
    simpl;
    repeat kjkj). *)

 (*
    + destruct a; solve_by_inversion.
    +
      inv H. simpl.
      eauto.
    + inv H.

      simpl.
      repeat kjkj.
      eauto.
      (*
      repeat jkjk.
      eauto. *)

    +
      inv H.
      simpl.
      repeat kjkj.

      do_split;
        do_sp;
        try (inv H3; inv H4; reflexivity).
    +
      inv H.
      simpl.
      repeat kjkj.

      do_split;
        do_sp;
        try (inv H3; inv H4; reflexivity).
*)

  - (* <- case *)
    intros.
    generalize dependent p.
    generalize dependent e.
    generalize dependent e'.

    induction t; intros;
      inv H;
      try (destruct a);
      try (do_split; repeat do_sp);
      repeat econstructor; eauto.
Defined.


From iris_simp_lang Require Import simp.
From iris Require Import options.

Section proof.
  Context `{!simpGS Σ}.

  Definition swap: val := λ: "x" "y",
    let: "tmp" := !"x" in
    "x" <- !"y";;
    "y" <- "tmp".

  Lemma swap_spec (x y: loc) v1 v2 :
    {{{ x ↦ v1 ∗ y ↦ v2 }}} swap #x #y {{{ RET #(); x ↦ v2 ∗ y ↦ v1 }}}.
  Proof.
    iIntros (Φ) "[Hx Hy] Post".
    wp_rec. wp_pures.
    wp_load. wp_load.
    wp_store. wp_store.
    iApply "Post"; iFrame.
  Qed.

End proof.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ O Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ Eprime O Eprime /\ col_ C O Eprime)))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load "preamble2D.v".

(* dans la couche 0 *)
Lemma LABCD : forall A B C D ,
rk(A :: C ::  nil) = 2 -> rk(A :: B :: D ::  nil) = 3 -> rk(C :: D ::  nil) = 2 ->
rk(A :: C :: D ::  nil) = 2 -> rk(A :: B :: C :: D ::  nil) = 3.
Proof.

intros A B C D
HACeq HABDeq HCDeq HACDeq .

(* dans constructProofaux(), preuve de 2 <= rg <= 3 pour ABCD requis par la preuve de (?)ABCD pour la règle 5  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 3 pour ABCD requis par la preuve de (?)ABCD pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : 4 *)
assert(HABCDm2 : rk(A :: B :: C :: D :: nil) >= 2).
{
	assert(HACmtmp : rk(A :: C :: nil) >= 2) by (solve_hyps_min HACeq HACm2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (A :: C :: nil) (A :: B :: C :: D :: nil)) by (repeat clear_all_rk;my_inO).
	apply (rule_5 (A :: C :: nil) (A :: B :: C :: D :: nil) 2 2 HACmtmp Hcomp Hincl).
}

(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : 4 *)
assert(HABCDm3 : rk(A :: B :: C :: D :: nil) >= 3).
{
	assert(HABDmtmp : rk(A :: B :: D :: nil) >= 3) by (solve_hyps_min HABDeq HABDm3).
	assert(Hcomp : 3 <= 3) by (repeat constructor).
	assert(Hincl : incl (A :: B :: D :: nil) (A :: B :: C :: D :: nil)) by (repeat clear_all_rk;my_inO).
	apply ( rule_5 (A :: B :: D :: nil) (A :: B :: C :: D :: nil) 3 3 HABDmtmp Hcomp Hincl ).
}

assert(HABCDM : rk(A :: B :: C :: D ::  nil) <= 3) by (solve_hyps_max HABCDeq HABCDM3).
assert(HABCDm : rk(A :: B :: C :: D ::  nil) >= 1) by (solve_hyps_min HABCDeq HABCDm1).
intuition.
Qed.

(* dans la couche 0 *)
Lemma LABC : forall A B C D ,
rk(A :: C ::  nil) = 2 -> rk(A :: B :: D ::  nil) = 3 -> rk(C :: D ::  nil) = 2 ->
rk(A :: C :: D ::  nil) = 2 -> rk(A :: B :: C ::  nil) = 3.
Proof.

intros A B C D
HACeq HABDeq HCDeq HACDeq .

(* dans constructProofaux(), preuve de 2 <= rg <= 3 pour ABC requis par la preuve de (?)ABC pour la règle 2  *)
(* dans constructProofaux(), preuve de 1 <= rg <= 3 pour ABC requis par la preuve de (?)ABC pour la règle 5  *)
(* Application de la règle 5 code (1 ou 2 dans la thèse) *)
(* marque de l'antécédent : 4 *)
assert(HABCm2 : rk(A :: B :: C :: nil) >= 2).
{
	assert(HACmtmp : rk(A :: C :: nil) >= 2) by (solve_hyps_min HACeq HACm2).
	assert(Hcomp : 2 <= 2) by (repeat constructor).
	assert(Hincl : incl (A :: C :: nil) (A :: B :: C :: nil)) by (repeat clear_all_rk;my_inO).
	apply (rule_5 (A :: C :: nil) (A :: B :: C :: nil) 2 2 HACmtmp Hcomp Hincl).
}

(* Application de la règle 2 code (7 ou 8 dans la thèse) conclusion A*)
(* marque des antécédents AUB AiB B: 4 4 et 4*)
assert(HABCm3 : rk(A :: B :: C :: nil) >= 3).
{
	assert(HACDMtmp : rk(A :: C :: D :: nil) <= 2) by (solve_hyps_max HACDeq HACDM2).
	assert(HABCDeq : rk(A :: B :: C :: D :: nil) = 3) by (apply LABCD with (A := A) (B := B) (C := C) (D := D) ; assumption).
	assert(HABCDmtmp : rk(A :: B :: C :: D :: nil) >= 3) by (solve_hyps_min HABCDeq HABCDm3).
	assert(HACmtmp : rk(A :: C :: nil) >= 2) by (solve_hyps_min HACeq HACm2).
	assert(Hincl : incl (A :: C :: nil) (list_inter (A :: B :: C :: nil) (A :: C :: D :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (A :: B :: C :: D :: nil) (A :: B :: C :: A :: C :: D :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (A :: B :: C :: A :: C :: D :: nil) ((A :: B :: C :: nil) ++ (A :: C :: D :: nil))) by (clear_all_rk;my_inO).
	rewrite HT1 in HABCDmtmp;rewrite HT2 in HABCDmtmp.
	apply ( rule_2 (A :: B :: C :: nil) (A :: C :: D :: nil) (A :: C :: nil) 3 2 2 HABCDmtmp HACmtmp HACDMtmp Hincl).
}

assert(HABCM : rk(A :: B :: C ::  nil) <= 3) by (solve_hyps_max HABCeq HABCM3).
assert(HABCm : rk(A :: B :: C ::  nil) >= 1) by (solve_hyps_min HABCeq HABCm1).
intuition.
Qed.


(** * Definition of a [comp]-based specification of a CFG parser-recognizer *)
Require Import Computation.Core Parsers.ContextFreeGrammar.

Set Implicit Arguments.

Definition parser_spec CharType (String : string_like CharType)
           (G : grammar CharType)
: String -> Comp bool
  := fun str => { b : bool | b = true <-> inhabited (parse_of_grammar String str G) }%comp.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export parallelisme_concours.
Set Implicit Arguments.
Unset Strict Implicit.

Definition translation (I J A : PO) :=
  barycentre (cons (-1) I) (cons 2 (barycentre (cons 1 J) (cons 1 A))).

Lemma translation_vecteur :
 forall I J A A' : PO, A' = translation I J A -> vec I J = vec A A'.
unfold vec, translation in |- *; intros.
rewrite H.
pattern 1 at 4 in |- *.
replace 1 with (-1 + 2); try ring.
repeat rewrite <- add_PP_barycentre; try discrR; auto.
RingPP.
Qed.

Lemma translation_identite :
 forall I A A' : PO, A' = translation I I A :>PO -> A = A'.
intros.
apply vecteur_nul_conf; auto.
rewrite <- (translation_vecteur (I:=I) (J:=I) (A:=A) (A':=A')); auto.
Ringvec.
Qed.

Lemma rec_translation_vecteur :
 forall I J A A' : PO, vec I J = vec A A' :>PP -> A' = translation I J A :>PO.
unfold vec, translation in |- *; intros.
elim
 cons_inj
  with
    (a := 1)
    (b := -1 + 2)
    (A := A')
    (B := barycentre (cons (-1) I)
            (cons 2 (barycentre (cons 1 J) (cons 1 A))));
 intros; auto with *.
repeat rewrite <- add_PP_barycentre; try discrR.
RingPP1 H.
RingPP.
Qed.

Lemma translation_trivial : forall I J : PO, J = translation I J I.
intros.
apply rec_translation_vecteur; auto.
Qed.
Hint Resolve translation_trivial: geo.

Lemma translation_bipoint :
 forall I J A A' B B' : PO,
 A' = translation I J A :>PO ->
 B' = translation I J B :>PO -> vec A B = vec A' B'.
intros I J A A' B B' H H0; try assumption.
apply egalite_vecteur.
rewrite <- (translation_vecteur (I:=I) (J:=J) (A:=A) (A':=A')); auto.
rewrite <- (translation_vecteur (I:=I) (J:=J) (A:=B) (A':=B')); auto.
Qed.

Lemma translation_trans :
 forall I J A A' B B' : PO,
 A' = translation I J A :>PO ->
 B' = translation I J B :>PO -> B' = translation A A' B :>PO.
intros I J A A' B B' H H0; try assumption.
apply rec_translation_vecteur.
rewrite <- (translation_vecteur (I:=I) (J:=J) (A:=A) (A':=A')); auto.
rewrite <- (translation_vecteur (I:=I) (J:=J) (A:=B) (A':=B')); auto.
Qed.

Lemma image_translation_distincts :
 forall I J A A' B B' : PO,
 A <> B -> A' = translation I J A :>PO -> B' = translation I J B -> A' <> B'.
intros.
apply distinct_egalite_vecteur with (A := A) (B := B); auto.
symmetry  in |- *; apply translation_bipoint with (I := I) (J := J); auto.
Qed.

Lemma translation_droite :
 forall I J A A' B B' : PO,
 A <> B ->
 A' = translation I J A :>PO ->
 B' = translation I J B :>PO -> paralleles (droite A' B') (droite A B).
intros.
apply colineaires_paralleles with 1; auto.
apply image_translation_distincts with (2 := H0) (3 := H1); auto.
replace (mult_PP 1 (vec A B)) with (vec A B).
symmetry  in |- *; apply translation_bipoint with (I := I) (J := J); auto.
Ringvec.
Qed.

Lemma translation_milieu :
 forall I J A A' B B' M N : PO,
 A' = translation I J A :>PO ->
 B' = translation I J B ->
 M = milieu A B -> N = milieu A' B' -> N = translation I J M.
intros I J A A' B B' M N H H0 H1 H2; try assumption.
apply rec_translation_vecteur; auto.
replace (vec M N) with (add_PP (cons (-1) M) (cons 1 N)); auto.
apply mult_PP_regulier with 2; try discrR.
repeat rewrite <- distrib_mult_cons.
replace (2 * 1) with 2; try ring; auto.
rewrite H2.
rewrite <- add_PP_milieu.
replace (2 * -1) with (-1 * 2); try ring; auto.
repeat rewrite <- def_mult_PP.
rewrite H1.
rewrite <- add_PP_milieu.
repeat rewrite <- distrib_mult_cons.
replace (-1 * 1) with (-1); try ring; auto.
rewrite <- calcul; auto.
replace (add_PP (cons (-1) B) (cons 1 B')) with (vec B B'); auto.
rewrite <- (translation_vecteur (I:=A) (J:=A') (A:=B) (A':=B')); auto.
rewrite (translation_vecteur (I:=I) (J:=J) (A:=A) (A':=A')); auto.
Ringvec.
apply translation_trans with (1 := H); auto.
Qed.

Lemma translation_alignement :
 forall I J A A' B B' C C' : PO,
 A' = translation I J A :>PO ->
 B' = translation I J B :>PO ->
 C' = translation I J C -> alignes A B C -> alignes A' B' C'.
intros I J A A' B B' C C' H H0 H1 H2; try assumption.
discrimine A B.
assert (A' = B'); auto with geo.
rewrite H0; rewrite <- H3; auto.
halignes H2 ipattern:(k).
apply colineaire_alignes with k.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=A) (A':=A') (B:=B) (B':=B'))
 ; auto.
rewrite <- H4; auto.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=A) (A':=A') (B:=C) (B':=C'))
 ; auto.
Qed.

Lemma translation_inverse :
 forall I J A A' : PO,
 A' = translation I J A :>PO -> A = translation J I A' :>PO.
intros.
apply rec_translation_vecteur; auto.
VReplace (vec J I) (mult_PP (-1) (vec I J)).
rewrite (translation_vecteur (I:=I) (J:=J) (A:=A) (A':=A')); auto.
Ringvec.
Qed.
Hint Resolve translation_inverse: geo.

Lemma translation_intersection :
 forall I J A A' B B' C C' D D' K K' : PO,
 A <> B ->
 C <> D ->
 ~ alignes A B C \/ ~ alignes A B D ->
 K = pt_intersection (droite A B) (droite C D) ->
 A' = translation I J A :>PO ->
 B' = translation I J B ->
 C' = translation I J C :>PO ->
 D' = translation I J D :>PO ->
 K' = translation I J K :>PO ->
 K' = pt_intersection (droite A' B') (droite C' D').
intros.
elim def_pt_intersection2 with (A := A) (B := B) (C := C) (D := D) (I := K);
 [ try clear def_pt_intersection2; intros | auto | auto | auto | auto ].
apply def_pt_intersection; auto.
apply image_translation_distincts with (2 := H3) (3 := H4); auto.
apply image_translation_distincts with (2 := H5) (3 := H6); auto.
elim H1;
 [ intros H10; try clear H1 | intros H10; try clear H1; try exact H10 ].
left.
red in |- *; intros; apply H10.
apply
 (translation_alignement (I:=J) (J:=I) (A:=A') (A':=A) (B:=B') (B':=B)
    (C:=C') (C':=C)); auto with geo.
right; red in |- *; intros H1; apply H10.
apply
 (translation_alignement (I:=J) (J:=I) (A:=A') (A':=A) (B:=B') (B':=B)
    (C:=D') (C':=D)); auto with geo.
apply
 (translation_alignement (I:=I) (J:=J) (A:=A) (A':=A') (B:=B) (B':=B') (C:=K)
    (C':=K')); auto with geo.
apply
 (translation_alignement (I:=I) (J:=J) (A:=C) (A':=C') (B:=D) (B':=D') (C:=K)
    (C':=K')); auto with geo.
Qed.

Lemma translation_paralleles :
 forall I J A A' B B' C C' D D' : PO,
 A <> B ->
 C <> D ->
 paralleles (droite A B) (droite C D) ->
 A' = translation I J A :>PO ->
 B' = translation I J B ->
 C' = translation I J C :>PO ->
 D' = translation I J D :>PO -> paralleles (droite A' B') (droite C' D').
intros.
elim paralleles_vecteur with (A := A) (B := B) (C := C) (D := D);
 [ intros k H6; try clear paralleles_vecteur; try exact H6
 | auto
 | auto
 | auto ].
apply colineaires_paralleles with k.
apply distinct_egalite_vecteur with (A := A) (B := B); auto.
symmetry  in |- *; apply translation_bipoint with (I := I) (J := J); auto.
apply distinct_egalite_vecteur with (A := C) (B := D); auto.
symmetry  in |- *; apply translation_bipoint with (I := I) (J := J); auto.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=C) (A':=C') (B:=D) (B':=D'))
 ; auto.
rewrite <- H6; auto.
symmetry  in |- *; apply translation_bipoint with (I := I) (J := J); auto.
Qed.

Definition homothetie (k : R) (I A : PO) :=
  barycentre (cons k A) (cons (1 + - k) I).

Lemma homothetie_identite : forall I A : PO, A = homothetie 1 I A.
unfold homothetie, vec in |- *; intros.
replace (1 + -1) with 0; try ring; auto.
rewrite barycentre_zero; auto with *.
Qed.

Lemma vecteur_homothetie :
 forall (k : R) (I A A' : PO),
 vec I A' = mult_PP k (vec I A) :>PP -> A' = homothetie k I A :>PO.
unfold vec, homothetie in |- *; intros.
elim
 cons_inj
  with
    (a := 1)
    (b := k + (1 + - k))
    (A := A')
    (B := barycentre (cons k A) (cons (1 + - k) I));
 intros; auto with *.
repeat rewrite <- add_PP_barycentre; try discrR.
RingPP2 H.
RingPP.
replace (k + (1 + - k)) with 1; try ring; try discrR.
Qed.

Lemma homothetie_centre : forall (I : PO) (k : R), I = homothetie k I I.
intros.
apply vecteur_homothetie.
Ringvec.
Qed.
Hint Resolve homothetie_centre: geo.

Lemma homothetie_vecteur :
 forall (k : R) (I A A' : PO),
 A' = homothetie k I A -> vec I A' = mult_PP k (vec I A).
unfold homothetie, vec in |- *; intros.
rewrite H.
pattern 1 at 2 in |- *.
replace 1 with (k + (1 + - k)); try ring.
repeat rewrite <- add_PP_barycentre; try discrR.
RingPP.
replace (k + (1 + - k)) with 1; try ring.
try discrR.
Qed.

Definition symetrie (I A : PO) := homothetie (-1) I A.

Lemma milieu_symetrie :
 forall A B I : PO, I = milieu A B :>PO -> B = symetrie I A :>PO.
unfold symetrie in |- *; intros.
apply vecteur_homothetie.
rewrite <- (milieu_vecteur (A:=A) (B:=B) (M:=I)); auto.
Ringvec.
Qed.

Lemma symetrie_milieu :
 forall A B I : PO, B = symetrie I A :>PO -> I = milieu A B :>PO.
unfold symetrie in |- *; intros.
cut (vec I B = mult_PP (-1) (vec I A)); intros.
2: apply homothetie_vecteur; auto.
apply vecteur_milieu.
replace (vec A B) with (add_PP (vec A I) (vec I B)); [ idtac | Ringvec ].
rewrite H0.
cut (2 <> 0); intros; auto with real.
Fieldvec 2.
Qed.
Hint Resolve milieu_symetrie symetrie_milieu: geo.

Lemma symetrie_involution :
 forall A B I : PO, B = symetrie I A :>PO -> A = symetrie I B :>PO.
intros.
apply milieu_symetrie.
apply milieu_permute.
apply symetrie_milieu; auto.
Qed.

Lemma existence_homothetique :
 forall (k : R) (I A : PO), exists A' : PO, A' = homothetie k I A.
intros.
elim
 existence_representant_mult_vecteur with (A := I) (B := I) (C := A) (k := k);
 intros A' H1; try clear existence_representant_mult_vecteur.
exists A'.
apply vecteur_homothetie; auto.
Qed.

Lemma existence_symetrique : forall A B : PO, exists C : PO, C = symetrie A B.
unfold symetrie in |- *; intros.
apply (existence_homothetique (-1) A B).
Qed.

Ltac symetrique O A B :=
  elim (existence_symetrique O A); intros B; intros; assert (O = milieu A B);
   auto with geo.

Lemma existence_symetrique_milieu:
 forall (A I : PO),  (exists B : PO , I = milieu A B ).
intros.
elim (existence_symetrique I A);
 [intros B H; (try clear existence_symetrique); (try exact H)].
exists B.
apply symetrie_milieu; auto.
Qed.

Lemma unicite_symetrique:
 forall (A B P : PO), milieu A P = milieu B P ->  A = B.
intros.
elim (existence_milieu B P); [intros I H1; (try clear existence_milieu)].
assert (B = symetrie I P).
apply milieu_symetrie; auto with geo.
rewrite H0.
apply milieu_symetrie.
rewrite H1.
auto with geo.
Qed.

Lemma homothetie_bipoint :
 forall (k : R) (I A B A' B' : PO),
 A' = homothetie k I A ->
 B' = homothetie k I B -> vec A' B' = mult_PP k (vec A B).
unfold homothetie, vec in |- *; intros.
rewrite H.
rewrite H0.
replace (cons (-1) (barycentre (cons k A) (cons (1 + - k) I))) with
 (mult_PP (-1) (cons 1 (barycentre (cons k A) (cons (1 + - k) I))));
 try ring; auto.
pattern 1 at 2 in |- *.
replace 1 with (k + (1 + - k)); try ring.
pattern 1 at 4 in |- *.
replace 1 with (k + (1 + - k)); try ring.
repeat rewrite <- add_PP_barycentre; try discrR.
RingPP.
replace (k + (1 + - k)) with 1; try ring.
try discrR.
replace (k + (1 + - k)) with 1; try ring.
try discrR.
RingPP.
Qed.

Lemma homothetie_milieu :
 forall (k : R) (I A A' B B' M N : PO),
 k <> 0 ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO ->
 M = milieu A B :>PO -> N = milieu A' B' :>PO -> homothetie k I M = N.
unfold homothetie, milieu in |- *; intros.
rewrite H2; rewrite H3; rewrite H1; rewrite H0.
elim
 cons_inj
  with
    (a := 2)
    (b := 2)
    (A := barycentre (cons k (barycentre (cons 1 A) (cons 1 B)))
            (cons (1 + - k) I))
    (B := barycentre (cons 1 (barycentre (cons k A) (cons (1 + - k) I)))
            (cons 1 (barycentre (cons k B) (cons (1 + - k) I))));
 (intros; auto); try discrR.
repeat rewrite <- add_PP_barycentre; try discrR.
replace 2 with (2 * (k + (1 + - k))); try ring; auto.
rewrite <-
 (homogene_barycentre (a:=k) (b:=1 + - k) (k:=2)
    (barycentre (cons 1 A) (cons 1 B)) I); try discrR.
replace (2 * (k + (1 + - k))) with (2 * k + 2 * (1 + - k)); try ring;
 try discrR.
repeat rewrite <- add_PP_barycentre; try discrR.
rewrite <- (homogene_barycentre (a:=1) (b:=1) (k:=k) A B); auto; try discrR.
replace (2 * k) with (k * 1 + k * 1); try ring; auto.
repeat rewrite <- add_PP_barycentre; auto; try discrR.
pattern 1 at 6 in |- *.
replace 1 with (k + (1 + - k)); try ring; auto.
repeat rewrite <- add_PP_barycentre; try discrR.
pattern 1 at 7 in |- *.
replace 1 with (k + (1 + - k)); try ring; auto.
repeat rewrite <- add_PP_barycentre; try discrR.
RingPP.
replace (k + (1 + - k)) with 1; try ring; try discrR.
replace (k + (1 + - k)) with 1; try ring; try discrR.
replace (k * 1 + k * 1) with (k * 2); try ring; auto.
apply Rmult_integral_contrapositive; (split; auto; try discrR).
replace (2 * k + 2 * (1 + - k)) with (2 * 1); try ring; try discrR.
replace (k + (1 + - k)) with 1; try ring; try discrR.
Qed.

Lemma image_homothetie_distincts :
 forall (k : R) (I A A' B B' : PO),
 k <> 0 :>R ->
 A <> B -> A' = homothetie k I A :>PO -> B' = homothetie k I B -> A' <> B'.
intros.
cut (vec A' B' <> zero); intros.
red in |- *; intros; apply H3; auto.
rewrite H4; Ringvec.
rewrite (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'));
 auto.
red in |- *; intros.
elim produit_vecteur_nul with (a := k) (A := A) (B := B);
 [ intros; try trivial | intros; try trivial | try trivial ].
absurd (k = 0); auto.
absurd (A = B); auto.
Qed.

Lemma homothetie_droite :
 forall (k : R) (I A A' B B' : PO),
 k <> 0 :>R ->
 A <> B ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO -> paralleles (droite A' B') (droite A B).
intros.
apply colineaires_paralleles with k; auto.
apply image_homothetie_distincts with (3 := H1) (4 := H2); auto.
apply homothetie_bipoint with (I := I); auto.
Qed.

Lemma homothetie_inverse :
 forall (k : R) (I A A' : PO),
 k <> 0 :>R -> A' = homothetie k I A :>PO -> A = homothetie (/ k) I A' :>PO.
intros.
apply vecteur_homothetie.
rewrite (homothetie_vecteur (k:=k) (I:=I) (A:=A) (A':=A')); auto.
Fieldvec k.
Qed.
Hint Resolve homothetie_inverse: geo.

Lemma homothetie_alignement :
 forall (k : R) (I A B A' B' C C' : PO),
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO ->
 C' = homothetie k I C -> alignes A B C -> alignes A' B' C'.
intros k I A B A' B' C C' H H0 H1 H2; try assumption.
discrimine A B.
assert (A' = B'); auto with geo.
rewrite H0; rewrite <- H3; auto.
halignes H2 ipattern:(k0).
apply colineaire_alignes with k0.
rewrite (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'));
 auto.
rewrite (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=C) (A':=A') (B':=C'));
 auto.
rewrite H4.
Ringvec.
Qed.

Lemma homothetie_paralleles :
 forall (k : R) (I A A' B B' C C' D D' : PO),
 k <> 0 :>R ->
 A <> B ->
 C <> D ->
 paralleles (droite A B) (droite C D) ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B ->
 C' = homothetie k I C :>PO ->
 D' = homothetie k I D :>PO -> paralleles (droite A' B') (droite C' D').
intros.
elim paralleles_vecteur with (A := A) (B := B) (C := C) (D := D);
 [ intros x H7; try clear paralleles_vecteur | auto | auto | auto ].
apply colineaires_paralleles with x.
apply
 (image_homothetie_distincts (k:=k) (I:=I) (A:=A) (A':=A') (B:=B) (B':=B'));
 auto.
apply
 (image_homothetie_distincts (k:=k) (I:=I) (A:=C) (A':=C') (B:=D) (B':=D'));
 auto.
rewrite (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'));
 auto.
rewrite (homothetie_bipoint (k:=k) (I:=I) (A:=C) (B:=D) (A':=C') (B':=D'));
 auto.
rewrite H7; Ringvec.
Qed.

Lemma homothetie_intersection :
 forall (k : R) (I A A' B B' C C' D D' K K' : PO),
 k <> 0 :>R ->
 A <> B ->
 C <> D ->
 ~ alignes A B C \/ ~ alignes A B D ->
 K = pt_intersection (droite A B) (droite C D) :>PO ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B ->
 C' = homothetie k I C :>PO ->
 D' = homothetie k I D :>PO ->
 K' = homothetie k I K :>PO ->
 K' = pt_intersection (droite A' B') (droite C' D') :>PO.
intros.
elim def_pt_intersection2 with (A := A) (B := B) (C := C) (D := D) (I := K);
 [ try clear def_pt_intersection2; intros | auto | auto | auto | auto ].
apply def_pt_intersection; auto.
apply image_homothetie_distincts with (3 := H4) (4 := H5); auto.
apply image_homothetie_distincts with (3 := H6) (4 := H7); auto.
elim H2;
 [ intros H11; try clear H2 | intros H11; try clear H2; try exact H11 ].
left.
red in |- *; intros; apply H11.
apply
 (homothetie_alignement (k:=/ k) (I:=I) (A:=A') (B:=B') (A':=A) (B':=B)
    (C:=C') (C':=C)); auto with geo.
right; red in |- *; intros H2; apply H11.
apply
 (homothetie_alignement (k:=/ k) (I:=I) (A:=A') (B:=B') (A':=A) (B':=B)
    (C:=D') (C':=D)); auto with geo.
apply
 (homothetie_alignement (k:=k) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B') (C:=K)
    (C':=K')); auto with geo.
apply
 (homothetie_alignement (k:=k) (I:=I) (A:=C) (B:=D) (A':=C') (B':=D') (C:=K)
    (C':=K')); auto with geo.
Qed.

Lemma paralleles_dilatations :
 forall A A' B B' : PO,
 A <> B ->
 A' <> B' ->
 paralleles (droite A' B') (droite A B) ->
 (exists I : PO,
    (exists J : PO, A' = translation I J A /\ B' = translation I J B)) \/
 (exists k : R,
    (exists I : PO, A' = homothetie k I A /\ B' = homothetie k I B)).
intros.
elim paralleles_vecteur with (A := A') (B := B') (C := A) (D := B);
 [ intros k H2; try clear paralleles_vecteur; try exact H2
 | trivial
 | trivial
 | trivial ].
elim (classic (k = 0)); intros; auto.
absurd (A' = B'); intros; auto.
apply vecteur_nul_conf; auto.
rewrite H2; rewrite H3; Ringvec.
elim (classic (k = 1)); intros; auto.
rewrite H4 in H2.
left; try assumption.
exists A; exists A'.
split; apply rec_translation_vecteur; auto.
apply egalite_vecteur; rewrite H2; Ringvec.
right; try assumption.
exists k; exists (barycentre (cons (- k) A) (cons 1 A')).
cut (A' = homothetie k (barycentre (cons (- k) A) (cons 1 A')) A).
intros H20.
split; [ try assumption | idtac ].
apply vecteur_homothetie.
replace (vec (barycentre (cons (- k) A) (cons 1 A')) B') with
 (add_PP (vec (barycentre (cons (- k) A) (cons 1 A')) A') (vec A' B')).
cut
 (vec (barycentre (cons (- k) A) (cons 1 A')) A' =
  mult_PP k (vec (barycentre (cons (- k) A) (cons 1 A')) A));
 intros.
rewrite H5; rewrite H2; Ringvec.
apply homothetie_vecteur; auto.
Ringvec.
unfold homothetie in |- *.
replace (1 + - k) with (- k + 1); try ring; auto.
apply conversion_PP with (a := 1) (b := 1); auto with real.
pattern 1 at 2 in |- *.
replace 1 with (k + (- k + 1)); try ring; auto.
rewrite <- add_PP_barycentre; auto.
rewrite <- add_PP_barycentre; auto.
RingPP.
red in |- *; intros; apply H4.
replace 1 with (k + (- k + 1)).
rewrite H5; try ring.
ring.
replace (k + (- k + 1)) with 1; try ring; auto with real.
Qed.


From iris.algebra Require Export ofe.
From iris Require Import options.

(** The Monoid class that is used for generic big operators in the file
[algebra/big_op]. The operation is an argument because we want to have multiple
monoids over the same type (for example, on [uPred]s we have monoids for [∗],
[∧], and [∨]). However, we do bundle the unit because:

- If we would not, it would appear explicitly in an argument of the big
  operators, which confuses rewrite. Now it is hidden in the class, and hence
  rewrite won't even see it.
- The unit is unique.

We could in principle have big ops over setoids instead of OFEs. However, since
we do not have a canonical structure for setoids, we do not go that way.

Note that we do not declare any of the projections as type class instances. That
is because we only need them in the [big_op] file, and nowhere else. Hence, we
declare these instances locally there to avoid them being used elsewhere. *)
Class Monoid {M : ofeT} (o : M → M → M) := {
  monoid_unit : M;
  monoid_ne : NonExpansive2 o;
  monoid_assoc : Assoc (≡) o;
  monoid_comm : Comm (≡) o;
  monoid_left_id : LeftId (≡) monoid_unit o;
}.
Lemma monoid_proper `{Monoid M o} : Proper ((≡) ==> (≡) ==> (≡)) o.
Proof. apply ne_proper_2, monoid_ne. Qed.
Lemma monoid_right_id `{Monoid M o} : RightId (≡) monoid_unit o.
Proof. intros x. etrans; [apply monoid_comm|apply monoid_left_id]. Qed.

(** The [Homomorphism] classes give rise to generic lemmas about big operators
commuting with each other. We also consider a [WeakMonoidHomomorphism] which
does not necessarily commute with unit; an example is the [own] connective: we
only have `True ==∗ own γ ∅`, not `True ↔ own γ ∅`. *)
Class WeakMonoidHomomorphism {M1 M2 : ofeT}
    (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{Monoid M1 o1, Monoid M2 o2}
    (R : relation M2) (f : M1 → M2) := {
  monoid_homomorphism_rel_po : PreOrder R;
  monoid_homomorphism_rel_proper : Proper ((≡) ==> (≡) ==> iff) R;
  monoid_homomorphism_op_proper : Proper (R ==> R ==> R) o2;
  monoid_homomorphism_ne : NonExpansive f;
  monoid_homomorphism x y : R (f (o1 x y)) (o2 (f x) (f y))
}.

Class MonoidHomomorphism {M1 M2 : ofeT}
    (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{Monoid M1 o1, Monoid M2 o2}
    (R : relation M2) (f : M1 → M2) := {
  monoid_homomorphism_weak :> WeakMonoidHomomorphism o1 o2 R f;
  monoid_homomorphism_unit : R (f monoid_unit) monoid_unit
}.

Lemma weak_monoid_homomorphism_proper
  `{WeakMonoidHomomorphism M1 M2 o1 o2 R f} : Proper ((≡) ==> (≡)) f.
Proof. apply ne_proper, monoid_homomorphism_ne. Qed.


(***************************************************************************
* Safety for STLC with Exceptions - Definitions                            *
* Extented from "Type Safety for STLC" by                                  *
* Arthur Charguéraud, July 2007, Coq v8.1                                  *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory.

(** Grammar of types. *)

Parameter atm : Set.

Inductive typ : Set :=
  | typ_exn : typ
  | typ_var : atm -> typ
  | typ_arrow  : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_raise : trm -> trm
  | trm_catch : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if k === i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_raise t1  => trm_raise (open_rec k u t1)
  | trm_catch t1 t2 => trm_catch (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_raise : forall t1,
      term t1 ->
      term (trm_raise t1)
  | term_catch : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_catch t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := Env.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L -> (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) -> E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T
  | typing_raise : forall E t1 T,
      E |= t1 ~: typ_exn ->
      E |= (trm_raise t1) ~: T
  | typing_catch : forall E t1 t2 T,
      E |= t1 ~: (typ_arrow typ_exn T) ->
      E |= t2 ~: T ->
      E |= (trm_catch t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Exception generation *)

Inductive fails : trm -> trm -> Prop :=
  | fails_raise_val : forall t1,
      value t1 ->
      fails (trm_raise t1) t1
  | fails_raise_1 : forall t1 e,
      fails t1 e ->
      fails (trm_raise t1) e
  | fails_app_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_app t1 t2) e
  | fails_app_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_app t1 t2) e.

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2')
  | red_catch_2 : forall t1 t2 t2',
      term t1 ->
      red t2 t2' ->
      red (trm_catch t1 t2) (trm_catch t1 t2')
  | red_catch_val : forall t1 t2,
      term t1 ->
      value t2 ->
      red (trm_catch t1 t2) t2
  | red_catch_exn : forall t1 t2 e,
      term t1 ->
      fails t2 e ->
      red (trm_catch t1 t2) (trm_app t1 e)
  | red_raise_1 : forall t1 t1',
      red t1 t1' ->
      red (trm_raise t1) (trm_raise t1').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ (exists e, fails t e)
  \/ (exists t', t --> t').


From algebra Require Export cmra option.
From prelude Require Export gmap.
From algebra Require Import upred.

Section cofe.
Context `{Countable K} {A : cofeT}.
Implicit Types m : gmap K A.

Instance map_dist : Dist (gmap K A) := λ n m1 m2,
  ∀ i, m1 !! i ≡{n}≡ m2 !! i.
Program Definition map_chain (c : chain (gmap K A))
  (k : K) : chain (option A) := {| chain_car n := c n !! k |}.
Next Obligation. by intros c k n i ?; apply (chain_cauchy c). Qed.
Instance map_compl : Compl (gmap K A) := λ c,
  map_imap (λ i _, compl (map_chain c i)) (c 0).
Definition map_cofe_mixin : CofeMixin (gmap K A).
Proof.
  split.
  - intros m1 m2; split.
    + by intros Hm n k; apply equiv_dist.
    + intros Hm k; apply equiv_dist; intros n; apply Hm.
  - intros n; split.
    + by intros m k.
    + by intros m1 m2 ? k.
    + by intros m1 m2 m3 ?? k; trans (m2 !! k).
  - by intros n m1 m2 ? k; apply dist_S.
  - intros n c k; rewrite /compl /map_compl lookup_imap.
    feed inversion (λ H, chain_cauchy c 0 n H k); simpl; auto with lia.
    by rewrite conv_compl /=; apply reflexive_eq.
Qed.
Canonical Structure mapC : cofeT := CofeT map_cofe_mixin.
Global Instance map_discrete : Discrete A → Discrete mapC.
Proof. intros ? m m' ? i. by apply (timeless _). Qed.
(* why doesn't this go automatic? *)
Global Instance mapC_leibniz: LeibnizEquiv A → LeibnizEquiv mapC.
Proof. intros; change (LeibnizEquiv (gmap K A)); apply _. Qed.

Global Instance lookup_ne n k :
  Proper (dist n ==> dist n) (lookup k : gmap K A → option A).
Proof. by intros m1 m2. Qed.
Global Instance lookup_proper k :
  Proper ((≡) ==> (≡)) (lookup k : gmap K A → option A) := _.
Global Instance alter_ne f k n :
  Proper (dist n ==> dist n) f → Proper (dist n ==> dist n) (alter f k).
Proof.
  intros ? m m' Hm k'.
  by destruct (decide (k = k')); simplify_map_eq; rewrite (Hm k').
Qed.
Global Instance insert_ne i n :
  Proper (dist n ==> dist n ==> dist n) (insert (M:=gmap K A) i).
Proof.
  intros x y ? m m' ? j; destruct (decide (i = j)); simplify_map_eq;
    [by constructor|by apply lookup_ne].
Qed.
Global Instance singleton_ne i n :
  Proper (dist n ==> dist n) (singletonM i : A → gmap K A).
Proof. by intros ???; apply insert_ne. Qed.
Global Instance delete_ne i n :
  Proper (dist n ==> dist n) (delete (M:=gmap K A) i).
Proof.
  intros m m' ? j; destruct (decide (i = j)); simplify_map_eq;
    [by constructor|by apply lookup_ne].
Qed.

Instance map_empty_timeless : Timeless (∅ : gmap K A).
Proof.
  intros m Hm i; specialize (Hm i); rewrite lookup_empty in Hm |- *.
  inversion_clear Hm; constructor.
Qed.
Global Instance map_lookup_timeless m i : Timeless m → Timeless (m !! i).
Proof.
  intros ? [x|] Hx; [|by symmetry; apply: timeless].
  assert (m ≡{0}≡ <[i:=x]> m)
    by (by symmetry in Hx; inversion Hx; cofe_subst; rewrite insert_id).
  by rewrite (timeless m (<[i:=x]>m)) // lookup_insert.
Qed.
Global Instance map_insert_timeless m i x :
  Timeless x → Timeless m → Timeless (<[i:=x]>m).
Proof.
  intros ?? m' Hm j; destruct (decide (i = j)); simplify_map_eq.
  { by apply: timeless; rewrite -Hm lookup_insert. }
  by apply: timeless; rewrite -Hm lookup_insert_ne.
Qed.
Global Instance map_singleton_timeless i x :
  Timeless x → Timeless ({[ i := x ]} : gmap K A) := _.
End cofe.

Arguments mapC _ {_ _} _.

(* CMRA *)
Section cmra.
Context `{Countable K} {A : cmraT}.
Implicit Types m : gmap K A.

Instance map_op : Op (gmap K A) := merge op.
Instance map_core : Core (gmap K A) := fmap core.
Instance map_valid : Valid (gmap K A) := λ m, ∀ i, ✓ (m !! i).
Instance map_validN : ValidN (gmap K A) := λ n m, ∀ i, ✓{n} (m !! i).
Instance map_div : Div (gmap K A) := merge div.

Lemma lookup_op m1 m2 i : (m1 ⋅ m2) !! i = m1 !! i ⋅ m2 !! i.
Proof. by apply lookup_merge. Qed.
Lemma lookup_div m1 m2 i : (m1 ÷ m2) !! i = m1 !! i ÷ m2 !! i.
Proof. by apply lookup_merge. Qed.
Lemma lookup_core m i : core m !! i = core (m !! i).
Proof. by apply lookup_fmap. Qed.

Lemma map_included_spec (m1 m2 : gmap K A) : m1 ≼ m2 ↔ ∀ i, m1 !! i ≼ m2 !! i.
Proof.
  split.
  - by intros [m Hm]; intros i; exists (m !! i); rewrite -lookup_op Hm.
  - intros Hm; exists (m2 ÷ m1); intros i.
    by rewrite lookup_op lookup_div cmra_op_div.
Qed.
Lemma map_includedN_spec (m1 m2 : gmap K A) n :
  m1 ≼{n} m2 ↔ ∀ i, m1 !! i ≼{n} m2 !! i.
Proof.
  split.
  - by intros [m Hm]; intros i; exists (m !! i); rewrite -lookup_op Hm.
  - intros Hm; exists (m2 ÷ m1); intros i.
    by rewrite lookup_op lookup_div cmra_op_div'.
Qed.

Definition map_cmra_mixin : CMRAMixin (gmap K A).
Proof.
  split.
  - by intros n m1 m2 m3 Hm i; rewrite !lookup_op (Hm i).
  - by intros n m1 m2 Hm i; rewrite !lookup_core (Hm i).
  - by intros n m1 m2 Hm ? i; rewrite -(Hm i).
  - by intros n m1 m1' Hm1 m2 m2' Hm2 i; rewrite !lookup_div (Hm1 i) (Hm2 i).
  - intros m; split.
    + by intros ? n i; apply cmra_valid_validN.
    + intros Hm i; apply cmra_valid_validN=> n; apply Hm.
  - intros n m Hm i; apply cmra_validN_S, Hm.
  - by intros m1 m2 m3 i; rewrite !lookup_op assoc.
  - by intros m1 m2 i; rewrite !lookup_op comm.
  - by intros m i; rewrite lookup_op !lookup_core cmra_core_l.
  - by intros m i; rewrite !lookup_core cmra_core_idemp.
  - intros x y; rewrite !map_included_spec; intros Hm i.
    by rewrite !lookup_core; apply cmra_core_preserving.
  - intros n m1 m2 Hm i; apply cmra_validN_op_l with (m2 !! i).
    by rewrite -lookup_op.
  - intros x y; rewrite map_included_spec=> ? i.
    by rewrite lookup_op lookup_div cmra_op_div.
  - intros n m m1 m2 Hm Hm12.
    assert (∀ i, m !! i ≡{n}≡ m1 !! i ⋅ m2 !! i) as Hm12'
      by (by intros i; rewrite -lookup_op).
    set (f i := cmra_extend n (m !! i) (m1 !! i) (m2 !! i) (Hm i) (Hm12' i)).
    set (f_proj i := proj1_sig (f i)).
    exists (map_imap (λ i _, (f_proj i).1) m, map_imap (λ i _, (f_proj i).2) m);
      repeat split; intros i; rewrite /= ?lookup_op !lookup_imap.
    + destruct (m !! i) as [x|] eqn:Hx; rewrite !Hx /=; [|constructor].
      rewrite -Hx; apply (proj2_sig (f i)).
    + destruct (m !! i) as [x|] eqn:Hx; rewrite /=; [apply (proj2_sig (f i))|].
      pose proof (Hm12' i) as Hm12''; rewrite Hx in Hm12''.
      by symmetry; apply option_op_positive_dist_l with (m2 !! i).
    + destruct (m !! i) as [x|] eqn:Hx; simpl; [apply (proj2_sig (f i))|].
      pose proof (Hm12' i) as Hm12''; rewrite Hx in Hm12''.
      by symmetry; apply option_op_positive_dist_r with (m1 !! i).
Qed.
Canonical Structure mapR : cmraT := CMRAT map_cofe_mixin map_cmra_mixin.
Global Instance map_cmra_unit : CMRAUnit mapR.
Proof.
  split.
  - by intros i; rewrite lookup_empty.
  - by intros m i; rewrite /= lookup_op lookup_empty (left_id_L None _).
  - apply map_empty_timeless.
Qed.
Global Instance map_cmra_discrete : CMRADiscrete A → CMRADiscrete mapR.
Proof. split; [apply _|]. intros m ? i. by apply: cmra_discrete_valid. Qed.

(** Internalized properties *)
Lemma map_equivI {M} m1 m2 : (m1 ≡ m2)%I ≡ (∀ i, m1 !! i ≡ m2 !! i : uPred M)%I.
Proof. by uPred.unseal. Qed.
Lemma map_validI {M} m : (✓ m)%I ≡ (∀ i, ✓ (m !! i) : uPred M)%I.
Proof. by uPred.unseal. Qed.
End cmra.

Arguments mapR _ {_ _} _.

Section properties.
Context `{Countable K} {A : cmraT}.
Implicit Types m : gmap K A.
Implicit Types i : K.
Implicit Types a : A.

Lemma map_lookup_validN n m i x : ✓{n} m → m !! i ≡{n}≡ Some x → ✓{n} x.
Proof. by move=> /(_ i) Hm Hi; move:Hm; rewrite Hi. Qed.
Lemma map_lookup_valid m i x : ✓ m → m !! i ≡ Some x → ✓ x.
Proof. move=> Hm Hi. move:(Hm i). by rewrite Hi. Qed.
Lemma map_insert_validN n m i x : ✓{n} x → ✓{n} m → ✓{n} <[i:=x]>m.
Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_eq. Qed.
Lemma map_insert_valid m i x : ✓ x → ✓ m → ✓ <[i:=x]>m.
Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_eq. Qed.
Lemma map_singleton_validN n i x : ✓{n} ({[ i := x ]} : gmap K A) ↔ ✓{n} x.
Proof.
  split; [|by intros; apply map_insert_validN, cmra_unit_validN].
  by move=>/(_ i); simplify_map_eq.
Qed.
Lemma map_singleton_valid i x : ✓ ({[ i := x ]} : gmap K A) ↔ ✓ x.
Proof. rewrite !cmra_valid_validN. by setoid_rewrite map_singleton_validN. Qed.

Lemma map_insert_singleton_opN n m i x :
  m !! i = None ∨ m !! i ≡{n}≡ Some (core x) → <[i:=x]> m ≡{n}≡ {[ i := x ]} ⋅ m.
Proof.
  intros Hi j; destruct (decide (i = j)) as [->|];
    [|by rewrite lookup_op lookup_insert_ne // lookup_singleton_ne // left_id].
  rewrite lookup_op lookup_insert lookup_singleton.
  by destruct Hi as [->| ->]; constructor; rewrite ?cmra_core_r.
Qed.
Lemma map_insert_singleton_op m i x :
  m !! i = None ∨ m !! i ≡ Some (core x) → <[i:=x]> m ≡ {[ i := x ]} ⋅ m.
Proof.
  rewrite !equiv_dist; naive_solver eauto using map_insert_singleton_opN.
Qed.

Lemma map_core_singleton (i : K) (x : A) :
  core ({[ i := x ]} : gmap K A) = {[ i := core x ]}.
Proof. apply map_fmap_singleton. Qed.
Lemma map_op_singleton (i : K) (x y : A) :
  {[ i := x ]} ⋅ {[ i := y ]} = ({[ i := x ⋅ y ]} : gmap K A).
Proof. by apply (merge_singleton _ _ _ x y). Qed.

Lemma singleton_includedN n m i x :
  {[ i := x ]} ≼{n} m ↔ ∃ y, m !! i ≡{n}≡ Some y ∧ x ≼ y.
  (* not m !! i = Some y ∧ x ≼{n} y to deal with n = 0 *)
Proof.
  split.
  - move=> [m' /(_ i)]; rewrite lookup_op lookup_singleton=> Hm.
    destruct (m' !! i) as [y|];
      [exists (x ⋅ y)|exists x]; eauto using cmra_included_l.
  - intros (y&Hi&?); rewrite map_includedN_spec=>j.
    destruct (decide (i = j)); simplify_map_eq.
    + rewrite Hi. by apply (includedN_preserving _), cmra_included_includedN.
    + apply: cmra_unit_leastN.
Qed.
Lemma map_dom_op m1 m2 : dom (gset K) (m1 ⋅ m2) ≡ dom _ m1 ∪ dom _ m2.
Proof.
  apply elem_of_equiv; intros i; rewrite elem_of_union !elem_of_dom.
  unfold is_Some; setoid_rewrite lookup_op.
  destruct (m1 !! i), (m2 !! i); naive_solver.
Qed.

Lemma map_insert_updateP (P : A → Prop) (Q : gmap K A → Prop) m i x :
  x ~~>: P → (∀ y, P y → Q (<[i:=y]>m)) → <[i:=x]>m ~~>: Q.
Proof.
  intros Hx%option_updateP' HP n mf Hm.
  destruct (Hx n (mf !! i)) as ([y|]&?&?); try done.
  { by generalize (Hm i); rewrite lookup_op; simplify_map_eq. }
  exists (<[i:=y]> m); split; first by auto.
  intros j; move: (Hm j)=>{Hm}; rewrite !lookup_op=>Hm.
  destruct (decide (i = j)); simplify_map_eq/=; auto.
Qed.
Lemma map_insert_updateP' (P : A → Prop) m i x :
  x ~~>: P → <[i:=x]>m ~~>: λ m', ∃ y, m' = <[i:=y]>m ∧ P y.
Proof. eauto using map_insert_updateP. Qed.
Lemma map_insert_update m i x y : x ~~> y → <[i:=x]>m ~~> <[i:=y]>m.
Proof.
  rewrite !cmra_update_updateP; eauto using map_insert_updateP with subst.
Qed.

Lemma map_singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) i x :
  x ~~>: P → (∀ y, P y → Q {[ i := y ]}) → {[ i := x ]} ~~>: Q.
Proof. apply map_insert_updateP. Qed.
Lemma map_singleton_updateP' (P : A → Prop) i x :
  x ~~>: P → {[ i := x ]} ~~>: λ m, ∃ y, m = {[ i := y ]} ∧ P y.
Proof. apply map_insert_updateP'. Qed.
Lemma map_singleton_update i (x y : A) : x ~~> y → {[ i := x ]} ~~> {[ i := y ]}.
Proof. apply map_insert_update. Qed.

Lemma map_singleton_updateP_empty `{Empty A, !CMRAUnit A}
    (P : A → Prop) (Q : gmap K A → Prop) i :
  ∅ ~~>: P → (∀ y, P y → Q {[ i := y ]}) → ∅ ~~>: Q.
Proof.
  intros Hx HQ n gf Hg.
  destruct (Hx n (from_option ∅ (gf !! i))) as (y&?&Hy).
  { move:(Hg i). rewrite !left_id.
    case _: (gf !! i); simpl; auto using cmra_unit_validN. }
  exists {[ i := y ]}; split; first by auto.
  intros i'; destruct (decide (i' = i)) as [->|].
  - rewrite lookup_op lookup_singleton.
    move:Hy; case _: (gf !! i); first done.
    by rewrite right_id.
  - move:(Hg i'). by rewrite !lookup_op lookup_singleton_ne // !left_id.
Qed.
Lemma map_singleton_updateP_empty' `{Empty A, !CMRAUnit A} (P: A → Prop) i :
  ∅ ~~>: P → ∅ ~~>: λ m, ∃ y, m = {[ i := y ]} ∧ P y.
Proof. eauto using map_singleton_updateP_empty. Qed.

Section freshness.
Context `{Fresh K (gset K), !FreshSpec K (gset K)}.
Lemma map_updateP_alloc_strong (Q : gmap K A → Prop) (I : gset K) m x :
  ✓ x → (∀ i, m !! i = None → i ∉ I → Q (<[i:=x]>m)) → m ~~>: Q.
Proof.
  intros ? HQ n mf Hm. set (i := fresh (I ∪ dom (gset K) (m ⋅ mf))).
  assert (i ∉ I ∧ i ∉ dom (gset K) m ∧ i ∉ dom (gset K) mf) as [?[??]].
  { rewrite -not_elem_of_union -map_dom_op -not_elem_of_union; apply is_fresh. }
  exists (<[i:=x]>m); split.
  { by apply HQ; last done; apply not_elem_of_dom. }
  rewrite map_insert_singleton_opN; last by left; apply not_elem_of_dom.
  rewrite -assoc -map_insert_singleton_opN;
    last by left; apply not_elem_of_dom; rewrite map_dom_op not_elem_of_union.
  by apply map_insert_validN; [apply cmra_valid_validN|].
Qed.
Lemma map_updateP_alloc (Q : gmap K A → Prop) m x :
  ✓ x → (∀ i, m !! i = None → Q (<[i:=x]>m)) → m ~~>: Q.
Proof. move=>??. eapply map_updateP_alloc_strong with (I:=∅); by eauto. Qed.
Lemma map_updateP_alloc_strong' m x (I : gset K) :
  ✓ x → m ~~>: λ m', ∃ i, i ∉ I ∧ m' = <[i:=x]>m ∧ m !! i = None.
Proof. eauto using map_updateP_alloc_strong. Qed.
Lemma map_updateP_alloc' m x :
  ✓ x → m ~~>: λ m', ∃ i, m' = <[i:=x]>m ∧ m !! i = None.
Proof. eauto using map_updateP_alloc. Qed.
End freshness.

(* Allocation is a local update: Just use composition with a singleton map. *)
(* Deallocation is *not* a local update. The trouble is that if we
   own {[ i ↦ x ]}, then the frame could always own "core x", and prevent
   deallocation. *)

(* Applying a local update at a position we own is a local update. *)
Global Instance map_alter_update `{!LocalUpdate Lv L} i :
  LocalUpdate (λ m, ∃ x, m !! i = Some x ∧ Lv x) (alter L i).
Proof.
  split; first apply _.
  intros n m1 m2 (x&Hix&?) Hm j; destruct (decide (i = j)) as [->|].
  - rewrite lookup_alter !lookup_op lookup_alter Hix /=.
    move: (Hm j); rewrite lookup_op Hix.
    case: (m2 !! j)=>[y|] //=; constructor. by apply (local_updateN L).
  - by rewrite lookup_op !lookup_alter_ne // lookup_op.
Qed.
End properties.

(** Functor *)
Instance map_fmap_ne `{Countable K} {A B : cofeT} (f : A → B) n :
  Proper (dist n ==> dist n) f → Proper (dist n ==>dist n) (fmap (M:=gmap K) f).
Proof. by intros ? m m' Hm k; rewrite !lookup_fmap; apply option_fmap_ne. Qed.
Instance map_fmap_cmra_monotone `{Countable K} {A B : cmraT} (f : A → B)
  `{!CMRAMonotone f} : CMRAMonotone (fmap f : gmap K A → gmap K B).
Proof.
  split; try apply _.
  - by intros n m ? i; rewrite lookup_fmap; apply (validN_preserving _).
  - intros m1 m2; rewrite !map_included_spec=> Hm i.
    by rewrite !lookup_fmap; apply: included_preserving.
Qed.
Definition mapC_map `{Countable K} {A B} (f: A -n> B) : mapC K A -n> mapC K B :=
  CofeMor (fmap f : mapC K A → mapC K B).
Instance mapC_map_ne `{Countable K} {A B} n :
  Proper (dist n ==> dist n) (@mapC_map K _ _ A B).
Proof.
  intros f g Hf m k; rewrite /= !lookup_fmap.
  destruct (_ !! k) eqn:?; simpl; constructor; apply Hf.
Qed.

Program Definition mapCF K `{Countable K} (F : cFunctor) : cFunctor := {|
  cFunctor_car A B := mapC K (cFunctor_car F A B);
  cFunctor_map A1 A2 B1 B2 fg := mapC_map (cFunctor_map F fg)
|}.
Next Obligation.
  by intros K ?? F A1 A2 B1 B2 n f g Hfg; apply mapC_map_ne, cFunctor_ne.
Qed.
Next Obligation.
  intros K ?? F A B x. rewrite /= -{2}(map_fmap_id x).
  apply map_fmap_setoid_ext=>y ??; apply cFunctor_id.
Qed.
Next Obligation.
  intros K ?? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -map_fmap_compose.
  apply map_fmap_setoid_ext=>y ??; apply cFunctor_compose.
Qed.
Instance mapCF_contractive K `{Countable K} F :
  cFunctorContractive F → cFunctorContractive (mapCF K F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply mapC_map_ne, cFunctor_contractive.
Qed.

Program Definition mapRF K `{Countable K} (F : rFunctor) : rFunctor := {|
  rFunctor_car A B := mapR K (rFunctor_car F A B);
  rFunctor_map A1 A2 B1 B2 fg := mapC_map (rFunctor_map F fg)
|}.
Next Obligation.
  by intros K ?? F A1 A2 B1 B2 n f g Hfg; apply mapC_map_ne, rFunctor_ne.
Qed.
Next Obligation.
  intros K ?? F A B x. rewrite /= -{2}(map_fmap_id x).
  apply map_fmap_setoid_ext=>y ??; apply rFunctor_id.
Qed.
Next Obligation.
  intros K ?? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -map_fmap_compose.
  apply map_fmap_setoid_ext=>y ??; apply rFunctor_compose.
Qed.
Instance mapRF_contractive K `{Countable K} F :
  rFunctorContractive F → rFunctorContractive (mapRF K F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply mapC_map_ne, rFunctor_contractive.
Qed.