From iris.algebra Require Export cmra.
From iris.algebra Require Import local_updates.
From iris.base_logic Require Import base_logic.
From iris Require Import options.
Local Arguments pcore _ _ !_ /.
Local Arguments cmra_pcore _ !_ /.
Local Arguments validN _ _ _ !_ /.
Local Arguments valid _ _  !_ /.
Local Arguments cmra_validN _ _ !_ /.
Local Arguments cmra_valid _  !_ /.

Inductive csum (A B : Type) :=
  | Cinl : A → csum A B
  | Cinr : B → csum A B
  | CsumBot : csum A B.
Arguments Cinl {_ _} _.
Arguments Cinr {_ _} _.
Arguments CsumBot {_ _}.

Instance: Params (@Cinl) 2 := {}.
Instance: Params (@Cinr) 2 := {}.
Instance: Params (@CsumBot) 2 := {}.

Instance maybe_Cinl {A B} : Maybe (@Cinl A B) := λ x,
  match x with Cinl a => Some a | _ => None end.
Instance maybe_Cinr {A B} : Maybe (@Cinr A B) := λ x,
  match x with Cinr b => Some b | _ => None end.

Section cofe.
Context {A B : ofeT}.
Implicit Types a : A.
Implicit Types b : B.

(* Cofe *)
Inductive csum_equiv : Equiv (csum A B) :=
  | Cinl_equiv a a' : a ≡ a' → Cinl a ≡ Cinl a'
  | Cinr_equiv b b' : b ≡ b' → Cinr b ≡ Cinr b'
  | CsumBot_equiv : CsumBot ≡ CsumBot.
Existing Instance csum_equiv.
Inductive csum_dist : Dist (csum A B) :=
  | Cinl_dist n a a' : a ≡{n}≡ a' → Cinl a ≡{n}≡ Cinl a'
  | Cinr_dist n b b' : b ≡{n}≡ b' → Cinr b ≡{n}≡ Cinr b'
  | CsumBot_dist n : CsumBot ≡{n}≡ CsumBot.
Existing Instance csum_dist.

Global Instance Cinl_ne : NonExpansive (@Cinl A B).
Proof. by constructor. Qed.
Global Instance Cinl_proper : Proper ((≡) ==> (≡)) (@Cinl A B).
Proof. by constructor. Qed.
Global Instance Cinl_inj : Inj (≡) (≡) (@Cinl A B).
Proof. by inversion_clear 1. Qed.
Global Instance Cinl_inj_dist n : Inj (dist n) (dist n) (@Cinl A B).
Proof. by inversion_clear 1. Qed.
Global Instance Cinr_ne : NonExpansive (@Cinr A B).
Proof. by constructor. Qed.
Global Instance Cinr_proper : Proper ((≡) ==> (≡)) (@Cinr A B).
Proof. by constructor. Qed.
Global Instance Cinr_inj : Inj (≡) (≡) (@Cinr A B).
Proof. by inversion_clear 1. Qed.
Global Instance Cinr_inj_dist n : Inj (dist n) (dist n) (@Cinr A B).
Proof. by inversion_clear 1. Qed.

Definition csum_ofe_mixin : OfeMixin (csum A B).
Proof.
  split.
  - intros mx my; split.
    + by destruct 1; constructor; try apply equiv_dist.
    + intros Hxy; feed inversion (Hxy 0); subst; constructor; try done;
      apply equiv_dist=> n; by feed inversion (Hxy n).
  - intros n; split.
    + by intros [|a|]; constructor.
    + by destruct 1; constructor.
    + destruct 1; inversion_clear 1; constructor; etrans; eauto.
  - by inversion_clear 1; constructor; apply dist_S.
Qed.
Canonical Structure csumO : ofeT := OfeT (csum A B) csum_ofe_mixin.

Program Definition csum_chain_l (c : chain csumO) (a : A) : chain A :=
  {| chain_car n := match c n return _ with Cinl a' => a' | _ => a end |}.
Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
Program Definition csum_chain_r (c : chain csumO) (b : B) : chain B :=
  {| chain_car n := match c n return _ with Cinr b' => b' | _ => b end |}.
Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
Definition csum_compl `{Cofe A, Cofe B} : Compl csumO := λ c,
  match c 0 with
  | Cinl a => Cinl (compl (csum_chain_l c a))
  | Cinr b => Cinr (compl (csum_chain_r c b))
  | CsumBot => CsumBot
  end.
Global Program Instance csum_cofe `{Cofe A, Cofe B} : Cofe csumO :=
  {| compl := csum_compl |}.
Next Obligation.
  intros ?? n c; rewrite /compl /csum_compl.
  feed inversion (chain_cauchy c 0 n); first auto with lia; constructor.
  + rewrite (conv_compl n (csum_chain_l c a')) /=. destruct (c n); naive_solver.
  + rewrite (conv_compl n (csum_chain_r c b')) /=. destruct (c n); naive_solver.
Qed.

Global Instance csum_ofe_discrete :
  OfeDiscrete A → OfeDiscrete B → OfeDiscrete csumO.
Proof. by inversion_clear 3; constructor; apply (discrete _). Qed.
Global Instance csum_leibniz :
  LeibnizEquiv A → LeibnizEquiv B → LeibnizEquiv csumO.
Proof. by destruct 3; f_equal; apply leibniz_equiv. Qed.

Global Instance Cinl_discrete a : Discrete a → Discrete (Cinl a).
Proof. by inversion_clear 2; constructor; apply (discrete _). Qed.
Global Instance Cinr_discrete b : Discrete b → Discrete (Cinr b).
Proof. by inversion_clear 2; constructor; apply (discrete _). Qed.

(** Internalized properties *)
Lemma csum_equivI {M} (x y : csum A B) :
  x ≡ y ⊣⊢@{uPredI M} match x, y with
                      | Cinl a, Cinl a' => a ≡ a'
                      | Cinr b, Cinr b' => b ≡ b'
                      | CsumBot, CsumBot => True
                      | _, _ => False
                      end.
Proof.
  uPred.unseal; do 2 split; first by destruct 1.
  by destruct x, y; try destruct 1; try constructor.
Qed.
End cofe.

Arguments csumO : clear implicits.

(* Functor on COFEs *)
Definition csum_map {A A' B B'} (fA : A → A') (fB : B → B')
                    (x : csum A B) : csum A' B' :=
  match x with
  | Cinl a => Cinl (fA a)
  | Cinr b => Cinr (fB b)
  | CsumBot => CsumBot
  end.
Instance: Params (@csum_map) 4 := {}.

Lemma csum_map_id {A B} (x : csum A B) : csum_map id id x = x.
Proof. by destruct x. Qed.
Lemma csum_map_compose {A A' A'' B B' B''} (f : A → A') (f' : A' → A'')
                       (g : B → B') (g' : B' → B'') (x : csum A B) :
  csum_map (f' ∘ f) (g' ∘ g) x = csum_map f' g' (csum_map f g x).
Proof. by destruct x. Qed.
Lemma csum_map_ext {A A' B B' : ofeT} (f f' : A → A') (g g' : B → B') x :
  (∀ x, f x ≡ f' x) → (∀ x, g x ≡ g' x) → csum_map f g x ≡ csum_map f' g' x.
Proof. by destruct x; constructor. Qed.
Instance csum_map_cmra_ne {A A' B B' : ofeT} n :
  Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==> dist n ==> dist n)
         (@csum_map A A' B B').
Proof. intros f f' Hf g g' Hg []; destruct 1; constructor; by apply Hf || apply Hg. Qed.
Definition csumO_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
  csumO A B -n> csumO A' B' :=
  OfeMor (csum_map f g).
Instance csumO_map_ne A A' B B' :
  NonExpansive2 (@csumO_map A A' B B').
Proof. by intros n f f' Hf g g' Hg []; constructor. Qed.

Section cmra.
Context {A B : cmraT}.
Implicit Types a : A.
Implicit Types b : B.

(* CMRA *)
Instance csum_valid : Valid (csum A B) := λ x,
  match x with
  | Cinl a => ✓ a
  | Cinr b => ✓ b
  | CsumBot => False
  end.
Instance csum_validN : ValidN (csum A B) := λ n x,
  match x with
  | Cinl a => ✓{n} a
  | Cinr b => ✓{n} b
  | CsumBot => False
  end.
Instance csum_pcore : PCore (csum A B) := λ x,
  match x with
  | Cinl a => Cinl <$> pcore a
  | Cinr b => Cinr <$> pcore b
  | CsumBot => Some CsumBot
  end.
Instance csum_op : Op (csum A B) := λ x y,
  match x, y with
  | Cinl a, Cinl a' => Cinl (a ⋅ a')
  | Cinr b, Cinr b' => Cinr (b ⋅ b')
  | _, _ => CsumBot
  end.

Lemma Cinl_op a a' : Cinl (a ⋅ a') = Cinl a ⋅ Cinl a'.
Proof. done. Qed.
Lemma Cinr_op b b' : Cinr (b ⋅ b') = Cinr b ⋅ Cinr b'.
Proof. done. Qed.

Lemma csum_included x y :
  x ≼ y ↔ y = CsumBot ∨ (∃ a a', x = Cinl a ∧ y = Cinl a' ∧ a ≼ a')
                      ∨ (∃ b b', x = Cinr b ∧ y = Cinr b' ∧ b ≼ b').
Proof.
  split.
  - unfold included. intros [[a'|b'|] Hy]; destruct x as [a|b|];
      inversion_clear Hy; eauto 10.
  - intros [->|[(a&a'&->&->&c&?)|(b&b'&->&->&c&?)]].
    + destruct x; exists CsumBot; constructor.
    + exists (Cinl c); by constructor.
    + exists (Cinr c); by constructor.
Qed.
Lemma Cinl_included a a' : Cinl a ≼ Cinl a' ↔ a ≼ a'.
Proof. rewrite csum_included. naive_solver. Qed.
Lemma Cinr_included b b' : Cinr b ≼ Cinr b' ↔ b ≼ b'.
Proof. rewrite csum_included. naive_solver. Qed.

Lemma csum_includedN n x y :
  x ≼{n} y ↔ y = CsumBot ∨ (∃ a a', x = Cinl a ∧ y = Cinl a' ∧ a ≼{n} a')
                         ∨ (∃ b b', x = Cinr b ∧ y = Cinr b' ∧ b ≼{n} b').
Proof.
  split.
  - unfold includedN. intros [[a'|b'|] Hy]; destruct x as [a|b|];
      inversion_clear Hy; eauto 10.
  - intros [->|[(a&a'&->&->&c&?)|(b&b'&->&->&c&?)]].
    + destruct x; exists CsumBot; constructor.
    + exists (Cinl c); by constructor.
    + exists (Cinr c); by constructor.
Qed.

Lemma csum_cmra_mixin : CmraMixin (csum A B).
Proof.
  split.
  - intros [] n; destruct 1; constructor; by ofe_subst.
  - intros ???? [n a a' Ha|n b b' Hb|n] [=]; subst; eauto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_ne n a a' ca) as (ca'&->&?); auto.
      exists (Cinl ca'); by repeat constructor.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_ne n b b' cb) as (cb'&->&?); auto.
      exists (Cinr cb'); by repeat constructor.
  - intros ? [a|b|] [a'|b'|] H; inversion_clear H; ofe_subst; done.
  - intros [a|b|]; rewrite /= ?cmra_valid_validN; naive_solver eauto using O.
  - intros n [a|b|]; simpl; auto using cmra_validN_S.
  - intros [a1|b1|] [a2|b2|] [a3|b3|]; constructor; by rewrite ?assoc.
  - intros [a1|b1|] [a2|b2|]; constructor; by rewrite 1?comm.
  - intros [a|b|] ? [=]; subst; auto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      constructor; eauto using cmra_pcore_l.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      constructor; eauto using cmra_pcore_l.
  - intros [a|b|] ? [=]; subst; auto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      feed inversion (cmra_pcore_idemp a ca); repeat constructor; auto.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      feed inversion (cmra_pcore_idemp b cb); repeat constructor; auto.
  - intros x y ? [->|[(a&a'&->&->&?)|(b&b'&->&->&?)]]%csum_included [=].
    + exists CsumBot. rewrite csum_included; eauto.
    + destruct (pcore a) as [ca|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_mono a a' ca) as (ca'&->&?); auto.
      exists (Cinl ca'). rewrite csum_included; eauto 10.
    + destruct (pcore b) as [cb|] eqn:?; simplify_option_eq.
      destruct (cmra_pcore_mono b b' cb) as (cb'&->&?); auto.
      exists (Cinr cb'). rewrite csum_included; eauto 10.
  - intros n [a1|b1|] [a2|b2|]; simpl; eauto using cmra_validN_op_l; done.
  - intros n [a|b|] y1 y2 Hx Hx'.
    + destruct y1 as [a1|b1|], y2 as [a2|b2|]; try by exfalso; inversion Hx'.
      destruct (cmra_extend n a a1 a2) as (z1&z2&?&?&?); [done|apply (inj Cinl), Hx'|].
      exists (Cinl z1), (Cinl z2). by repeat constructor.
    + destruct y1 as [a1|b1|], y2 as [a2|b2|]; try by exfalso; inversion Hx'.
      destruct (cmra_extend n b b1 b2) as (z1&z2&?&?&?); [done|apply (inj Cinr), Hx'|].
      exists (Cinr z1), (Cinr z2). by repeat constructor.
    + by exists CsumBot, CsumBot; destruct y1, y2; inversion_clear Hx'.
Qed.
Canonical Structure csumR := CmraT (csum A B) csum_cmra_mixin.

Global Instance csum_cmra_discrete :
  CmraDiscrete A → CmraDiscrete B → CmraDiscrete csumR.
Proof.
  split; first apply _.
  by move=>[a|b|] HH /=; try apply cmra_discrete_valid.
Qed.

Global Instance Cinl_core_id a : CoreId a → CoreId (Cinl a).
Proof. rewrite /CoreId /=. inversion_clear 1; by repeat constructor. Qed.
Global Instance Cinr_core_id b : CoreId b → CoreId (Cinr b).
Proof. rewrite /CoreId /=. inversion_clear 1; by repeat constructor. Qed.

Global Instance Cinl_exclusive a : Exclusive a → Exclusive (Cinl a).
Proof. by move=> H[]? =>[/H||]. Qed.
Global Instance Cinr_exclusive b : Exclusive b → Exclusive (Cinr b).
Proof. by move=> H[]? =>[|/H|]. Qed.

Global Instance Cinl_cancelable a : Cancelable a → Cancelable (Cinl a).
Proof.
  move=> ?? [y|y|] [z|z|] ? EQ //; inversion_clear EQ.
  constructor. by eapply (cancelableN a).
Qed.
Global Instance Cinr_cancelable b : Cancelable b → Cancelable (Cinr b).
Proof.
  move=> ?? [y|y|] [z|z|] ? EQ //; inversion_clear EQ.
  constructor. by eapply (cancelableN b).
Qed.

Global Instance Cinl_id_free a : IdFree a → IdFree (Cinl a).
Proof. intros ? [] ? EQ; inversion_clear EQ. by eapply id_free0_r. Qed.
Global Instance Cinr_id_free b : IdFree b → IdFree (Cinr b).
Proof. intros ? [] ? EQ; inversion_clear EQ. by eapply id_free0_r. Qed.

(** Interaction with [option] *)
Lemma Some_csum_includedN x y n :
  Some x ≼{n} Some y ↔
    y = CsumBot ∨
    (∃ a a', x = Cinl a ∧ y = Cinl a' ∧ Some a ≼{n} Some a') ∨
    (∃ b b', x = Cinr b ∧ y = Cinr b' ∧ Some b ≼{n} Some b').
Proof.
  repeat setoid_rewrite Some_includedN. rewrite csum_includedN. split.
  - intros [Hxy|?]; [inversion Hxy|]; naive_solver.
  - naive_solver by f_equiv.
Qed.
Lemma Some_csum_included x y :
  Some x ≼ Some y ↔
    y = CsumBot ∨
    (∃ a a', x = Cinl a ∧ y = Cinl a' ∧ Some a ≼ Some a') ∨
    (∃ b b', x = Cinr b ∧ y = Cinr b' ∧ Some b ≼ Some b').
Proof.
  repeat setoid_rewrite Some_included. rewrite csum_included. split.
  - intros [Hxy|?]; [inversion Hxy|]; naive_solver.
  - naive_solver by f_equiv.
Qed.

(** Internalized properties *)
Lemma csum_validI {M} (x : csum A B) :
  ✓ x ⊣⊢@{uPredI M} match x with
                    | Cinl a => ✓ a
                    | Cinr b => ✓ b
                    | CsumBot => False
                    end.
Proof. uPred.unseal. by destruct x. Qed.

(** Updates *)
Lemma csum_update_l (a1 a2 : A) : a1 ~~> a2 → Cinl a1 ~~> Cinl a2.
Proof.
  intros Ha n [[a|b|]|] ?; simpl in *; auto.
  - by apply (Ha n (Some a)).
  - by apply (Ha n None).
Qed.
Lemma csum_update_r (b1 b2 : B) : b1 ~~> b2 → Cinr b1 ~~> Cinr b2.
Proof.
  intros Hb n [[a|b|]|] ?; simpl in *; auto.
  - by apply (Hb n (Some b)).
  - by apply (Hb n None).
Qed.
Lemma csum_updateP_l (P : A → Prop) (Q : csum A B → Prop) a :
  a ~~>: P → (∀ a', P a' → Q (Cinl a')) → Cinl a ~~>: Q.
Proof.
  intros Hx HP n mf Hm. destruct mf as [[a'|b'|]|]; try by destruct Hm.
  - destruct (Hx n (Some a')) as (c&?&?); naive_solver.
  - destruct (Hx n None) as (c&?&?); naive_solver eauto using cmra_validN_op_l.
Qed.
Lemma csum_updateP_r (P : B → Prop) (Q : csum A B → Prop) b :
  b ~~>: P → (∀ b', P b' → Q (Cinr b')) → Cinr b  ~~>: Q.
Proof.
  intros Hx HP n mf Hm. destruct mf as [[a'|b'|]|]; try by destruct Hm.
  - destruct (Hx n (Some b')) as (c&?&?); naive_solver.
  - destruct (Hx n None) as (c&?&?); naive_solver eauto using cmra_validN_op_l.
Qed.
Lemma csum_updateP'_l (P : A → Prop) a :
  a ~~>: P → Cinl a ~~>: λ m', ∃ a', m' = Cinl a' ∧ P a'.
Proof. eauto using csum_updateP_l. Qed.
Lemma csum_updateP'_r (P : B → Prop) b :
  b ~~>: P → Cinr b ~~>: λ m', ∃ b', m' = Cinr b' ∧ P b'.
Proof. eauto using csum_updateP_r. Qed.

Lemma csum_local_update_l (a1 a2 a1' a2' : A) :
  (a1,a2) ~l~> (a1',a2') → (Cinl a1,Cinl a2) ~l~> (Cinl a1',Cinl a2').
Proof.
  intros Hup n mf ? Ha1; simpl in *.
  destruct (Hup n (mf ≫= maybe Cinl)); auto.
  { by destruct mf as [[]|]; inversion_clear Ha1. }
  split. done. by destruct mf as [[]|]; inversion_clear Ha1; constructor.
Qed.
Lemma csum_local_update_r (b1 b2 b1' b2' : B) :
  (b1,b2) ~l~> (b1',b2') → (Cinr b1,Cinr b2) ~l~> (Cinr b1',Cinr b2').
Proof.
  intros Hup n mf ? Ha1; simpl in *.
  destruct (Hup n (mf ≫= maybe Cinr)); auto.
  { by destruct mf as [[]|]; inversion_clear Ha1. }
  split. done. by destruct mf as [[]|]; inversion_clear Ha1; constructor.
Qed.
End cmra.

Arguments csumR : clear implicits.

(* Functor *)
Instance csum_map_cmra_morphism {A A' B B' : cmraT} (f : A → A') (g : B → B') :
  CmraMorphism f → CmraMorphism g → CmraMorphism (csum_map f g).
Proof.
  split; try apply _.
  - intros n [a|b|]; simpl; auto using cmra_morphism_validN.
  - move=> [a|b|]=>//=; rewrite -cmra_morphism_pcore; by destruct pcore.
  - intros [xa|ya|] [xb|yb|]=>//=; by rewrite cmra_morphism_op.
Qed.

Program Definition csumRF (Fa Fb : rFunctor) : rFunctor := {|
  rFunctor_car A _ B _ := csumR (rFunctor_car Fa A B) (rFunctor_car Fb A B);
  rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := csumO_map (rFunctor_map Fa fg) (rFunctor_map Fb fg)
|}.
Next Obligation.
  by intros Fa Fb A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply csumO_map_ne; try apply rFunctor_map_ne.
Qed.
Next Obligation.
  intros Fa Fb A ? B ? x. rewrite /= -{2}(csum_map_id x).
  apply csum_map_ext=>y; apply rFunctor_map_id.
Qed.
Next Obligation.
  intros Fa Fb A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -csum_map_compose.
  apply csum_map_ext=>y; apply rFunctor_map_compose.
Qed.

Instance csumRF_contractive Fa Fb :
  rFunctorContractive Fa → rFunctorContractive Fb →
  rFunctorContractive (csumRF Fa Fb).
Proof.
  intros ?? A1 ? A2 ? B1 ? B2 ? n f g Hfg.
  by apply csumO_map_ne; try apply rFunctor_map_contractive.
Qed.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
Set Implicit Arguments.

Require Import Morphisms.
Require Import ZArith.
Require Import DItv.
Require Import DomArrayBlk.
Require Import UserInputType.
Require Import UserProofType.
Require Import UserInput.
Require GenFunc.
Require Import VocabA.
Require Import vgtac.
Require Import Monad.
Require Import Fold.

Include Input.
Include GenFunc.Make.

Definition Var_g (x : DomCon.Var.t) : Var.t :=
  match x with
  | DomCon.Var.Inl gx => Var.Inl gx
  | DomCon.Var.Inr (_, f, lx) => Var.Inr (f, lx)
  end.

Lemma var_g_mor : Proper (DomCon.Var.eq ==> Var.eq) Var_g.
Proof.
inversion 1.
- by constructor.
- destruct x' as [[n1 f1] x'], y' as [[n2 f2] y2']. simpl in Heq.
  constructor. tauto.
Qed.

Definition Allocsite_g (a : DomCon.Allocsite.t) : Allocsite.t :=
  match a with
  | DomCon.Allocsite.Inl n => Allocsite.Inl n
  | DomCon.Allocsite.Inr (DomCon.ExtAllocsite.Inl f) =>
    Allocsite.Inr (ExtAllocsite.Inl f)
  | DomCon.Allocsite.Inr (DomCon.ExtAllocsite.Inr f) =>
    Allocsite.Inr (ExtAllocsite.Inr f)
  end.

Definition allocsite_g_mor :
  Proper (DomCon.Allocsite.eq ==> Allocsite.eq) Allocsite_g.
Proof.
inversion 1.
- constructor. tauto.
- inversion Heq.
  + constructor. constructor. by auto.
  + constructor. constructor. by auto.
Qed.

Definition VarRegion_g (vr : DomCon.VarRegion.t) : VarAllocsite.t :=
  match vr with
  | DomCon.VarRegion.Inl x => VarAllocsite.Inl (Var_g x)
  | DomCon.VarRegion.Inr (_, a, _) => VarAllocsite.Inr (Allocsite_g a)
  end.

Lemma varregion_g_mor :
  Proper (DomCon.VarRegion.eq ==> VarAllocsite.eq) VarRegion_g.
Proof.
inversion 1.
- constructor. by apply var_g_mor.
- destruct x' as [[n1 a1] [[o1 s1] st1]], y' as [[n2 a2] [[o2 s2] st2]].
  simpl in *.
  constructor. apply allocsite_g_mor. by apply Heq.
Qed.

Fixpoint Fields_g (fs : DomCon.Fields.t) : Fields.t :=
  match fs with
  | DomCon.Fields.nil => Fields.nil
  | DomCon.Fields.cons f tl => Fields.cons f (Fields_g tl)
  end.

Lemma fields_g_mor :
  Proper (DomCon.Fields.eq ==> Fields.eq) Fields_g.
Proof.
unfold Fields.eq. induction DNList.size.
- intros f1 f2 Hf. apply Fields.eq_zero.
- induction 1.
  + apply Fields.eq_nil.
  + apply Fields.eq_cons; [by auto|by apply IHn].
Qed.

Definition Loc_g (l : DomCon.Loc.t) : Loc.t :=
  let (vr, fs) := l in
  Loc.Inl (VarRegion_g vr, Fields_g fs).

Lemma loc_g_mor : Proper (DomCon.Loc.eq ==> Loc.eq) Loc_g.
Proof.
intros [vr1 f1] [vr2 f2] Hl. inversion Hl. constructor. simpl in *; split.
- by apply varregion_g_mor.
- by apply fields_g_mor.
Qed.

Definition Itv_g := Itv.gamma.

Inductive ArrayBlk_g' : DomCon.Region.t -> ArrayBlk.t -> Prop :=
| ArrayBlk_g_intro :
    forall s a o sz st o' sz' st' ab
           (Ho : Itv_g o o') (Hsz : Itv_g sz sz' ) (Hst : Itv_g st st')
           (Hab : ArrayBlk.find (Allocsite_g a) ab = (o', sz', st')),
      ArrayBlk_g' (s, a, (o, sz, st)) ab.

Definition ArrayBlk_g := ArrayBlk_g'.

Inductive Val_g' : DomCon.val_t -> Val.t -> Prop :=
| Val_g_z :
    forall z i ls ab ps (Hz : Itv_g z i), Val_g' (inl (inl z)) (i, ls, ab, ps)
| Val_g_loc :
    forall l i ls ab ps (Hl : PowLoc.mem (Loc_g l) ls = true),
      Val_g' (inl (inr l)) (i, ls, ab, ps)
| Val_g_ab :
    forall r i ls ab ps (Hl : ArrayBlk_g r ab),
      Val_g' (inl (inr (DomCon.VarRegion.Inr r, DomCon.Fields.nil)))
            (i, ls, ab, ps)
| Val_g_proc :
    forall p i ls ab ps (Hp : PowProc.mem p ps = true),
      Val_g' (inr p) (i, ls, ab, ps)
.

Definition Val_g := Val_g'.

(** Abstraction of Proc.t in DomCon.stack1. *)
Definition SProc_g (f : DomCon.Proc.t) : Loc.t := Loc.Inr f.

Lemma arrayBlk_g_monotone : monotone ArrayBlk.le ArrayBlk_g.
Proof.
intros v x y. inversion 1; i. subst.
assert (ArrInfo.le (o', sz', st') (ArrayBlk.find (Allocsite_g a) y)) as Hy
; [rewrite <- Hab; apply Hle|].
remember (ArrayBlk.find (Allocsite_g a) y) as oss'.
destruct oss' as [[o'' sz''] st''].
inversion Hy as [[Ho'' Hsz''] Hst'']; simpl in Ho'', Hsz'', Hst''.
apply ArrayBlk_g_intro with o'' sz'' st''.
- by apply Itv.gamma_monotone with o'.
- by apply Itv.gamma_monotone with sz'.
- by apply Itv.gamma_monotone with st'.
- by auto.
Qed.

Lemma val_g_monotone : monotone Val.le Val_g.
Proof.
intros v [[[i ls] ab] ps] [[[i' ls'] ab'] ps'] Hx Hle.
unfold Val.le, Val.E3.le, Val.E2.le in Hle; simpl in Hle.
destruct Hle as [[[Hi Hls] Hab] Hps].
inversion Hx; subst.
- apply Val_g_z. by apply Itv.gamma_monotone with i.
- apply Val_g_loc. by apply PowLoc.le_mem_true with ls.
- apply Val_g_ab. by apply arrayBlk_g_monotone with ab.
- apply Val_g_proc. by apply PowProc.le_mem_true with ps.
Qed.

Lemma val_g_mor : Proper (Logic.eq ==> Val.eq ==> Basics.impl) Val_g.
Proof.
intros v1 v2 Hv v1' v2' Hv'; intros Hvalg.
eapply val_g_monotone; [rewrite <- Hv; by apply Hvalg|by apply Val.le_refl].
Qed.

Lemma var_g_eq1 :
  forall x1 x2 x (Heq1 : Var.eq (Var_g x1) (Var.Inl x))
     (Heq2 : Var.eq (Var_g x2) (Var.Inl x)),
    DomCon.Var.eq x1 x2.
Proof.
i. unfold Var_g in *.
destruct x1 as [x1|[[? ?] ?]]; [|by inversion Heq1].
destruct x2 as [x2|[[? ?] ?]]; [|by inversion Heq2].
inversion_clear Heq1; inversion_clear Heq2. subst.
by apply DomCon.Var.eq_refl.
Qed.

Lemma var_g_eq2 g :
  forall m (Hm : SemCon.wf_non_rec_mem g m)
     f (Hf : Global.G.is_rec f g = false)
     x1 fs1 x2 fs2 x
     (Hml1 : DomCon.M.In (elt:=DomCon.val_t) (DomCon.VarRegion.Inl x1, fs1) m)
     (Hml2 : DomCon.M.In (elt:=DomCon.val_t) (DomCon.VarRegion.Inl x2, fs2) m)
     (Heq1 : Var.eq (Var_g x1) (Var.Inr (f, x)))
     (Heq2 : Var.eq (Var_g x2) (Var.Inr (f, x))),
    DomCon.Var.eq x1 x2.
Proof.
i. unfold Var_g in *.
destruct x1 as [x1|[[? ?] ?]]; [by inversion Heq1|].
destruct x2 as [x2|[[? ?] ?]]; [by inversion Heq2|].
inversion_clear Heq1; inversion_clear Heq2; simpl in *.
destruct Heq as [Hf1 Hx1], Heq0 as [Hf2 Hx2]. subst.
constructor; s.
split; [|by auto]. split; [|by auto].
eapply Hm; [by apply Hf|by apply Hml1|by apply Hml2].
Qed.

Lemma varregion_g_eq1 :
  forall vr1 vr2 x
     (Hveq1 : VarAllocsite.eq (VarRegion_g vr1) (VarAllocsite.Inl (Var.Inl x)))
     (Hveq2 : VarAllocsite.eq (VarRegion_g vr2) (VarAllocsite.Inl (Var.Inl x))),
    DomCon.VarRegion.eq vr1 vr2.
Proof.
i. unfold VarRegion_g in *.
destruct vr1 as [x1|[[? ?] ?]]; [|by inversion Hveq1].
destruct vr2 as [x2|[[? ?] ?]]; [|by inversion Hveq2].
inversion_clear Hveq1; inversion_clear Hveq2.
constructor. eapply var_g_eq1; [by apply Heq|by apply Heq0].
Qed.

Lemma varregion_g_eq2 g :
  forall m (Hm : SemCon.wf_non_rec_mem g m)
     f (Hf : Global.G.is_rec f g = false)
     vr1 fs1 (Hml1 : DomCon.M.In (elt:=DomCon.val_t) (vr1, fs1) m)
     vr2 fs2 (Hml2 : DomCon.M.In (elt:=DomCon.val_t) (vr2, fs2) m)
     x
     (Hveq1 :
        VarAllocsite.eq (VarRegion_g vr1) (VarAllocsite.Inl (Var.Inr (f, x))))
     (Hveq2 :
        VarAllocsite.eq (VarRegion_g vr2) (VarAllocsite.Inl (Var.Inr (f, x)))),
    DomCon.VarRegion.eq vr1 vr2.
Proof.
i. unfold VarRegion_g in *.
destruct vr1 as [x1|[[? ?] ?]]; [|by inversion Hveq1].
destruct vr2 as [x2|[[? ?] ?]]; [|by inversion Hveq2].
inversion_clear Hveq1; inversion_clear Hveq2.
constructor. eapply var_g_eq2
; [ by apply Hm | by apply Hf | by apply Hml1 | by apply Hml2
  | by apply Heq | by apply Heq0 ].
Qed.

Lemma fields_g_nil' :
  forall f n (Hn : n > 0) (Hf : Fields.eq' n (Fields_g f) Fields.nil),
    f = DomCon.Fields.nil.
Proof.
destruct n; [by inversion 1|i].
destruct f; [reflexivity|].
simpl in Hf. by inversion Hf.
Qed.

Lemma fields_g_nil :
  forall f (Hf : Fields.eq (Fields_g f) Fields.nil),
    f = DomCon.Fields.nil.
Proof.
intros. eapply fields_g_nil'; [|by apply Hf].
unfold DNList.size. omega.
Qed.

Lemma prop_approx_one_loc :
  forall g l (Hl: approx_one_loc g l = true)
     m (Hm : SemCon.wf_non_rec_mem g m)
     l1 (Hl1: Loc.eq (Loc_g l1) l) (Hml1 : DomCon.M.In l1 m)
     l2 (Hl2: Loc.eq (Loc_g l2) l) (Hml2 : DomCon.M.In l2 m),
    DomCon.Loc.eq l1 l2.
Proof.
i. unfold approx_one_loc in Hl.
destruct l as [[[[x|[f x]]|a] fs]|p]; [| |discriminate|discriminate].
- unfold Loc_g in *. destruct l1 as [vr1 fs1], l2 as [vr2 fs2].
  inversion_clear Hl1; inversion_clear Hl2. simpl in Heq, Heq0.
  destruct Heq as [Hveq1 Hfs1], Heq0 as [Hveq2 Hfs2].
  constructor; s.
  + eapply varregion_g_eq1; [by apply Hveq1|by apply Hveq2].
  + destruct fs; [|discriminate].
    rewrite (fields_g_nil _ Hfs1), (fields_g_nil _ Hfs2). constructor.
- unfold Loc_g in *. destruct l1 as [vr1 fs1], l2 as [vr2 fs2].
  inversion_clear Hl1; inversion_clear Hl2. simpl in Heq, Heq0.
  destruct Heq as [Hveq1 Hfs1], Heq0 as [Hveq2 Hfs2].
  constructor; s.
  + destruct fs; [|discriminate].
    eapply varregion_g_eq2
    ; [ by apply Hm | apply Bool.negb_true_iff; by apply Hl
      | by apply Hml1 | by apply Hml2 | by apply Hveq1 | by apply Hveq2 ].
  + destruct fs; [|discriminate].
    rewrite (fields_g_nil _ Hfs1), (fields_g_nil _ Hfs2). constructor.
Qed.

Inductive Loc_opt_g : option DomCon.Loc.t -> PowLoc.t -> Prop :=
| Loc_opt_g_none : forall l', Loc_opt_g None l'
| Loc_opt_g_some :
    forall l l' (Hv : PowLoc.mem (Loc_g l) l' = true), Loc_opt_g (Some l) l'.

Import RunOnly RunOnly.SemMem RunOnly.SemEval.

Load MemGCommon.
Load MemPfCommon.

Lemma cor_eval_const :
  forall c v (Hc : SemCon.Eval_const c v), Val_g v (SemEval.eval_const c).
Proof.
destruct 1; constructor.
- by apply Itv.cor_itv_top.
- by apply Itv.cor_of_int.
- by apply Itv.cor_of_int.
- unfold Itv.of_ints. destruct (Z_le_dec lb ub); [constructor|omega].
  + constructor; omega.
  + constructor; omega.
- by apply Itv.cor_itv_top.
Qed.

Lemma val_g_bot_false : forall x, ~ (Val_g x Val.bot).
Proof.
inversion_clear 1; subst.
- by inversion Hz.
- by inversion Hl.
- inversion_clear Hl; subst.
  inversion Hab; subst.
  by inversion Hsz.
- by inversion Hp.
Qed.

Lemma cor_eval_uop :
  forall op v v' abs_v (Hu : SemCon.Eval_uop op v v') (Habs : Val_g v abs_v),
    Val_g v' (SemEval.eval_uop op abs_v).
Proof.
i. unfold SemEval.eval_uop.
destruct (Val.eq_dec abs_v Val.bot)
; [ eapply val_g_mor in Habs
    ; [by apply val_g_bot_false in Habs|reflexivity|by apply e] |].
inversion Hu; subst.
- inversion Habs; subst. constructor.
  rewrite <- Z.sub_0_l. apply Itv.cor_minus; [by apply Itv.cor_of_int|by auto].
- inversion Habs; subst. constructor.
  unfold Itv.b_not_itv. apply Itv.unknown_unary_prop; i.
  inversion Hz; subst. by inversion FH.
- inversion Habs; subst. constructor.
  eapply Itv.not_itv_prop1; [by apply Ht|by auto].
- inversion Habs; subst. constructor.
  eapply Itv.not_itv_prop2; by auto.
Qed.

Lemma itv_non_bot :
  forall z abs_v (Habs : Val_g (DomCon.val_of_z z) abs_v),
    ~ (Itv.eq (itv_of_val abs_v) Itv.bot).
Proof.
i. destruct abs_v as [[[i ls] ab] ps].
inversion Habs; subst.
eapply Itv.non_bot; [by apply Hz|by apply FH].
Qed.

Lemma itv_non_zero :
  forall z abs_v (Ht : z <> 0%Z) (Habs : Val_g (DomCon.val_of_z z) abs_v),
    ~ (Itv.eq (itv_of_val abs_v) Itv.zero).
Proof.
inversion 2; subst. s; i.
exploit Itv.gamma_mor; [reflexivity|by apply FH|by apply Hz|].
inversion 1; subst.
elim Ht. inversion Hle1; inversion Hle2. omega.
Qed.

Local Open Scope sumbool.

Lemma cor_plus_offset :
  forall step alloc o sz st z ab i
     (Hab : ArrayBlk_g (step, alloc, (o, sz, st)) ab) (Hz : Itv_g z i),
    ArrayBlk_g (step, alloc, ((o + z)%Z, sz, st)) (ArrayBlk.plus_offset ab i).
Proof.
inversion 1; subst; i.
apply ArrayBlk_g_intro with (o':=Itv.plus o' i) (st':=st') (sz':=sz')
; [by apply Itv.cor_plus|by auto|by auto|].
unfold ArrayBlk.plus_offset.
destruct (Itv.eq_dec i Itv.bot)
; [exploit Itv.non_bot; [by apply Hz|by apply e|by auto]|].
erewrite ArrayBlk.map_1; [| |by apply Hab0].
- unfold ArrInfo.plus_offset.
  destruct (Itv.eq_dec Itv.bot o'); [|reflexivity].
  exploit Itv.non_bot; [by apply Ho|by apply Itv.eq_sym|by auto].
- unfold ArrInfo.plus_offset. simpl.
  destruct (Itv.eq_dec Itv.bot Itv.bot)
  ; [by auto|elim f0; by apply Itv.eq_refl].
Qed.

Lemma cor_minus_offset :
  forall step alloc o sz st z ab i
     (Hab : ArrayBlk_g (step, alloc, (o, sz, st)) ab) (Hz : Itv_g z i),
    ArrayBlk_g (step, alloc, ((o - z)%Z, sz, st)) (ArrayBlk.minus_offset ab i).
Proof.
inversion 1; subst; i.
apply ArrayBlk_g_intro with (o':=Itv.minus o' i) (st':=st') (sz':=sz')
; [by apply Itv.cor_minus|by auto|by auto|].
unfold ArrayBlk.minus_offset.
destruct (Itv.eq_dec i Itv.bot)
; [exploit Itv.non_bot; [by apply Hz|by apply e|by auto]|].
erewrite ArrayBlk.map_1; [| |by apply Hab0].
- unfold ArrInfo.minus_offset.
  destruct (Itv.eq_dec Itv.bot o'); [|reflexivity].
  exploit Itv.non_bot; [by apply Ho|by apply Itv.eq_sym|by auto].
- unfold ArrInfo.minus_offset. simpl.
  destruct (Itv.eq_dec Itv.bot Itv.bot)
  ; [by auto|elim f0; by apply Itv.eq_refl].
Qed.

Lemma cor_plus_pi :
  forall step alloc o sz st z v i
     (Hv : Val_g
                (DomCon.val_of_loc
                   (DomCon.loc_of_alloc
                      step alloc (o, sz, st) DomCon.Fields.nil))
                v)
     (Hz : Itv_g z i),
    Val_g
      (DomCon.val_of_loc
         (DomCon.loc_of_alloc step alloc ((o + z)%Z, sz, st) DomCon.Fields.nil))
      (Val.join
         (SemEval.array_loc_of_val v)
         (val_of_array (ArrayBlk.plus_offset (array_of_val v) i))).
Proof.
i; inversion_clear Hv; subst.
- eapply val_g_monotone; [apply Val_g_loc|by apply Val.join_left].
  unfold DomCon.loc_of_alloc, Loc_g, VarRegion_g in *.
  apply PowLoc.filter1; [by apply SemEval.is_array_loc_mor|by apply Hl|by auto].
- eapply val_g_monotone; [apply Val_g_ab|by apply Val.join_right].
  by apply cor_plus_offset.
Qed.

Lemma cor_minus_pi :
  forall step alloc o sz st z v i
     (Hv : Val_g
                (DomCon.val_of_loc
                   (DomCon.loc_of_alloc
                      step alloc (o, sz, st) DomCon.Fields.nil))
                v)
     (Hz : Itv_g z i),
    Val_g
      (DomCon.val_of_loc
         (DomCon.loc_of_alloc step alloc ((o - z)%Z, sz, st) DomCon.Fields.nil))
      (Val.join
         (SemEval.array_loc_of_val v)
         (val_of_array (ArrayBlk.minus_offset (array_of_val v) i))).
Proof.
i; inversion_clear Hv; subst.
- eapply val_g_monotone; [apply Val_g_loc|by apply Val.join_left].
  unfold DomCon.loc_of_alloc, Loc_g, VarRegion_g in *.
  apply PowLoc.filter1; [by apply SemEval.is_array_loc_mor|by apply Hl|by auto].
- eapply val_g_monotone; [apply Val_g_ab|by apply Val.join_right].
  by apply cor_minus_offset.
Qed.

Lemma cor_eval_bop :
  forall op v1 v2 v' abs_v1 abs_v2 (Hu : SemCon.Eval_bop op v1 v2 v')
     (Habs1 : Val_g v1 abs_v1) (Habs2 : Val_g v2 abs_v2),
    Val_g v' (SemEval.eval_bop op abs_v1 abs_v2).
Proof.
inversion_clear 1; subst.
{                               (* PlusA *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2. by apply Itv.cor_plus.
}
{                               (* PlusPI *)
i. unfold SemEval.eval_bop.
inversion_clear Habs2; subst.
by apply cor_plus_pi.
}
{                               (* IndexPI *)
i. unfold SemEval.eval_bop.
inversion_clear Habs2; subst.
by apply cor_plus_pi.
}
{                               (* MinusA *)
i. unfold SemEval.eval_bop.
inversion_clear Habs1; inversion_clear Habs2.
constructor; by apply Itv.cor_minus.
}
{                               (* MinusPI *)
i. unfold SemEval.eval_bop.
inversion_clear Habs2; subst.
by apply cor_minus_pi.
}
{                               (* Mult *)
i. unfold SemEval.eval_bop.
inversion_clear Habs1; inversion_clear Habs2. constructor.
by apply Itv.times_prop.
}
{                               (* Div *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
by apply Itv.divide_prop.
}
{                               (* Mod *)
i. unfold SemEval.eval_bop, Itv.mod_itv.
constructor. apply Itv.unknown_binary_prop; i.
- by apply itv_non_bot in Habs1.
- by apply itv_non_bot in Habs2.
}
{                               (* Shiftlt *)
i. unfold SemEval.eval_bop, Itv.l_shift_itv.
constructor. apply Itv.unknown_binary_prop; i.
- by apply itv_non_bot in Habs1.
- by apply itv_non_bot in Habs2.
}
{                               (* Shiftrt *)
i. unfold SemEval.eval_bop, Itv.r_shift_itv.
constructor. apply Itv.unknown_binary_prop; i.
- by apply itv_non_bot in Habs1.
- by apply itv_non_bot in Habs2.
}
{                               (* Lt *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
by apply Itv.cor_lt1 with (z1:=z1) (z2:=z2).
}
{                               (* Lt *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
by apply Itv.cor_lt0 with (z1:=z1) (z2:=z2).
}
{                               (* Gt *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
unfold Itv.gt_itv.
apply Itv.cor_lt1 with (z1:=z2) (z2:=z1); [omega|by auto|by auto].
}
{                               (* Gt *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
unfold Itv.gt_itv.
apply Itv.cor_lt0 with (z1:=z2) (z2:=z1); [intro; elim Hle; omega|by auto|by auto].
}
{                               (* Le *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
apply Itv.cor_le1 with (z1:=z1) (z2:=z2); by auto.
}
{
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
apply Itv.cor_le0 with (z1:=z1) (z2:=z2); by auto.
}
{                               (* Ge *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
unfold Itv.ge_itv.
apply Itv.cor_le1 with (z1:=z2) (z2:=z1); [omega|by auto|by auto].
}
{                               (* Ge *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
unfold Itv.ge_itv.
apply Itv.cor_le0 with (z1:=z2) (z2:=z1); [intro; elim Hlt; omega|by auto|by auto].
}
{                               (* Eq *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
apply Itv.cor_eq1 with (z:=z2); by auto.
}
{                               (* Eq *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
apply Itv.cor_eq0 with (z1:=z1) (z2:=z2); by auto.
}
{                               (* Ne *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
apply Itv.cor_ne1 with (z1:=z1) (z2:=z2); by auto.
}
{                               (* Ne *)
i. unfold SemEval.eval_bop. constructor.
inversion_clear Habs1; inversion_clear Habs2.
apply Itv.cor_ne0 with (z:=z2); by auto.
}
{                               (* BAnd *)
i. unfold SemEval.eval_bop, Itv.b_and_itv.
constructor. apply Itv.unknown_binary_prop; i.
- by apply itv_non_bot in Habs1.
- by apply itv_non_bot in Habs2.
}
{                               (* BXor *)
i. unfold SemEval.eval_bop, Itv.b_xor_itv.
constructor. apply Itv.unknown_binary_prop; i.
- by apply itv_non_bot in Habs1.
- by apply itv_non_bot in Habs2.
}
{                               (* BOr *)
i. unfold SemEval.eval_bop, Itv.b_or_itv.
constructor. apply Itv.unknown_binary_prop; i.
- by apply itv_non_bot in Habs1.
- by apply itv_non_bot in Habs2.
}
{                               (* LAnd *)
i. unfold SemEval.eval_bop, Itv.and_itv.
dest_if_dec; [|dest_if_dec; [|dest_if_dec]].
- apply False_ind. destruct o; by eauto using itv_non_bot.
- apply False_ind. destruct Hz. destruct o as [o|o].
  + by apply (itv_non_zero (z:=z1)) in o.
  + by apply (itv_non_zero (z:=z2)) in o.
- constructor. by apply Itv.true_itv_prop.
- constructor. by apply Itv.unknown_bool_prop1.
}
{                               (* LAnd *)
i. unfold SemEval.eval_bop, Itv.and_itv.
dest_if_dec; [|dest_if_dec; [|dest_if_dec]].
- apply False_ind. destruct o; by eauto using itv_non_bot.
- constructor. by apply Itv.false_itv_prop.
- destruct a1 as [a1 _]; elim a1. inversion Habs1; subst. by apply Itv.false_itv1.
- constructor. by apply Itv.unknown_bool_prop0.
}
{                               (* LAnd *)
i. unfold SemEval.eval_bop, Itv.and_itv.
dest_if_dec; [|dest_if_dec; [|dest_if_dec]].
- apply False_ind. destruct o; by eauto using itv_non_bot.
- constructor. by apply Itv.false_itv_prop.
- destruct a1 as [_ a1]; elim a1. inversion Habs2; subst. by apply Itv.false_itv1.
- constructor. by apply Itv.unknown_bool_prop0.
}
{                               (* LOr *)
i. unfold SemEval.eval_bop, Itv.or_itv.
dest_if_dec; [|dest_if_dec; [|dest_if_dec]].
- apply False_ind. destruct o; by eauto using itv_non_bot.
- destruct a0; by apply itv_non_zero in Habs1.
- constructor. by apply Itv.true_itv_prop.
- constructor. by apply Itv.unknown_bool_prop1.
}
{                               (* LOr *)
i. unfold SemEval.eval_bop, Itv.or_itv.
dest_if_dec; [|dest_if_dec; [|dest_if_dec]].
- apply False_ind. destruct o; by eauto using itv_non_bot.
- destruct a0; by apply itv_non_zero in Habs2.
- constructor. by apply Itv.true_itv_prop.
- constructor. by apply Itv.unknown_bool_prop1.
}
{                               (* LOr *)
i. unfold SemEval.eval_bop, Itv.or_itv.
dest_if_dec; [|dest_if_dec; [|dest_if_dec]].
- apply False_ind. destruct o; by eauto using itv_non_bot.
- constructor. by apply Itv.false_itv_prop.
- destruct o0 as [o0|o0]; elim o0.
  + inversion Habs1; subst; by apply Itv.false_itv1.
  + inversion Habs2; subst; by apply Itv.false_itv1.
- constructor. by apply Itv.unknown_bool_prop0.
}
Qed.

Local Close Scope sumbool.

Lemma eval_zero :
  forall abs_v (Habs : Val_g (DomCon.val_of_z 0) abs_v),
    Itv.le Itv.zero (DomAbs.itv_of_val abs_v).
Proof. inversion 1; inversion Hz; subst. by constructor. Qed.

Lemma cor_cast :
  forall step alloc o o' sz sz' st st' ab
         (Ho' : o' = (c_div (o * st) st')%Z)
         (Hsz' : sz' = (c_div (sz * st) st')%Z)
         (Hab : ArrayBlk_g (step, alloc, (o, sz, st)) ab),
    ArrayBlk_g (step, alloc, (o', sz', st')) (ArrayBlk.cast_array_int st' ab).
Proof.
inversion 3; subst. econstructor.
- apply Itv.divide_prop; [apply Itv.times_prop|].
  + by apply Ho.
  + by apply Hst.
  + by apply Itv.cor_of_int.
- apply Itv.divide_prop; [apply Itv.times_prop|].
  + by apply Hsz.
  + by apply Hst.
  + by apply Itv.cor_of_int.
- by apply Itv.cor_of_int.
- unfold ArrayBlk.cast_array_int, ArrayBlk.cast_array.
  rewrite ArrayBlk.map_1 with (v:=(o'0, sz'0, st'0)); [| |by auto].
  + destruct (Itv.eq_dec Itv.bot st'0); [|by auto].
    apply Itv.non_bot in Hst; [by elim Hst|by apply Itv.eq_sym].
  + s; destruct (Itv.eq_dec Itv.bot Itv.bot)
    ; [reflexivity|by elim f; apply Itv.eq_refl].
Qed.

Lemma cor_pow_loc_of_array :
  forall r ab (Hr : ArrayBlk_g r ab),
    PowLoc.mem (Loc_g (DomCon.VarRegion.Inr r, DomCon.Fields.nil))
               (ArrayBlk.pow_loc_of_array ab) = true.
Proof.
inversion 1; subst; s.
unfold ArrayBlk.pow_loc_of_array.
eapply ArrayBlk.foldi_1
with (teq:=PowLoc.eq) (k:=Allocsite_g a) (v:=(o', sz', st')).
- constructor
  ; [ intros ?; by apply PowLoc.eq_refl
    | intros ? ? ?; by apply PowLoc.eq_trans
    | intros ? ?; by apply PowLoc.eq_sym ].
- intros ls1 ls2 Hls; split; intro Hmem.
  + rewrite PowLoc.mem_mor
    ; [by apply Hmem|by apply Loc.eq_refl|by apply PowLoc.eq_sym].
  + rewrite PowLoc.mem_mor; [by apply Hmem|by apply Loc.eq_refl|by auto].
- rewrite Hab; by apply ArrInfo.eq_refl.
- destruct (ArrInfo.eq_dec ArrInfo.bot (o', sz', st'))
  ; [ inversion e; simpl in H0; apply Itv.non_bot in Hst
      ; [by elim Hst|by apply Itv.eq_sym] |].
  i; apply DomBasic.PowLoc.mem_add_1; by apply Loc.eq_refl.
- i; destruct (ArrInfo.eq_dec ArrInfo.bot v)
  ; [by apply PowLoc.eq_refl|by elim f].
- i; destruct (ArrInfo.eq_dec ArrInfo.bot v); [by auto|].
  by apply PowLoc.mem_add_3.
- i; destruct (ArrInfo.eq_dec ArrInfo.bot v1).
  + destruct (ArrInfo.eq_dec ArrInfo.bot v2)
    ; [|elim f; eapply ArrInfo.eq_trans; [by apply e|by auto]].
    by auto.
  + destruct (ArrInfo.eq_dec ArrInfo.bot v2)
    ; [ elim f; eapply ArrInfo.eq_trans; [by apply e|by apply ArrInfo.eq_sym]
      | rewrite <- Hf ].
    apply PowLoc.mem_mor; [by auto|].
    apply PowLoc.add_mor; [|by apply PowLoc.eq_refl].
    apply DomBasic.loc_of_allocsite_mor; by apply Allocsite.eq_sym.
Qed.

Lemma cor_deref_of_val :
  forall l v (Habs : Val_g (DomCon.val_of_loc l) v),
    PowLoc.mem (Loc_g l) (SemEval.deref_of_val v) = true.
Proof.
inversion 1; subst.
- unfold SemEval.deref_of_val.
  eapply PowLoc.le_mem_true; [by apply PowLoc.join_left|by apply Hl].
- unfold SemEval.deref_of_val.
  eapply PowLoc.le_mem_true; [by apply PowLoc.join_right|].
  apply cor_pow_loc_of_array. by apply Hl.
Qed.

Lemma cor_fields_app :
  forall fs n f,
    Fields.eq' n (Fields_g (SemCon.fields_app1 fs f))
               (Fields.app (Fields_g fs) f).
Proof.
induction fs.
- i; s; by apply Fields.eq'_refl.
- i; s. destruct n; [by constructor|].
  constructor; [by auto|by apply IHfs].
Qed.

Lemma cor_append_field :
  forall va fs f v (Hl : Val_g (DomCon.val_of_loc (va, fs)) v),
    PowLoc.mem (Loc_g (va, SemCon.fields_app1 fs f))
               (PowLoc.join
                  (DomBasic.pow_loc_append_field (DomAbs.pow_loc_of_val v) f)
                  (ArrayBlk.pow_loc_of_struct_w_field (DomAbs.array_of_val v) f)) =
    true.
Proof.
inversion 1; subst; clear Hl.
- eapply PowLoc.mem_monotone1
  ; [by apply Loc.eq_refl|by apply PowLoc.join_left|].
  unfold DomBasic.pow_loc_append_field.
  remember (fun l : Loc.t' => append_field l f) as append_f.
  assert
    (Loc.eq (Loc_g (va, SemCon.fields_app1 fs f)) (append_f (Loc_g (va, fs))))
  as Hl.
  + rewrite Heqappend_f. unfold append_field, Loc_g. constructor; s.
    split; [by apply VarAllocsite.eq_refl|by apply cor_fields_app].
  + rewrite Hl. apply SMLocLoc.map_1; [|by apply Hl0].
    intros l1 l2 Hl'. subst. by apply DomBasic.append_field_mor.
- eapply PowLoc.mem_monotone1
  ; [by apply Loc.eq_refl|by apply PowLoc.join_right|].
  unfold ArrayBlk.pow_loc_of_struct_w_field.
  inversion Hl0; subst; clear Hl0.
  apply ArrayBlk.foldi_1
  with (teq:=PowLoc.eq) (k:=Allocsite_g a) (v:=(o', sz', st')).
  + constructor
    ; [ intros ?; by apply PowLoc.eq_refl
      | intros ? ? ?; by apply PowLoc.eq_trans
      | intros ? ?; by apply PowLoc.eq_sym ].
  + intros l1 l2 Hl; split; intro Hmem.
    * rewrite DomBasic.PowLoc.mem_mor
      ; [by apply Hmem|by apply Loc.eq_refl|by apply PowLoc.eq_sym].
    * rewrite DomBasic.PowLoc.mem_mor
      ; [by apply Hmem|by apply Loc.eq_refl|by auto].
  + unfold DomAbs.array_of_val.
    rewrite <- Hab; by apply ArrInfo.eq_refl.
  + i; dest_if_dec
    ; [ inversion e; simpl in H0; apply Itv.non_bot in Hst
        ; [by elim Hst|by auto] |].
    apply PowLoc.mem_add_1.
    constructor; split; [by apply VarAllocsite.eq_refl|by apply cor_fields_app].
  + i. dest_if_dec. elim f0; by apply ArrInfo.eq_sym.
  + i; dest_if_dec. by apply PowLoc.mem_add_3.
  + i. destruct (ArrInfo.eq_dec v1 ArrInfo.bot).
    * destruct (ArrInfo.eq_dec v2 ArrInfo.bot)
      ; [| elim f0; eapply ArrInfo.eq_trans
           ; [apply ArrInfo.eq_sym; by apply Hv|by auto] ].
      by auto.
    * destruct (ArrInfo.eq_dec v2 ArrInfo.bot)
      ; [elim f0; eapply ArrInfo.eq_trans; [by apply Hv|by auto]|].
      rewrite <- Hf. apply PowLoc.mem_mor; [by apply Loc.eq_refl|].
      apply PowLoc.add_mor; [|by apply PowLoc.eq_refl].
      apply DomBasic.append_field_mor; [|by apply Field.eq_refl].
      apply DomBasic.loc_of_allocsite_mor; by apply Allocsite.eq_sym.
Qed.

Lemma cor_plus_offset_val :
  forall step alloc o idx sz st abs_idx abs_v
         (Habs : Val_g
                   (DomCon.val_of_loc
                      (DomCon.loc_of_alloc
                         step alloc (o, sz, st) DomCon.Fields.nil))
                   abs_v)
         (Hidx : Itv_g idx abs_idx),
    Val_g
      (DomCon.val_of_loc
         (DomCon.loc_of_alloc
            step alloc ((o + idx)%Z, sz, st) DomCon.Fields.nil))
      (DomAbs.modify_array
         abs_v (ArrayBlk.plus_offset (DomAbs.array_of_val abs_v) abs_idx)).
Proof.
i. unfold ArrayBlk.plus_offset.
destruct (Itv.eq_dec abs_idx Itv.bot).
- inversion Hidx; subst. inversion e.
- inversion Habs; subst.
  + apply Val_g_loc. by apply Hl.
  + apply Val_g_ab.
    inversion Hl; subst.
    eapply ArrayBlk_g_intro
    ; [ apply Itv.cor_plus; [by apply Ho|by apply Hidx]
      | by apply Hsz
      | by apply Hst |].
    rewrite ArrayBlk.map_1 with (v:=(o', sz', st')).
    * s. destruct (Itv.eq_dec Itv.bot o')
         ; [inversion Ho; subst; inversion e|reflexivity].
    * s. destruct (Itv.eq_dec Itv.bot Itv.bot); by auto.
    * by auto.
Qed.

Lemma cor_eval :
  forall step cn e cid callee m d abs_m
         (Hm : Mem_g (cid, callee, m, d) abs_m)
         v (Heval : SemCon.Eval_exp step cn cid m e v),
    Val_g v (eval Strong cn e abs_m)

with cor_eval_lv :
  forall step cn lv cid callee m d abs_m
    (Hm : Mem_g (cid, callee, m, d) abs_m)
    l (Heval : SemCon.Eval_lv step cn cid m lv l),
    PowLoc.mem (Loc_g l)
               (eval_lv Strong cn lv abs_m)
    = true

with cor_resolve_offset :
  forall cn step cid callee m d o l l' abs_m
         (Hm : Mem_g (cid, callee, m, d) abs_m)
         (Hres : SemCon.Resolve_offset step cn cid m l o l')
         v (Hl : Val_g (DomCon.val_of_loc l) v),
    PowLoc.mem (Loc_g l')
               (resolve_offset Strong cn v o abs_m)
    = true.
Proof.
induction 2.
{ s. apply cor_eval_const. by apply Hc. }
{ s. eapply cor_mem_lookup; [|by apply Hm0|by apply Hm].
eapply cor_eval_lv; [by apply Hm|by apply Hl].
}
{ s. constructor. by apply Itv.cor_of_int. }
{ s. constructor. by apply Itv.cor_of_int. }
{ s. constructor. by apply Itv.cor_of_int. }
{ s. constructor. by apply Itv.cor_of_int. }
{ s. constructor. by apply Itv.cor_itv_top. }
{ s. eapply cor_eval_uop; [by apply Hu|by apply IHHeval]. }
{ s. eapply cor_eval_bop; [by apply Hb|by apply IHHeval1|by apply IHHeval2]. }
{ s. unfold MId.bind.
match goal with [|- context[if ?c then _ else _]] => destruct c end
; [apply False_ind; eapply itv_non_bot; [by apply IHHeval1|by apply e]|].
match goal with [|- context[if ?c then _ else _]] => destruct c end
; [ apply False_ind; eapply itv_non_zero
    ; [by apply Ht|by apply IHHeval1|by apply e] |].
match goal with [|- context[if ?c then _ else _]] => destruct c end
; [ by apply IHHeval2 |].
eapply val_g_monotone; [by apply IHHeval2|by apply Val.join_left].
}
{ s. unfold MId.bind.
match goal with [|- context[if ?c then _ else _]] => destruct c end
; [apply False_ind; eapply itv_non_bot; [by apply IHHeval1|by apply e]|].
match goal with [|- context[if ?c then _ else _]] => destruct c end
; [by apply IHHeval2|].
match goal with [|- context[if ?c then _ else _]] => destruct c end
; [elim f1; apply eval_zero; by apply IHHeval1|].
eapply val_g_monotone; [by apply IHHeval2|by apply Val.join_right].
}
{ s. unfold MId.bind, MId.ret.
  rewrite Hl in IHHeval. inversion_clear IHHeval.
- apply Val_g_loc. rewrite Hl'. simpl in *. by apply Hl0.
- rewrite Hl'. apply Val_g_ab.
  eapply cor_cast; [by apply Ho'|by apply Hsz'|by apply Hl0].
}
{ s. constructor. eapply cor_eval_lv; [by apply Hm|by apply Hl]. }
{ s. constructor. eapply cor_eval_lv; [by apply Hm|by apply Hl]. }

induction 2.
{ s. eapply cor_resolve_offset; [by apply Hm|by apply Ho|].
constructor. apply PowLoc.singleton_1. by apply Loc.eq_refl. }
{ s. eapply cor_resolve_offset; [by apply Hm|by apply Ho|].
constructor. apply PowLoc.singleton_1. by apply Loc.eq_refl. }
{ s. eapply cor_resolve_offset; [by apply Hm|by apply Ho|].
eapply cor_eval; [by apply Hm|by apply Hv]. }

induction 2; i.
{ s. apply cor_deref_of_val. by apply Hl. }
{ s. eapply IHHres. constructor. eapply cor_append_field. by apply Hl. }
{ s. eapply IHHres.
rewrite Hl'. apply cor_plus_offset_val.
- eapply cor_mem_lookup.
  + apply cor_deref_of_val; by apply Hl0.
  + rewrite <- Hl; by apply Hm0.
  + by apply Hm.
- assert (Val_g (DomCon.val_of_z idx) (SemEval.eval Strong cn e abs_m)) as Hval_g
  ; [eapply cor_eval; [by apply Hm|by apply Hv]|].
  inversion Hval_g; subst. by apply Hz.
}
Qed.

Lemma cor_eval_alloc' :
  forall step cn sz
         a (Ha : a = DomCon.Allocsite.Inl cn)
         al (Hal : al = DomCon.loc_of_alloc step a (0%Z, sz, 1%Z) DomCon.Fields.nil)
         v (Hv : Val_g (DomCon.val_of_z sz) v),
    Val_g (DomCon.val_of_loc al) (eval_alloc' cn v).
Proof.
i. rewrite Hal, Ha.
eapply val_g_monotone; [|by apply Val.join_left].
unfold DomCon.val_of_loc.
apply Val_g_loc. s.
unfold loc_of_allocsite, allocsite_of_node.
apply PowLoc.singleton_1; by apply Loc.eq_refl.
Qed.

Lemma cor_eval_string :
  forall g cn s step sz cid callee d m m' abs_m
     base o (Hbase : base = DomCon.loc_of_alloc step (DomCon.Allocsite.Inl cn) (o, sz, 1%Z) DomCon.Fields.nil)
     (Hinit : SemCon.Initial_s g step (DomCon.Allocsite.Inl cn) base s m m')
     (Hmem_g : Mem_g (cid, callee, m, d) abs_m),
    Mem_g (cid, callee, m', d)
          (mem_wupdate Strong
                      (PowLoc.singleton
                         (loc_of_allocsite (allocsite_of_node cn)))
                      (SemEval.eval_string s) abs_m).
Proof.
induction s.
- i; inversion_clear Hinit; subst.
  eapply cor_wupdate; [| |by apply Hmem_g|reflexivity|reflexivity].
  + apply DomBasic.PowLoc.singleton_1; by apply Loc.eq_refl.
  + constructor; constructor; [constructor; omega|by constructor].
- i; inversion Hinit; subst. inversion Hl; subst.
  eapply mem_g_mor; [reflexivity|by apply mem_wupdate_double|].
  eapply IHs; [reflexivity|by apply Htl|].
  eapply cor_wupdate; [| |by apply Hmem_g|reflexivity|reflexivity].
  + apply DomBasic.PowLoc.singleton_1; by apply Loc.eq_refl.
  + constructor; constructor; [constructor; omega|by constructor].
Qed.

Lemma cor_eval_string_loc :
  forall step cn sz s
         a (Ha : a = DomCon.Allocsite.Inl cn)
         base (Hbase : base = DomCon.loc_of_alloc step a (0%Z, sz, 1%Z) DomCon.Fields.nil),
    Val_g (DomCon.val_of_loc base)
          (SemEval.eval_string_loc
             s (allocsite_of_node cn)
             (PowLoc.singleton (loc_of_allocsite (allocsite_of_node cn)))).
Proof.
i. unfold DomCon.val_of_loc, SemEval.eval_string_loc, DomAbs.val_of_pow_loc, DomAbs.val_of_array.
eapply val_g_monotone; [|by apply Val.join_left].
apply Val_g_loc.
rewrite Hbase, Ha. unfold allocsite_of_node, loc_of_allocsite. s.
apply PowLoc.singleton_1. by apply Loc.eq_refl.
Qed.

Lemma cor_ret_some :
  forall callee callee' cid cid' m m' retl d abs_m abs_m'
     (Hmem_g : Mem_g (cid, callee, m, (callee', Some retl, cid') :: d) abs_m)
         v v' (Hv : Val_g v v')
         (Habs_m' : abs_m' = mem_wupdate Strong
                                     (SemEval.deref_of_val
                                        (mem_lookup
                                           (PowLoc.singleton
                                              (loc_of_proc callee'))
                                           abs_m))
                                     v' abs_m)
         (Hm' : DomCon.M.add retl v m = m'),
    Mem_g (cid', callee, m', d) abs_m'.
Proof.
i. rewrite Habs_m', <- Hm'.
eapply cor_wupdate
; [|by apply Hv|eapply weaken_mem_g; by apply Hmem_g|reflexivity|reflexivity].
apply cor_deref_of_val.
destruct Hmem_g as [Hm Hs]. unfold Stack_g in Hs.
assert (Hs' : Val_g (DomCon.val_of_loc retl) (Mem.find (SProc_g callee') abs_m))
; [eapply Hs; s; left; reflexivity|].
eapply val_g_monotone; [by apply Hs'|].
apply mem_find_mem_lookup. apply PowLoc.singleton_1. by apply Loc.eq_refl.
Qed.

Lemma cor_modify_itv :
  forall v z abs_v itv_v (Hv : v = DomCon.val_of_z z) (Hz : Itv_g z itv_v),
    Val_g v (DomAbs.modify_itv abs_v itv_v).
Proof. i; unfold DomAbs.modify_itv; subst; by apply Val_g_z. Qed.

Lemma Itv_g_mor :
  forall z i1 i2 (Hz : Itv_g z i1) (Hi : Itv.eq i1 i2), Itv_g z i2.
Proof.
inversion 1; subst; inversion 1; subst; constructor.
- apply Itv.le'_trans with lb.
Abort.

Lemma cor_gen_itv :
  forall z lb ub (Hlb : Itv.le' lb (Itv.Int z)) (Hub : Itv.le' (Itv.Int z) ub)
     (lb_c : Itv.eq' lb Itv.PInf -> False) (ub_c : Itv.eq' ub Itv.MInf -> False),
    Itv_g z (Itv.gen_itv lb ub).
Proof.
i. unfold Itv.gen_itv.
destruct (Itv.le'_dec lb ub)
; [|elim f; by apply Itv.le'_trans with (Itv.Int z)].
destruct lb; [|elim lb_c; by apply Itv.eq'_refl|].
- destruct ub; [| |by inversion l]; by constructor.
- destruct ub; [| |elim ub_c; by apply Itv.eq'_refl]; by constructor.
Qed.

Lemma cor_minus'_one :
  forall z1 z2 ub (Hz : (z1 < z2)%Z) (Hub : Itv.le' (Itv.Int z2) ub),
    Itv.le' (Itv.Int z1) (Itv.minus'_one ub).
Proof.
inversion 2; subst; simpl Itv.minus'_one.
- by constructor.
- constructor; omega.
Qed.

Lemma cor_plus'_one :
  forall z1 z2 lb (Hz : (z1 < z2)%Z) (Hub : Itv.le' lb (Itv.Int z1)),
    Itv.le' (Itv.plus'_one lb) (Itv.Int z2).
Proof.
inversion 2; subst; simpl Itv.plus'_one.
- by constructor.
- constructor; omega.
Qed.

Lemma Itv_eq_min :
  forall a b c (Hle : Itv.eq' (Itv.min' a b) c), Itv.eq' a c \/ Itv.eq' b c.
Proof. i. unfold Itv.min' in Hle. destruct (Itv.le'_dec a b); by auto. Qed.

Lemma Itv_eq_max :
  forall a b c (Hle : Itv.eq' (Itv.max' a b) c), Itv.eq' a c \/ Itv.eq' b c.
Proof. i. unfold Itv.max' in Hle. destruct (Itv.le'_dec a b); by auto. Qed.

Lemma Itv_eq_min_minf :
  forall a (Ha : Itv.eq' (Itv.minus'_one a) Itv.MInf), Itv.eq' a Itv.MInf.
Proof.
destruct a; i; [by inversion Ha|by inversion Ha|by apply Itv.eq'_refl].
Qed.

Lemma Itv_eq_max_pinf :
  forall a (Ha : Itv.eq' (Itv.plus'_one a) Itv.PInf), Itv.eq' a Itv.PInf.
Proof.
destruct a; i; [by inversion Ha|by apply Itv.eq'_refl|by inversion Ha].
Qed.

Lemma Itv_g_meet :
  forall z x y (Hx : Itv_g z x) (Hy : Itv_g z y), Itv_g z (Itv.meet x y).
Proof.
inversion 1; inversion 1; subst. unfold Itv.meet.
dest_if_dec. dest_if_dec.
apply cor_gen_itv.
- by apply Itv.max'3.
- by apply Itv.min'3.
- intro Heq; apply Itv_eq_max in Heq; destruct Heq
  ; [by elim lb_c|by elim lb_c0].
- intro Heq; apply Itv_eq_min in Heq; destruct Heq
  ; [by elim ub_c|by elim ub_c0].
Qed.

Lemma cor_itv_prune :
  forall b z z0 i v2 abs_v2
    (Hprune : z <> 0%Z) (Hz : Itv_g z0 i)
    (Hb : SemCon.Eval_bop b (inl (inl z0)) v2 (DomCon.val_of_z z))
    (Habs_v2 : Val_g v2 abs_v2),
  Itv_g z0 (SemPrune.itv_prune b i (DomAbs.itv_of_val abs_v2)).
Proof.
i; inversion Hb; subst
; try (unfold SemPrune.itv_prune
     ; inversion Hz; subst; inversion Habs_v2; subst; inversion Hz0; subst
     ; s; by auto)
; try (unfold SemPrune.itv_prune
       ; inversion Hz; subst; inversion Habs_v2; subst; inversion Hz1; subst
       ; s; by auto)
; unfold SemPrune.itv_prune
; inversion Hz; subst; clear Hz
; inversion Habs_v2; subst; clear Habs_v2
; inversion Hz; subst; clear Hz; s.
- apply cor_gen_itv.
  + by auto.
  + apply Itv.min'3.
    * by auto.
    * eapply cor_minus'_one; [by apply Hlt|by auto].
  + by auto.
  + intro Hminf; apply Itv_eq_min in Hminf; elim Hminf
    ; [by auto|intro Hminf'; by apply Itv_eq_min_minf in Hminf'].
- apply cor_gen_itv.
  + apply Itv.max'3.
    * by auto.
    * eapply cor_plus'_one with z2; [omega|by auto].
  + by auto.
  + intro Hpinf; apply Itv_eq_max in Hpinf; elim Hpinf
    ; [by auto|intro Hpinf'; by apply Itv_eq_max_pinf in Hpinf'].
  + by auto.
- apply cor_gen_itv.
  + by auto.
  + apply Itv.min'3.
    * by auto.
    * apply Itv.le'_trans with (Itv.Int z2); [by constructor|by auto].
  + by auto.
  + intro Hminf; apply Itv_eq_min in Hminf; elim Hminf; by auto.
- apply cor_gen_itv.
  + apply Itv.max'3.
    * by auto.
    * apply Itv.le'_trans with (Itv.Int z2); [by auto|constructor; omega].
  + by auto.
  + intro Hpinf; apply Itv_eq_max in Hpinf; elim Hpinf; by auto.
  + by auto.
- unfold DomAbs.itv_of_val. apply Itv_g_meet.
  + by auto.
  + by constructor.
Qed.

Lemma cor_prune :
  forall g step cn abs_m abs_m' cid m d
     (Hmem_g : Mem_g (cid, None, m, d) abs_m)
     e z (Hv : SemCon.Eval_exp step cn cid m e (DomCon.val_of_z z))
     (Hprune : z <> 0%Z)
     (HAbs : abs_m' = SemPrune.prune g Strong cn e abs_m)
     (Hwf : SemCon.wf_non_rec_mem g m),
    Mem_g (cid, None, m, d) abs_m'.
Proof.
unfold SemPrune.prune; i.
destruct e; try (subst; by apply Hmem_g).
destruct e1; try (subst; by apply Hmem_g).
destruct lv; try (subst; by apply Hmem_g).
destruct lh; try (subst; by apply Hmem_g).
destruct o; try (subst; by apply Hmem_g).
subst. unfold MId.bind.
inversion_clear Hv. inversion_clear Hv1.
eapply cor_update' with (l:=l) (v:=v1); [| | |reflexivity| |]
; [ inversion Hl; subst; inversion Ho; subst; by apply Loc.eq_refl
  | | by auto
  | symmetry; by apply DomCon.M.P.F.find_mapsto_iff
  | by auto ].
remember (SemPrune.SemMem.mem_lookup
          (DomBasic.PowLoc.singleton
             (SemPrune.SemEval.eval_var cn x is_global)) abs_m) as abs_v1.
assert (Val_g v1 abs_v1) as Habs_v1.
{ rewrite Heqabs_v1; eapply cor_mem_lookup; [|by apply Hm|by apply Hmem_g]
  ; inversion Hl; subst; inversion Ho; subst; s
  ; by apply DomBasic.PowLoc.singleton_1, Loc.eq_refl. }
remember (SemPrune.SemEval.eval Strong cn e2 abs_m) as abs_v2.
assert (Val_g v2 abs_v2) as Habs_v2.
{ rewrite Heqabs_v2; eapply cor_eval; [by apply Hmem_g|by apply Hv2]. }
inversion Habs_v1; try (by constructor).
eapply cor_modify_itv; [reflexivity|].
eapply cor_itv_prune; [by apply Hprune|by apply Hz|subst; by apply Hb|by auto].
Qed.

Lemma cor_update_rets :
  forall cn cid m d step callee callees ret_opt l_opt abs_m abs_m'
         (Hcallee : PowProc.mem callee callees = true)
         (Hret : SemCon.Eval_lv_opt step cn cid m ret_opt l_opt)
         (Habs : Mem_g (step, Some callee, m, d) abs_m)
         (Hupdate :
            update_rets Strong cn callees ret_opt abs_m
            = abs_m'),
    Mem_g (step, Some callee, m, (callee, l_opt, cid) :: d) abs_m'.
Proof. {
i. subst. unfold update_rets, MId.bind, MId.ret. split.
- apply mem_wupdate_diff; [by apply Habs|].
  i. apply SMProcLoc.map_diff.
  unfold Loc_g, DomBasic.loc_of_proc; destruct l; inversion 1.
- unfold RunOnly.mem_wupdate, mem_wupdate, MId.bind, MId.ret.
  unfold weak_add, DomMem.IdMem.mem_weak_add; s.
  apply cor_update2 with
  (m := abs_m)
  (l' := match ret_opt with
         | Some ret_lv =>
           SemPrune.SemEval.eval_lv Strong cn ret_lv abs_m
         | None => DomBasic.PowLoc.bot
         end).
  + by apply Habs.
  + destruct l_opt; inversion Hret; subst; [constructor|by constructor].
    apply cor_eval_lv with
    (step:=step) (cid:=cid) (m:=m) (d:=d) (callee:=Some callee)
    ; [|by apply Hl].
    split; by apply Habs.
  + apply PowLoc.fold_3; [|by apply Mem.le_refl, Mem.eq_refl].
    i. eapply Mem.le_trans; [by apply Hx|].
    intro. destruct (Loc.eq_dec k e).
    * eapply Val.le_trans; [|by apply Val.le_refl, Mem.weak_add_prop].
      eapply Val.le_trans; [|by apply Val.join_right].
      apply Val.le_refl, Mem.find_mor; [by auto|by apply Mem.eq_refl].
    * rewrite Mem.weak_add_diff; [by apply Val.le_refl, Val.eq_refl|by auto].
  + destruct ret_opt; [|by apply Val.bot_prop].
    generalize
      (SemPrune.SemEval.eval_lv Strong cn l abs_m) as v
    ; i.
    apply PowLoc.fold_1 with (e:=loc_of_proc callee).
    * apply SMProcLoc.map_1; [by apply DomBasic.loc_of_proc_mor|by auto].
    * i.
      eapply Val.le_trans
      ; [ by apply Val.join_left
        | by apply Val.le_refl, Mem.weak_add_prop, Loc.eq_refl ].
    * i; s. destruct (Loc.eq_dec (loc_of_proc callee) e').
      { eapply Val.le_trans
        ; [by apply Val.join_left|by apply Val.le_refl, Mem.weak_add_prop]. }
      { rewrite Mem.weak_add_diff; by auto. }
    * i. eapply Val.le_trans; [by apply He0|].
      apply Mem.find_mor'; [by apply Loc.eq_refl|].
      apply Mem.weak_add_mor'
      ; [ by auto
        | by apply Val.le_refl, Val.eq_refl
        | by apply Mem.le_refl, Mem.eq_refl ].
} Qed.

Inductive Val_g_list : list DomCon.val_t -> list Val.t -> Prop :=
| Val_g_list_nil : Val_g_list nil nil
| Val_g_list_cons :
    forall v v' vs vs' (Hv : Val_g v v') (Hvs : Val_g_list vs vs'),
      Val_g_list (cons v vs) (cons v' vs').

Lemma cor_eval_list :
  forall step cn cid callee m d m'
     (Hm : Mem_g (cid, callee, m, d) m')
     es vs (Hvs : SemCon.Eval_list step cn cid m es vs)
     vs' (Hvs' : SemEval.eval_list Strong cn es m' = vs'),
    Val_g_list vs vs'.
Proof.
induction 2; i.
- simpl in Hvs'. subst. by constructor.
- simpl in Hvs'. subst. constructor.
  + eapply cor_eval; [by apply Hm|by apply Hv].
  + by apply IHHvs.
Qed.

Lemma bind_arg_monotone :
  forall f x v, Proper (Mem.le ==> Mem.le) (bind_arg Strong f x v).
Proof. unfold bind_arg. i. by apply mem_wupdate_monotone. Qed.

Lemma cor_bind_arg :
  forall step opt_callee d  callee x v v' m m' abs_m abs_m'
     (Hm_g : Mem_g (step, opt_callee, m, d) abs_m)
     (Hv_g : Val_g v v')
     (Hm :
        DomCon.M.add (DomCon.loc_of_lvar step callee x DomCon.Fields.nil) v m
        = m')
     (Habs_m : bind_arg Strong callee x v' abs_m = abs_m'),
    Mem_g (step, opt_callee, m', d) abs_m'.
Proof.
i; subst. unfold bind_arg.
eapply cor_wupdate; [|by apply Hv_g|by apply Hm_g|reflexivity|reflexivity].
by apply PowLoc.singleton_1.
Qed.

Lemma list_fold2_m_monotone A B :
  forall (f: A -> B -> Mem.t -> Mem.t) l vs
     (Hf : forall a b, Proper (Mem.le ==> Mem.le) (f a b)),
    Proper (Mem.le ==> Mem.le) (list_fold2_m f l vs).
Proof.
induction l.
- intros vs m1 m2 Hm. s. destruct vs; by auto.
- intros vs Hf m1 m2 Hm. s. destruct vs; [by auto|].
  apply IHl; [by auto|by apply Hf].
Qed.

Lemma list_fold2_m_ext A B :
  forall (f : A -> B -> Mem.t -> Mem.t) l m m' vs
     (Hm : Mem.le m m') (Hf : forall a b m, Mem.le m (f a b m)),
    Mem.le m (list_fold2_m f l vs m').
Proof.
induction l.
- i; s. destruct vs; by auto.
- i; s. destruct vs; [by auto|].
  unfold MId.bind. apply IHl; [|by auto].
  eapply Mem.le_trans; [by apply Hm|by apply Hf].
Qed.

Lemma bind_args_monotone :
  forall g vs f, Proper (Mem.le ==> Mem.le) (bind_args Strong g vs f).
Proof.
i. intros m1 m2 Hm. unfold bind_args.
destruct (InterCfg.get_args (Global.G.icfg g) f); [|by auto].
apply list_fold2_m_monotone; [by apply bind_arg_monotone|by auto].
Qed.

Lemma bind_args_ext :
  forall g vs e m, Mem.le m (bind_args Strong g vs e m).
Proof.
unfold bind_args. i. destruct (InterCfg.get_args (Global.G.icfg g) e).
- apply list_fold2_m_ext; [by apply Mem.le_refl, Mem.eq_refl|].
  unfold bind_arg. i. by apply mem_wupdate_ext.
- by apply Mem.le_refl, Mem.eq_refl.
Qed.

Lemma cor_bind_args :
  forall g step opt_callee callee callees callee_args vs vs' m m' d
     abs_m abs_m'
     (Hmem_g : Mem_g (step, opt_callee, m, d) abs_m)
     (Hargs_p : Some callee_args = InterCfg.get_args (Global.G.icfg g) callee)
     (Hbind : SemCon.Bind_list step callee callee_args vs m m')
     (Hval_g : Val_g_list vs vs')
     (Hcallee_g : PowProc.mem callee callees = true)
     (Habs_m' : abs_m' = BJProcMem.weak_big_join
                           (bind_args Strong g vs')
                           callees abs_m),
    Mem_g (step, opt_callee, m', d) abs_m'.
Proof.
i; subst.
eapply mem_g_monotone
; [|apply BJProcMem.weak_big_join_1; [by apply Hcallee_g| |]].
- unfold bind_args. rewrite <- Hargs_p.
  generalize vs m m' Hbind vs' Hval_g abs_m Hmem_g Hcallee_g.
  clear vs vs' m m' abs_m Hmem_g Hargs_p Hbind Hval_g Hcallee_g.
  induction 1; i.
  + inversion Hval_g; subst. simpl list_fold2_m. by apply Hmem_g.
  + inversion Hval_g; subst. simpl list_fold2_m. unfold MId.bind. apply IHHbind.
    * by inversion Hval_g.
    * eapply cor_bind_arg
      ; [by apply Hmem_g|by apply Hv|reflexivity|reflexivity].
    * by auto.
- intros f1 f2 Hf. subst. by apply bind_args_monotone.
- unfold MId.le, MId.ret. i. by apply bind_args_ext.
Qed.

Lemma correct_run :
  forall g step cn cmd con_s con_s' abs_m abs_m'
    (Hmem_g : Mem_g con_s abs_m)
    (HCon : SemCon.Run g step cn cmd con_s con_s')
    (HAbs : abs_m' = run_only Strong g cn cmd abs_m),
    Mem_g con_s' abs_m'.
Proof. {
destruct 2.
{ simpl run_only; i; unfold MId.bind in HAbs; subst abs_m'; destruct lv, lh, o
  ; try (eapply cor_update with (l:=l) (g:=g)
         ; [ by apply Loc.eq_refl
           | eapply cor_eval; [by apply Hmem_g|by apply Hv]
           | by apply Hmem_g
           | destruct is_global; inversion Hl; subst; inversion Ho; subst
             ; reflexivity
           | by auto
           | by auto ])
  ; try (eapply cor_wupdate with (l:=l)
         ; [ eapply cor_eval_lv; [by apply Hmem_g|by apply Hl]
           | eapply cor_eval; [by apply Hmem_g|by apply Hv]
           | by apply Hmem_g
           | try (destruct is_global; inversion Hl; subst; inversion Ho; subst)
             ; reflexivity
           | by auto ]).
}
{ simpl run_only. i.
eapply cor_wupdate; [| |by apply Hmem_g|by apply HAbs|symmetry; by apply Hm'].
- eapply cor_eval_lv; [by apply Hmem_g|by apply Hl].
- eapply cor_eval_alloc'; [by apply Ha|by apply Hal|].
  eapply cor_eval; [by apply Hmem_g|by apply Hsz].
}
{ simpl run_only. i.
eapply cor_wupdate; [| | |by apply HAbs|symmetry; by apply Hm''].
- eapply cor_eval_lv; [by apply Hmem_g|by apply Hl].
- eapply cor_eval_string_loc; [by apply Ha|by apply Hbase].
- rewrite Ha in *; eapply cor_eval_string
  ; [by apply Hbase|by apply Hinit|by apply Hmem_g].
}
{ simpl run_only. i.
eapply cor_wupdate
; [| |by apply Hmem_g|by apply HAbs|symmetry; by apply Hm'].
- eapply cor_eval_lv; [by apply Hmem_g|by apply Hl].
- unfold DomCon.val_of_proc, DomAbs.val_of_pow_proc.
  apply Val_g_proc. by apply PowProc.singleton_1.
}
{ simpl run_only. i.
  eapply cor_prune
  ; [by apply Hmem_g|by apply Hv|by apply Hprune|by apply HAbs|by apply Hwf].
}
{ unfold run_only, run, MId.bind, MId.ret. i.
remember (Global.G.is_undef_e f g) as ud; destruct ud; [discriminate|].
rewrite HAbs. clear HAbs Hf_def Hequd.
eapply cor_bind_args
with (callees := powProc_of_val (eval Strong cn f abs_m))
; [|by apply Hargs_p|by apply Hbind| | |reflexivity].
- eapply cor_update_rets;
  [|by apply Hret|by apply Hmem_g|reflexivity].
  exploit cor_eval; [by apply Hmem_g|by apply Hf|].
  i. inversion x0; subst.
  assert (RunOnly.eval = eval) as eval'; [reflexivity|by rewrite eval', <- H].
- eapply cor_eval_list; [by apply Hmem_g|by apply Hargs|reflexivity].
- exploit cor_eval; [by apply Hmem_g|by apply Hf|].
  i. inversion x0; subst. by auto.
}
{ simpl run_only. i.
eapply cor_ret_some with (cid:=cid)
; [|eapply cor_eval; [by apply Hmem_g|by apply Hv]|by apply HAbs|by apply Hm'].
eapply cor_remove_local_variables; [by apply Hmem_g|reflexivity].
}
{ simpl run_only. i. rewrite HAbs.
eapply cor_remove_local_variables; [|by apply Hm'].
eapply weaken_mem_g. by apply Hmem_g.
}
{ simpl run_only. i. by rewrite HAbs. }
{ simpl run_only. i. by rewrite HAbs. }
} Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import fintype paths finfun bigops finset prime binomial groups.
Require Import morphisms perm action automorphism normal zmodp cyclic.
Require Import gfunc pgroups gprod center commutators.
Require Import gseries nilpotent sylow abelian maximal hall.
Require Import BGsection1 BGsection4 BGsection5 BGsection6.
Require Import BGsection7 BGsection8.

(******************************************************************************)
(*   This file covers B & G, section 9, i.e., the proof the Uniqueness        *)
(* Theorem, along with the several variants and auxiliary results. Note that  *)
(* this is the only file to import BGsection8.                                *)
(******************************************************************************)

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

Import GroupScope.

Section Nine.

Variable gT : minSimpleOddGroupType.
Local Notation G := (TheMinSimpleOddGroup gT).
Implicit Types H K L M A B P Q R : {group gT}.
Implicit Types p q r : nat.

(* This is B & G, Theorem 9.1(b) *)
Lemma noncyclic_normed_sub_Uniqueness : forall p M B,
    M \in 'M -> B \in 'E_p(M) -> ~~ cyclic B ->
    \bigcup_(K \in |/|_G(B; p^')) K \subset M ->
  B \in 'U.
Proof.
move=> p M B maxM; case/pElemP=> sBM abelB ncycB snbBp'_M.
have prM := mmax_proper maxM; have solM := mFT_sol prM.
have [pB cBB _] := and3P abelB.
apply/uniq_mmaxP; exists M; symmetry; apply/eqP.
rewrite eqEsubset sub1set inE maxM sBM; apply/subsetPn=> [[H0 MB_H0 neH0M]].
have:= erefl [arg max_(H > H0 | (H \in 'M(B)) && (H :!=: M)) #|H :&: M|`_p].
have [|H] := arg_maxP; first by rewrite MB_H0; rewrite inE in neH0M.
rewrite inE -andbA; case/and3P=> maxH sBH neHM maxHM _ {H0 MB_H0 neH0M}.
have sB_HM: B \subset H :&: M by rewrite subsetI sBH.
have{sB_HM} [R sylR sBR] := Sylow_superset sB_HM pB.
have [] := and3P sylR; rewrite subsetI; case/andP=> sRH sRM pR _.
have [P sylP sRP] := Sylow_superset sRM pR; have [sPM pP _] := and3P sylP.
have sHp'M: 'O_p^'(H) \subset M.
  apply: subset_trans snbBp'_M; rewrite (bigcup_max 'O_p^'(H)%G) // inE -andbA.
  by rewrite subsetT pcore_pgroup (subset_trans sBH) ?bgFunc_norm.
have{snbBp'_M} defMp': <<\bigcup_(K \in |/|_G(P; p^')) K>> = 'O_p^'(M).
  have nMp'M: M \subset 'N('O_p^'(M)) by exact: bgFunc_norm.
  have nMp'P := subset_trans sPM nMp'M.
  apply/eqP; rewrite eqEsubset gen_subG sub_gen ?andbT; last first.
    by rewrite (bigcup_max 'O_p^'(M)%G) // inE -andbA subsetT pcore_pgroup.
  apply/bigcupsP=> K; rewrite inE -andbA; case/and3P=> _ p'K nKP.
  have sKM: K \subset M.
    apply: subset_trans snbBp'_M; rewrite (bigcup_max K) // inE -andbA subsetT.
    by rewrite p'K (subset_trans (subset_trans sBR sRP)).
  rewrite -quotient_sub1 ?(subset_trans sKM) //=; set Mp' := 'O__(M).
  have tiKp: 'O_p(M / Mp') :&: (K / _) = 1.
    exact: coprime_TIg (pnat_coprime (pcore_pgroup _ _) (quotient_pgroup _ _)).
  suffices sKMp: K / _ \subset 'O_p(M / Mp') by rewrite -(setIidPr sKMp) tiKp.
  rewrite -Fitting_eq_pcore ?trivg_pcore_quotient //.
  apply: subset_trans (cent_sub_Fitting (quotient_sol _ solM)).
  rewrite subsetI quotientS //= (Fitting_eq_pcore (trivg_pcore_quotient _ _)).
  rewrite (sameP commG1P trivgP) /= -/Mp' -tiKp subsetI commg_subl commg_subr.
  rewrite (subset_trans (quotientS _ sKM)) ?bgFunc_norm //=.
  apply: subset_trans (pcore_sub_Hall (quotient_pHall nMp'P sylP)) _.
  by rewrite quotient_norms.
have ntR: R :!=: 1.
  by case: eqP sBR ncycB => // ->; move/trivgP->; rewrite cyclic1.
have{defMp'} sNPM: 'N(P) \subset M.
  case: (eqVneq 'O_p^'(M) 1) => [Mp'1 | ntMp'].
    have nsZLP: 'Z('L(P)) <| M.
      apply: Puig_center_normal Mp'1 => //; exact: mFT_odd.
    rewrite -(mmax_normal maxM nsZLP).
      exact: char_norm_trans (center_Puig_char P) _.
    apply: contra ntR; move/eqP; move/(trivg_center_Puig_pgroup pP)=> P1.
    by rewrite -subG1 -P1.
  rewrite -(mmax_normal maxM (pcore_normal _ _) ntMp') /= -defMp' norms_gen //.
  apply/subsetP=> x nPx; rewrite inE sub_conjg; apply/bigcupsP=> K.
  rewrite inE -andbA -sub_conjg; case/and3P=> _ p'K nKP.
  rewrite (bigcup_max (K :^ x)%G) // inE -andbA subsetT pgroupJ p'K /=.
  by rewrite -(normP nPx) normJ conjSg.
have sylPG := mmax_sigma_Sylow maxM sylP sNPM.
have{sNPM} [sNRM sylRH]: 'N(R) \subset M /\ p.-Sylow(H) R.
  have:= sRP; rewrite subEproper; case/predU1P=> [defR | ltRP].
    by split; rewrite defR // (pHall_subl _ (subsetT _)) // -defR.
  have [|D]:= @mmax_exists _ 'N(R).
    by rewrite mFT_norm_proper // (mFT_pgroup_proper pR).
  case/setIdP=> maxD sND; move/implyP: (maxHM D); rewrite inE {}maxD /= leqNgt.
  rewrite (subset_trans (subset_trans sBR (normG R))) //= implybN.
  have ltRN := nilpotent_proper_norm (pgroup_nil pP) ltRP.
  rewrite -(card_Hall sylR) (leq_trans (proper_card ltRN)) /=; last first.
    rewrite setIC -(part_pnat_id (pgroupS (subsetIr _ _) pP)) dvdn_leq //.
    by rewrite partn_dvd ?cardG_gt0 // cardSg // setISS.
  move/eqP=> defD; rewrite defD in sND; split; rewrite // -Sylow_subnorm.
  by rewrite (pHall_subl _ _ sylR) ?setIS // subsetI sRH normG.
have sFH_RHp': 'F(H) \subset R * 'O_p^'(H).
  case/dprodP: (nilpotent_pcoreC p (Fitting_nil H)) => _ /= <- _ _.
  by rewrite p_core_Fitting mulgSS ?(pcore_sub_Hall sylRH) ?pcore_Fitting.
have sFH_M: 'F(H) \subset M by rewrite (subset_trans sFH_RHp') ?mul_subG.
case/(H :=P: M): neHM; case: (ltnP 2 'r('F(H))) => [le3r | ge2r].
  have [D uF_D] := uniq_mmaxP (Fitting_Uniqueness maxH le3r).
  by rewrite (eq_uniq_mmax uF_D maxM) // (eq_uniq_mmax uF_D maxH) ?Fitting_sub.
have nHp'R: R \subset 'N('O_p^'(H)) by rewrite (subset_trans sRH) ?bgFunc_norm.
have nsRHp'H: R <*> 'O_p^'(H) <| H.
  rewrite sub_der1_normal //= ?mulgen_subG ?sRH ?pcore_sub //.
  rewrite norm_mulgenEl // (subset_trans _ sFH_RHp') //.
  rewrite rank2_der1_sub_Fitting ?mFT_odd //.
  by rewrite mFT_sol ?mmax_proper.
have sylR_RHp': p.-Sylow(R <*> 'O_p^'(H)) R.
  by apply: (pHall_subl _ _ sylRH); rewrite ?mulgen_subl // normal_sub.
rewrite (mmax_max maxH) // -(Frattini_arg nsRHp'H sylR_RHp') /=.
by rewrite mulG_subG mulgen_subG sRM sHp'M /= setIC subIset ?sNRM.
Qed.

(* This is B & G, Theorem 9.1(a) *)
Lemma noncyclic_cent1_sub_Uniqueness : forall p M B,
    M \in 'M -> B \in 'E_p(M) -> ~~ cyclic B ->
    \bigcup_(b \in B^#) 'C[b] \subset M ->
  B \in 'U.
Proof.
move=> p M B maxM EpB ncycB sCB_M.
apply: (noncyclic_normed_sub_Uniqueness maxM EpB) => //.
apply/bigcupsP=> K; rewrite inE -andbA; case/and3P=> _ p'K nKB.
case/pElemP: EpB => _; case/and3P=> pB cBB _.
rewrite (coprime_abelian_gen_cent1 cBB ncycB nKB); last first.
  by rewrite coprime_sym (pnat_coprime pB).
rewrite bigprodGE gen_subG (subset_trans _ sCB_M) //.
by apply/bigcupsP=> b Bb; rewrite (bigcup_max b) // subsetIr.
Qed.

(* This is B & G, Corollary 9.2 *)
Lemma cent_uniq_Uniqueness : forall K L,
  L \in 'U -> K \subset 'C(L) -> 'r(K) >= 2 -> K \in 'U.
Proof.
move=> K L uL; have ntL := uniq_mmax_neq1 uL.
case/uniq_mmaxP: uL => H uL_H cLK; have [maxH sLH] := mem_uniq_mmax uL_H.
case/rank_geP=> B; case/nElemP=> p; case/pnElemP=> sBK abelB; move/eqP=> dimB2.
have scBH: \bigcup_(b \in B^#) 'C[b] \subset H.
  apply/bigcupsP=> b; case/setIdP; rewrite inE -cycle_eq1 => ntb Bb.
  apply: (sub_uniq_mmax uL_H); last by rewrite /= -cent_cycle mFT_cent_proper.
  by rewrite sub_cent1 (subsetP cLK) ?(subsetP sBK).
have EpB: B \in 'E_p(H).
  apply/pElemP; split=> //; rewrite -(setD1K (group1 B)) subUset sub1G /=.
  apply/subsetP=> b Bb; apply: (subsetP scBH).
  by apply/bigcupP; exists b => //; exact/cent1P.
have prK: K \proper G by rewrite (sub_proper_trans cLK) ?mFT_cent_proper.
apply: uniq_mmaxS prK (noncyclic_cent1_sub_Uniqueness _ EpB _ _) => //.
by rewrite (abelem_cyclic abelB) (eqP dimB2).
Qed.

(* This is B & G, Corollary 9.3 *)
Lemma any_cent_rank3_Uniquness : forall p A B,
    abelian A -> p.-group A -> 'r(A) >= 3 -> A \in 'U ->
    p.-group B -> ~~ cyclic B -> 'r_p('C(B)) >= 3 ->
  B \in 'U.
Proof.
move=> p A B cAA pA rA3 uA pB ncycB; case/p_rank_geP=> C /= Ep3C.
have [cBC abelC dimC3] := pnElemP Ep3C; have [pC cCC _] := and3P abelC.
have [P /= sylP sCP] := Sylow_superset (subsetT _) pC.
wlog sAP: A pA cAA rA3 uA / A \subset P.
  move=> IHA; have [x _] := Sylow_Jsub sylP (subsetT _) pA.
  by apply: IHA; rewrite ?pgroupJ ?abelianJ ?rankJ ?uniq_mmaxJ.
have ncycC: ~~ cyclic C by rewrite (abelem_cyclic abelC) dimC3.
have ncycP: ~~ cyclic P := contra (cyclicS sCP) ncycC.
have [D] := ex_odd_normal_abelem2 (pHall_pgroup sylP) (mFT_odd _) ncycP.
case/andP=> sDP nDP; case/pnElemP=> _ abelD dimD2.
have CADge2: 'r('C_A(D)) >= 2.
  move: rA3; rewrite (rank_pgroup pA); case/p_rank_geP=> E.
  case/pnElemP=> sEA abelE dimE3; apply: leq_trans (rankS (setSI _ sEA)).
  rewrite (rank_abelem (abelemS (subsetIl _ _) abelE)) -(leq_add2r 1) addn1.
  rewrite -dimE3 -leq_sub_add -logn_div ?cardSg ?divgS ?subsetIl //.
  rewrite logn_quotient_cent_abelem ?dimD2 //.
  exact: subset_trans (subset_trans sAP nDP).
have CCDge2: 'r('C_C(D)) >= 2.
  rewrite (rank_abelem (abelemS (subsetIl _ _) abelC)) -(leq_add2r 1) addn1.
  rewrite -dimC3 -leq_sub_add -logn_div ?cardSg ?divgS ?subsetIl //.
  by rewrite logn_quotient_cent_abelem ?dimD2 //; exact: subset_trans nDP.
rewrite centsC in cBC; apply: cent_uniq_Uniqueness cBC _; last first.
  by rewrite ltnNge (rank_pgroup pB) -odd_pgroup_rank1_cyclic ?mFT_odd.
have cCDC: C \subset 'C('C_C(D))
  by rewrite (sub_abelian_cent (abelem_abelian abelC)) ?subsetIl.
apply: cent_uniq_Uniqueness cCDC _; last by rewrite (rank_abelem abelC) dimC3.
apply: cent_uniq_Uniqueness (subsetIr _ _) CCDge2.
have cDCA: D \subset 'C('C_A(D)) by rewrite centsC subsetIr.
apply: cent_uniq_Uniqueness cDCA _; last by rewrite (rank_abelem abelD) dimD2.
by apply: cent_uniq_Uniqueness uA _ CADge2; rewrite subIset // -abelianE cAA.
Qed.

(* This is B & G, Lemma 9.4 *)
Lemma any_rank3_Fitting_Uniqueness : forall p M P,
  M \in 'M -> 'r_p('F(M)) >= 3 -> p.-group P -> 'r(P) >= 3 -> P \in 'U.
Proof.
move=> p M P maxM FMge3 pP; rewrite (rank_pgroup pP).
case/p_rank_geP=> B; case/pnElemP=> sBP abelB dimB3.
have [pB cBB _] := and3P abelB.
have CBge3: 'r_p('C(B)) >= 3 by rewrite -dimB3 -(p_rank_abelem abelB) p_rankS.
have ncycB: ~~ cyclic B by rewrite (abelem_cyclic abelB) dimB3.
apply: {P pP}uniq_mmaxS sBP (mFT_pgroup_proper pP) _.
case/orP: (orbN (p.-group 'F(M))) => [pFM | pFM'].
  have [P sylP sFP] := Sylow_superset (Fitting_sub _) pFM.
  have pP := pHall_pgroup sylP.
  have [|A SCN_A]:= p_rank_3_SCN pP (mFT_odd _).
    by rewrite (rank_pgroup pP) (leq_trans FMge3) ?p_rankS.
  have [_ _ uA] := SCN_Fitting_Uniqueness maxM pFM sylP FMge3 SCN_A.
  case/setIdP: SCN_A => SCN_A dimA3; case: (setIdP SCN_A); case/andP=> sAP _ _.
  have cAA := SCN_abelian SCN_A; have pA := pgroupS sAP pP.
  exact: (any_cent_rank3_Uniquness cAA pA).
have [A0 EpA0 A0ge3] := p_rank_pmaxElem_exists FMge3.
have uA := non_pcore_Fitting_Uniqueness maxM pFM' EpA0 A0ge3.
case/pmaxElemP: EpA0; case/setIdP=> _ abelA0 _.
have [pA0 cA0A0 _] := and3P abelA0; rewrite -rank_pgroup // in A0ge3.
rewrite (any_cent_rank3_Uniquness _ pA0) // (cent_uniq_Uniqueness uA) 1?ltnW //.
by rewrite centsC subsetIr.
Qed.

(* This is B & G, Lemma 9.5 *)
Lemma SCN_3_Uniqueness : forall p A, A \in 'SCN_3[p] -> A \in 'U.
Proof.
move=> p A SCN3_A; apply/idPn=> uA'.
have [P]:= bigcupP SCN3_A; rewrite inE => sylP; case/setIdP=> SCN_A Age3.
have [nsAP _] := setIdP SCN_A; have [sAP nAP] := andP nsAP.
have cAA := SCN_abelian SCN_A.
have pP := pHall_pgroup sylP; have pA := pgroupS sAP pP.
have ntA: A :!=: 1 by rewrite -rank_gt0 -(subnKC Age3).
have [p_pr _ [e oA]] := pgroup_pdiv pA ntA.
have{e oA} def_piA: \pi(#|A|) =i (p : nat_pred).
  by rewrite oA pi_of_exp //; exact: pi_of_prime.
have FmCAp_le2: forall M, M \in 'M('C(A)) -> 'r_p('F(M)) <= 2.
  move=> M; case/setIdP=> maxM cCAM; rewrite leqNgt; apply: contra uA' => Fge3.
  exact: (any_rank3_Fitting_Uniqueness maxM Fge3).
have sNP_mCA: forall M, M \in 'M('C(A)) -> 'N(P) \subset M.
  move=> M mCA_M; have Fple2 := FmCAp_le2 M mCA_M.
  case/setIdP: mCA_M => maxM sCAM; set F := 'F(M) in Fple2.
  have sNR_M: forall R, A \subset R -> R \subset P :&: M -> 'N(R) \subset M.
    move=> R sAR; rewrite subsetI; case/andP=> sRP sRM.
    pose q := if 'r(F) <= 2 then max_pdiv #|M| else s2val (rank_witness 'F(M)).
    have nMqR: R \subset 'N('O_q(M)) := subset_trans sRM (bgFunc_norm _ _).
    have{nMqR} [Q maxQ sMqQ] := max_normed_exists (pcore_pgroup _ _) nMqR.
    have [p'q sNQ_M]: q != p /\ 'N(Q) \subset M.
      case/mem_max_normed: maxQ sMqQ; rewrite {}/q.
      case: leqP => [Fle2 | ]; last first.
        case: rank_witness => q /= q_pr -> Fge3 qQ _ sMqQ; split=> //.
          by case: eqP Fge3 => // ->; rewrite ltnNge Fple2.
        have Mqge3: 'r('O_q(M)) >= 3.
          rewrite (rank_pgroup (pcore_pgroup _ _)) /= -p_core_Fitting.
          by rewrite -(p_rank_Sylow (nilpotent_pcore_Hall _ (Fitting_nil _))).
        have uMq: 'O_q(M)%G \in 'U.
          exact: (any_rank3_Fitting_Uniqueness _ Fge3 (pcore_pgroup _ _)).
        have uMqM := def_uniq_mmax uMq maxM (pcore_sub _ _).
        apply: sub_uniq_mmax (subset_trans sMqQ (normG _)) _ => //.
        apply: mFT_norm_proper (mFT_pgroup_proper qQ).
        by rewrite -rank_gt0 2?ltnW ?(leq_trans Mqge3) ?rankS.
      set q := max_pdiv _ => qQ _ sMqQ.
      have sylMq: q.-Sylow(M) 'O_q(M).
        by rewrite [pHall _ _ _]rank2_pcore_max_Sylow ?mFT_odd ?mmax_sol.
      have defNMq: 'N('O_q(M)) = M.
        rewrite (mmax_normal maxM (pcore_normal _ _)) // -rank_gt0.
        rewrite (rank_pgroup (pcore_pgroup _ _)) -(p_rank_Sylow sylMq).
        by rewrite p_rank_gt0 pi_max_pdiv cardG_gt1 mmax_neq1.
      have sylMqG: q.-Sylow(G) 'O_q(M).
        by rewrite (mmax_sigma_Sylow maxM) ?defNMq.
      rewrite (hall_maximal sylMqG (subsetT _) qQ) // defNMq; split=> //.
      have: 'r_p(G) > 2.
        by rewrite (leq_trans Age3) // (rank_pgroup pA) p_rankS ?subsetT.
      apply: contraL; move/eqP <-; rewrite (p_rank_Sylow sylMqG).
      rewrite -leqNgt -(rank_pgroup (pcore_pgroup _ _)) /=.
      by rewrite -p_core_Fitting (leq_trans _ Fle2) // rankS ?pcore_sub.
    have trCRq': [transitive 'O_p^'('C(R)), on |/|*(R; q) | 'JG].
      have cstrA: normed_constrained A.
        by apply: SCN_normed_constrained sylP _; rewrite inE SCN_A ltnW.
      have pR: p.-group R := pgroupS sRP pP.
      have snAR: A <|<| R by rewrite (nilpotent_subnormal (pgroup_nil pR)).
      have A'q: q \notin \pi(#|A|) by rewrite def_piA.
      rewrite -(eq_pgroup _ def_piA) in pR.
      have [|? []] := normed_trans_superset cstrA A'q snAR pR.
        by rewrite (eq_pcore _ (eq_negn def_piA)) Thompson_transitivity.
      by rewrite (eq_pcore _ (eq_negn def_piA)).
    apply/subsetP=> x nRx; have maxQx: (Q :^ x)%G \in |/|*(R; q).
      by rewrite (actsP (norm_acts_max_norm _ _)).
    have [y cRy [defQx]] := atransP2 trCRq' maxQ maxQx.
    rewrite -(mulgKV y x) groupMr.
      by rewrite (subsetP sNQ_M) // inE conjsgM defQx conjsgK.
    apply: subsetP cRy; apply: (subset_trans (pcore_sub _ _)).
    exact: subset_trans (centS _) sCAM.
  have sNA_M: 'N(A) \subset M.
    by rewrite sNR_M // subsetI sAP (subset_trans cAA).
  by rewrite sNR_M // subsetI subxx (subset_trans nAP).
pose P0 := [~: P, 'N(P)].
have ntP0: P0 != 1.
  apply/eqP; move/commG1P; rewrite centsC -(setIidPr (subsetT 'N(P))) /=.
  move/(Burnside_normal_complement sylP); case/sdprodP=> _ /= defG nGp'P _.
  have prGp': 'O_p^'(G) \proper G.
    rewrite properT; apply: contra ntA; move/eqP=> defG'.
    rewrite -(setIidPl (subsetT A)) /= -defG'.
    by rewrite coprime_TIg // (pnat_coprime pA (pcore_pgroup _ _)).
  have ntGp': 'O_p^'(G) != 1.
    apply: contraL (mFT_pgroup_proper pP).
    by rewrite -{2}defG; move/eqP->; rewrite mul1g proper_irrefl.
  by have:= mFT_norm_proper ntGp' prGp'; rewrite properE bgFunc_norm andbF.
have sP0P: P0 \subset P by rewrite commg_subl.
have pP0: p.-group P0 := pgroupS sP0P pP.
have uNP0_mCA: forall M, M \in 'M('C(A)) -> 'M('N(P0)) = [set M].
  move=> M mCA_M; have [maxM sCAM] := setIdP mCA_M.
  have sAM := subset_trans cAA sCAM.
  pose F := 'F(M); pose D := 'O_p^'(F).
  have cDP0: P0 \subset 'C(D).
    have sA1A := Ohm_sub 1 A.
    have nDA1: 'Ohm_1(A) \subset 'N(D).
      apply: subset_trans sA1A (subset_trans sAM (char_norm _)).
      exact: char_trans (pcore_char _ _) (Fitting_char _).
    have abelA1: p.-abelem 'Ohm_1(A) by rewrite Ohm1_abelem.
    have dimA1ge3: logn p #|'Ohm_1(A)| >= 3.
      by rewrite -(rank_abelem abelA1) rank_Ohm1.
    have coDA1: coprime #|D| #|'Ohm_1(A)|.
      rewrite coprime_sym (coprimeSg sA1A) //.
      exact: pnat_coprime pA (pcore_pgroup _ _).
    rewrite centsC -[D]/(gval _).
    rewrite (coprime_abelian_gen_cent (abelianS sA1A cAA) nDA1) //=.
    rewrite bigprodGE gen_subG /= -/D; apply/bigcupsP=> B.
    case/and3P=> cycqB sBA1 nBA1; have abelB := abelemS sBA1 abelA1.
    have sBA := subset_trans sBA1 sA1A.
    have{cycqB} ncycB: ~~ cyclic B.
      move: cycqB; rewrite (abelem_cyclic (quotient_abelem _ abelA1)).
      rewrite card_quotient // -divgS // logn_div ?cardSg // leq_sub_add addn1.
      move/(leq_trans dimA1ge3); rewrite ltnS ltnNge.
      by rewrite -(abelem_cyclic abelB).
    have [x Bx sCxM']: exists2 x, x \in B^# & ~~ ('C[x] \subset M).
      suff: ~~ (\bigcup_(x \in B^#) 'C[x] \subset M).
        case/subsetPn=> y; case/bigcupP=> x Bx cxy My'.
        by exists x; last by apply/subsetPn; exists y.
      have EpB: B \in 'E_p(M) by rewrite inE (subset_trans sBA sAM).
      apply: contra uA' => sCB_M.
      apply: uniq_mmaxS sBA (mFT_pgroup_proper pA) _.
      exact: noncyclic_cent1_sub_Uniqueness maxM EpB ncycB sCB_M.
    case/setD1P: Bx; rewrite -cycle_eq1 => ntx Bx.
    have{ntx} [L] := mmax_exists (mFT_cent_proper ntx).
    case/setIdP=> maxL; rewrite /= cent_cycle => sCxL.
    have{sCxM'} [neLM] : L != M by case: eqP sCxL sCxM' => // -> ->.
    have sNP_LM: 'N(P) \subset L :&: M.
      rewrite subsetI !sNP_mCA // inE maxL (subset_trans _ sCxL) // -cent_set1.
      by rewrite centS // sub1set (subsetP sBA).
    have sP0_LM': P0 \subset (L :&: M)^`(1).
      exact: subset_trans (commSg _ (normG _)) (dergS 1 sNP_LM).
    have DLle2: 'r(D :&: L) <= 2.
      apply: contraR neLM; rewrite -ltnNge -in_set1; case/rank_geP=> E.
      case/nElemP=> q /=; do 2!case/setIdP; rewrite subsetI /= -/D.
      case/andP=> sED sEL abelE; rewrite -p_rank_abelem //; move/eqP => dimE3.
      have sEF: E \subset F := subset_trans sED (pcore_sub _ _).
      have Fge3: 'r_q(F) >= 3 by rewrite -dimE3 p_rankS.
      have qE := abelem_pgroup abelE.
      have uE: E \in 'U.
        apply: any_rank3_Fitting_Uniqueness Fge3 _ _ => //.
        by rewrite (rank_pgroup qE) dimE3.
      rewrite -(def_uniq_mmax uE maxM (subset_trans sEF (Fitting_sub _))).
      by rewrite inE maxL.
    have cDL_P0: P0 \subset 'C(D :&: L).
      have nsDM: D <| M:= char_normal_trans (pcore_char _ _) (Fitting_normal M).
      have{nsDM} [sDM nDM] := andP nsDM.
      have sDL:  D :&: L \subset L :&: M by rewrite setIC setIS.
      have nsDL: D :&: L <| L :&: M by rewrite /normal sDL setIC normsIG.
      have [s ch_s last_s_DL] := chief_series_exists nsDL.
      have solLM := solvableS (subsetIl L M) (mmax_sol maxL).
      have solDL := solvableS sDL solLM.
      apply: (stable_series_cent (congr_group last_s_DL)) => //; first 1 last.
        rewrite coprime_sym (coprimegS (subsetIl _ _)) //.
        exact: pnat_coprime (pcore_pgroup _ _).
      have{last_s_DL}: last 1%G s \subset D :&: L by rewrite last_s_DL.
      rewrite /= -/P0; elim/last_ind: s ch_s => //= s U IHs.
      rewrite !path_rcons last_rcons /=; set V := last _ s.
      case/andP=> ch_s chUV sUDL; have [maxU _ nU_LM] := and3P chUV.
      case/andP: {maxU}(maxgroupp maxU); case/andP=> sVU _ nV_LM.
      have nVU := subset_trans sUDL (subset_trans sDL nV_LM).
      rewrite IHs ?(subset_trans sVU) // /stable_factor /normal sVU nVU !andbT.
      have nVP0 := subset_trans (subset_trans sP0_LM' (der_sub _ _)) nV_LM.
      rewrite commGC -sub_astabQR // (subset_trans sP0_LM') //.
      have: is_abelem (U / V) := sol_chief_abelem solLM chUV.
      case/is_abelemP=> q _; case/andP=> qUV _.
      apply: rank2_cent_chief qUV sUDL; rewrite ?mFT_odd //.
      exact: leq_trans (p_rank_le_rank _ _) DLle2.
    rewrite centsC (subset_trans cDL_P0) ?centS ?setIS //.
    by rewrite (subset_trans _ sCxL) // -cent_set1 centS ?sub1set.
  case: (ltnP 2 'r(F)) => [| Fle2].
    have [q q_pr -> /= Fq3] := rank_witness [group of F].
    have Mq3: 'r('O_q(M)) >= 3.
      rewrite (rank_pgroup (pcore_pgroup _ _)) /= -p_core_Fitting.
      by rewrite -(p_rank_Sylow (nilpotent_pcore_Hall _ (Fitting_nil _))).
    have uMq: 'O_q(M)%G \in 'U.
      exact: any_rank3_Fitting_Uniqueness Fq3 (pcore_pgroup _ _) Mq3.
    apply: def_uniq_mmaxS (def_uniq_mmax uMq maxM (pcore_sub q _)); last first.
      exact: mFT_norm_proper ntP0 (mFT_pgroup_proper pP0).
    rewrite cents_norm // centsC (subset_trans cDP0) ?centS //=.
    rewrite -p_core_Fitting sub_pcore // => q1; move/eqnP=> ->{q1}.
    by apply/eqnP=> def_q; rewrite ltnNge def_q FmCAp_le2 in Fq3.
  rewrite (mmax_normal maxM) ?mmax_sup_id //.
  have sNP_M := sNP_mCA M mCA_M; have sPM := subset_trans (normG P) sNP_M.
  rewrite /normal comm_subG //= -/P0.
  have nFP: P \subset 'N(F) by rewrite (subset_trans _ (bgFunc_norm _ _)).
  have <-: F <*> P * 'N_M(P) = M.
    apply: Frattini_arg (pHall_subl (mulgen_subr _ _) (subsetT _) sylP).
    rewrite -(quotientGK (Fitting_normal M)) /= norm_mulgenEr //= -/F.
    rewrite -quotientK // cosetpre_normal -sub_abelian_normal ?quotientS //.
    by rewrite sub_der1_abelian ?rank2_der1_sub_Fitting ?mFT_odd ?mmax_sol.
  case/dprodP: (nilpotent_pcoreC p (Fitting_nil M)) => _ /= defF cDFp _.
  rewrite norm_mulgenEr //= -{}defF (centC cDFp) -/D p_core_Fitting /= -/F.
  rewrite -!mulgA mul_subG //; first by rewrite cents_norm // centsC.
  rewrite mulgA [_ * P]mulSGid ?pcore_sub_Hall 1?(pHall_subl _ (subsetT _)) //.
  by rewrite mulSGid ?subsetI ?sPM ?normG // subIset // orbC normsRr.
have [M mCA_M] := mmax_exists (mFT_cent_proper ntA).
have [maxM sCAM] := setIdP mCA_M; have sAM := subset_trans cAA sCAM.
have abelA1: p.-abelem 'Ohm_1(A) by rewrite Ohm1_abelem.
have sA1A := Ohm_sub 1 A.
have EpA1: 'Ohm_1(A)%G \in 'E_p(M) by rewrite inE (subset_trans sA1A).
have ncycA1: ~~ cyclic 'Ohm_1(A).
  rewrite (abelem_cyclic abelA1) -(rank_abelem abelA1) rank_Ohm1.
  by rewrite -(subnKC Age3).
have [x A1x sCxM']: exists2 x, x \in 'Ohm_1(A)^# & ~~ ('C[x] \subset M).
  suff: ~~ (\bigcup_(x \in 'Ohm_1(A)^#) 'C[x] \subset M).
    case/subsetPn=> y; case/bigcupP=> x A1 cxy My'.
    by exists x; last by apply/subsetPn; exists y.
  apply: contra uA' => sCA1_M.
  apply: uniq_mmaxS sA1A (mFT_pgroup_proper pA) _.
  exact: noncyclic_cent1_sub_Uniqueness maxM EpA1 ncycA1 sCA1_M.
case/setD1P: A1x; rewrite -cycle_eq1 => ntx A1x.
have: 'C[x] \proper G by rewrite -cent_cycle mFT_cent_proper.
case/mmax_exists=> L; case/setIdP=> maxL sCxL.
have mCA_L: L \in 'M('C(A)).
  rewrite inE maxL (subset_trans _ sCxL) //= -cent_set1 centS // sub1set.
  by rewrite (subsetP sA1A).
case/negP: sCxM'; move/uNP0_mCA: mCA_L; rewrite (uNP0_mCA M) //.
by move/set1_inj->.
Qed.

(* This is B & G, Theorem 9.6, first assertion; note that B & G omit the      *)
(* (required!) condition K \proper G.                                         *)
Theorem rank3_Uniqueness : forall K, K \proper G -> 'r(K) >= 3 -> K \in 'U.
Proof.
move=> K prK; case/rank_geP=> B; case/nElemP=> p.
case/pnElemP=> sBK abelB dimB3; have [pB cBB _] := and3P abelB.
suffices: B \in 'U by exact: uniq_mmaxS.
have [P sylP sBP] := Sylow_superset (subsetT _) pB.
have pP := pHall_pgroup sylP.
have [|A SCN3_A] :=  p_rank_3_SCN pP (mFT_odd _).
  by rewrite -dimB3 -(rank_abelem abelB) rankS.
have [SCN_A Age3] := setIdP SCN3_A.
have: A \in 'SCN_3[p] by apply/bigcupP; exists P; rewrite // inE.
move/SCN_3_Uniqueness=> uA; have cAA := SCN_abelian SCN_A.
case/setIdP: SCN_A; case/andP=> sAP _ _; have pA := pgroupS sAP pP.
apply: any_cent_rank3_Uniquness uA pB _ _ => //.
  by rewrite (abelem_cyclic abelB) dimB3.
by rewrite -dimB3 -p_rank_abelem ?p_rankS.
Qed.

(* This is B & G, Theorem 9.6, second assertion *)
Theorem cent_rank3_Uniqueness : forall K,
  'r(K) >= 2 -> 'r('C(K)) >= 3 -> K \in 'U.
Proof.
move=> K Kge2 CKge3; have cCK_K: K \subset 'C('C(K)) by rewrite centsC.
apply: cent_uniq_Uniqueness cCK_K _ => //.
apply: rank3_Uniqueness (mFT_cent_proper _) CKge3.
by rewrite -rank_gt0 ltnW.
Qed.

(* This is B & G, Theorem 9.6, final observation *)
Theorem nonmaxElem2_Uniqueness : forall p A,
  A \in 'E_p^2(G) :\: 'E*_p(G) -> A \in 'U.
Proof.
move=> p A; case/setDP=> EpA nmaxA; have [_ abelA dimA2]:= pnElemP EpA.
case/setIdP: EpA => EpA _; have [pA _] := andP abelA.
apply: cent_rank3_Uniqueness; first by rewrite -dimA2 -(rank_abelem abelA).
have [E maxE sAE] := pmaxElem_exists EpA.
have [] := pmaxElemP maxE; case/pElemP=> _ abelE _.
have [pE cEE _] := and3P abelE.
have: 'r(E) <= 'r('C(A)) by rewrite rankS // (subset_trans cEE) ?centS.
apply: leq_trans; rewrite (rank_abelem abelE) -dimA2 properG_ltn_log //.
by rewrite properEneq; case: eqP maxE nmaxA => //; move/group_inj=> -> ->.
Qed.

End Nine.