Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div prime.
Require Import fintype paths ssralg bigops finset.
Require Import groups morphisms gprod normal pgroups cyclic nilpotent.
Require Import sylow maximal schurzass.

(* Require Import connect finfun group_perm automorphism action center. *)

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

Import GroupScope.

Lemma HallSolvable : forall pi (gT : finGroupType) (G : {group gT}),
  solvable G -> exists2 H : {group gT}, pi.-Hall(G) H
                & forall K : {group gT}, K \subset G -> pi.-group K ->
                  exists2 x, x \in G & K \subset H :^ x.
Proof.
move=> pi gT G; move: {2}_.+1 (ltnSn #|G|) => n.
elim: n gT G => // n IHn gT G; rewrite ltnS => leGn solG.
case: (eqsVneq G 1) => [G1 | ntG].
  exists G => [|K]; rewrite G1; last move/trivGP=> -> {K} _.
    by rewrite pHallE sub1G cards1 part_p'nat.
  by exists (1 : gT); rewrite ?conjs1g ?sub1set set11.
case: (solvable_norm_abelem solG (normal_refl _)) => // M [sMG nMG ntM].
case/abelemP=> p pr_p; do 2![case/andP]=> abelM _ pM.
have{pM} pM: primes #|M| = [:: p].
  move: ntM; rewrite trivg_card1; case/p_natP: pM => // [[|k]] -> // _.
  by rewrite primes_exp // primes_prime.
pose Gb := (G / M)%G; case: (IHn _ Gb) => [||Hb]; try exact: quotient_sol.
  rewrite -[#|_|]mul1n card_quotient; last by case/andP: nMG.
  apply: leq_trans leGn; have:= ltn_0group G.
  rewrite -(LaGrange sMG) ltn_0mul; case/andP=> _ M'pos.
  by rewrite ltn_pmul2r // ltnNge -trivg_card_le1.
case/and3P=> [sHbGb piHb pi'Hb'] transHb.
case: (inv_quotientS nMG sHbGb) => H def_H sMH sHG.
have{transHb} transH: forall K : {group gT},
  K \subset G -> pi.-group K -> exists2 x, x \in G & K \subset H :^ x.
- move=> K sKG piK.
  have nMK: K \subset 'N(M) by apply: subset_trans sKG _; case/andP: nMG.
  case: (transHb (K / M)%G) => [||xb Gxb sKHxb]; first exact: morphimS.
    exact: morphim_pgroup.
  case/morphimP: Gxb => x Nx Gx /= def_x; exists x => //.
  apply/subsetP=> y Ky.
  have: y \in coset M y by rewrite val_coset (subsetP nMK, rcoset_refl).
  have: coset M y \in (H :^ x) / M.
    rewrite /quotient morphimJ //=.
    rewrite def_x def_H in sKHxb; apply: (subsetP sKHxb); exact: mem_quotient.
  case/morphimP=> z Nz Hxz ->.
  rewrite val_coset //; case/rcosetP=> t Mt ->; rewrite groupMl //.
  by rewrite mem_conjg (subsetP sMH) // -mem_conjg (normP Nx).
have{pi'Hb'} pi'H': pi^'.-nat #|G : H|.
  move: pi'Hb'; rewrite -!divgS // def_H !card_quotient //; last first.
  - by case/andP: nMG.
  - by apply: (subset_trans sHG); case/andP: nMG.
  by rewrite -(divn_pmul2l (ltn_0group M)) !LaGrange.
case pi_p: (p \in pi).
  exists H => //; apply/and3P; split=> //.
  rewrite /pgroup -(LaGrange sMH) -card_quotient //; last first.
    case/andP: nMG => _; exact: subset_trans.
  rewrite pnat_mul {1}/pnat pM ltn_0group /= pi_p.
  by rewrite def_H in piHb.
case: (ltnP #|H| #|G|) => [ltHG | leGH {n IHn leGn transH}].
  case: (IHn _ H (leq_trans ltHG leGn)) => [|H1].
    exact: solvableS solG.
  case/and3P=> sH1H piH1 pi'H1' transH1.
  have sH1G: H1 \subset G by exact: subset_trans sHG.
  exists H1=> [|K sKG piK].
    apply/and3P; split => //.
    rewrite -divgS // -(LaGrange sHG) -(LaGrange sH1H) -mulnA.
    by rewrite mulKn // pnat_mul pi'H1'.
  case: (transH K sKG piK) => x Gx def_K.
  case: (transH1 (K :^ x^-1)%G) => [||y Hy def_K1].
  - by rewrite sub_conjgV.
  - by rewrite /pgroup cardJg.
  exists (y * x); first by rewrite groupMr // (subsetP sHG).
  by rewrite -(conjsgKV x K) conjsgM conjSg.
have{leGH Gb sHbGb sHG sMH pi'H'} eqHG: H = G.
  by apply/eqP; rewrite -val_eqE eqEcard sHG.
have{H Hb def_H eqHG piHb} hallM: pi^'.-Hall(G) M.
  rewrite /pHall sMG /pgroup {1}/pnat pM /= inE /= pi_p ltn_0group /=.
  apply: etrans piHb; rewrite -card_quotient ?normal_norm // -eqHG def_H.
  by rewrite pnatNK.
case/splitsP: (SchurZass_split (pHall_Hall hallM) nMG) => H.
case/complP=> trMH defG.
have sHG: H \subset G by rewrite -defG mulG_subr.
exists H => [|K sKG piK].
  apply: etrans hallM; rewrite /pHall sMG sHG /= -!divgS // -defG andbC.
  by rewrite (TI_cardMg trMH) mulKn ?mulnK // pnatNK.
pose G1 := (K <*> M)%G; pose K1 := (H :&: G1)%G.
have nMK: K \subset 'N(M) by apply: subset_trans sKG _; case/andP: nMG.
have defG1: M * K = G1 by rewrite -normC -?norm_mulgenEl.
have sK1G1: K1 \subset M * K by rewrite defG1 subsetIr.
have coMK: coprime #|M| #|K|.
  rewrite coprime_sym (pnat_coprime piK) //.
  by rewrite /pnat pM ltn_0group //= inE /= pi_p.
case: (SchurZass_trans_sol _ nMK sK1G1 coMK) => [||x Mx defK1].
- exact: solvableS solG.
- apply/eqP; rewrite -(eqn_pmul2l (ltn_0group M)) -TI_cardMg //; last first.
    by apply/trivgP; rewrite -trMH /= setIA subsetIl.
  rewrite -coprime_cardMg // defG1; apply/eqP; congr #|(_ : {set _})|.
  rewrite group_modl; last by rewrite -defG1 mulG_subl.
  by apply/setIidPr;  rewrite defG gen_subG subUset sKG.
exists x^-1; first by rewrite groupV (subsetP sMG).
by rewrite -(_ : K1 :^ x^-1 = K) ?(conjSg, subsetIl) // defK1 conjsgK.
Qed.

Module AfterHall. End AfterHall.

Section HallCorollaries.

Variable (gT : finGroupType).

Corollary HallExist : forall pi (G : {group gT}),
  solvable G -> exists H : {group gT}, pi.-Hall(G) H.
Proof. by move=> pi G solG; case: (HallSolvable pi solG) => H; exists H. Qed.

Corollary HallConj : forall pi (G H1 H2 : {group gT}),
  solvable G -> pi.-Hall(G) H1 -> pi.-Hall(G) H2 ->
  exists2 x, x \in G & H1 = (H2 :^ x)%G.
Proof.
move=> pi G H1 H2 solG; case: (HallSolvable pi solG) => H hallH transH.
have conjH: forall K : {group gT},
  pi.-Hall(G) K -> exists2 x, x \in G & K = (H :^ x)%G.
- move=> K hallK; case/and3P: (hallK) => sKG piK _.
  case: (transH K sKG piK) => x Gx sKH; exists x => //.
  apply/eqP; rewrite -val_eqE eqEcard sKH cardJg.
  by rewrite (card_Hall hallH) (card_Hall hallK) /=.
case/conjH=> x1 Gx1 ->{H1}; case/conjH=> x2 Gx2 ->{H2}.
exists (x2^-1 * x1); first by rewrite groupMl ?groupV.
by apply: val_inj; rewrite /= conjsgM conjsgK.
Qed.

Lemma hall_norm_conj : forall pi (G H : {group gT}) x,
  x \in 'N(G) -> pi.-Hall(G) (H :^ x) = pi.-Hall(G) H.
Proof.
by move=> pi G H x Nx; rewrite !pHallE cardJg -{1}(normP Nx) conjSg.
Qed.

Lemma hall_conj : forall pi (G H : {group gT}) x,
  x \in G -> pi.-Hall(G) (H :^ x) = pi.-Hall(G) H.
Proof. by move=> pi G *; rewrite hall_norm_conj ?(subsetP (normG G)). Qed.

Corollary HallSubset : forall pi (G K : {group gT}),
  solvable G -> K \subset G -> pi.-group K ->
    exists2 H : {group gT}, pi.-Hall(G) H & K \subset H.
Proof.
move=> pi G K solG sKG; case: (HallSolvable pi solG) => H hallH transH.
by case/transH=> // x Gx sKHx; exists (H :^ x)%G; rewrite ?hall_conj.
Qed.

Lemma Hall_Frattini_arg : forall pi (G K H : {group gT}),
  solvable K -> K <| G -> pi.-Hall(K) H -> K * 'N_G(H) = G.
Proof.
move=> pi G K H solK; case/andP=> sKG nKG hallH.
have sHG: H \subset G by apply: subset_trans sKG; case/andP: hallH.
rewrite setIC group_modl //; apply/setIidPr; apply/subsetP=> x Gx.
pose H1 := (H :^ x^-1)%G; have hallH1: pi.-Hall(K) H1.
  by rewrite hall_norm_conj // groupV (subsetP nKG).
case: (HallConj solK hallH hallH1) => y Ky defH.
rewrite -(mulKVg y x) mem_mulg //; apply/normP.
by rewrite conjsgM {1}defH conjsgK conjsgKV.
Qed.

Lemma hall_maximal : forall pi (G H K : {group gT}),
  pi.-Hall(G) H -> K \subset G -> pi.-group K -> H \subset K -> K = H.
Proof.
move=> pi G H K hallH sKG piK sHK; apply/eqP.
suff: pi.-Hall(G) K.
  rewrite eq_sym -val_eqE eqEcard sHK /= (card_Hall hallH).
  by move/card_Hall->.
rewrite /pHall sKG piK; case/and3P: hallH => _ _; apply: pnat_dvd.
rewrite -(dvdn_pmul2l (ltn_0group K)) LaGrange // -(LaGrange sHK) mulnAC.
by rewrite LaGrange (subset_trans sHK, dvdn_mulr).
Qed.

Lemma HallSubnormal : forall pi (G K H : {group gT}),
  solvable G -> K <| G -> pi.-Hall(G) H -> pi.-Hall(K) (H :&: K).
Proof.
move=> pi G K H solG; case/andP=> sKG nKG hallH.
case: (HallExist pi (solvableS sKG solG)) => H1 hallH1.
have [sH1G piH1]: H1 \subset G /\ pi.-group H1.
  case/and3P: hallH1=> sH1K piH1 _; split=> //; exact: subset_trans sKG.
case: (HallSubset solG sH1G piH1) => H2 hallH2 sH12.
case: (HallConj solG hallH hallH2) => x; move/(subsetP nKG) => Nx ->.
rewrite -{2}(normP Nx) -conjIg hall_norm_conj //.
rewrite (@hall_maximal _ _ _ (H2 :&: K)%G hallH1) //; first exact: subsetIr.
  apply: pgroupS (pHall_pgroup hallH2); exact: subsetIl.
by rewrite subsetI sH12; case/andP: hallH1.
Qed.

End HallCorollaries.


Require Import ssreflect ssrfun ssrbool.

Require Import PG32.pg32_inductive PG32.pg32_proofs.
Require Import PG32.pg32_spreads.
Require Import PG32.pg32_spreads_collineations.
Require Import PG32.pg32_spreads_packings.
Require Import PG32.pg32_packings_collineations.
Require Import PG32.pg32_automorphisms.
Require Import PG32.pg32_decomp_prelude.

Require Import PG32.pg32_decomp0.
Require Import PG32.pg32_decomp1.
Require Import PG32.pg32_decomp2.
Require Import PG32.pg32_decomp3.
Require Import PG32.pg32_decomp4.
Require Import PG32.pg32_decomp5.
Require Import PG32.pg32_decomp6.
Require Import PG32.pg32_decomp7.
Require Import PG32.pg32_decomp8.
Require Import PG32.pg32_decomp9.
Require Import PG32.pg32_decomp10.
Require Import PG32.pg32_decomp11.
Require Import PG32.pg32_decomp12.
Require Import PG32.pg32_decomp13.
Require Import PG32.pg32_decomp14.

Require Import List.
Import ListNotations.
Lemma focus : forall (fp:Point->Point) (fl:Line->Line),
    forall l0 l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11 l12 l13 L,
      In (fp, fl) (l0++l1++l2++l3++l4++l5++l6 ++l7++l8++l9++l10++l11++l12++l13) ->
      In (fp, fl) (l0++l1++l2++l3++l4++l5++l6 ++l7++l8++l9++l10++l11++l12++l13++L)
   .
Proof.
  intros fp fl l0 l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11 l12 l13 L.
  repeat rewrite in_app_iff; solve [intuition].
Qed.

Lemma strip : forall (fp:Point->Point) (fl:Line->Line),
    forall l0 l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11 l12 l13 L,
      In (fp, fl) L ->
      In (fp, fl) (l0++l1++l2++l3++l4++l5++l6 ++l7++l8++l9++l10++l11++l12++l13++L).
Proof.
  intros fp fl l0 l1 l2 l3 l4 l5 l6 l7 l8 l9 l10 l11 l12 l13 L.
  repeat rewrite in_app_iff; solve [intuition].
Qed.

Lemma is_collineations_descr_B :
  forall fp fl, is_collineation fp fl -> In (fp,fl) all_collineations.
Proof.
  intros fp fl Hfpfl.
  case_eq (fp P0); intros HP0.
  apply focus; apply is_collineations_descr_B_P0; assumption.
  do 1 apply strip; apply focus; apply is_collineations_descr_B_P1; assumption.
  do 2 apply strip; apply focus; apply is_collineations_descr_B_P2; assumption.
  do 3 apply strip; apply focus; apply is_collineations_descr_B_P3; assumption.
  do 4 apply strip; apply focus; apply is_collineations_descr_B_P4; assumption.
  do 5 apply strip; apply focus; apply is_collineations_descr_B_P5; assumption.
  do 6 apply strip; apply focus; apply is_collineations_descr_B_P6; assumption.
  do 7 apply strip; apply focus; apply is_collineations_descr_B_P7; assumption.
  do 8 apply strip; apply focus; apply is_collineations_descr_B_P8; assumption.
  do 9 apply strip; apply focus; apply is_collineations_descr_B_P9; assumption.
  do 10 apply strip; apply focus; apply is_collineations_descr_B_P10; assumption.
  do 11 apply strip; apply focus; apply is_collineations_descr_B_P11; assumption.
  do 12 apply strip; apply focus; apply is_collineations_descr_B_P12; assumption.
  do 13 apply strip; apply focus; apply is_collineations_descr_B_P13; assumption.
  do 14 apply strip; apply is_collineations_descr_B_P14; assumption.
Qed.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section Robust2relPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Set.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rsat__S := rsat2 Source_Semantics.
  Local Definition rsat__T := rsat2 Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable σ : (trace__T * trace__T -> Prop) -> (trace__S * trace__S -> Prop).
  Variable τ : (trace__S * trace__S -> Prop) -> (trace__T * trace__T -> Prop).

  Definition σR2rP (P1 P2 : par__S) (T : trace__T * trace__T -> Prop) :=
    rsat__S P1 P2 (σ T) -> rsat__T (P1 ↓) (P2 ↓) T.

  Definition σR2rTP := forall P1 P2 T, σR2rP P1 P2 T.

  Lemma contra_σR2rP (P1 P2 : par__S) (T : trace__T * trace__T -> Prop) :
    (σR2rP P1 P2 T) <->  ((exists C__T t1 t2, sem__T ( plug__T (P1 ↓) C__T) t1 /\
                                      sem__T ( plug__T (P2 ↓) C__T) t2 /\  ~ (T (t1,t2))) ->
                        (exists C__S s1 s2, sem__S (plug__S P1 C__S) s1 /\
                                      sem__S (plug__S P2 C__S) s2 /\
                                    ~ (σ T) (s1, s2))).
  Proof.
    rewrite /σR2rP. by rewrite [_ -> _] contra !neg_rsat2.
  Qed.

  Lemma contra_σR2rTP :
    σR2rTP <-> (forall P1 P2 T, (exists C__T t1 t2, sem__T (plug__T (P1 ↓) C__T) t1 /\
                                       sem__T (plug__T (P2 ↓) C__T) t2 /\
                                     ~ (T (t1, t2))) ->
                        (exists C__S s1 s2, sem__S (plug__S P1 C__S) s1 /\
                                      sem__S (plug__S P2 C__S) s2 /\
                                     ~ (σ T) (s1, s2))).
  Proof.
    rewrite /σR2rTP.
    split => H P1 P2 T; by move/contra_σR2rP: (H P1 P2 T).
  Qed.

  Definition τR2rP (P1 P2 : par__S) (S : trace__S * trace__S -> Prop) :=
    rsat__S P1 P2 S -> rsat__T (P1 ↓) (P2 ↓) (τ S).

  Definition τR2rTP := forall P1 P2 S, τR2rP P1 P2 S.

  Lemma contra_τR2rP (P1 P2 : par__S) (S : trace__S * trace__S -> Prop) :
    (τR2rP P1 P2 S) <-> ((exists C__T t1 t2, sem__T (plug__T (P1 ↓) C__T) t1 /\
                                    sem__T (plug__T (P2 ↓) C__T) t2 /\
                                   ~ (τ S) (t1, t2)) ->
                      (exists C__S s1 s2, sem__S (plug__S P1 C__S) s1 /\
                                    sem__S (plug__S P2 C__S) s2 /\
                                   ~ S (s1, s2))).
  Proof.
    rewrite /τR2rP. by rewrite [_ -> _] contra !neg_rsat2.
  Qed.

  Lemma contra_τR2rTP :
    τR2rTP <-> (forall P1 P2 S, ((exists C__T t1 t2, sem__T ( plug__T (P1 ↓) C__T) t1 /\
                                         sem__T ( plug__T (P2 ↓) C__T) t2 /\
                                       ~ (τ S) (t1, t2)) ->
                          (exists C__S s1 s2, sem__S (plug__S P1 C__S) s1 /\
                                        sem__S (plug__S P2 C__S) s2 /\
                                       ~ S (s1, s2)))).
  Proof.
    rewrite /τR2rTP.
    split => H P1 P2 S; by move/contra_τR2rP: (H P1 P2 S).
  Qed.

  Theorem G_σR2rTP_iff_τR2rTP :
    (Galois_fst τ σ) -> (Galois_snd τ σ) -> (σR2rTP <-> τR2rTP).
  Proof.
    move => G1 G2. split.
    - move => Hσ P1 P2 S Hrsat_src. apply: (Hσ P1 P2 (τ S)).
      apply: rsat2_upper_closed. exact Hrsat_src. by apply: G1.
    - move => Hτ P1 P2 T Hrrsat_tgt.
      have H : rsat__T (P1 ↓) (P2 ↓) (τ (σ T)) by apply: Hτ.
      apply: rsat2_upper_closed. exact H. by apply: G2.
  Qed.

  Corollary Adj_σR2rTP_iff_τR2rTP :
    Adjunction_law τ σ -> (σR2rTP <-> τR2rTP).
  Proof.
    rewrite Galois_equiv. move => [ms [mt [G1 G2]]].
      by apply: G_σR2rTP_iff_τR2rTP.
  Qed.

End Robust2relPreservation.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                            Solange Coupet-Grimal                         *)
(*                                                                          *)
(*                                                                          *)
(*           Laboratoire d'Informatique Fondamentale de Marseille           *)
(*                   CMI-Technopole de Chateau-Gombert                      *)
(*                       39, Rue F. Joliot Curie                            *)
(*                       13453 MARSEILLE Cedex 13                           *)
(*                     Solange.Coupet@cmi.univ-mrs.fr                       *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Juillet  2002                                *)
(*                                                                          *)
(****************************************************************************)
(*                              termination.v                               *)
(****************************************************************************)

Section termination.

Load ltl.

Require Import Relations.

Variables (Alpha : Set) (state : Set) (r : relation Alpha)
  (meas : state -> Alpha -> Prop).

Hypothesis H_wf : well_founded r.

Notation Stream := (stream state) (only parsing).
Notation State_formula := (state_formula state) (only parsing).

Lemma wf_leadsto :
 forall (A B C : state_formula state) (str : stream state),
 (forall v : Alpha,
  leads_to_via (state2stream_formula (fun s : state => A s /\ meas s v))
    (state2stream_formula B)
    (state2stream_formula
       (fun s : state => A s /\ (exists t : Alpha, meas s t /\ r t v) \/ C s))
    str) ->
 A (hdn str) /\ (exists v : Alpha, meas (hdn str) v) ->
 until (state2stream_formula B) (state2stream_formula C) str.

intros A B C str; unfold leads_to_via in |- *; unfold implies in |- *;
 intros H h; elim h; clear h.
intros A_head h; elim h; clear h.
intro v0; generalize str H A_head; clear H A_head str.
elim (H_wf v0); clear v0.
intros v0 H_acc H_rec str H A_head H_meas.
cut
 (always
    (fun str : stream state =>
     state2stream_formula (fun s : state => A s /\ meas s v0) str ->
     until (state2stream_formula B)
       (state2stream_formula
          (fun s : state =>
           A s /\ (exists t : Alpha, meas s t /\ r t v0) \/ C s)) str) str);
 auto.
intro h; inversion h; clear h.
(*rewrite H2; rewrite H2 in H0;*) generalize C_always4. (*replace str0 with (tln str).*)
(*2: rewrite <- H2; auto.*)
clear (*H1 H2 s0 str0*) C_always4. unfold state2stream_formula in C_always3.
 cut
  (until (fun str : stream state => B (hdn str))
     (fun str : stream state =>
      A (hdn str) /\ (exists t : Alpha, meas (hdn str) t /\ r t v0) \/
      C (hdn str)) str); try apply C_always3; auto.
clear C_always3. intro H_until. generalize H; elim H_until.
clear H H_until A_head H_meas str; intros str H H_always H_always_v0; elim H;
 clear H.
intro H; elim H; clear H.
intros A_head H; elim H; clear H.
intros v H; elim H; clear H.
intros H_meas H_r; apply H_rec with (y := v); auto.
constructor 1; auto.
clear H_rec H_acc H_wf H A_head H_meas H_until str.
intros (*s*) str H_B H_until H_rec H_always.
constructor 2; auto.
apply H_rec.
intro v.
 cut
  (always
     (fun str : stream state =>
      state2stream_formula (fun s : state => A s /\ meas s v) str ->
      until (state2stream_formula B)
        (state2stream_formula
           (fun s : state =>
            A s /\ (exists t : Alpha, meas s t /\ r t v) \/ C s)) str)
     str); auto.
clear H_always. intro H_always. inversion H_always. assumption.
simpl in C_always4; inversion C_always4. (*rewrite H2;*) generalize C_always5.
 (*replace str0 with (tl_str str);*) auto.
(*rewrite <- H2; auto.*)
Qed.

Hint Resolve wf_leadsto.

Lemma wf_leadsto_rule :
 forall (A B C : state_formula state) (str : stream state),
 (forall v : Alpha,
  leads_to_via (state2stream_formula (fun s : state => A s /\ meas s v))
    (state2stream_formula B)
    (state2stream_formula
       (fun s : state => A s /\ (exists t : Alpha, meas s t /\ r t v) \/ C s))
    str) ->
 leads_to_via
   (state2stream_formula
      (fun s : state => A s /\ (exists t : Alpha, meas s t)))
   (state2stream_formula B) (state2stream_formula C) str.

intros A B C; cofix wf_leadsto_rule.
intro str. (*case str;*) intros (*s tl*) H; constructor; eauto.
unfold leads_to_via in wf_leadsto_rule; unfold implies in wf_leadsto_rule;
 apply wf_leadsto_rule.
intro v.
 cut
  (leads_to_via (state2stream_formula (fun s : state => A s /\ meas s v))
     (state2stream_formula B)
     (state2stream_formula
        (fun s : state => A s /\ (exists t : Alpha, meas s t /\ r t v) \/ C s))
     ((*Conn s tl*) str)); auto.
unfold leads_to_via in |- *; unfold implies in |- *. intro H0.
 inversion_clear H0; assumption.
Qed.

End termination.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.verif_sha_update3.
Local Open Scope Z.
Local Open Scope logic.

Lemma Hblocks_lem:
 forall {blocks: list int} {frag: list byte} {data},
 intlist_to_bytelist blocks = frag ++ sublist 0 (Zlength blocks * 4 - Zlength frag) data ->
 Zlength frag <= Zlength blocks * 4.
Proof.
intros.
assert (Zlength (intlist_to_bytelist blocks) =
               Zlength ( frag ++
     sublist 0 (Zlength blocks * 4 - Zlength frag) data)) by congruence.
 autorewrite with sublist in H0.
 pose proof (Zlength_nonneg (sublist 0 (Zlength blocks * 4 - Zlength frag) data)).
 omega.
Qed.

Definition sha_update_loop_body :=
  (Ssequence
     (Scall None
        (Evar _sha256_block_data_order
           (Tfunction
              (Tcons (tptr t_struct_SHA256state_st) (Tcons (tptr tvoid) Tnil))
              tvoid cc_default))
        [Etempvar _c (tptr t_struct_SHA256state_st);
        Etempvar _data (tptr tuchar)])
     (Ssequence
        (Sset _data
           (Ebinop Oadd (Etempvar _data (tptr tuchar))
              (Ebinop Omul (Econst_int (Int.repr 16) tint)
                 (Econst_int (Int.repr 4) tint) tint) (tptr tuchar)))
        (Sset _len
           (Ebinop Osub (Etempvar _len tuint)
              (Ebinop Omul (Econst_int (Int.repr 16) tint)
                 (Econst_int (Int.repr 4) tint) tint) tuint)))).

Definition update_outer_if :=
     Sifthenelse
        (Ebinop Cop.One (Etempvar _n tuint) (Econst_int (Int.repr 0) tint) tint)
        (Ssequence
           (Sset _fragment
              (Ebinop Osub
                 (Ebinop Omul (Econst_int (Int.repr 16) tint)
                    (Econst_int (Int.repr 4) tint) tint) (Etempvar _n tuint)
                 tuint)) update_inner_if)
        Sskip.

Lemma update_outer_if_proof:
 forall  (Espec : OracleKind) (hashed : list int)
           (dd data : list byte) (c d : val) (wsh sh : share) (len : Z) gv
   (H : 0 <= len <= Zlength data)
   (Hwsh: writable_share wsh)
   (Hsh: readable_share sh)
   (HBOUND : bitlength hashed dd + len * 8 < two_p 64)
   (H3 : Zlength dd < CBLOCKz)
   (H4 : (LBLOCKz | Zlength hashed))
   (Hlen : len <= Int.max_unsigned),
semax
     (func_tycontext f_SHA256_Update Vprog Gtot nil)
  (PROP  ()
   LOCAL
   (temp _p (field_address t_struct_SHA256state_st [StructField _data] c);
    temp _n (Vint (Int.repr (Zlength dd)));
    temp _data d; temp _c c;temp _data_ d;
    temp _len (Vint (Int.repr len));
    gvars gv)
   SEP  (data_at wsh t_struct_SHA256state_st
                 (map Vint (hash_blocks init_registers hashed),
                  (Vint (lo_part (bitlength hashed dd + len*8)),
                   (Vint (hi_part (bitlength hashed dd + len*8)),
                    (map Vubyte dd ++ list_repeat (Z.to_nat (CBLOCKz-Zlength dd)) Vundef,
                     Vint (Int.repr (Zlength dd))))))
               c;
     K_vector gv;
     data_block sh data d))
  update_outer_if
  (overridePost (sha_update_inv wsh sh hashed len c d dd data gv false)
    (frame_ret_assert
     (function_body_ret_assert tvoid
        (EX  a' : s256abs,
         PROP  (update_abs (sublist 0 len data) (S256abs hashed dd) a')
         LOCAL ()
         SEP  (K_vector gv;
                 sha256state_ wsh a' c; data_block sh data d)))
    emp)).
Proof.
intros.
unfold update_outer_if.
forward_if (sha_update_inv wsh sh hashed len c d dd data gv false).
* (* then clause *)

Time forward.  (* fragment = SHA_CBLOCK-n; *) (*2.2*)
drop_LOCAL 5%nat.
rewrite semax_seq_skip.
fold (inv_at_inner_if wsh sh hashed len c d dd data gv).
apply semax_seq with (sha_update_inv wsh sh hashed len c d dd data gv false).
weak_normalize_postcondition.
normalize. change (16*4)%Z with 64.
simple apply (update_inner_if_proof Espec hashed dd data c d wsh sh len gv);
  try assumption.
forward.
apply andp_left2; auto.
* (* else clause *)
forward.  (* skip; *)
Exists (@nil int). rewrite <- app_nil_end.
rename H0 into H1.
rewrite H1 in *.
rewrite Zlength_correct in H1;  destruct dd; inv H1.
autorewrite with sublist.
simpl intlist_to_bytelist.
Time entailer!.  (* 4.6; was: 139 sec -> 3.27 sec *)
split.
apply Z.divide_0_r.
rewrite field_address0_offset by auto with field_compatible.
simpl. normalize.

(* TODO:  see if a "stronger" proof system could work here
  rewrite data_at_field_at.
   apply field_at_stronger.
  ...
  with automatic cancel...
*)

Tactic Notation "unfold_data_atx" uconstr(a) :=
 tryif (is_nat_uconstr a)
 then (
    idtac "Warning: unfold_data_at with numeric argument is deprecated";
     let x := constr:(a) in unfold_data_at_tac x
   )
 else
 (let x := fresh "x" in set (x := a : mpred);
  lazymatch goal with
  | x := ?D : mpred |- _ =>
    match D with
     | (@data_at_ ?cs ?sh ?t ?p) =>
            change D with (@field_at_mark cs sh t (@nil gfield) (@default_val cs (@nested_field_type cs t nil)) p) in x
     | (@data_at ?cs ?sh ?t ?v ?p) =>
            change D with (@field_at_mark cs sh t (@nil gfield) v p) in x
     | (@field_at_ ?cs ?sh ?t ?gfs ?p) =>
            change D with (@field_at_mark cs sh t gfs (@default_val cs (@nested_field_type cs t gfs)) p) in x
     | (@field_at ?cs ?sh ?t ?gfs ?v ?p) =>
            change D with (@field_at_mark cs sh t gfs v p) in x
     end;
        subst x;  unfold_field_at';
idtac (*
   repeat match goal with |- context [@field_at ?cs ?sh ?t ?gfs (@default_val ?cs' ?t') ?p] =>
       change (@field_at cs sh t gfs (default_val cs' t') p) with (@field_at_ cs sh t gfs p)
    end*)
end).
 match goal with |- ?A |-- ?B => unfold_data_at A; unfold_data_at B; cancel end.
Time Qed. (*5.4*)

Lemma update_while_proof:
 forall (Espec : OracleKind) (hashed : list int) (dd data: list byte) gv
    (c d : val) (wsh sh : share) (len : Z)
  (H : 0 <= len <= Zlength data)
   (Hwsh: writable_share wsh)
   (Hsh: readable_share sh)
  (HBOUND : bitlength hashed dd + len * 8 < two_p 64)
  (H3 : Zlength dd < CBLOCKz)
  (H4 : (LBLOCKz | Zlength hashed))
  (Hlen : len <= Int.max_unsigned),
 semax
       (func_tycontext f_SHA256_Update Vprog Gtot nil)
  (sha_update_inv wsh sh hashed len c d dd data gv false)
  (Swhile
     (Ebinop Oge (Etempvar _len tuint)
        (Ebinop Omul (Econst_int (Int.repr 16) tint)
           (Econst_int (Int.repr 4) tint) tint) tint) sha_update_loop_body)
  (normal_ret_assert (sha_update_inv wsh sh hashed len c d dd data gv true)).
Proof.
intros.
abbreviate_semax.
unfold sha_update_inv.
Intros blocks.
rewrite semax_seq_skip. (* should be part of forward_while *)
forward_while
    (sha_update_inv wsh sh hashed len c d dd data gv false);
  try rename blocks0 into blocks'.
*
 Exists blocks. entailer!.
*
  entailer!.
*
 clear H8.
 normalize_postcondition.
 clear dependent blocks.
 rename blocks' into blocks.
 pose proof (Hblocks_lem H7).
 assert (H0': (Zlength dd <= Zlength blocks * 4)%Z) by Omega1.
 clear H0; rename H0' into H0.
 rewrite Int.unsigned_repr in HRE by omega.
 pose (bl := bytelist_to_intlist (sublist (Zlength blocks * 4 - Zlength dd)
                                                   (Zlength blocks * 4 - Zlength dd + CBLOCKz) data)).
assert (Zlength bl = LBLOCKz). {
 apply Zlength_bytelist_to_intlist.
 pose proof CBLOCKz_eq; pose proof LBLOCKz_eq;
  autorewrite with sublist. reflexivity.
}
 {
  rename H6 into Hdiv. rename H7 into Hblocks. rename H0 into H7.
  rename HRE into Hlen_ge.  clear H5.
  assert (H6: sublist (Zlength blocks * 4 - Zlength dd)
                    (Zlength blocks * 4 - Zlength dd + CBLOCKz) data =
        intlist_to_bytelist bl).
  unfold bl; rewrite bytelist_to_intlist_to_bytelist; auto.
  pose proof CBLOCKz_eq;  autorewrite with sublist.
  exists LBLOCKz; reflexivity.
  rename dd into frag.
  clear H7; rename H1 into H7.
  rename HBOUND into LEN64.
  clear - Hwsh Hsh H Hdiv H4 Hblocks H3 Hlen Hlen_ge H6 H7 LEN64.
  unfold sha_update_loop_body.
  assert (Hblocks' := Hblocks_lem Hblocks).
  Time assert_PROP (field_compatible (tarray tuchar (Zlength data)) [] d) as FC by entailer!. (*1.8*)
  assert (DM: Zlength data < Ptrofs.modulus).
  { (* TODO: simplify this proof. *)
    clear - FC. red in FC. simpl in FC. destruct d; try tauto.
    simpl in FC.
    rewrite Z.max_r in FC by (specialize (Zlength_nonneg data); intros; omega).
    inv_int i.
    rewrite Z.mul_1_l in FC.
    omega.
  }
  set (lo := Zlength blocks * 4 - Zlength frag) in *.
  replace_SEP 2
    (data_block sh (sublist 0 lo data) d *
       data_block sh (sublist lo (lo+CBLOCKz) data)
         (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc lo] d) *
       data_block sh (sublist (lo+CBLOCKz) (Zlength data) data)
         (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc (lo+CBLOCKz)] d)).
  { Time entailer!. (*2.5*)
   rewrite (split3_data_block lo (lo+CBLOCKz) sh data); auto;
     subst lo; Omega1.
  }
 rewrite H6.
 assert (LBLOCKz | Zlength (hashed ++ blocks))
  by (apply divide_length_app; auto).
 assert (Zlength (hash_blocks init_registers (hashed ++ blocks)) = 8)
  by (rewrite Zlength_length; [apply length_hash_blocks|]; auto).
 Time forward_call (* sha256_block_data_order (c,data); *)
   (hash_blocks init_registers (hashed++blocks),  bl, c, wsh,
    field_address0 (tarray tuchar (Zlength data))  [ArraySubsc lo] d,
    sh, gv). (*3.8*)
  { Time unfold_data_at (data_at _ _ _ c). (*0.8*)
    Time cancel. (*2.5*)
  }
 rewrite hash_blocks_last by auto.
 Time forward. (* data += SHA_CBLOCK; *) (*5*)
 simpl (temp _data _).
 Time forward. (* len  -= SHA_CBLOCK; *) (*6*)
 Exists (blocks++ bl).
 Time entailer!. (*17.4 SLOW*)
 subst lo. autorewrite with sublist.
 rewrite Z.mul_add_distr_r.
 {repeat split; auto.
  + Omega1.
  + rewrite H7; apply Z.divide_add_r; auto. apply Z.divide_refl.
  + rewrite intlist_to_bytelist_app.
      rewrite Hblocks; rewrite <- H6.
      rewrite app_ass.
      f_equal.
      rewrite <- sublist_split; try Omega1.
      f_equal. Omega1.
  + assert (0 <= Zlength blocks * 4 + Zlength bl * 4 - Zlength frag <= Zlength data)
         by Omega1.
      rewrite !field_address0_offset by auto with field_compatible.
      rewrite offset_offset_val.
      simpl. f_equal. Omega1.
  + f_equal. f_equal. Omega1.
 }
 Time unfold_data_at (data_at _ _ _ c).  (*0.8*)
 rewrite (split3_data_block lo (lo+CBLOCKz) sh data d)
    by (auto; subst lo; try Omega1).
 rewrite app_ass.
 rewrite H6.
 Time cancel. (*1.2*)
 }
*
 assert  (Zlength blocks' * 4 >= Zlength dd).
   rewrite <- (Zlength_intlist_to_bytelist blocks').
   rewrite H7. autorewrite with sublist. Omega1.
 normalize in HRE.
 unfold sha_update_inv.
 clear dependent blocks.
 forward.
 Exists blocks'.
 Time entailer!. (*2.9*)
Time Qed. (*VST2.0: 1.7s *)


Require Import Category.Lib.
Require Import Category.Instance.Sets.
Require Import Category.Structure.Cocartesian.

Generalizable All Variables.

#[export]
Program Instance Sets_Cocartesian : @Cocartesian Sets := {
  product_obj := fun x y =>
    {| carrier := (carrier x + carrier y)%type
     ; is_setoid :=
         {| equiv := fun z w =>
              match z with
              | Datatypes.inl z =>
                match w with
                | Datatypes.inl w => @equiv _ x z w
                | Datatypes.inr _ => False
                end
              | Datatypes.inr z =>
                match w with
                | Datatypes.inl _ => False
                | Datatypes.inr w => @equiv _ y z w
                end
              end
          ; setoid_equiv := _
          |} |};
  fork := fun _ _ _ f g =>
    {| morphism := fun x =>
         match x with
         | Datatypes.inl x => f x
         | Datatypes.inr x => g x
         end |};
  exl := fun _ _ => {| morphism := Datatypes.inl |};
  exr := fun _ _ => {| morphism := Datatypes.inr |}
}.
Next Obligation.
  proper.
  destruct f, g; intuition.
  destruct y, x; intuition;
  destruct z; intuition.
Qed.
Next Obligation.
  proper.
  destruct x2; intuition.
Qed.
Next Obligation.
  simplify; intuition;
  now match goal with
    [ H : ∀ _ : _ + _, _ ≈ _ |- _ ] => rewrite H
  end.
Qed.


(******************)
(* Key-Value maps *)
(******************)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype seq path.
From pcm Require Import options axioms pred ordtype finmap.
From pcm Require Import pcm unionmap heap autopcm automap.
From htt Require Import options interlude model heapauto.

(***********************)
(* stateful KV map ADT *)
(***********************)

Module KVmap.
Record Sig (K : ordType) (V : Type) : Type :=
  make {tp :> Type;

        default : tp;

        shape : tp -> {finMap K -> V} -> Pred heap;

        new : STsep (emp, [vfun x => shape x (nil K V)]);

        free : forall x, {s}, STsep (shape x s,
                                     [vfun _ : unit => emp]);

        insert : forall x k v,
                   {s}, STsep (shape x s,
                               [vfun y => shape y (ins k v s)]);

        remove : forall x k,
                   {s}, STsep (shape x s,
                               [vfun y => shape y (rem k s)]);

        lookup : forall x k,
                   {s}, STsep (shape x s,
                               [vfun y m => m \In shape x s /\ y = fnd k s])}.
End KVmap.

(**********************************************************)
(* KV map implemented as a sorted association linked list *)
(**********************************************************)

Module AssocList.
Section AssocList.

Variable (K : ordType) (V : Set).
Notation fmap := (finMap K V).
Notation nil := (nil K V).

(* single entry of the map as a triple of heap cells *)
Definition entry (p q : ptr) (k : K) (v : V) : heap :=
  p :-> k \+ p.+1 :-> v \+ p.+2 :-> q.

(* similarly to plain linked list, we with a generic definition of a segment and *)
(* then specialize it to self-contained lists specified by a finMap structure *)

Fixpoint shape_seg' (x y : ptr) (xs : seq (K * V)) : Pred heap :=
  if xs is (k,v) :: tl then
     [Pred h | exists q h',
       h = entry x q k v \+ h'
     /\ h' \In shape_seg' q y tl]
  else [Pred h | x = y /\ h = Unit].

Definition shape_seg (x y : ptr) (s : fmap) : Pred heap :=
  shape_seg' x y (seq_of s).

Definition shape (x : ptr) (s : fmap) : Pred heap :=
  shape_seg x null s.

(* null pointer represents an empty map *)

Lemma shape_null (s : fmap) h :
  valid h -> h \In shape null s ->
  s = nil /\ h = Unit.
Proof.
move=>D; case: s; case=>/=.
- by move=>? [_ ->] //; rewrite fmapE.
move=>[??]??[?][?][H].
by rewrite H -!joinA validPtUn in D.
Qed.

(* non-empty well-formed region represents a non-empty map such that *)
(* a head entry respecting the key order can be pulled out of the map *)

Lemma shape_cont (s : fmap) p h :
  p != null -> h \In shape p s ->
  exists k v q h',
   [/\ s = ins k v (behd s),            (* k:->v is the head entry *)
       all (ord k) (supp (behd s)),
       h = entry p q k v \+ h' &
       h' \In shape q (behd s)].
Proof.
move=>E; case: s=>xs srt /=.
elim: xs srt=>/=.
- by move=>? [E0]; rewrite E0 in E.
move=>[k v] /= l IH srt [q][h'][-> H].
exists k,v,q,h'; split=>//; last by apply: path_all.
by rewrite fmapE /= last_ins'.
Qed.

(* TODO move to finmap? *)
Lemma all_path (s : fmap) k : all (ord k) (supp s) -> path ord k (supp s).
Proof. by rewrite path_sortedE // =>->/=; case: s. Qed.

(* inserting an entry with minimal key is prepending to the list *)

Lemma shape_cons (s : fmap) p q h k v :
   all (ord k) (supp s) -> h \In shape q s ->
   entry p q k v \+ h \In shape p (ins k v s).
Proof.
move/all_path=>S H.
suff: ins k v s = @FinMap _ _ ((k,v)::seq_of s) S by move=>->; exists q,h.
rewrite fmapE /=; case: s {H}S=>/= xs ??.
by rewrite last_ins'.
Qed.

(* inserting an entry with maximal key is appending to the list *)

Lemma shape_seg_rcons (s : fmap) x p q h k v :
  (* conceptually last s < k *)
  all (ord^~ k) (supp s) ->
  h \In shape_seg x p s ->
  (h \+ entry p q k v) \In shape_seg x q (ins k v s).
Proof.
case: s=>xs; elim: xs h x=>/=.
- move=>??? _ [->->]; rewrite unitL.
  by exists q, Unit; rewrite unitR.
move=>[k' v'] /= xs IH _ x S /andP [O Os] [x0][h'][-> H'].
rewrite /shape_seg /=; move/nsym/negP/negbTE: (O)=>->.
case: ordP O=>//= _ _.
exists x0, (h' \+ entry p q k v); rewrite -!joinA; split=>//.
by apply: IH=>//; apply: (path_sorted S).
Qed.

(* disjoint maps can be concatenated if the order is respected *)

Lemma shape_fcat s1 s2 h1 h2 x y :
  (* conceptually last s1 < head s2 *)
  allrel ord (supp s1) (supp s2) ->
  h1 \In shape_seg x y s1 -> h2 \In shape y s2 ->
  h1 \+ h2 \In shape x (fcat s1 s2).
Proof.
move=>O1 H1.
case: s2 O1=>xs; elim: xs h1 y h2 s1 H1=>/=.
- by move=>???? H1 ? _ [Eq ->]; rewrite Eq in H1; rewrite unitR.
move=>[k' v'] xs; rewrite /fcat /= => IH /= h1 y h2 s1 H1 srt O2 H2.
case: H2=>z[h'][-> H']; rewrite joinA; apply: IH; first 1 last.
- by apply/path_sorted/srt.
- move=>H0; rewrite (allrel_in_l (xs':=k'::supp s1) _); last by apply: supp_ins.
  rewrite allrel_consl path_all //=.
  by apply/allrel_sub_r/O2=>?; rewrite inE orbC=>->.
- by move=>?; apply: H'.
apply: shape_seg_rcons=>//.
by move: O2; rewrite allrel_consr =>/andP [].
Qed.

(* main procedures *)

(* a new map is just a null pointer *)

Program Definition new : STsep (emp, [vfun x => shape x nil]) :=
  Do (ret null).
Next Obligation. by move=>[] /= _ ->; step. Qed.

(* freeing a map is deallocating all its elements *)

Definition freeT : Type :=
  forall p, {fm}, STsep (shape p fm, [vfun _ : unit => emp]).

Program Definition free : freeT :=
  Fix (fun (loop : freeT) p =>
       Do (if p == null then ret tt
           else pnext <-- !(p.+2);
                dealloc p;;
                dealloc (p.+1);;
                dealloc (p.+2);;
                loop pnext)).
Next Obligation.
(* pull out ghost var, precondition, branch *)
move=>loop p [fm][] i /= H; case: eqP=>[|/eqP] E.
- (* reached the end, heap must be empty *)
  by apply: vrfV=>D; step=>_; rewrite E in H; case: (shape_null D H).
(* pull out the head entry *)
case: (shape_cont E H)=>k[v][q][h][_ _ {i H}-> H].
(* deallocate it *)
do 4!step; rewrite !unitL.
(* invoke the loop on the tail *)
by apply: [gE (behd fm)].
Qed.

(* looking up an element in the map *)

Definition lookupT k : Type :=
  forall p, {fm}, STsep (shape p fm,
                        [vfun y m => m \In shape p fm /\ y = fnd k fm]).

Program Definition lookup x (k : K) :
  {fm}, STsep (shape x fm,
              [vfun y m => m \In shape x fm /\ y = fnd k fm]) :=
  Fix (fun (loop : lookupT k) (cur : ptr) =>
       Do (if cur == null then ret None
           else
             k' <-- !cur;
             if k == k'
               then v <-- !(cur.+1);
                    ret (Some v)
               else if ord k' k
                 then next <-- !(cur.+2);
                      loop next
                 else ret None)) x.
Next Obligation.
(* pull out ghost var+precondition, branch on cur being null *)
move=>_ k go cur [fm][] h /= H; case: eqP=>[|/eqP] Ec.
- (* reached the end, the heap and the spec must be empty, element not found *)
  by apply: vrfV=>Vh; step=>_; rewrite Ec in H; case: (shape_null Vh H)=>->.
(* pull out the head entry *)
case: (shape_cont Ec H)=>k'[v][next][h'][Ef O' Ei H']; rewrite {h}Ei in H *.
(* read the head key, branch on equality comparison *)
step; case: eqP=>[|/eqP] Ek.
- (* the key matches, return the head value *)
  by do 2![step]=>_; split=>//; rewrite Ef fnd_ins Ek eq_refl.
(* branch on comparison *)
case: ifP=>Ho'.
- (* head key is less than the needed one, loop on tail *)
  (* (we fall back to gR to preserve associativity) *)
  step; apply/[gR (behd fm)] @ h'=>//= v0 h0' [H0 E0] _.
  by rewrite Ef fnd_ins (negbTE Ek); split=>//; exact: shape_cons.
(* head key is bigger than the needed one, abort *)
move: (semiconnex Ek); rewrite {}Ho' orbC /= =>Ho'; step=>_; split=>//.
(* k is not in the head entry *)
apply/esym/fnd_supp; rewrite Ef supp_ins inE negb_or; apply/andP; split=>//.
(* nor it is in the tail *)
by apply/notin_path/path_le/all_path/O'.
Qed.

(* removing an element by key from the map, return the pointer to the new map *)

(* loop invariant: *)
(* 1. we split the list into a zipper-like structure `fml ++ [k'->v'] ++ fmr` *)
(* 2. the ordering is respected *)
(* 3. k is not in fml nor in the focus entry k'->v' *)
(* the focus is needed so that we can connect the remainder of the map to it after removal *)
Definition removeT p k : Type :=
  forall (prevcur : ptr * ptr),
    {fm}, STsep (fun h => exists fml fmr k' v',
                  [/\ fm = fcat (ins k' v' fml) fmr,
                      all (ord^~ k') (supp fml) /\ all (ord k') (supp fmr),
                      k \notin supp fml /\ k != k' &
                      h \In
                       (shape_seg p prevcur.1 fml #
                       (fun h => h = entry prevcur.1 prevcur.2 k' v') #
                       shape prevcur.2 fmr)],
                  [vfun _ : unit => shape p (rem k fm)]).

Program Definition remove x (k : K) :
  {fm}, STsep (shape x fm,
              [vfun y => shape y (rem k fm)]) :=
  Do (let go := Fix (fun (loop : removeT x k) '(prev, cur) =>
                     Do (if cur == null then ret tt
                         else k' <-- !cur;
                              if k == k'
                                then next <-- !(cur.+2);
                                     dealloc cur;;
                                     dealloc (cur.+1);;
                                     dealloc (cur.+2);;
                                     prev.+2 ::= (next : ptr);;
                                     ret tt
                                else if ord k' k
                                     then next <-- !(cur.+2);
                                          loop (cur, next)
                                     else ret tt))
      in
      if x == null then ret null
        else k' <-- !x;
             if k == k'
                then next <-- !(x.+2);
                     dealloc x;;
                     dealloc (x.+1);;
                     dealloc (x.+2);;
                     ret next
                else if ord k' k
                     then next <-- !(x.+2);
                          go (x, next);;
                          ret x
                     else ret x).
(* first the loop *)
(* we don't return the pointer because it cannot change, as the head is fixed by fml *)
Next Obligation.
(* pull out ghost var, preconditions and heap validity *)
move=>x k0 go _ prev cur [_][] _ /= [fml][fmr][k][v][-> [Ol Or][El E]][hl][_][-> Hl [_][hr][->->Hr]].
(* branch on cur *)
case: eqP=>[|/eqP] Ec.
(* cur = null - nothing to left to process, i.e., fmr = [] *)
- apply: vrfV=>Vh; step=>_; rewrite {}Ec in Hr *.
  (* k is not in fml ++ (k->v) *)
  case: (shape_null (validX Vh) Hr)=>/=->->; rewrite fcats0 unitR rem_ins (negbTE E) (rem_supp El).
  by exact: shape_seg_rcons.
(* cur <> null, pull out the head entry from fmr *)
case: (shape_cont Ec Hr)=>k'[v'][next][hr'][Efr /all_path Or' {hr Hr Ec}-> Hr']; rewrite joinA joinC.
(* derive ordering facts *)
move/all_path: (Or); rewrite {1}Efr; case/(path_supp_ins_inv Or')/andP=>Ho' Or''.
(* get head key, branch on comparing it to needed one *)
step; case: eqP=>[|/eqP] Ek.
- (* k = k' - element is found, run the deallocations *)
  do 4!step; rewrite !unitL; do 2![step]=>_.
  (* pull out fml ++ (k->v) *)
  rewrite Efr -fcat_srem; last by rewrite supp_ins inE negb_or E.
  (* drop the element in the spec *)
  rewrite rem_ins {1}Ek eq_refl rem_supp; last by rewrite Ek; apply: notin_path.
  (* heap shape is respected *)
  rewrite joinC; apply/shape_fcat/Hr'; last by apply: shape_seg_rcons.
  (* the ordering is respected as well *)
  rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins.
  rewrite allrel_consl path_all //=.
  by apply/(allrel_trans (z:=k))/path_all=>//; exact: trans.
(* k <> k', now branch on order comparison *)
case: ifP=>Ho0.
- (* k' is less than k, invoke the loop, shifting the focus to the right *)
  step; apply: [gE (fcat (ins k' v' (ins k v fml)) (behd fmr))]=>//=.
  - (* prove that all conditions are respected *)
    exists (ins k v fml), (behd fmr), k', v'; do!split=>//.
    - (* new focus comes after fml ++ old focus *)
      rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho' /=; last by apply: supp_ins.
      by apply/sub_all/Ol=>? /trans; apply.
    - (* new focus comes before the new suffix *)
      by apply: path_all.
    - (* the needed key is not in fml ++ old focus *)
      by rewrite supp_ins inE negb_or E.
    (* heap shape is respected *)
    exists (hl \+ entry prev cur k v), (entry cur next k' v' \+ hr').
    rewrite joinC; split=>//; last by vauto.
    by apply: shape_seg_rcons.
  (* we can reassemble the spec because insertions of old and new foci commute *)
  move=>_ m Hm Vm; rewrite Efr.
  by rewrite fcat_inss // -?fcat_sins // in Hm; apply: notin_path.
(* k' is bigger than k, abort *)
move: (semiconnex Ek); rewrite {}Ho0 orbC /= =>Ho0.
step=>_; rewrite rem_supp.
- (* the shape is preserved *)
  rewrite joinC; apply: shape_fcat; first 1 last.
  - by apply: shape_seg_rcons.
  - by rewrite Efr; apply: shape_cons=>//; apply: path_all.
  (* ordering is preserved *)
  rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins.
  rewrite allrel_consl Or /=.
  by apply/(allrel_trans (z:=k))=>//; exact: trans.
(* the element wasn't found *)
rewrite Efr supp_fcat !inE negb_or; apply/andP; split;
  rewrite supp_ins !inE negb_or; apply/andP; split=>//.
by apply/notin_path/path_le/Or'.
Qed.
(* now the outer function, which mostly repeats the loop *)
(* the first iteration is special because we don't yet have a left prefix *)
(* to connect to the remainder if the head is removed *)
Next Obligation.
(* pull out ghost+precondition, branch on x *)
move=>/= x k0 [fm][]i /= H; case: eqP=>[|/eqP] Ex.
- (* x is null, nothing to process *)
  by apply: vrfV=>Vh; move: H; rewrite Ex =>/(shape_null Vh) [->->]; step=>_.
(* x <> null, pull out the head entry *)
case: (shape_cont Ex H)=>{Ex}k[v][next][h'][Ef Of Eh H']; rewrite Eh.
(* read the key, branch on equality comparison *)
step; case: eqP=>[->|/eqP Ek].
- (* k = k', element found in head position, run deallocations, return new head *)
  do 5![step]=>_; rewrite !unitL Ef rem_ins eq_refl rem_supp //.
  by apply/notin_path/all_path.
(* k <> k', now branch on order comparison *)
case: ifP=>Ho0.
(* k' is less than k, start the loop with the head entry as the focus *)
- step; apply: [stepE fm]=>//=; last by move=>_ ??; step.
  (* invariants and shape are satisfied *)
  exists nil, (behd fm), k, v; do!split=>//.
  - by rewrite fcat_inss; [rewrite fcat0s|apply/notin_path/all_path].
  by exists Unit, (entry x next k v \+ h'); split=>//; [rewrite unitL | vauto].
(* k' is bigger than k, abort *)
move: (semiconnex Ek); rewrite {}Ho0 orbC /= =>Ho0.
(* return the old head, invariants are preserved *)
step=>_; rewrite -Eh rem_supp // Ef supp_ins !inE negb_or Ek /=.
by apply/notin_path/path_le/all_path/Of.
Qed.

(* upserting (inserting or updating if the key is found) an entry into the map, return the pointer to the new map *)

(* loop invariant, essentially identical to remove: *)
(* 1. as for remove, we split the list into a zipper-like structure `fml ++ [k'->v'] ++ fmr` *)
(* 2. the ordering is respected *)
(* 3. k is not in fml and is less than the key k' of focus entry *)
(* the focus is needed so that we can connect the new element to it after insertion *)
Definition insertT p k v : Type :=
  forall (prevcur : ptr * ptr),
    {fm}, STsep (fun h => exists fml fmr k' v',
                  [/\ fm = fcat (ins k' v' fml) fmr,
                      all (ord^~ k') (supp fml) /\ all (ord k') (supp fmr),
                      k \notin supp fml /\ ord k' k &
                      h \In
                       (shape_seg p prevcur.1 fml #
                       (fun h => h = entry prevcur.1 prevcur.2 k' v') #
                       shape prevcur.2 fmr)],
                 [vfun _ : unit => shape p (ins k v fm)]).

Program Definition insert x (k : K) (v : V) :
  {fm}, STsep (shape x fm,
              [vfun y => shape y (ins k v fm)]) :=
  Do (let go := Fix (fun (loop : insertT x k v) '(prev, cur) =>
                     Do (if cur == null
                           then new <-- allocb k 3;
                                new.+1 ::= v;;
                                new.+2 ::= null;;
                                prev.+2 ::= new;;
                                ret tt
                           else k' <-- !cur;
                                if k == k'
                                  then cur.+1 ::= v;;
                                       ret tt
                                  else if ord k' k
                                       then next <-- !(cur.+2);
                                            loop (cur, next)
                                       else new <-- allocb k 3;
                                            new.+1 ::= v;;
                                            new.+2 ::= cur;;
                                            prev.+2 ::= new;;
                                            ret tt))
      in
      if x == null
        then new <-- allocb k 3;
             new.+1 ::= v;;
             new.+2 ::= null;;
             ret new
        else k' <-- !x;
             if k == k'
               then x.+1 ::= v;;
                    ret x
               else if ord k' k
                    then next <-- !(x.+2);
                         go (x, next);;
                         ret x
                    else new <-- allocb k 3;
                         new.+1 ::= v;;
                         new.+2 ::= x;;
                         ret new).
(* first the loop *)
(* we don't return the pointer because it cannot change, as the head is fixed by fml *)
Next Obligation.
(* pull out ghost var+preconditions *)
move=>x k0 v0 loop _ prev cur [_][] _ /= [fml][fmr][k][v][-> [Ol Or][El Ho0]][hl][_][-> Hl [_][hr][->-> Hr]].
(* branch on cur *)
case: eqP=>[|/eqP] Ec.
- (* cur = null, insert as the last element *)
  rewrite {}Ec in Hr; apply: vrfV=>Vh.
  step=>p; rewrite ptrA unitR; do 2!step; rewrite joinC; do 2![step]=>_.
  (* fmr is empty *)
  case: (shape_null (validX Vh) Hr)=>/=->->.
  rewrite fcats0 unitR [X in _ \+ entry _ _ _ _ \+ X]joinA.
  (* shape and ordering invariants are satisfied *)
  apply/shape_seg_rcons/shape_seg_rcons=>//.
  rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho0 /=; last by apply: supp_ins.
  by apply/sub_all/Ol=>? /trans; apply.
(* cur <> null, pull out the head entry from fmr *)
case: (shape_cont Ec Hr)=>k'[v'][next][hr'][Efr Or' {hr Hr Ec}-> Hr']; rewrite joinA joinC.
(* derive ordering facts *)
move/all_path: (Or); rewrite {1}Efr; case/(path_supp_ins_inv (all_path Or'))/andP=>Ho' /(path_all (@trans _)) Or''.
(* get new key, branch on equality comparison *)
step; case: eqP=>[|/eqP] Ek.
- (* k = k', update the value at this position *)
  do 2![step]=>_; rewrite Efr -fcat_sins ins_ins -Ek eq_refl joinC.
  (* invariants are preserved as the key didn't change *)
  apply: shape_fcat; first 1 last.
  - by apply: shape_seg_rcons.
  - by apply: shape_cons=>//; rewrite Ek.
  rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins.
  rewrite (allrel_in_r (ys':=k0::supp (behd fmr)) _ _); last by apply: supp_ins.
  rewrite allrel_consl allrel_consr /= Ho0 Or'' /=; apply/andP; split.
  - by apply/sub_all/Ol=>? /trans; apply.
  by apply: (allrel_trans (z:=k))=>//; exact: trans.
(* k <> k', now branch on order comparison *)
case: ifP=>Ho'0.
(* k' is less than k, invoke the loop, shifting the focus to the right *)
- step; apply/[gE (fcat (ins k' v' (ins k v fml)) (behd fmr))]=>//=.
  - (* prove that all conditions are respected *)
    exists (ins k v fml), (behd fmr), k', v'; do!split=>//.
    - (* new focus comes after fml ++ old focus *)
      rewrite (eq_all_r (s2:=k::supp fml)) /= ?Ho' /=; last by apply: supp_ins.
      by apply/sub_all/Ol=>? /trans; apply.
    - (* the needed key is not in fml ++ old focus *)
      rewrite supp_ins inE negb_or andbC El /=.
      by case: ordP Ho0.
    (* heap shape is respected *)
    exists (hl \+ entry prev cur k v), (entry cur next k' v' \+ hr').
    by rewrite joinC; split=>//; [apply: shape_seg_rcons | vauto].
  (* we can reassemble the spec because insertions of old and new foci commute *)
  move=>_ m Hm _; rewrite Efr.
  rewrite fcat_inss // in Hm; first by rewrite -fcat_sins in Hm.
  by apply/notin_path/all_path.
(* k' is bigger than k, insert at this position *)
move: (semiconnex Ek); rewrite {}Ho'0 orbC /= =>Ho0'.
(* run the allocation and assignments *)
step=>new; rewrite ptrA unitR; do 2!step; rewrite joinA joinC; do 2![step]=>_.
rewrite Efr -fcat_sins; apply: shape_fcat; first 1 last.
- (* shape is respected for the prefix fml ++ old focus *)
  by apply: shape_seg_rcons.
- (* shape is satisfed for new element + suffix *)
  rewrite [X in X \+ (entry _ _ _ _ \+ _)]joinA; apply/shape_cons/shape_cons=>//.
  by apply/path_all/path_supp_ins=>//; apply/path_le/all_path/Or'.
(* ordering is respected *)
rewrite (allrel_in_l (xs':=k::supp fml) _); last by apply: supp_ins.
rewrite (allrel_in_r (ys':=k0::k'::supp (behd fmr)) _ _); last first.
- by move=>?; rewrite ?(supp_ins,inE).
rewrite allrel_consl !allrel_consr /= Ho0 Ho' Or'' /=; apply/and3P; split.
- by apply/sub_all/Ol=>? /trans; apply.
- by apply/sub_all/Ol=>? /trans; apply.
by apply: (allrel_trans (z:=k))=>//; exact: trans.
Qed.
(* now the outer function, which mostly repeats the loop *)
(* the first iteration is special because we don't yet have a left prefix *)
(* to connect to the new element if it inserted at the head position *)
Next Obligation.
(* pull out ghost+precondition, branch on x *)
move=>/= x k0 v0 [fm][]h /= H; case: eqP=>[|/eqP] Ex.
- (* x = null, insert as the only element, heap and spec are empty *)
  apply: vrfV=>Vh; move: H; rewrite Ex=>/(shape_null Vh) [->->].
  (* run *)
  step=>p; rewrite ptrA !unitR; do 3![step]=>_.
  by exists null, Unit; rewrite unitR joinA.
(* x <> null, pull out the head entry *)
case: (shape_cont Ex H)=>{Ex}k[v][next][h'][Ef Of {h H}-> H].
(* read the head key, branch on equality comparison *)
step; case: eqP=>[->|/eqP Ek].
- (* k = k', exact key found in head position, update the head value *)
  do 2![step]=>_; rewrite Ef ins_ins eq_refl.
  by apply: shape_cons.
(* k <> k', now branch on order comparison *)
case: ifP=>Ho0.
- (* k' is less than k, run the loop with the head entry as the focus *)
  step; apply: [stepE fm]=>//=; last by move=>_ ??; step.
  (* invariants are respected *)
  exists nil, (behd fm), k, v; do!split=>//.
  - by rewrite fcat_inss; [rewrite fcat0s|apply/notin_path/all_path].
  by exists Unit, (entry x next k v \+ h'); split=>//; [rewrite unitL | vauto].
(* k' is bigger than k, insert after the head *)
move: (semiconnex Ek); rewrite {}Ho0 orbC /= =>Ho0.
(* run allocation and assignments, return the old head *)
step=>q; rewrite ptrA unitR; do 3![step]=>_.
(* invariants are preserved *)
rewrite Ef [X in X \+ (entry _ _ _ _ \+ _)]joinA; apply/shape_cons/shape_cons=>//.
by apply/path_all/path_supp_ins=>//; apply/path_le/all_path/Of.
Qed.

(* ordered association list is a KV map *)

Definition AssocList := KVmap.make null new free insert remove lookup.

End AssocList.
End AssocList.