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

(**********************************************************************)
(*                Typed LambdaFactor Calculus                         *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        LamSF_Confluence.v                          *)
(*                                                                    *)
(* adapted from Confluence.v for Lambda Calculus                      *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import Beta_Reduction.
Require Import LamSF_Redexes.
Require Import LamSF_Marks.
Require Import LamSF_Substitution.
Require Import LamSF_Residuals.
Require Import LamSF_Simulation.
Require Import LamSF_Cube.

(* Confluence *)

Definition confluence (A : Set) (R : A -> A -> Prop) :=
  forall x y : A,
  R x y -> forall z : A, R x z -> exists u : A, R y u /\ R z u.

(***************************************)
(* Parallel moves lemma and confluence *)
(***************************************)

Lemma parallel_moves : confluence lamSF par_red1.
Proof.

red in |- *; intros M N R1 P R2.
elim (simulation M N); trivial with arith.
elim (simulation M P); trivial with arith.
intros V RV U RU.
elim (paving U V (mark M) (mark N) (mark P)); trivial with arith.
intros UV C1; elim C1.
intros VU C2; elim C2.
intros UVW C3; elim C3; intros P1 P2.
exists (unmark UVW); split.
rewrite (inverse N).
apply completeness with VU; trivial with arith.
rewrite (inverse P).
apply completeness with UV; trivial with arith.

Qed.

Lemma confluence_parallel_reduction : confluence lamSF par_red.
Proof.
red.
eapply2 diamond_tiling.
eapply2 parallel_moves.
Qed.


Require Export Qual.metalib.
Require Export Qual.tactics.
Require Export Qual.labels.

Set Implicit Arguments.
Open Scope grade_scope.

(* Helps with specializing the IH for weakening proofs. *)
Local Ltac weakening_ih :=
    match goal with
    | [ H3 : forall P5 P4, [(?x, ?psi0)] ++ ?P2 ++ ?P1 = P4 ++ P5 -> _ |- _ ]
     => specialize (H3 P1 (x ~ psi0 ++ P2) ltac:(eauto) ltac:(simpl_env;auto)); simpl_env in H3
     end.

Lemma CGrade_Grade_weakening_middle : (forall P psi psi0 b,
    CGrade P psi psi0 b -> forall P1 P2, P = P2 ++ P1 -> forall P3,
     uniq (P2 ++ P3 ++ P1)
    -> CGrade (P2 ++ P3 ++ P1) psi psi0 b) /\ (forall P psi b,
    Grade P psi b -> forall P1 P2, P = P2 ++ P1 -> forall P3,
     uniq (P2 ++ P3 ++ P1)
    -> Grade (P2 ++ P3 ++ P1) psi b).
Proof.
  eapply CGrade_Grade_mutual.
  all: intros; eauto.
  all: try solve [subst; eapply G_Var; eauto].

  all: try solve
        [subst; fresh_apply_Grade x; eauto;
         repeat spec x;
         weakening_ih;
         eauto].
Qed.

Lemma Grade_weakening_middle : forall P1 P2 P3 psi b,
    Grade (P2 ++ P1) psi b -> uniq (P2 ++ P3 ++ P1)
    -> Grade (P2 ++ P3 ++ P1) psi b.
Proof.
  intros.   eapply CGrade_Grade_weakening_middle; eauto. Qed.

Lemma Grade_weakening : forall P2 P1 psi b,
    Grade P1 psi b
    -> uniq (P2 ++ P1)
    -> Grade (P2 ++ P1) psi b.
Proof.
  intros.
  eapply CGrade_Grade_weakening_middle with (P2 := nil); simpl_env; eauto.
Qed.

Ltac geq_weakening_ih :=
    match goal with
    | [ H3 : forall P3 P4, [(?x, ?psi0)] ++ ?P2 ++ ?P1 = P4 ++ P3 -> _ |- _ ]
     => specialize (H3 P1 ([(x,psi0)] ++ P2) ltac:(eauto) _ ltac:(simpl_env;eauto)); simpl_env in H3
     end.

Lemma CEq_GEq_weakening :
  (forall P phi phi0 a b,
  CEq P phi phi0 a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> CEq (P2 ++ P3 ++ P1) phi phi0 a b) /\
  (forall P phi a b,
  GEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> GEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  eapply CEq_GEq_mutual.
  all: intros; eauto.
  all: try solve [subst; eapply GEq_Var; eauto].
  all: try solve [subst;
    fresh_apply_GEq x; eauto;
    repeat spec x;
    geq_weakening_ih;
    eauto].
Qed.

Lemma GEq_weakening_middle :  (forall P phi a b,
  GEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> GEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  destruct CEq_GEq_weakening.
  auto.
Qed.

Lemma GEq_weakening : forall P phi b1 b2,
  GEq P phi b1 b2 -> forall P2, uniq (P2 ++ P) -> GEq (P2 ++ P) phi b1 b2.
Proof.
  destruct CEq_GEq_weakening.
  intros.
  eapply H0 with (P2 := nil); eauto.
Qed.

Lemma CDefEq_DefEq_weakening_middle :
  (forall P phi psi a b,
  CDefEq P phi psi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> CDefEq (P2 ++ P3 ++ P1) phi psi a b) /\
  (forall P phi a b,
  DefEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> DefEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  apply CDefEq_DefEq_mutual.
  all: intros; subst; eauto 3 using Grade_weakening_middle.
  all: try solve [subst;
    fresh_apply_DefEq x; auto;
    repeat spec x;
    geq_weakening_ih;
    eauto].
  all: try solve [
             pick fresh x and apply Eq_SubstIrrel; eauto 2;
             repeat spec x;
             geq_weakening_ih;
             eauto].

  all: eauto 4 using Grade_weakening_middle.
  all: try (eapply Eq_Case; eauto 3 using Grade_weakening_middle).
Qed.

Lemma DefEq_weakening_middle :
  (forall P phi a b,
  DefEq P phi a b -> forall P1 P2, P = P2 ++ P1 -> forall P3, uniq (P2 ++ P3 ++ P1) -> DefEq (P2 ++ P3 ++ P1) phi a b).
Proof.
  intros.
  eapply CDefEq_DefEq_weakening_middle; eauto.
Qed.

Lemma DefEq_weakening : forall P phi b1 b2,
  DefEq P phi b1 b2 -> forall P2, uniq (P2 ++ P) -> DefEq (P2 ++ P) phi b1 b2.
Proof.
  intros.
  eapply CDefEq_DefEq_weakening_middle with (P2 := nil); eauto.
Qed.

Lemma CPar_Par_weakening_middle :
  (forall G0 psi psi0 a b, CPar G0 psi psi0 a b ->
  forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) ->  CPar (F ++ E ++ G) psi psi0 a b) /\
  (forall G0 psi a b, Par G0 psi a b ->
  forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) ->  Par (F ++ E ++ G) psi a b).
Proof.
  apply CPar_Par_mutual.
  all: intros; subst; eauto 3 using Grade_weakening_middle.
  all: try solve [
  subst; fresh_apply_Par x; auto; repeat spec x;
  match goal with
  | [ H3 : forall E F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G = F0 ++ G0 -> _ |- _ ]
    =>  specialize (H3 E ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto) ltac:(simpl_env;eauto)) ;
  simpl_env in H3 end; eauto].

  all: eauto 5 using Grade_weakening_middle.
Qed.

Lemma Par_weakening_middle :
  forall G0 a psi b, Par G0 psi a b ->
  forall E F G, (G0 = F ++ G) -> uniq (F ++ E ++ G) ->  Par (F ++ E ++ G) psi a b.
Proof.
  intros. eapply CPar_Par_weakening_middle; eauto.
Qed.

Lemma Par_weakening :
  forall G a psi b, Par G psi a b ->
  forall E, uniq (E ++ G) ->  Par (E ++ G) psi a b.
Proof.
  intros. eapply Par_weakening_middle with (F := nil); eauto.
Qed.

Lemma Typing_weakening_middle : forall W2 W1 q b B,
    Typing (W2 ++ W1) q b B ->
    forall W, uniq (W2 ++ W ++ W1) ->
    Typing (W2 ++ W ++ W1) q b B.
Proof.
  intros W2 W1 q b B h. dependent induction h.
  all: intros; subst; eauto 3 using DefEq_weakening_middle.
  all: have UL1: uniq (meet_ctx_l q_C W2 ++ meet_ctx_l q_C W ++ meet_ctx_l q_C W1) by
    unfold meet_ctx_l; solve_uniq.
  all: have UL2: uniq (labels (meet_ctx_l q_C W2) ++ labels (meet_ctx_l q_C W) ++ labels (meet_ctx_l q_C W1)) by
   unfold labels; solve_uniq.
  (* easy cases *)
  all: try solve [eapply T_App; eauto].
  all: try solve [
             eapply T_AppIrrel; simpl_env; eauto;
             eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_WPair; simpl_env; eauto;
             eapply IHh1; simpl_env; eauto].
  all: try solve [
             eapply T_WPairIrrel; simpl_env; eauto;
             try eapply IHh1; simpl_env; eauto;
             try eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_SPair; simpl_env; eauto;
             try eapply IHh1; simpl_env; eauto;
             try eapply IHh2; simpl_env; eauto].
  all: try solve [
             apply T_Sum; simpl_env; eauto;
             try eapply IHh1; simpl_env; eauto;
             try eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_Inj1; simpl_env; eauto;
             eapply IHh2; simpl_env; eauto].
  all: try solve [
             eapply T_Inj2; simpl_env; eauto;
             eapply IHh2; simpl_env; eauto].
  all: try solve [eapply T_Eq; simpl_env; eauto].

  (* conversion *)
  all: try match goal with [ H : DefEq _ _ _ _ |- _ ] =>
                  eapply T_Conv; eauto 3;
                    simpl_env in *;
                    try eapply DefEq_weakening_middle; eauto end.

  (* pi *)
  subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x;
  match goal with
  | [ H2 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
    => specialize (H2 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3));
  simpl_env in H2; eauto 3; try eapply H2; try solve_uniq end.

  (* abs *)
  subst; fresh_apply_Typing x; simpl_env; try eapply IHh; simpl_env; eauto; repeat spec x;
  try match goal with
  | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
    => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3) W) ;
  simpl_env in H3 ; eauto 3; try eapply H3 end.

  (* wsigma *)
  subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x;
  match goal with
  | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
    => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)) ;
  simpl_env in H3; eauto 3; try eapply H3; try solve_uniq end.

  (* letpair *)
  - subst; fresh_apply_Typing x.
    + clear H H1 H2 IHh.
    repeat spec x. simpl_env.
    match goal with
    | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ meet_ctx_l q_C (?F ++ ?G) ~= F0 ++ G0 -> _ |- _ ]
      => specialize (H3 ([(x,psi0)] ++ meet_ctx_l q_C F) (meet_ctx_l q_C G) ltac:(simpl_env;eauto 3) (meet_ctx_l q_C W));
          simpl_env in H3; eapply H3 end.
    eapply uniq_cons_3; auto. repeat rewrite dom_app. repeat rewrite dom_meet_ctx_l. auto.
    + eapply IHh; auto.
    + move => y Fry.
      clear H H0 H1 IHh.
      spec x. spec y.
      specialize (H0 ([(x, (psi0 * psi,A))] ++ W2) W1 ltac:(simpl_env; auto) W).
      simpl_env in H0. eapply H0. solve_uniq.

  (* ssigma *)
  - subst; fresh_apply_Typing x; eauto 1; auto; repeat spec x;
      match goal with
      | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ ?F ++ ?G ~= F0 ++ G0 -> _ |- _ ]
        => specialize (H3 ([(x,psi0)] ++ F) G ltac:(simpl_env;eauto 3)) ;
            simpl_env in H3; eauto 3; try eapply H3; try solve_uniq end.
  - (* case *)
    fresh_apply_Typing x; auto.
    repeat spec x.
    simpl_env.
    match goal with
    | [ H3 : forall F0 G0, [(?x, ?psi0)] ++ meet_ctx_l q_C (?F ++ ?G) ~= F0 ++ G0 -> _ |- _ ]
      => specialize (H3 ([(x,psi0)] ++ meet_ctx_l q_C F) (meet_ctx_l q_C G) ltac:(simpl_env;eauto 3)
                   (meet_ctx_l q_C W));
          simpl_env in H3 ; eapply H3 end.
    eapply uniq_cons_3; auto. repeat rewrite dom_app. repeat rewrite dom_meet_ctx_l. auto.
Qed.

Lemma Typing_weakening : forall W1 q b B,
    Typing W1 q b B ->
    forall W2, uniq (W2 ++ W1) ->
    Typing (W2 ++ W1) q b B.
Proof.
  intros.
  eapply Typing_weakening_middle with (W2 := nil); simpl_env; eauto.
Qed.


Require Import Common.Definitions.
Require Import Common.Values.
Require Import Source.CS.
Require Import Source.GlobalEnv.

Require Export Source.Language.
Require Export Extraction.Definitions.

Import Source.

Definition run (p: program) (fuel: nat) :=
  let G := prepare_global_env p in
  let st := CS.initial_machine_state p in
  match CS.execN fuel G st with
  | Some [CState _, _, _, _, E_exit, _] => print_explicit_exit tt
  | Some [CState _, _, _, _, E_val (Int n), _] => print_ocaml_int (z2int n)
  | _ => print_error ocaml_int_0
  end.


(* First a simplification of the bug *)

Set Printing Universes.

Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A.

Definition id (X:Type(*5*)) (x:X) := x.

Lemma test : let S := Type(*6 : 7*) in enc S -> S.
simpl; intros.
apply enc.
apply id.
apply Prop.
Defined.

(* Then the original bug *)

Require Import List.

Inductive a : Set := (* some dummy inductive *)
b : (list a) -> a.   (* i don't know if this *)
                     (* happens for smaller  *)
                     (* ones                 *)

Inductive sg : Type := Sg. (* single *)

Definition ipl2 (P : a -> Type) :=   (* in Prop, that means P is true forall *)
fold_right (fun x => prod (P x)) sg. (* the elements of a given list         *)

Definition ind
     : forall S : a -> Type,
       (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s :=
fun (S : a -> Type)
  (X : forall ls : list a, ipl2 S ls -> S (b ls)) =>
fix ind2 (s : a) :=
match s as a return (S a) with
| b l =>
    X l
      (list_rect (fun l0 : list a => ipl2 S l0) Sg
         (fun (a0 : a) (l0 : list a) (IHl : ipl2 S l0) =>
          pair (ind2 a0) IHl) l)
end. (* some induction principle *)

Implicit Arguments ind [S].

Lemma k : a -> Type. (* some ininteresting lemma *)
intro;pattern H;apply ind;intros.
  assert (K : Type).
    induction ls.
      exact sg.
      exact sg.
  exact (prod K sg).
Defined.

Lemma k' : a -> Type. (* same lemma but with our bug *)
intro;pattern H;apply ind;intros.
  apply prod.
    induction ls.
      exact sg.
      exact sg.
    exact sg. (* Proof complete *)
Defined. (* bug *)


Require Import RGref.DSL.Core.

(** * Helpful Constants, Lemmas, and Proof Tactics *)
(** ** General stufff *)
Definition any {A:Set} : hpred A := fun _ => fun _ => True.

Lemma stable_any : forall (A:Set) (R:hrel A), stable any R.
Proof.
  intros; compute; eauto.
Qed.
Hint Resolve stable_any.
Lemma precise_any : forall (A:Set){RA:ImmediateReachability A}, @precise_pred A RA any.
Proof.
  intros; compute; eauto.
Qed.
Hint Resolve precise_any.
Lemma any_true : forall (A:Set) (a:A) h, any a h.
Proof. compute; auto. Qed.
Hint Resolve any_true.

Definition havoc {A:Set} : hrel A := fun _ => fun _ => fun _ => fun _ => True.
Lemma precise_havoc : forall (A:Set)`{ImmediateReachability A}, precise_rel (@havoc A).
Proof. intros; compute; eauto. Qed.
Hint Resolve precise_havoc.
Lemma havoc_true : forall (A:Set) (a a':A) h h', havoc a a' h h'.
Proof. intros; compute; auto. Qed.
Hint Resolve havoc_true.
Lemma havoc_refl : forall (A:Set), hreflexive (@havoc A).
Proof. compute; eauto. Qed.
Hint Resolve havoc_refl.

Definition empty {A:Set} : hrel A := fun _ => fun _ => fun _ => fun _ => False.
Definition locally_const {A:Set} (R:hrel A) := forall a a' h h', R a a' h h' -> a=a'.

Lemma stable_empty : forall (A:Set) (P:hpred A), stable P empty.
Proof.
  compute; intuition.
Qed.
Hint Resolve stable_empty.
Lemma precise_empty : forall (A:Set)`{ImmediateReachability A}, precise_rel empty.
Proof. intros; compute; eauto. Qed.
Hint Resolve precise_empty.

Definition local_imm {A:Set} : hrel A := fun a => fun a' => fun _ => fun _ => a=a'.
Lemma local_imm_const : forall A, locally_const (@local_imm A).
Proof. intros; firstorder. Qed.
Hint Resolve local_imm_const.
Lemma local_imm_precise : forall (T:Set)`{ImmediateReachability T}, precise_rel (@local_imm T).
Proof.
  red; intros. induction H2. red. reflexivity.
Qed.
Hint Resolve local_imm_precise.
Lemma local_imm_refl : forall (T:Set), @hreflexive T local_imm.
Proof.
  compute; eauto.
Qed.
Hint Resolve local_imm_refl.
Axiom immutable_vals :
  forall T P h h' (r:ref{T|P}[local_imm,local_imm]), h[r]=h'[r].

(** We can always read when we have only one writable ref *)
Global Instance strong_read (T:Set) : readable_at T local_imm havoc :=
  { res := T ;
    dofold := fun x => x
  }.
(** And we can always read when the guarantee is strictly local *)
Global Instance weak_read (T:Set) : readable_at T local_imm local_imm :=
  { res := T ;
    dofold := fun x => x
  }.
(** I'm torn about providing this, but it's a common enough pattern (it is
    the common case that types are only read at one R/G) that
    we should(?) make it easy as a matter of library design...*)
Definition id_fold {T:Set}{R G:hrel T} : readable_at T R G :=
  Build_readable_at T R G T (fun x => x).

Definition heap_agnostic_pred {A:Set} (P:hpred A) := forall a h h', P a h -> P a h'.
Definition heap_agnostic_rel {A:Set} (R:hrel A) := forall a a' h h' h'' h''', R a a' h h' -> R a a' h'' h'''.

Lemma agnostic_pred_stable : forall (A:Set) (P:hpred A), heap_agnostic_pred P -> stable P local_imm.
Proof.
  compute. intros. subst; intuition; eauto.
Qed.

Hint Resolve agnostic_pred_stable.

(** *** Option types *)
Inductive optset (A:Set) : hrel (option A) :=
  | optset_nop : forall (o:option A) h h', optset A o o h h'
  | optset_set : forall (a:A) h h', optset A None (Some a) h h'.
Inductive option_reach : forall (A:Set)`(ImmediateReachability A) {T:Set}{P R G} (p:ref{T|P}[R,G]) (ao:option A), Prop :=
  | opt_reach_some : forall (A:Set)(a:A)`(ImmediateReachability A) {T:Set}{P R G} (p:ref{T|P}[R,G]),
                         imm_reachable_from_in p a ->
                         option_reach A _ p (Some a).
Global Instance reach_option {A:Set}`{ImmediateReachability A} : ImmediateReachability (option A) :=
  { imm_reachable_from_in := fun T P R G p oa => option_reach A _ p oa }.
Lemma optset_precise : forall A `(ImmediateReachability A), precise_rel (optset A).
Proof. compute. intros. inversion H2; subst; constructor. Qed.
Hint Resolve optset_precise.
(* TODO: Contains instance for options *)
Global Instance option_fold {A:Set}`{rel_fold A} : rel_fold (option A) :=
  { rgfold := fun R G => option (rgfold havoc (fun a a' h h' => G (Some a) (Some a') h h')) ;
    fold := fun R G o => match o with None => None | Some o' => Some (fold o') end
  }.
Lemma optset_refl : forall (A:Set), hreflexive (optset A).
Proof. compute; intuition; constructor. Qed.
Hint Resolve optset_refl.
Inductive opt_contains {A:Set}`{Containment A} : hrel (option A) -> Prop :=
  | some_contains : forall RR (h h':heap),
                      contains (fun a a' h h' => RR (Some a) (Some a') h h') ->
                      opt_contains RR.
Global Instance option_contains {A:Set}`{Containment A} : Containment (option A) :=
  { contains := opt_contains }.

(** ** Combinator Lemmas *)

Lemma pred_and_stable : forall (A:Set) (P:hpred A) Q R, stable P R -> stable Q R -> stable (P ⊓ Q) R.
Proof. intros; firstorder. Qed.
Lemma pred_or_stable : forall (A:Set) (P Q:hpred A) R, stable P R -> stable Q R -> stable (P ⊔ Q) R.
Proof. intros; firstorder. Qed.
Lemma rel_and_stable : forall (A:Set) (P:hpred A) R S, stable P R -> stable P S -> stable P (R ⋂ S).
Proof. intros; firstorder. Qed.
Lemma rel_or_stable : forall (A:Set) (P:hpred A) R S, stable P R -> stable P S -> stable P (R ⋃ S).
Proof. intros; firstorder. Qed.
Lemma pred_and_precise : forall (A:Set){RA:ImmediateReachability A}(P Q:hpred A), precise_pred P -> precise_pred Q -> precise_pred (P ⊓ Q).
Proof. intros; firstorder. Qed.
Lemma pred_or_precise : forall (A:Set){RA:ImmediateReachability A}(P Q:hpred A), precise_pred P -> precise_pred Q -> precise_pred (P ⊔ Q).
Proof. intros; firstorder. Qed.
Lemma rel_and_precise : forall (A:Set){RA:ImmediateReachability A}(R S:hrel A), precise_rel R -> precise_rel S -> precise_rel (R ⋂ S).
Proof. intros. compute[precise_rel rel_and] in *. intuition. eauto. eauto. Qed.
Lemma rel_or_precise : forall (A:Set){RA:ImmediateReachability A}(R S:hrel A), precise_rel R -> precise_rel S -> precise_rel (R ⋃ S).
Proof. intros. compute[precise_rel rel_or] in *. intuition. eauto. eauto. Qed.
Require Import Coq.Classes.RelationClasses.
Global Instance rel_sub_eq_preorder `{A:Set} : PreOrder (@rel_sub_eq A).
Proof. constructor. firstorder. firstorder. Qed.
Global Instance pred_sub_eq_preorder `{A:Set} : PreOrder (@pred_sub_eq A).
Proof. constructor; firstorder. Qed.

Lemma pred_sub_refl : forall T (P:hpred T), P⊑P.
Proof.
  reflexivity.
Qed.
Hint Resolve pred_sub_refl.

Lemma rel_sub_refl : forall T (R:hrel T), R⊆R.
Proof.
  reflexivity.
Qed.
Hint Resolve rel_sub_refl.

(** Also need to be able to pull results out of conjunctions *)
Lemma pred_and_proj1 : forall (A:Set) P Q (a:A) (h:heap), (P ⊓ Q) a h -> P a h.
Proof. firstorder. Qed.
Lemma pred_and_proj2 : forall (A:Set) P Q (a:A) (h:heap), (P ⊓ Q) a h -> Q a h.
Proof. firstorder. Qed.

Hint Resolve pred_and_stable rel_and_stable pred_and_precise rel_and_precise.
Hint Resolve pred_or_stable rel_or_stable pred_or_precise rel_or_precise.


From iris.algebra Require Import gmap agree auth.
From iris.proofmode Require Import tactics.
From cap_machine Require Export stdpp_extra iris_extra multiple_updates region.
From cap_machine.binary_model Require Export region_invariants_binary region_invariants_transitions_binary logrel_binary.
Import uPred.

Section heap.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          {nainv: logrel_na_invs Σ} {cfgg : cfgSG Σ}
          `{MachineParameters}.

  Notation STS := (leibnizO (STS_states * STS_rels)).
  Notation STS_STD := (leibnizO (STS_std_states Addr region_type)).
  Notation WORLD := (prodO STS_STD STS).
  Implicit Types W : WORLD.

  (* --------------------------------------------------------------------------------------------------------- *)
  (* ------------------------------------------ UNINITIALIZATION --------------------------------------------- *)
  (* --------------------------------------------------------------------------------------------------------- *)

  (*
     Full uninitialization turns every temporary/monotemporary
     location state to uninitialized.
     Unlike revocation, it is only required to uninitialize
     all addresses above some chosen address a
   *)

  (* Uninitializing only changes the states of the standard STS collection *)
  (* A weaker revocation which only revokes elements from a list *)
  Definition u_merge_op (wo : option (Word * Word)) (ro : option region_type) : option region_type :=
    match wo,ro with
    | Some w, Some r => match r with
                       | Monotemporary => Some (Uninitialized w)
                       | _ => Some r
                       end
    | _, Some r => Some r
    |_, None => None
    end.

  Definition uninitialize_std_sta (m : gmap Addr (Word * Word)) : STS_STD → STS_STD :=
    merge u_merge_op m.

  Definition uninitialize W m : WORLD := (uninitialize_std_sta m (std W),loc W).

  Global Instance diag_none_u_merge_op : DiagNone u_merge_op.
  Proof. by rewrite /u_merge_op /DiagNone /=. Qed.

  Lemma uninitialize_std_sta_empty fs :
    uninitialize_std_sta ∅ fs = fs.
  Proof.
    rewrite map_eq_iff. intros a.
    rewrite /uninitialize_std_sta.
    rewrite lookup_merge lookup_empty /=.
    destruct (fs !! a) eqn:Hsome;rewrite Hsome;auto.
  Qed.

  Lemma uninitialize_empty W :
    uninitialize W ∅ = W.
  Proof.
    rewrite /uninitialize uninitialize_std_sta_empty.
    destruct W;auto.
  Qed.

  Definition uninitialize_i j w :=
    match j with
    | Monotemporary => Uninitialized w
    | _ => j
    end.

  Lemma uninitialize_std_sta_spec (m : gmap Addr (Word * Word)) :
    forall (Wstd_sta : STS_STD) (i : Addr),
      (uninitialize_std_sta m Wstd_sta) !! i = match Wstd_sta !! i with
                                              | None => None
                                              | Some j => Some (match m !! i with
                                                               | Some w => uninitialize_i j w
                                                               | None => j
                                                               end)
                                              end.
  Proof.
    induction m using map_ind; intros.
    - rewrite uninitialize_std_sta_empty.
      destruct (Wstd_sta !! i) eqn:Hsome;auto.
    - destruct (decide (i = i0));subst.
      + simplify_map_eq.
        rewrite lookup_merge.
        destruct (Wstd_sta !! i0) eqn:Hsome.
        * simplify_map_eq. destruct r; auto.
        * simplify_map_eq. auto.
      + simplify_map_eq.
        rewrite lookup_merge. rewrite lookup_insert_ne//.
        specialize (IHm Wstd_sta i0). by rewrite lookup_merge in IHm.
  Qed.

  Lemma uninitialize_std_sta_None_lookup i l m :
    l !! i = None →
    (uninitialize_std_sta l m) !! i = m !! i.
  Proof.
    intros Hnin.
    rewrite lookup_merge Hnin.
    simpl; destruct (m !! i) eqn:Hsome;rewrite Hsome;auto.
  Qed.

  Lemma uninitialize_std_sta_not_elem_of_lookup i l m :
    i ∉ dom (gset Addr) l →
    (uninitialize_std_sta l m) !! i = m !! i.
  Proof.
    intros Hnin. apply not_elem_of_dom in Hnin.
    apply uninitialize_std_sta_None_lookup;auto.
  Qed.

  Lemma uninitialize_std_sta_is_Some i l m :
    is_Some (m !! i) <->
    is_Some ((uninitialize_std_sta l m) !! i).
  Proof.
    split; intros Hsome; destruct Hsome as [x Hx].
    rewrite lookup_merge Hx.
    destruct (l !! i);simpl;destruct x;eauto.
    rewrite lookup_merge in Hx.
    destruct (m !! i) eqn:Hsome;eauto.
    rewrite Hsome /= in Hx.
    destruct (l !! i);simpl in Hx; inversion Hx.
  Qed.

  Lemma uninitialize_dom W m :
    dom (gset Addr) (uninitialize W m).1 = dom (gset Addr) W.1.
  Proof.
    apply set_equiv_spec_L. split.
    - apply elem_of_subseteq. intros x Hx.
      apply elem_of_gmap_dom in Hx as [y Hx].
      apply elem_of_gmap_dom. eapply (uninitialize_std_sta_is_Some _ m). eauto.
    - apply elem_of_subseteq. intros x Hx.
      apply elem_of_gmap_dom. rewrite -(uninitialize_std_sta_is_Some _ m).
      apply elem_of_gmap_dom. auto.
  Qed.

  Lemma uninitialize_std_sta_insert fs m w a :
    fs !! a = Some Monotemporary →
    <[a:=Uninitialized w]> (uninitialize_std_sta m fs) = uninitialize_std_sta (<[a:=w]> m) fs.
  Proof.
    intros Htemps.
    apply map_eq'. intros k v;split.
    - intros Ha. destruct (decide (k = a));subst;simplify_map_eq_alt.
      + rewrite lookup_merge lookup_insert /=.
        rewrite Htemps;auto.
      + rewrite lookup_merge /=. rewrite /u_merge_op. simplify_map_eq.
        destruct (m !! k) eqn:Hsome.
        * destruct (fs !! k) eqn:Hsome';rewrite Hsome';[destruct r;auto|].
          all: rewrite lookup_merge Hsome Hsome' /= in Ha;auto.
        * rewrite lookup_merge Hsome /= in Ha;auto.
    - intros Ha. destruct (decide (k = a));subst;simplify_map_eq_alt;simplify_eq.
      + rewrite lookup_merge lookup_insert in Ha.
        rewrite Htemps /= in Ha;auto. rewrite lookup_insert. auto.
      + rewrite lookup_merge lookup_insert_ne// in Ha.
        rewrite lookup_insert_ne//. rewrite lookup_merge. auto.
  Qed.

  Lemma uninitialize_std_sta_lookup_in i m (fs : STS_STD) (v : Word * Word) :
    m !! i = Some v →
    fs !! i = Some Monotemporary →
    (uninitialize_std_sta m fs) !! i = Some (Uninitialized v).
  Proof.
    intros Hi Hsome.
    rewrite lookup_merge Hi.
    rewrite Hsome; auto.
  Qed.

  Lemma uninitialize_std_sta_singleton fs a v :
    fs !! a = Some Monotemporary ->
    uninitialize_std_sta {[a := v]} fs = <[a:=Uninitialized v]> fs.
  Proof.
    intros Hin.
    apply map_eq'. intros k w. rewrite lookup_merge.
    destruct (decide (a = k));subst;simplify_map_eq;simplify_map_eq_alt;auto.
    rewrite lookup_insert;auto.
    destruct (fs !! k) eqn:Hsome;auto;rewrite lookup_insert_ne//;rewrite Hsome//.
  Qed.

  Lemma uninitialize_related_pub_a W m a :
    (∀ a' : Addr, is_Some (m !! a') ↔ (W.1 !! a' = Some Monotemporary) ∧ (a <= a')%a) →
    related_sts_a_world W (uninitialize W m) a.
  Proof.
    intros Hcond.
    split;[|apply related_sts_pub_plus_refl].
    split.
    - rewrite uninitialize_dom. done.
    - intros i x y Hx Hy.
      destruct (decide (le_a a i)).
      + destruct (decide (x = Monotemporary)).
        * assert (is_Some (m !! i)) as [v Hv].
          { apply Hcond. split;auto. subst;auto. }
          rewrite lookup_merge Hv Hx /= in Hy.
          simplify_eq. eright;[|left]. right. constructor.
        * assert ((m !! i) = None) as Hnone.
          { apply eq_None_not_Some. intros Hcontr%Hcond. destruct Hcontr as [Hcontr _].
            rewrite Hx in Hcontr; inversion Hcontr; congruence. }
          rewrite lookup_merge Hnone Hx /= in Hy. simplify_eq. left.
      + destruct (m !! i) eqn:Hsome.
        2: { rewrite lookup_merge Hsome Hx /= in Hy. simplify_eq. left. }
        destruct (decide (W.1 !! i = Some Monotemporary)).
        2: { rewrite lookup_merge Hsome Hx /= in Hy. destruct x;simplify_eq;try contradiction;left. }
        assert (is_Some (m !! i)) as Hcontr%Hcond;eauto. destruct Hcontr as [_ Hcontr].
        solve_addr.
  Qed.

  (* ------------------------------------------------------------------------------------------------- *)
  (* ------------------------ Binary versions of lemmas in the revocation file ----------------------- *)
  (* ------------------------------------------------------------------------------------------------- *)

  Lemma reg_get (γ : gname) (R : relT) (n : Addr) (r : leibnizO (gname)) :
    own γ (● (to_agree <$> R : relUR)) ∧ ⌜R !! n = Some r⌝ ==∗
    (own γ (● (to_agree <$> R : relUR)) ∗ own γ (◯ {[n := to_agree r]})).
  Proof.
    iIntros "[HR #Hlookup]".
    iDestruct "Hlookup" as %Hlookup.
    iApply own_op.
    iApply (own_update with "HR").
    apply auth_update_core_id; auto. apply gmap_core_id,agree_core_id.
    apply singleton_included_l. exists (to_agree r). split; auto.
    (* apply leibniz_equiv_iff in Hlookup.  *)
    rewrite lookup_fmap. apply fmap_Some_equiv.
    exists r. split; auto.
  Qed.

  Lemma region_rel_get (W : WORLD) (a : Addr) :
    (std W) !! a = Some Monotemporary ->
    region W ∗ sts_full_world W ==∗
     region W ∗ sts_full_world W ∗ ∃ φ, ⌜forall Wv, Persistent (φ Wv)⌝ ∗ rel a φ.
  Proof.
    iIntros (Hlookup) "[Hr Hsts]".
    rewrite region_eq /region_def.
    iDestruct "Hr" as (M Mρ) "(HM & #Hdom & #Hdom' & Hr)".
    iDestruct "Hdom" as %Hdom. iDestruct "Hdom'" as %Hdom'.
    assert (is_Some (M !! a)) as [γp Hγp].
    { apply elem_of_gmap_dom. rewrite -Hdom. apply elem_of_gmap_dom. eauto. }
    rewrite RELS_eq /RELS_def.
    iMod (reg_get with "[$HM]") as "[HM Hrel]";[eauto|].
    (* rewrite /region_map_def. iDestruct (reg_in with "[$HM $Hrel]") as %HMeq. *)
    iDestruct (big_sepM_delete _ _ a with "Hr") as "[Hstate Hr]";[eauto|].
    iDestruct "Hstate" as (ρ Ha) "[Hρ Hstate]".
    iDestruct (sts_full_state_std with "Hsts Hρ") as %Hx''.
    all: rewrite Hlookup in Hx'';inversion Hx'';subst.
    all: iDestruct "Hstate" as (φ Hpers) "(#Hsaved & Ha)".
    all: iDestruct "Ha" as (v v') "(Ha & Ha' & Hmono & #Hφ)".
    all: iDestruct (big_sepM_delete _ _ a with "[Hρ Ha Ha' Hmono Hφ $Hr]") as "Hr";[eauto| |].
    { iExists Monotemporary. iFrame. iSplit;auto. iExists φ. iFrame "∗ # %". iExists _,_;iFrame. auto. }
    all: iModIntro.
    all: iSplitL "HM Hr".
    { iExists M. iFrame. auto. }
    all: iFrame; iExists φ; iSplit;auto; rewrite rel_eq /rel_def REL_eq /REL_def;iExists γp.
    all: iFrame "Hsaved Hrel".
  Qed.

  (* ------------------------------------------------------------------------------------------------- *)
  (* ------------------ A version of uninitialization where we remember the invariants --------------- *)
  (* ------------------------------------------------------------------------------------------------- *)

  Definition monotemp_pers_resources W φ a v1 v2 : iProp Σ :=
    (future_pub_a_mono a φ v1 v2 ∗ φ (W,(v1,v2)))%I.

  Lemma uninitialize_region_last_keep W E :
    region W ∗ sts_full_world W ={E}=∗ ∃ m, ⌜((∃ (v v' : Word), {[addr_reg.top:=(v,v')]} = m) ↔ W.1 !! addr_reg.top = Some Monotemporary)
                                             ∧ (∅ = m <-> W.1 !! addr_reg.top ≠ Some Monotemporary)⌝
                                             ∗ region W ∗ sts_full_world (uninitialize W m)
                                             ∗ □ ▷ ([∗ map] a↦w ∈ m, □ ∃ φ, ⌜forall Wv, Persistent (φ Wv)⌝ ∗ monotemp_pers_resources W φ a w.1 w.2 ∗ rel a φ).
  Proof.
    iIntros "[Hr Hsts]".
    destruct (decide (W.1 !! addr_reg.top = Some Monotemporary)).
    + iMod (region_rel_get with "[$Hr $Hsts]") as "(Hr & Hsts & #Hrel)";eauto.
      iDestruct "Hrel" as (φ' Hpers') "Hrel".
      rewrite region_eq /region_def.
      iDestruct "Hr" as (M Mρ) "(HM & #HM_dom & #HMρ_dom & Hmap)".
      iDestruct "HM_dom" as %HM_dom. iDestruct "HMρ_dom" as %HMρ_dom.
      assert (is_Some (M !! addr_reg.top)) as [γp Hγp].
      { apply elem_of_gmap_dom. rewrite -HM_dom. apply elem_of_gmap_dom. eauto. }
      iDestruct (big_sepM_delete with "Hmap") as "[Ha Hmap]";[apply Hγp|].
      iDestruct "Ha" as (ρ Hlookup) "[Hstate Hresources]".
      iDestruct (sts_full_state_std with "Hsts Hstate") as %Hρ.
      iDestruct "Hresources" as (φ Hpers) "[#Hsaved Ha]".
      rewrite e in Hρ;inversion Hρ;subst ρ.
      iDestruct "Ha" as (v1 v2) "(Ha & Ha' & Hres)".
      iMod (sts_update_std _ _ _ (Uninitialized (v1,v2)) with "Hsts Hstate") as "[Hsts Hstate]".
      iDestruct (region_map_delete_nonstatic with "Hmap") as "Hmap".
      { intros m'. rewrite Hlookup. auto. }
      iDestruct (region_map_insert_nonmonostatic (Uninitialized (v1,v2)) with "Hmap") as "Hmap";auto.
      iDestruct (big_sepM_insert _ _ addr_reg.top with "[$Hmap Ha Ha' Hstate]") as "Hmap";[apply lookup_delete|..].
      { iExists (Uninitialized _). rewrite lookup_insert. iSplit;auto. iFrame. iExists _. iSplit;eauto. }
      rewrite insert_delete. rewrite (insert_id M);[|auto]. iModIntro.
      iExists {[addr_reg.top:= _]}. rewrite /uninitialize uninitialize_std_sta_singleton// /=. iFrame.
      iSplit;[iPureIntro|iSplit].
      * split;split.
        { intros;auto. }
        { intros _. eexists;eauto. }
        { intros Hcontr;inversion Hcontr. }
        { intros Hcontr; contradiction. }
      * iExists _,_. iFrame. iPureIntro. rewrite HM_dom -HMρ_dom. clear -Hlookup. split;auto.
          assert (addr_reg.top ∈ dom (gset Addr) Mρ);[apply elem_of_gmap_dom;eauto|]. rewrite dom_insert_L. set_solver.
      * rewrite rel_eq /rel_def REL_eq /REL_def RELS_eq /RELS_def. iDestruct "Hrel" as (γpred') "[HREL Hsaved']".
        iDestruct (reg_in with "[$HM $HREL]") as %Hmeq. rewrite Hmeq lookup_insert in Hγp;inversion Hγp. simplify_eq.
        iDestruct (saved_pred_agree _ _ _ (W,(v1,v2)) with "Hsaved Hsaved'") as "Heq".
        iDestruct "Hres" as "#Hres". iModIntro.
        rewrite big_sepM_singleton. iModIntro. iExists φ. iModIntro. iSplit;auto.
    + iModIntro. iExists ∅. rewrite uninitialize_empty. iFrame. rewrite big_sepM_empty. iSplit;[|auto].
      iPureIntro. split. split;intros;try contradiction. destruct H0. inversion H0. done.
      split;intros;auto.
  Qed.

  Lemma uninitialize_region_states_keep W (a : Addr) (l : list Addr) E :
    ⌜l = region_addrs a addr_reg.top ++ [addr_reg.top]⌝ -∗
    region W ∗ sts_full_world W ={E}=∗
    ∃ m, ⌜∀ (a' : Addr), is_Some(m !! a') ↔ ((W.1 !! a' = Some Monotemporary) ∧ (a' ∈ l)%a)⌝
         ∗ region W ∗ sts_full_world (uninitialize W m)
         ∗ □ ▷ ([∗ map] a↦w ∈ m, □ ∃ φ, ⌜forall Wv, Persistent (φ Wv)⌝ ∗ monotemp_pers_resources W φ a w.1 w.2 ∗ rel a φ).
  Proof.
    iIntros (Heq) "(Hr & Hsts)".
    iInduction (l) as [|a' l] "IH" forall (a Heq).
    { destruct (region_addrs a addr_reg.top); inversion Heq. }
    destruct l.
    - iMod (uninitialize_region_last_keep with "[$Hr $Hsts]") as (m [Hcond Hcond']) "[Hr [Hsts #Hresources] ]".
      iExists m. iModIntro. iFrame "∗ #". iPureIntro. intros a0. split;intros Hc.
      + destruct (region_addrs a addr_reg.top);[inversion Heq;subst|destruct l; inversion Heq].
        destruct (decide (W.1 !! addr_reg.top = Some Monotemporary));[|exfalso]. assert (e':=e).
        apply Hcond in e as [v [v' <-] ]. destruct Hc as [c Hc]. apply lookup_singleton_Some in Hc as [Heq1 Heq2];subst.
        split;auto. constructor.
        apply Hcond' in n. subst. rewrite lookup_empty in Hc. inversion Hc. done.
      + destruct Hc as [Hc1 Hc2]. destruct (region_addrs a addr_reg.top);[inversion Heq;subst|destruct l; inversion Heq].
        apply elem_of_list_singleton in Hc2. subst. apply Hcond in Hc1 as [v [v' <-] ]. eauto.
    - assert ((a' + 1)%a = Some a0 ∧ (a' = a) ∧ (region_addrs a addr_reg.top = a :: region_addrs a0 addr_reg.top))
        as [Hnext [Heqa Haddrs_cons ] ].
      { assert (a < addr_reg.top)%a as Hlt.
        { destruct (decide (a < addr_reg.top)%a);auto.
          apply Znot_lt_ge in n. rewrite region_addrs_empty in Heq;[|solve_addr]. inversion Heq. }
        assert (Heq':=Heq).
        rewrite region_addrs_cons in Heq;auto. inversion Heq;subst.
        assert ((a + 1)%a = Some a0) as  Ha''.
        { destruct (a + 1)%a eqn:Hsome;[|solve_addr].
          simpl in *. destruct (decide (a1 = addr_reg.top));subst;auto.
          - rewrite region_addrs_empty in H2;[|solve_addr]. destruct l;inversion H2. auto.
          - rewrite region_addrs_cons in Heq;[|solve_addr]. inversion Heq;auto. }
        repeat split;auto. rewrite region_addrs_cons;auto. rewrite Ha''. auto. }
      subst a'.
      destruct (decide (W.1 !! a = Some Monotemporary)).
      + iMod (region_rel_get with "[$Hr $Hsts]") as "(Hr & Hsts & #Hrel)";eauto.
        iDestruct "Hrel" as (φ' Hpers') "Hrel".
        iMod ("IH" $! a0 with "[] Hr Hsts") as (m Hmcond) "[Hr [Hsts #Hres] ]".
        { rewrite region_addrs_cons in Heq;[|solve_addr]. rewrite Hnext in Heq. inversion Heq;auto. }
        assert (m !! a = None) as Hnone.
        { destruct (m!!a)eqn:Hsome';auto. assert (is_Some (m!!a)) as HisSome;eauto. apply Hmcond in HisSome as [Htemps Hin]. exfalso.
          rewrite Haddrs_cons in Heq. inversion Heq. rewrite H1 in Hin. apply elem_of_app in Hin as [Hin | Heq'].
          apply elem_of_region_addrs in Hin. solve_addr. apply elem_of_list_singleton in Heq';subst;solve_addr. }
        rewrite region_eq /region_def.
        iDestruct "Hr" as (M Mρ) "(HM & #HM_dom & #HMρ_dom & Hmap)".
        iDestruct "HM_dom" as %HM_dom. iDestruct "HMρ_dom" as %HMρ_dom.
        assert (is_Some (M !! a)) as [γp Hγp].
        { apply elem_of_gmap_dom. rewrite -HM_dom. apply elem_of_gmap_dom. eauto. }
        iDestruct (big_sepM_delete with "Hmap") as "[Ha Hmap]";[apply Hγp|].
        iDestruct "Ha" as (ρ Hlookup) "[Hstate Hresources]".
        iDestruct (sts_full_state_std with "Hsts Hstate") as %Hρ.
        rewrite uninitialize_std_sta_None_lookup in Hρ;[|auto].
        iDestruct "Hresources" as (φ Hpers) "[#Hsaved Ha]".
        rewrite e in Hρ;inversion Hρ;subst ρ.
        iDestruct "Ha" as (v v') "(Ha & Ha' & Hres')".
        iMod (sts_update_std _ _ _ (Uninitialized _) with "Hsts Hstate") as "[Hsts Hstate]".
        iDestruct (region_map_delete_nonstatic with "Hmap") as "Hmap".
        { intros m'. rewrite Hlookup. auto. }
        iDestruct(region_map_insert_nonmonostatic (Uninitialized (v,v')) with "Hmap") as "Hmap";auto.
        iDestruct (big_sepM_insert _ _ a with "[$Hmap Ha Ha' Hstate]") as "Hmap";[apply lookup_delete|..].
        { iExists (Uninitialized (v,v')). rewrite lookup_insert. iSplit;auto. iFrame. iExists _. iSplit;eauto. }
        rewrite insert_delete. rewrite (insert_id M);[|auto]. iModIntro.
        iExists (<[a:=(v,v')]> m). rewrite /uninitialize /= uninitialize_std_sta_insert;[|auto]. iFrame.
        iSplit;[iPureIntro|iSplit].
        * intros a'. destruct (decide (a = a'));[subst;rewrite lookup_insert|rewrite lookup_insert_ne//].
          { split;intros;[split;auto;constructor|eauto]. }
          { split;intros Hcond;[apply Hmcond in Hcond as [? ?]|]. split;auto. constructor;auto.
            apply Hmcond. destruct Hcond as [? Hcond]. split;auto. apply elem_of_cons in Hcond as [-> | Hcond];[|auto].
            contradiction. }
        * iExists _,_. iFrame. iPureIntro. rewrite HM_dom -HMρ_dom. clear -Hlookup. split;auto.
          assert (a ∈ dom (gset Addr) Mρ);[apply elem_of_gmap_dom;eauto|]. rewrite dom_insert_L. set_solver.
        * rewrite rel_eq /rel_def REL_eq /REL_def RELS_eq /RELS_def. iDestruct "Hrel" as (γpred') "[HREL Hsaved']".
          iDestruct (reg_in with "[$HM $HREL]") as %Hmeq. rewrite Hmeq lookup_insert in Hγp;inversion Hγp. simplify_eq.
          iDestruct (saved_pred_agree _ _ _ (W,(v,v')) with "Hsaved Hsaved'") as "Heq".
          iDestruct "Hres'" as "#Hres'". iModIntro. iNext. iApply big_sepM_insert;[auto|].
          iFrame "Hres". iExists φ. iModIntro. iSplit;auto.
      + iMod ("IH" $! a0 with "[] Hr Hsts") as (m Hmcond) "[Hr [Hsts #Hres] ]".
        { rewrite region_addrs_cons in Heq;[|solve_addr]. rewrite Hnext in Heq. inversion Heq;auto. }
        assert (m !! a = None) as Hnone.
        { destruct (m!!a)eqn:Hsome';auto. assert (is_Some (m!!a)) as HisSome;eauto. apply Hmcond in HisSome as [Htemps Hin]. exfalso.
          rewrite Haddrs_cons in Heq. inversion Heq. rewrite H1 in Hin. apply elem_of_app in Hin as [Hin | Heq'].
          apply elem_of_region_addrs in Hin. solve_addr. apply elem_of_list_singleton in Heq';subst;solve_addr. }
        iModIntro. iExists m.
        iFrame "∗ #". iPureIntro. intros a'. split.
        * intros Hsome. apply Hmcond in Hsome as [? ?]. split;auto. constructor;auto.
        * intros [Htemps Hin]. apply Hmcond. split;auto.
          apply elem_of_cons in Hin as [-> | Hcons];auto. contradiction.
  Qed.

  Lemma uninitialize_region_world W a m :
    ⌜∀ (a' : Addr), is_Some(m !! a') ↔ ((W.1 !! a' = Some Monotemporary) ∧ (a <= a')%a)⌝ -∗
    region W -∗ sts_full_world (uninitialize W m) -∗ region (uninitialize W m) ∗ sts_full_world (uninitialize W m).
  Proof.
    iIntros (Hcond) "Hr Hsts".
    rewrite region_eq /region_def.
    iDestruct "Hr" as (M Mρ) "(HM & #Hdom_m & #Hdom_mρ & Hpreds)".
    iDestruct "Hdom_m" as %Hdom_m. iDestruct "Hdom_mρ" as %Hdom_mρ.
    iApply sep_exist_r. iExists M. iApply sep_exist_r. iExists Mρ.
    iAssert (⌜∀ a ρ, Mρ !! a = Some ρ → (uninitialize W m).1 !! a = Some ρ⌝)%I as %Hρcond.
    { iIntros (a' ρ Ha'). assert (is_Some (M !! a')) as [γp HMa'];[apply elem_of_gmap_dom;rewrite -Hdom_mρ;apply elem_of_gmap_dom;eauto|].
      iDestruct (big_sepM_delete with "Hpreds") as "[Ha _]";[apply HMa'|].
      iDestruct "Ha" as (ρ' Hlookup) "[Hρ' _]".
      iDestruct (sts_full_state_std with "Hsts Hρ'") as %Hρ'. simplify_eq. auto. }
    iFrame. rewrite uninitialize_dom. repeat iSplit;auto.
    iApply (big_sepM_mono with "Hpreds").
    iIntros (a' x Hmx) "Ha".
    iDestruct "Ha" as (ρ Hlookup) "[Hstate Ha]".
    iDestruct "Ha" as (φ Hpers) "[#Hsaved Hres]".
    apply Hρcond in Hlookup as Hρ.
    iExists ρ. iSplit;auto. iFrame. iExists φ. repeat iSplit;auto.
    destruct (decide (W.1 !! a' = Some Monotemporary)).
    - destruct (decide (a <= a')%a).
      + assert (is_Some (m !! a')) as [v Hv];[apply Hcond;auto|].
        pose proof (uninitialize_std_sta_lookup_in a' m W.1 v Hv e) as Hmin.
        rewrite Hρ in Hmin. inversion Hmin;subst ρ. iFrame.
      + assert (m !! a' = None) as Hnone.
        { apply eq_None_not_Some. intros Hcontr%Hcond. destruct Hcontr as [? ?]; contradiction. }
        rewrite uninitialize_std_sta_None_lookup in Hρ;auto.
        rewrite e in Hρ. inversion Hρ;subst ρ.
        iDestruct "Hres" as (v v') "Hres".
        iDestruct "Hres" as "(Ha & Ha' & #Hmono & #Hφ)".
        iExists _,_; iFrame "∗ #".
        iApply ("Hmono" with "[] Hφ"). iPureIntro.
        apply related_sts_a_weak_world with a. clear -n;solve_addr. apply uninitialize_related_pub_a. auto.
    - assert (m !! a' = None) as Hnone.
      { apply eq_None_not_Some. intros Hcontr%Hcond. destruct Hcontr as [ ? ?]; contradiction. }
      rewrite uninitialize_std_sta_None_lookup in Hρ;auto.
      rewrite Hρ in n.
      destruct ρ;auto;try contradiction.
      * iDestruct "Hres" as (v v') "Ha".
        iDestruct "Ha" as "(Ha & Ha' & #Hmono & #Hφ)".
        iExists v,v'. iFrame "∗ #". iNext.
        iApply ("Hmono" with "[] Hφ"). iPureIntro.
        apply related_sts_pub_plus_priv_world.
        apply related_sts_a_pub_plus_world with a.
        apply uninitialize_related_pub_a; auto.
  Qed.

  Lemma uninitialize_region_keep W (a : Addr) E :
    region W ∗ sts_full_world W ={E}=∗
    ∃ m, ⌜∀ (a' : Addr), is_Some(m !! a') ↔ (((std W) !! a' = Some Monotemporary) ∧ (a <= a')%a)⌝
      ∗ region (uninitialize W m) ∗ sts_full_world (uninitialize W m)
      ∗ □ ▷ ([∗ map] a↦w ∈ m, □ ∃ φ, ⌜forall Wv, Persistent (φ Wv)⌝ ∗ monotemp_pers_resources W φ a w.1 w.2 ∗ rel a φ).
  Proof.
    iIntros "(Hr & Hsts)".
    iMod (uninitialize_region_states_keep _ _ (region_addrs a addr_reg.top ++ [addr_reg.top])
            with "[] [$Hr $Hsts]") as (m Hconds) "[Hr [Hsts #Hres] ]";[eauto|].
    iModIntro. iExists m.
    assert (∀ (a' : Addr), is_Some(m !! a') ↔ ((W.1 !! a' = Some Monotemporary) ∧ (a <= a')%a)) as Hconds'.
    { intros a'. split.
      - intros Hsome. apply Hconds in Hsome. destruct Hsome as [Hmono Hin].
        apply elem_of_app in Hin as [Hin | Hin];[|apply elem_of_list_singleton in Hin;subst].
        apply elem_of_region_addrs in Hin as [Hin ?]. split;auto.
        split;auto. solve_addr.
      - intros [Hmono Hle]. apply Hconds. split;auto. apply elem_of_app. destruct (decide (a' < addr_reg.top)%a).
        left. apply elem_of_region_addrs;auto. right. assert (a' = addr_reg.top);[solve_addr|subst]. constructor. }
    iDestruct (uninitialize_region_world with "[] Hr Hsts") as "[Hr Hsts]";[eauto|iFrame;auto].
  Qed.

  (* ------------------------------------------------------------------------------------------------- *)
  (* ------------------- A version of uninitialization where we forget the invariants ---------------- *)
  (* ------------------------------------------------------------------------------------------------- *)

  Lemma uninitialize_region_last W E :
    region W ∗ sts_full_world W ={E}=∗ ∃ m, ⌜((∃ (v v': Word), {[addr_reg.top:=(v,v')]} = m) ↔ W.1 !! addr_reg.top = Some Monotemporary)
                                             ∧ (∅ = m <-> W.1 !! addr_reg.top ≠ Some Monotemporary)⌝
                                       ∗ region W ∗ sts_full_world (uninitialize W m).
  Proof.
    iIntros "[Hr Hsts]".
    iMod (uninitialize_region_last_keep with "[$Hr $Hsts]") as (m Hforall) "(Hr & Hsts & Hm)".
    iModIntro. iExists m. iFrame. auto.
  Qed.

  Lemma uninitialize_region_states W (a : Addr) (l : list Addr) E :
    ⌜l = region_addrs a addr_reg.top ++ [addr_reg.top]⌝ -∗
    region W ∗ sts_full_world W ={E}=∗
    ∃ m, ⌜∀ (a' : Addr), is_Some(m !! a') ↔ ((W.1 !! a' = Some Monotemporary) ∧ (a' ∈ l)%a)⌝
         ∗ region W ∗ sts_full_world (uninitialize W m).
  Proof.
    iIntros (Heq) "(Hr & Hsts)".
    iMod (uninitialize_region_states_keep with "[] [$Hr $Hsts]") as (m Hforall) "(Hr & Hsts & Hm)". eauto.
    iModIntro. iExists m. iFrame. auto.
  Qed.

  Lemma uninitialize_region W (a : Addr) E :
    region W ∗ sts_full_world W ={E}=∗
    ∃ m, ⌜∀ (a' : Addr), is_Some(m !! a') ↔ (((std W) !! a' = Some Monotemporary) ∧ (a <= a')%a)⌝
         ∗ region (uninitialize W m) ∗ sts_full_world (uninitialize W m).
  Proof.
    iIntros "(Hr & Hsts)".
    iMod (uninitialize_region_keep with "[$Hr $Hsts]") as (m Hforall) "(Hr & Hsts & Hres)".
    iModIntro. iExists m. iFrame. auto.
  Qed.

  (* ------------------------------------------------------------------------------------------------- *)
  (* -------------- We will want to change the values of an already uninitialized region ------------- *)
  (* ------------------------------------------------------------------------------------------------- *)

  Lemma uninitialized_condition W m a :
    (∀ a' : Addr, is_Some (m !! a') ↔ (W.1 !! a' = Some Monotemporary) ∧ (a <= a')%a) →
    ∀ a'' : Addr, (a <= a'')%a → (uninitialize W m).1 !! a'' ≠ Some Monotemporary.
  Proof.
    intros Hcond.
    intros a'' Hle.
    destruct (m !! a'') eqn:Hsome.
    - assert (is_Some (m !! a'')) as Ha'';[eauto|]. apply Hcond in Ha'' as [Hmono Ha''].
      rewrite (uninitialize_std_sta_lookup_in _ _ _ p);auto.
    - intros Hcontr. rewrite uninitialize_std_sta_None_lookup in Hcontr;auto.
      assert (is_Some (m !! a'')) as [v Hv]. apply Hcond. split;auto.
      rewrite Hsome in Hv. done.
  Qed.

  Lemma valid_uninitialized_condition_weak W m a p g b e b' (w : Word) :
    pwlU p = true → isU p = true → (b' <= b)%a →
    (∀ a' : Addr, is_Some (m !! a') ↔ (W.1 !! a' = Some Monotemporary) ∧ (b' <= a')%a) →
    interp W (inr (p,g,b,e,a),w) -∗ ⌜∀ a', (b <= a' < e)%a → (∃ w, (uninitialize W m).1 !! a' = Some (Uninitialized w))⌝.
  Proof.
    iIntros (HpwlU HU Hle' Hcond) "#Hv".
    iDestruct (interp_eq with "Hv") as %<-.
    iIntros (a' [Hle Hlt]).
    iDestruct (writeLocalAllowedU_implies_local with "Hv") as %Hmono;auto.
    destruct g;inversion Hmono.
    destruct p;inversion HU;inversion HpwlU.
    - rewrite fixpoint_interp1_eq /=. iDestruct "Hv" as "[_ [Hv' Hv]]".
      destruct (decide (a <= a'))%a.
      + iDestruct (big_sepL_elem_of _ _ a' with "Hv") as "[Hcond #Hreg]".
        { apply elem_of_region_addrs. solve_addr. }
        iDestruct "Hreg" as %[Hreg | [? Hreg] ].
        { assert (is_Some (m !! a')) as [v Hv];[apply Hcond;split;auto;solve_addr|].
          rewrite (uninitialize_std_sta_lookup_in _ _ _ v);eauto. }
        { assert (m !! a' = None) as Hv;[|rewrite uninitialize_std_sta_None_lookup//;rewrite Hreg;eauto].
          destruct (m !! a') eqn:Hsome;auto. assert (is_Some (m!!a')) as Hissome;eauto.
          apply Hcond in Hissome as [Heq ?]. rewrite Heq in Hreg;inversion Hreg. }
      + iDestruct (big_sepL_elem_of _ _ a' with "Hv'") as "[Hcond #Hreg]".
        { apply elem_of_region_addrs. solve_addr. }
        iDestruct "Hreg" as %Hreg.
        assert (is_Some (m !! a')) as [v Hv];[apply Hcond;split;auto;solve_addr|].
        rewrite (uninitialize_std_sta_lookup_in _ _ _ v);eauto.
    - rewrite fixpoint_interp1_eq /=. iDestruct "Hv" as "[_ [Hv' Hv]]".
      destruct (decide (a <= a'))%a.
      + iDestruct (big_sepL_elem_of _ _ a' with "Hv") as "[Hcond #Hreg]".
        { apply elem_of_region_addrs. solve_addr. }
        iDestruct "Hreg" as %[Hreg | [? Hreg] ].
        { assert (is_Some (m !! a')) as [v Hv];[apply Hcond;split;auto;solve_addr|].
          rewrite (uninitialize_std_sta_lookup_in _ _ _ v);eauto. }
        { assert (m !! a' = None) as Hv;[|rewrite uninitialize_std_sta_None_lookup//;rewrite Hreg;eauto].
          destruct (m !! a') eqn:Hsome;auto. assert (is_Some (m!!a')) as Hissome;eauto.
          apply Hcond in Hissome as [Heq ?]. rewrite Heq in Hreg;inversion Hreg. }
      + iDestruct (big_sepL_elem_of _ _ a' with "Hv'") as "[Hcond #Hreg]".
        { apply elem_of_region_addrs. solve_addr. }
        iDestruct "Hreg" as %Hreg.
        assert (is_Some (m !! a')) as [v Hv];[apply Hcond;split;auto;solve_addr|].
        rewrite (uninitialize_std_sta_lookup_in _ _ _ v);eauto.
  Qed.

  Lemma valid_readAllowed_condition_weak W m a p g b e b' (w : Word) :
    readAllowed p = true → (b' <= b)%a →
    (∀ a' : Addr, is_Some (m !! a') ↔ (W.1 !! a' = Some Monotemporary) ∧ (b' <= a')%a) →
    interp W (inr (p,g,b,e,a),w) -∗ ⌜∀ a', (b <= a' < e)%a → ((uninitialize W m).1 !! a' = Some Permanent ∨ (∃ w, (uninitialize W m).1 !! a' = Some (Uninitialized w)))⌝.
  Proof.
    iIntros (Hra Hle' Hcond) "#Hv".
    iDestruct (interp_eq with "Hv") as %<-.
    iIntros (a' [Hle Hlt]).
    iDestruct (readAllowed_implies_region_conditions with "Hv") as "Hcond";auto.
    rewrite /region_conditions.
    destruct (pwl p).
    - iDestruct (big_sepL_elem_of _ _ a' with "Hcond") as "[Ha' #Hreg]".
      { apply elem_of_region_addrs. solve_addr. }
      rewrite /region_state_pwl_mono. iDestruct "Hreg" as %Hmono.
      iRight.
      assert (is_Some (m !! a')) as [v Hv];[apply Hcond;split;auto;solve_addr|].
      rewrite (uninitialize_std_sta_lookup_in _ _ _ v);eauto.
    - iDestruct (big_sepL_elem_of _ _ a' with "Hcond") as "[Ha' #Hreg]".
      { apply elem_of_region_addrs. solve_addr. }
      rewrite /region_state_nwl. iDestruct "Hreg" as %Hmono.
      destruct g.
      { iLeft;auto.
        assert (m !! a' = None) as Hv;[|rewrite uninitialize_std_sta_None_lookup//;rewrite Hreg;eauto].
        destruct (m !! a') eqn:Hsome;auto. assert (is_Some (m!!a')) as Hissome;eauto.
        apply Hcond in Hissome as [Heq ?]. rewrite Hmono in Heq. congruence. }
      { iLeft;auto.
        assert (m !! a' = None) as Hv;[|rewrite uninitialize_std_sta_None_lookup//;rewrite Hreg;eauto].
        destruct (m !! a') eqn:Hsome;auto. assert (is_Some (m!!a')) as Hissome;eauto.
        apply Hcond in Hissome as [Heq ?]. rewrite Hmono in Heq. congruence. }
      { destruct Hmono as [Hmono | Hmono].
        + assert (is_Some (m !! a')) as [v Hv];[apply Hcond;split;auto;solve_addr|].
          rewrite (uninitialize_std_sta_lookup_in _ _ _ v);eauto.
        + assert (m !! a' = None) as Hv;[|rewrite uninitialize_std_sta_None_lookup//;rewrite Hmono;eauto].
          destruct (m !! a') eqn:Hsome;auto. assert (is_Some (m!!a')) as Hissome;eauto.
          apply Hcond in Hissome as [Heq ?]. rewrite Hmono in Heq. congruence.
      }
  Qed.

  Lemma valid_uninitialized_condition W m a p g b e w :
    pwlU p = true → isU p = true →
    (∀ a' : Addr, is_Some (m !! a') ↔ (W.1 !! a' = Some Monotemporary) ∧ (b <= a')%a) →
    interp W (inr (p,g,b,e,a),w) -∗ ⌜∀ a', (b <= a' < e)%a → (∃ w, (uninitialize W m).1 !! a' = Some (Uninitialized w))⌝.
  Proof.
    iIntros (HpwlU HU Hcond) "#Hv".
    iApply valid_uninitialized_condition_weak;eauto.
    solve_addr.
  Qed.

  Lemma region_map_uninitialized_monotone W W' M Mρ a :
    related_sts_a_world W W' a →
    (∀ a'', (a <= a'')%a → Mρ !! a'' ≠ Some Monotemporary) →
    region_map_def M Mρ W -∗ region_map_def M Mρ W'.
  Proof.
    iIntros (Hrelated Hcond) "Hr".
    iApply big_sepM_mono; iFrame.
    iIntros (a' γ Hsome) "Hm".
    iDestruct "Hm" as (ρ Hρ) "[Hstate Hm]".
    iExists ρ. iFrame. iSplitR;[auto|].
    destruct ρ.
    - destruct (decide (a' <= a))%a.
      2: { exfalso. assert (a <= a')%a as Hle;[solve_addr|].
           apply Hcond in Hle as ?. congruence. }
      iDestruct "Hm" as (φ Hpers) "(#Hsavedφ & Hl)".
      iDestruct "Hl" as (v1 v2) "(Hl & Hl' & Hmono & Hφ)".
      iExists _. do 2 (iSplitR;[eauto|]).
      iFrame "#". iExists _,_.
      iDestruct "Hmono" as "#Hmono"; iFrame "∗ #";
        iApply "Hmono"; iFrame; auto.
      iPureIntro. eapply related_sts_a_weak_world;eauto.
    - iDestruct "Hm" as (φ Hpers) "(#Hsavedφ & Hl)".
      iDestruct "Hl" as (v v') "(Hl & Hl' & #Hmono & Hφ)".
      iExists _. do 2 (iSplitR;[eauto|]).
      iFrame "∗ #". iExists _,_. iFrame "∗ #".
      iApply "Hmono"; iFrame "∗ #"; auto.
      iPureIntro.
      apply related_sts_pub_plus_priv_world.
      eapply related_sts_a_pub_plus_world;eauto.
    - done.
    - done.
    - done.
  Qed.

  Lemma related_sts_a_uninitialized W a a' w :
    (a <= a')%a →
    (∃ v, W.1 !! a' = Some (Uninitialized v)) →
    related_sts_a_world W (<s[a':=Uninitialized w]s>W) a.
  Proof.
    intros Hle Hcond.
    split;[|apply related_sts_pub_plus_refl].
    split.
    - rewrite dom_insert_L. set_solver.
    - intros i x y Hx Hy.
      destruct (decide (i = a')).
      + subst. rewrite lookup_insert in Hy.
        destruct Hcond as [v Hv]. rewrite Hv in Hx.
        simplify_eq. right with Monotemporary.
        rewrite decide_True;auto. left. constructor.
        eright;[|left]. rewrite decide_True;auto. right. constructor.
      + rewrite lookup_insert_ne// in Hy. rewrite Hx in Hy;inversion Hy. left.
  Qed.

  Lemma uninitialize_open_region_change E W a a' φ v w w' `{∀ Wv, Persistent (φ Wv)}:
    (a <= a')%a →
    (∀ a'', (a <= a'')%a → W.1 !! a'' ≠ Some Monotemporary) →
    rel a' φ
    ∗ open_region a' W
    ∗ sts_full_world W
    ∗ a' ↦ₐ w
    ∗ a' ↣ₐ w'
    ∗ sts_state_std a' (Uninitialized v)
    ={E}=∗
    region (<s[a':=Uninitialized (w,w')]s> W) ∗ sts_full_world (<s[a':=Uninitialized (w,w')]s> W).
  Proof.
    iIntros (Hle Hcond) "(#Hrel & Hreg & Hsts & Ha & Ha' & Hstate)".
    rewrite open_region_eq /open_region_def rel_eq /rel_def REL_eq /REL_def RELS_eq /RELS_def.
    iDestruct "Hrel" as (γpred) "[Hown Hsaved]".
    iDestruct "Hreg" as (M Mρ) "(HM & #Hdom_m & #Hdom_mρ & Hpreds)".
    iDestruct "Hdom_m" as %Hdom_m; iDestruct "Hdom_mρ" as %Hdom_mρ.
    assert (Hle':=Hle).
    apply Hcond in Hle' as Hv.
    iDestruct (sts_full_state_std with "Hsts Hstate") as %Hρ.
    iDestruct (reg_in γrel M with "[$HM $Hown]") as %HMeq.

    iAssert (⌜∀ a ρ, delete a' Mρ !! a = Some ρ ↔ delete a' W.1 !! a = Some ρ⌝)%I as %Hρcond.
    { iIntros (a0 ρ). rewrite iff_to_and.
      iSplit;iIntros (Ha').
      - destruct (decide (a0 = a'));[subst;rewrite lookup_delete in Ha';done|rewrite lookup_delete_ne// in Ha'].
        assert (is_Some (M !! a0)) as [γp HMa'];[apply elem_of_gmap_dom;rewrite -Hdom_mρ;apply elem_of_gmap_dom;eauto|].
        iDestruct (big_sepM_delete with "Hpreds") as "[Ha'' _]";[rewrite lookup_delete_ne// apply HMa'|].
        iDestruct "Ha''" as (ρ' Hlookup) "[Hρ' _]".
        iDestruct (sts_full_state_std with "Hsts Hρ'") as %Hρ';
          rewrite lookup_delete_ne// in Hlookup; rewrite lookup_delete_ne//; simplify_eq; auto.
      - destruct (decide (a0 = a'));[subst;rewrite lookup_delete in Ha';done|rewrite lookup_delete_ne// in Ha'].
        assert (is_Some (M !! a0)) as [γp HMa'];[apply elem_of_gmap_dom;rewrite -Hdom_m;apply elem_of_gmap_dom;eauto|].
        iDestruct (big_sepM_delete with "Hpreds") as "[Ha'' _]";[rewrite lookup_delete_ne// apply HMa'|].
        iDestruct "Ha''" as (ρ' Hlookup) "[Hρ' _]".
        iDestruct (sts_full_state_std with "Hsts Hρ'") as %Hρ'. rewrite Ha' in Hρ'. inversion Hρ'. auto. }

    iDestruct (region_map_insert_nonmonostatic (Uninitialized (w,w')) with "Hpreds") as "Hpreds";[intros;auto|].
    iDestruct (region_map_uninitialized_monotone _ (<s[a':=Uninitialized (w,w')]s>W) _ _ a with "Hpreds") as "Hpreds".
    { apply related_sts_a_uninitialized;auto. rewrite Hρ. eauto. }
    { intros a'' Ha''. destruct (decide (a'' = a')); subst;simplify_map_eq;eauto.
      intros Hcontr. specialize (Hρcond a'' Monotemporary).
      apply Hcond in Ha''. rewrite !lookup_delete_ne// in Hρcond. apply Hρcond in Hcontr. contradiction. }

    iMod (sts_update_std _ _ _ (Uninitialized (w,w')) with "Hsts Hstate") as "[Hsts Hstate]".
    iModIntro. iFrame.

    iDestruct (big_sepM_insert _ (delete a' M) a' with "[-HM]") as "test";
      first by rewrite lookup_delete.
    { iFrame. iExists _. iFrame.
      iSplit;[iPureIntro;apply lookup_insert|].
      iExists _. iFrame "∗ #". repeat iSplitR; auto. }
    rewrite -HMeq. rewrite region_eq /region_def RELS_eq /RELS_def. iExists _,_; iFrame. iPureIntro.
    repeat rewrite dom_insert_L. rewrite Hdom_m Hdom_mρ.
    assert (a' ∈ dom (gset Addr) M) as Hin;[rewrite HMeq dom_insert_L;clear;set_solver|].
    split;clear -Hin;set_solver.
  Qed.

End heap.


(* --------------------------------------------------------------------
 * Copyright (c) - 2017--2020 - Xavier Allamigeon <xavier.allamigeon at inria.fr>
 * Copyright (c) - 2017--2020 - Ricardo D. Katz <katz@cifasis-conicet.gov.ar>
 * Copyright (c) - 2019--2020 - Pierre-Yves Strub <pierre-yves@strub.nu>
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra finmap.
Require Import extra_misc inner_product lrel.

Import Order.Theory.

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

Local Open Scope ring_scope.
Import Order.TTheory GRing.Theory Num.Theory.

(* -------------------------------------------------------------------- *)
Declare Scope polyh_scope.
Delimit Scope polyh_scope with PH.

Local Open Scope polyh_scope.

(* -------------------------------------------------------------------- *)
Reserved Notation "''affine[' R ]_ n"
  (at level 8, n at level 2, format "''affine[' R ]_ n").
Reserved Notation "''affine[' R ]"
  (at level 8, format "''affine[' R ]").
Reserved Notation "''affine_' n"
  (at level 8, format "''affine_' n").
Reserved Notation "[ 'affine' I ]" (at level 0, format "[ 'affine'  I ]").
Reserved Notation "[ 'affine' U & Ω ]"
         (at level 0, format "[ 'affine'  U  &  Ω ]").
Reserved Notation "[ 'hp' e ]" (at level 0, format "[ 'hp'  e ]").
Reserved Notation "[ 'pt' Ω ]" (at level 0, format "[ 'pt'  Ω ]").
Reserved Notation "[ 'line' c & Ω ]"  (at level 0, format "[ 'line'  c  &  Ω ]").

Reserved Notation "'[' 'affine0' ']'" (at level 0).
Reserved Notation "'[' 'affineT' ']'" (at level 0).

(* -------------------------------------------------------------------- *)
Reserved Notation "\polyI_ i F"
  (at level 41, F at level 41, i at level 0,
           format "'[' \polyI_ i '/  '  F ']'").
Reserved Notation "\polyI_ ( i <- r | P ) F"
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \polyI_ ( i  <-  r  |  P ) '/  '  F ']'").
Reserved Notation "\polyI_ ( i <- r ) F"
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \polyI_ ( i  <-  r ) '/  '  F ']'").
Reserved Notation "\polyI_ ( m <= i < n | P ) F"
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \polyI_ ( m  <=  i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\polyI_ ( m <= i < n ) F"
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \polyI_ ( m  <=  i  <  n ) '/  '  F ']'").
Reserved Notation "\polyI_ ( i | P ) F"
  (at level 41, F at level 41, i at level 50,
           format "'[' \polyI_ ( i  |  P ) '/  '  F ']'").
Reserved Notation "\polyI_ ( i : t | P ) F"
  (at level 41, F at level 41, i at level 50).
Reserved Notation "\polyI_ ( i : t ) F"
  (at level 41, F at level 41, i at level 50).
Reserved Notation "\polyI_ ( i < n | P ) F"
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \polyI_ ( i  <  n  |  P ) '/  '  F ']'").
Reserved Notation "\polyI_ ( i < n ) F"
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \polyI_ ( i  <  n )  F ']'").
Reserved Notation "\polyI_ ( i 'in' A | P ) F"
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \polyI_ ( i  'in'  A  |  P ) '/  '  F ']'").
Reserved Notation "\polyI_ ( i 'in' A ) F"
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \polyI_ ( i  'in'  A ) '/  '  F ']'").

Reserved Notation "x `<=` y `<=` z" (at level 70, y, z at next level).
Reserved Notation "x `<=` y `<` z" (at level 70, y, z at next level).
Reserved Notation "x `<` y `<=` z" (at level 70, y, z at next level).
Reserved Notation "x `<` y `<` z" (at level 70, y, z at next level).

Reserved Notation "x `>=` y" (at level 70, y at next level).
Reserved Notation "x `>` y" (at level 70, y at next level).

Reserved Notation "x `<=` y :> T" (at level 70, y at next level).
Reserved Notation "x `<` y :> T" (at level 70, y at next level).
Reserved Notation "x `>=` y :> T" (at level 70, y at next level).
Reserved Notation "x `>` y :> T" (at level 70, y at next level).

Reserved Notation "x `>=<` y" (at level 70, y at next level).
Reserved Notation "x `><` y" (at level 70, y at next level).

Reserved Notation "`<=` y" (at level 35).
Reserved Notation "`>=` y" (at level 35).
Reserved Notation "`<` y" (at level 35).
Reserved Notation "`>` y" (at level 35).
Reserved Notation "`>=<` y" (at level 35).
Reserved Notation "`><` y" (at level 35).
Reserved Notation "`<=` y :> T" (at level 35, y at next level).
Reserved Notation "`>=` y :> T" (at level 35, y at next level).
Reserved Notation "`<` y :> T" (at level 35, y at next level).
Reserved Notation "`>` y :> T" (at level 35, y at next level).
Reserved Notation "`>=<` y :> T" (at level 35, y at next level).
Reserved Notation "`><` y :> T" (at level 35, y at next level).

Reserved Notation "x `<=` y ?= 'iff' c"
  (at level 70, y, c at next level,
       format "x '[hv'  `<=`  y '/'  ?=  'iff'  c ']'").

Reserved Notation "x `<=` y ?= 'iff' c :> T"
  (at level 70, y, c at next level,
       format "x '[hv'  `<=`  y '/'  ?=  'iff'  c  :> T ']'").

(* -------------------------------------------------------------------- *)
Fact polyh_display : unit. Proof. exact: tt. Qed.

Notation poly_0    := (@Order.bottom polyh_display) (only parsing).
Notation poly_1    := (@Order.top polyh_display) (only parsing).
Notation poly_le   := (@Order.le polyh_display _) (only parsing).
Notation poly_lt   := (@Order.lt polyh_display _) (only parsing).
Notation poly_ge   := (@Order.ge polyh_display _) (only parsing).
Notation poly_gt   := (@Order.gt polyh_display _) (only parsing).
Notation poly_leif := (@Order.leif polyh_display _) (only parsing).
Notation poly_cmp  := (@Order.comparable polyh_display _) (only parsing).
Notation poly_meet := (@Order.meet polyh_display _).

Notation "<=%PH"  := poly_le   : fun_scope.
Notation ">=%PH"  := poly_ge   : fun_scope.
Notation "<%PH"   := poly_lt   : fun_scope.
Notation ">%PH"   := poly_gt   : fun_scope.
Notation "<?=%PH" := poly_leif : fun_scope.
Notation ">=<%PH" := poly_cmp  : fun_scope.
Notation "><%PH"  := (fun x y => ~~ (poly_cmp x y)) : fun_scope.

Notation "`<=` y" := (poly_ge y) : polyh_scope.
Notation "`<=` y :> T" := (`<=` (y : T)) (only parsing) : polyh_scope.
Notation "`>=` y"  := (poly_le y) : polyh_scope.
Notation "`>=` y :> T" := (`>=` (y : T)) (only parsing) : polyh_scope.

Notation "`<` y" := (poly_gt y) : polyh_scope.
Notation "`<` y :> T" := (`<` (y : T)) (only parsing) : polyh_scope.
Notation "`>` y" := (poly_lt y) : polyh_scope.
Notation "`>` y :> T" := (`>` (y : T)) (only parsing) : polyh_scope.

Notation "`>=<` y" := (poly_cmp y) : polyh_scope.
Notation "`>=<` y :> T" := (`>=<` (y : T)) (only parsing) : polyh_scope.

Notation "`><` y" := (fun x => ~~ (poly_cmp y x)) : polyh_scope.
Notation "`><` y :> T" := (`><` (y : T)) (only parsing) : polyh_scope.

Notation "x `<=` y" := (poly_le x y) : polyh_scope.
Notation "x `<=` y :> T" := ((x : T) `<=` (y : T)) (only parsing) : polyh_scope.
Notation "x `>=` y" := (y `<=` x) (only parsing) : polyh_scope.
Notation "x `>=` y :> T" := ((x : T) `>=` (y : T)) (only parsing) : polyh_scope.

Notation "x `<` y"  := (poly_lt x y) : polyh_scope.
Notation "x `<` y :> T" := ((x : T) `<` (y : T)) (only parsing) : polyh_scope.
Notation "x `>` y"  := (y `<` x) (only parsing) : polyh_scope.
Notation "x `>` y :> T" := ((x : T) `>` (y : T)) (only parsing) : polyh_scope.

Notation "x `<=` y `<=` z" := ((x `<=` y) && (y `<=` z)) : polyh_scope.
Notation "x `<` y `<=` z" := ((x `<` y) && (y `<=` z)) : polyh_scope.
Notation "x `<=` y `<` z" := ((x `<=` y) && (y `<` z)) : polyh_scope.
Notation "x `<` y `<` z" := ((x `<` y) && (y `<` z)) : polyh_scope.

Notation "x `<=` y ?= 'iff' C" := (poly_leif x y C) : polyh_scope.
Notation "x `<=` y ?= 'iff' C :> R" := ((x : R) `<=` (y : R) ?= iff C)
  (only parsing) : polyh_scope.

Notation "x `>=<` y" := (poly_cmp x y) : polyh_scope.
Notation "x >< y" := (~~ (poly_cmp x y)) : polyh_scope.

Notation "P `&` Q" := (poly_meet P Q) (at level 48, left associativity) : polyh_scope.

Notation "\meet_ ( i <- r | P ) F" :=
  (\big[poly_meet/poly_1]_(i <- r | P%B) F).
Notation "\meet_ ( i <- r ) F" :=
  (\big[poly_meet/poly_1]_(i <- r) F).
Notation "\meet_ ( i | P ) F" :=
  (\big[poly_meet/poly_1]_(i | P%B) F).
Notation "\meet_ i F" :=
  (\big[poly_meet/poly_1]_i F).
Notation "\meet_ ( i : I | P ) F" :=
  (\big[poly_meet/poly_1]_(i : I | P%B) F) (only parsing).
Notation "\meet_ ( i : I ) F" :=
  (\big[poly_meet/poly_1]_(i : I) F) (only parsing).
Notation "\meet_ ( m <= i < n | P ) F" :=
 (\big[poly_meet/poly_1]_(m <= i < n | P%B) F).
Notation "\meet_ ( m <= i < n ) F" :=
 (\big[poly_meet/poly_1]_(m <= i < n) F).
Notation "\meet_ ( i < n | P ) F" :=
 (\big[poly_meet/poly_1]_(i < n | P%B) F).
Notation "\meet_ ( i < n ) F" :=
 (\big[poly_meet/poly_1]_(i < n) F).
Notation "\meet_ ( i 'in' A | P ) F" :=
 (\big[poly_meet/poly_1]_(i in A | P%B) F).
Notation "\meet_ ( i 'in' A ) F" :=
 (\big[poly_meet/poly_1]_(i in A) F).

Section Solve.

Variable (R : realFieldType) (n : nat) (V : {vspace lrel[R]_n}).

Let base := vbasis V.

Definition sat x :=
   all (fun e : lrel => '[e.1, x] == e.2) base.

Lemma sum_lrel_fst m (v : 'I_m -> lrel[R]_n) : (* RK : I have added this auxiliary lemma. Should it be somewhere else? *)
  (\sum_(i < m) v i).1 = (\sum_(i < m) (v i).1).
Proof.
by apply: (@big_morph _ lrel[R]_n (fun y => y.1)).
Qed.

(*TODO : change the name, and maybe put this lemma somewhere else *)
Lemma sum_lrel_fst_gen (F : finType) (P : pred F) (v : F -> lrel[R]_n) :
  (\sum_(i : F | P i) v i).1 = (\sum_(i : F | P i) (v i).1).
Proof. by apply: (@big_morph _ lrel[R]_n (fun y => y.1)). Qed.

Lemma sum_lrel_snd m (v : 'I_m -> lrel[R]_n) : (* RK : I have added this auxiliary lemma. Should it be somewhere else? *)
  (\sum_(i < m) v i).2 = (\sum_(i < m) (v i).2).
Proof.
by apply: (@big_morph _ lrel[R]_n (fun y => y.2)).
Qed.

Lemma sum_lrel_snd_gen (F : finType) (P : pred F) (v : F -> lrel[R]_n) :
  (\sum_(i : F | P i) v i).2 = (\sum_(i : F | P i) (v i).2).
Proof. by apply: (@big_morph _ lrel[R]_n (fun y => y.2)). Qed.

Lemma size_vbasis_dim : (* RK : I have added this auxiliary lemma, since I could not find it even if it is quite natural. Should it be somewhere else? *)
  size (vbasis V) = \dim V.
Proof.
apply/eqP; rewrite eqn_leq.
move: (vbasisP V) => basis_of_vbasis.
apply/andP; split.
- rewrite basisEdim in basis_of_vbasis.
  exact: (proj2 (andP basis_of_vbasis)).
- rewrite basisEfree in basis_of_vbasis.
  exact: (proj2 (andP (proj2 (andP basis_of_vbasis)))).
Qed.

Lemma satP x :
  reflect (forall e, e \in V -> '[e.1, x] = e.2) (sat x).
Proof. (* RK *)
apply/(iffP idP) => [/allP sat_x e e_in_V | sat_in_V ].
- rewrite (coord_vbasis e_in_V) sum_lrel_fst sum_lrel_snd vdot_sumDl.
  apply: eq_bigr => i _; rewrite vdotZl.
  apply/(congr1 (fun y => coord (vbasis V) i e * y))/eqP/sat_x/mem_nth.
  by rewrite size_vbasis_dim.
- apply/allP => e ?.
  by apply/eqP/(sat_in_V e)/vbasis_mem.
Qed.

Let A := (\matrix_i (tnth base i).1^T)^T.
Let b := (\row_i (tnth base i).2).

Lemma satE x : sat x = (b == x^T *m A).
Proof. (* RK *)
apply/idP/idP => [/allP sat_x |/eqP/rowP b_eq].
- apply/eqP/trmx_inj/colP => j.
  rewrite trmx_mul -row_vdot trmxK rowK 2!trmxK !mxE.
  symmetry; apply/eqP/sat_x/mem_nth.
  by rewrite size_vbasis_dim.
- apply/satP => e e_in_V.
  rewrite (coord_vbasis e_in_V) sum_lrel_fst sum_lrel_snd vdot_sumDl.
  apply: eq_bigr => i _; rewrite vdotZl.
  apply/(congr1 (fun y => coord (vbasis V) i e * y)).
  move: (b_eq i) => b_eq_i; rewrite mxE (tnth_nth 0%R) in b_eq_i.
  by rewrite b_eq_i -trmx_mul mxE -row_vdot rowK (tnth_nth 0%R) trmxK.
Qed.

Definition is_sat := (b <= A)%MS.

Lemma is_satP :
  reflect (exists x, sat x) is_sat.
Proof.
apply/(iffP idP).
- move => h_sat.
  exists (b *m pinvmx A)^T; by rewrite satE trmxK mulmxKpV.
- case => x; rewrite satE => /eqP sat_x.
  by apply/submxP; exists x^T.
Qed.

Lemma is_satPn :
  reflect (sat =1 pred0) (~~ is_sat).
Proof.
apply/(iffP idP).
- move => satN x /=; apply/negbTE.
  move: satN; apply/contra => sat_x.
  by apply/is_satP; exists x.
- move => sat0.
  by apply/negP; case/is_satP => x; rewrite sat0.
Qed.

End Solve.

Arguments satP {R n V x}.
Arguments is_satP {R n V}.
Arguments is_satPn {R n V}.

Section Lift.

Variable (R : realFieldType) (n : nat).

Definition be_lift0 (x: 'cV[R]_n) := fun v => [<v, '[v,x]>].

Lemma be_lift0_linear x : lmorphism (be_lift0 x).
Proof.
by split; move => v w; rewrite /be_lift0 ?beaddE ?bescaleE ?vdotBl ?vdotZl.
Qed.

Definition be_lift x := linfun (Linear (be_lift0_linear x)).

Lemma befstE x : (befst \o (be_lift x) = \1)%VF.
Proof.
apply/lfunP => v.
by rewrite comp_lfunE !lfunE.
Qed.

Lemma be_liftE W x :
  sat W x -> ((be_lift x) @: (befst @: W))%VS = W.
Proof. (* RK *)
move/satP => sat_x.
have be_liftE_on_W u: u \in W -> be_lift x (befst u) = u.
  move => u_in_W.
  rewrite !lfunE; apply/eqP/be_eqP; split; first by done.
  exact: (sat_x _ u_in_W).
apply/vspaceP => w.
apply/idP/idP => [/memv_imgP [? /memv_imgP [v v_in_W] ->] ->| w_in_W].
- by rewrite (be_liftE_on_W _ v_in_W).
- apply/memv_imgP; exists (fst (be_lift0 x (fst w))).
  + by apply/memv_imgP; exists w; [done | rewrite lfunE].
  + by rewrite -(be_liftE_on_W _ w_in_W) !lfunE.
Qed.

(*Lemma dim_be_lift W Ω : (\dim ((be_lift Ω) @: W) = \dim W)%N.
Proof.
apply/limg_dim_eq/subv_anti/andP; split; rewrite ?sub0v //.
apply/subvP => v; rewrite memv_cap memv_ker => /andP [h /eqP].
move/(congr1 befst); rewrite -comp_lfunE befstE id_lfunE linear0 => ->.
by rewrite memv0.
Qed.*)

End Lift.

Module Core.
Section Core.
Context {R : realFieldType} (n : nat).

Variant type :=
| Affine0
| Affine (I : {vspace lrel[R]_n}) of is_sat I.

Definition type_of of phant R := type.
Notation  "''affine[' R ]" := (type_of (Phant R)).

Definition eq_vect V :=
  match V with
  | Affine0 => let e := [<0, 1>] in <[ e ]>%VS
  | Affine eqV _ => eqV
  end.

Definition affine V :=
  if (@idP (is_sat V)) is ReflectT H then
    Affine H
  else Affine0.

Definition affine_of (phR : phant R) := affine : _ -> type_of phR.

Lemma eq_vectK : cancel eq_vect affine.
Proof.
move => V; rewrite /eq_vect.
case: V.
- set e := [<0, 1>].
  suff /negP h: ~~ (is_sat <[e]>).
  rewrite /affine; case: {-}_/idP => //.
  apply/is_satPn; move => x /=.
  apply/negbTE/negP; move/satP/(_ _ (memv_line _)) => /= /eqP.
  by rewrite vdot0l eq_sym oner_eq0.
- move => V h; rewrite /affine.
  case: {-}_/idP => // h'.
  by apply/congr1/bool_irrelevance.
Qed.

Definition affine_eqMixin := (CanEqMixin eq_vectK).
Canonical affine_eqType := EqType type affine_eqMixin.
Definition affine_choiceMixin := (CanChoiceMixin eq_vectK).
Canonical affine_choiceType := ChoiceType type affine_choiceMixin.

Identity Coercion type_of_type : type_of >-> type.
Canonical affine_of_eqType := [eqType of 'affine[R]].
Canonical affine_of_choiceType := [choiceType of 'affine[R]].

Definition affine_pred_sort (S : type) : {pred 'cV[R]_n} :=
  match S with
  | Affine0 => pred0
  | Affine eqV _ => sat eqV
  end.

End Core.

Module Import Exports.
Coercion affine_pred_sort : type >-> pred_sort.
Canonical affine_eqType.
Canonical affine_choiceType.
Canonical affine_of_eqType.
Canonical affine_of_choiceType.
End Exports.
End Core.

Export Core.Exports.
Notation "''affine[' R ]_ n" := (Core.type_of n (Phant R)).
Notation "''affine[' R ]"    := 'affine[R]_(_).
Notation "''affine_' n"      := 'affine[_]_n.
Notation "[ 'affine' I ]"    := (@Core.affine_of _ _ (Phant _) I%VS).
Notation "'eq_vect'"         := Core.eq_vect (at level 8).

Section Specs.

Context {R : realFieldType} {n : nat}.

Implicit Type (x : 'cV[R]_n) (e : lrel[R]_n)
         (U : {vspace lrel[R]_n}) (V : 'affine[R]_n)
         (W : {vspace 'cV[R]_n}).

Definition affine0 : 'affine[R]_n := (Core.Affine0 _).

Lemma in_affine0 x : x \in affine0 = false.
Proof.
by [].
Qed.

Lemma affineN0 V :
  reflect (exists x, x \in V) (V != affine0).
Proof.
apply/(iffP idP).
- by case: V => [/eqP //| U U_sat _]; apply/is_satP.
- by case => x; apply/contraTneq => ->; rewrite in_affine0.
Qed.

Lemma in_affineE U x :
  (x \in [affine U]) = sat U x.
Proof.
rewrite /Core.affine_of /Core.affine.
case: {-}_/idP => [// | /negP/is_satPn ->].
by rewrite in_affine0.
Qed.

Lemma in_affineP {U x} :
  reflect (forall e, e \in U -> '[e.1, x] = e.2) (x \in [affine U]).
Proof.
rewrite in_affineE; exact: satP.
Qed.

Variant affine_spec : 'affine[R]_n -> bool -> Type :=
| Affine0 : affine_spec affine0 true
| Affine U of (exists x, x \in [affine U]) : affine_spec [affine U] false.

Lemma affineP V : affine_spec V (V == affine0).
Proof.
case: V => [| U U_sat].
- rewrite eq_refl; constructor.
- have ->: (Core.Affine U_sat) = [affine U].
    rewrite /Core.affine_of /Core.affine; case: {-}_/idP => // ?.
    apply/congr1; exact: bool_irrelevance.
  suff h: exists x, x \in [affine U].
    have /negbTE ->: [affine U] != affine0 by apply/affineN0.
    by constructor.
  case/is_satP : U_sat => x x_in; exists x.
  by rewrite in_affineE.
Qed.

Lemma affine_is_sat U :
  [affine U] != affine0 = is_sat U.
Proof.
rewrite /Core.affine_of /Core.affine; case: {-}_/idP.
- move => is_sat; rewrite is_sat.
  by apply/eqP.
- move/negP/negbTE ->.
  by rewrite eq_refl.
Qed.

Definition mk_affine W Ω : 'affine[R]_n :=
  [affine ((be_lift Ω) @: W^OC)%VS].

Notation "[ 'affine' W & Ω ]" := (mk_affine W Ω) : polyh_scope.

Lemma in_mk_affine W Ω x :
  (x \in [affine W & Ω]) = (x - Ω \in W).
Proof.
apply/in_affineP/idP => [h|].
- rewrite -[W]orthK; apply/orthvP => y.
  move/(memv_img (be_lift Ω))/h; rewrite lfunE /= => /eqP.
  by rewrite -subr_eq0 -vdotBr => /eqP.
- rewrite -{1}[W]orthK => /orthvP h.
  move => v /memv_imgP [{}v /h eq0 ->].
  rewrite vdotBr in eq0.
  by move/subr0_eq: eq0; rewrite lfunE /=.
Qed.

Lemma in_mk_affineP {W Ω x} :
  reflect (exists2 d, d \in W & x = Ω + d) (x \in [affine W & Ω]).
Proof.
rewrite in_mk_affine; apply/(iffP idP) => [?|[?? ->]].
- by exists (x - Ω); last rewrite addrC subrK.
- by rewrite addrC addKr.
Qed.

Lemma orig_affine W Ω : Ω \in [affine W & Ω].
Proof.
by rewrite in_mk_affine addrN mem0v.
Qed.

Lemma mk_affineN0 W Ω :
  [affine W & Ω] != affine0.
Proof.
by apply/affineN0; exists Ω; apply/orig_affine.
Qed.

Definition dir V :=
  match affineP V with
  | Affine0 => 0%VS
  | Affine U _ => (befst @: U)^OC%VS
  end.

Lemma dir0 : dir affine0 = 0%VS.
Proof.
rewrite /dir.
by case/affineP: affine0 (eq_refl (affine0 : 'affine[R]_n)).
Qed.

Lemma in_dirP V x :
  x \in V -> forall d, (d \in dir V) = (x + d \in V).
Proof.
rewrite /dir; case/affineP: V; rewrite ?in_affine0 ?in_affine //.
move => U _ /in_affineP x_in d.
apply/idP/in_affineP.
- move/orthvP => h v v_in_U.
  move/(_ (befst v) (memv_img _ v_in_U)): h.
  rewrite vdotDr lfunE => ->; rewrite addr0.
  by apply/x_in.
- move => h; apply/orthvP => c c_in.
  pose e := (be_lift x) c.
  have e_in_U: e \in U.
  + move/satP: x_in => /be_liftE <-.
    by apply/memv_img.
  move/(_ _ e_in_U): h.
  rewrite vdotDr; move/(_ _ e_in_U): x_in ->.
  move/(canRL (addKr _)); rewrite addNr.
  by rewrite /e lfunE.
Qed.

Lemma dir_mk_affine W Ω :
  dir [affine W & Ω] = W.
Proof.
apply/vspaceP => d.
rewrite (in_dirP (orig_affine W Ω)) in_mk_affine.
by rewrite addrAC addrN add0r.
Qed.

Lemma mk_affine_dir V x :
  x \in V -> V = [affine (dir V) & x].
Proof.
rewrite /dir; case/affineP: V; rewrite ?in_affine0 //.
move => U _ x_in.
apply/congr1; rewrite orthK.
by rewrite be_liftE //; rewrite in_affineE in x_in.
Qed.

Lemma dir_eq V V' x :
  x \in V -> x \in V' -> dir V = dir V' -> V = V'.
Proof.
by move => /mk_affine_dir {2}-> /mk_affine_dir {2}-> ->.
Qed.

Inductive mk_affine_spec : 'affine[R]_n -> {vspace 'cV[R]_n} -> Prop :=
| MkAffine0 : mk_affine_spec affine0 0%VS
| MKAffineN0 W Ω : mk_affine_spec [affine W & Ω] W.

Lemma mk_affineP V : mk_affine_spec V (dir V).
Proof.
case/affineP: V => [| U [x]].
- rewrite dir0; constructor.
- by move/mk_affine_dir => {1}->; constructor.
Qed.

Lemma affine_eqP V V' :
  (V =i V') <-> (V = V').
Proof.
split; last by move ->.
case/mk_affineP: V.
- move => ext_eq.
  apply/contraTeq: isT => /=.
  rewrite eq_sym; case/affineN0 => x.
  by rewrite -ext_eq; rewrite in_affine0.
- move => W Ω ext_eq.
  have Ω_in_V' : Ω \in V'.
  + by rewrite -ext_eq orig_affine.
  apply/(dir_eq (orig_affine _ _)) => //.
  apply/vspaceP => d.
  rewrite (in_dirP Ω_in_V') dir_mk_affine -ext_eq in_mk_affine.
  by rewrite addrAC addrN add0r.
Qed.

Definition affineI V V' :=
  match affineP V, affineP V' with
  | Affine0, _ => affine0
  | _, Affine0 => affine0
  | Affine U _, Affine U' _ => [affine (U + U')]
  end.

Lemma in_affineI x V V' :
  x \in affineI V V' = (x \in V) && (x \in V').
Proof.
rewrite /affineI.
case: (affineP V) => [| U _]; case: (affineP V') => [| U' _];
  rewrite ?in_affine0 ?andbF //.
apply/in_affineP/andP => [x_in| [x_in x_in']].
- by split; apply/in_affineP => e e_in; apply/x_in;
    move: e_in; apply/subvP; rewrite ?addvSl ?addvSr.
  (* TODO: add mem_addvl and mem_addvr statements  to vector.v *)
- move => ? /memv_addP [e1 e1_in] [e2 e2_in] -> /=.
  by rewrite vdotDl; apply: congr2; [apply/(in_affineP x_in) | apply/(in_affineP x_in')].
Qed.

Definition affine_le V V' := (V == affineI V V').

Lemma affine_leP {V V'} : reflect {subset V <= V'} (affine_le V V').
Proof.
apply/(iffP eqP).
- move/affine_eqP => eq x.
  by rewrite eq in_affineI => /andP[].
- move => sub; apply/affine_eqP => x.
  rewrite in_affineI.
  by apply/idP/andP => [?|[] //]; split => //; apply/sub.
Qed.

End Specs.

Notation "[ 'affine' W & Ω ]" := (mk_affine W Ω) : polyh_scope.

Module Order.
Section Order.

Context {R : realFieldType} {n : nat}.

Implicit Type (V : 'affine[R]_n).

Lemma affine_le_refl : reflexive (@affine_le R n).
Proof.
by move => ?; apply/affine_leP.
Qed.

Lemma affine_le_anti : antisymmetric (@affine_le R n).
Proof.
move => V V' /andP [/affine_leP sub /affine_leP sub'].
by apply/affine_eqP => x; apply/idP/idP; [apply/sub | apply/sub'].
Qed.

Lemma affine_le_trans : transitive (@affine_le R n).
Proof. (* RK *)
move => ? ? ? /affine_leP subset1 /affine_leP subset2.
by apply/affine_leP => ? ?; apply/subset2/subset1.
Qed.

Definition affine_LtPOrderMixin :=
  LePOrderMixin (fun _ _ => erefl _) affine_le_refl affine_le_anti affine_le_trans.

Canonical affine_POrderType :=
  Eval hnf in POrderType polyh_display 'affine[R]_n affine_LtPOrderMixin.

Program Definition affine_bottomMixin :=
  @BottomMixin polyh_display [porderType of 'affine[R]_n] affine0 _.

Next Obligation.
by apply/affine_leP => v; rewrite in_affine0.
Qed.

Program Canonical affine_PBOrderType :=
  Eval hnf in BPOrderType 'affine[R]_n affine_bottomMixin.

Program Definition affine_meetMixin :=
  @MeetMixin _ _ affineI _ _ _.

Next Obligation.
by move => V V'; apply/affine_eqP => x; rewrite !in_affineI andbC.
Qed.

Next Obligation.
by move => V1 V2 V3; apply/affine_eqP => x; rewrite !in_affineI andbA.
Qed.

Next Obligation.
apply/affine_leP/eqP => [|<-].
+ move=> le_xy; apply/affine_eqP=> c; rewrite in_affineI.
  by apply: andb_idr; apply: le_xy.
+ by move => c; rewrite in_affineI => /andP[].
Qed.

Canonical affine_MeetSemilatticeType :=
  Eval hnf in MeetSemilatticeType 'affine[R]_n affine_meetMixin.

Canonical affine_bMeetSemilatticeType := [bMeetSemilatticeType of 'affine[R]_n].
End Order.

Module Import Exports.
Canonical affine_POrderType.
Canonical affine_PBOrderType.
Canonical affine_MeetSemilatticeType.
Canonical affine_bMeetSemilatticeType.
End Exports.
End Order.

Export Order.Exports.

Notation "'[' 'affine0' ']'" := affine0.

Section BasicObjects.

Context {R : realFieldType} {n : nat}.

Implicit Type (Ω d : 'cV[R]_n) (e : lrel[R]_n)
         (U : {vspace lrel[R]_n}) (V : 'affine[R]_n).

Lemma affineS :
  {homo (@Core.affine _ _: {vspace lrel[R]_n} -> 'affine[R]_n) : U V / (U <= V)%VS >-> (U `>=` V)}.
Proof. (* RK *)
move => ? ? /subvP Hsubset; apply/affine_leP => ?.
move/in_affineP => Hin_affime.
apply/in_affineP =>  ? ?.
by apply/Hin_affime/Hsubset.
Qed.

Lemma dir_affine U :
  [affine U] `>` [affine0] -> dir [affine U] = (befst @: U)^OC%VS.
Proof. (* RK *)
move/andP => [? _].
have aff_U_neq0: exists x : 'cV_n, x \in [affine U] by apply/affineN0.
move: aff_U_neq0 => [? in_aff_U].
apply/vspaceP => d; rewrite (in_dirP in_aff_U).
apply/idP/orthvP => [/in_affineP in_aff ? /memv_imgP [u u_in_U] ->| H].
- rewrite lfunE /=; move/eqP: (in_aff _ u_in_U).
  by rewrite vdotDr ((in_affineP in_aff_U) _ u_in_U) -subr_eq0 [X in X-_]addrC -addrA subrr addr0 => /eqP <-.
- apply/in_affineP => u u_in_U.
  rewrite vdotDr ((in_affineP in_aff_U) _ u_in_U).
  suff ->: '[ u.1, d] = 0 by rewrite addr0.
  by apply/H/memv_imgP; exists u; [exact: u_in_U | rewrite lfunE].
Qed.

Lemma affine_proper0P V :
  reflect (exists x, x \in V) (V `>` [affine0]).
Proof.
rewrite lt0x; exact: affineN0.
Qed.

Lemma mk_affine_proper0 Ω W :
  [affine W & Ω] `>` [affine0].
Proof.
apply/affine_proper0P; exists Ω; exact: orig_affine.
Qed.

Lemma mk_affineS Ω : { mono (mk_affine^~ Ω) : W W' / (W <= W')%VS >-> (W `<=` W') }.
Proof. (* RK *)
move => ? ?; apply/affine_leP/subvP => [Hsubset w ? | Hsubset ?].
- rewrite -[w]addr0 -(subrr Ω) addrA -in_mk_affine addrC.
  by apply/Hsubset/in_mk_affineP; exists w.
- by rewrite !in_mk_affine; apply: Hsubset.
Qed.

Lemma dirS V V' : (V `<=` V') -> (dir V <= dir V')%VS.
Proof. (* RK *)
case/affineP: V => [_  |U [? Hin_affine] /affine_leP Hsubset];
  rewrite ?dir0 ?sub0v //.
by apply/subvP => ?; rewrite (in_dirP Hin_affine) (in_dirP (Hsubset _ Hin_affine)); apply/Hsubset.
Qed.

Lemma affine_mono U U' :
  [affine U] `>` [affine0] -> [affine U] `<=` [affine U'] = (U' <= U)%VS.
Proof.
move => U_neq0.
apply/idP/idP; last by apply/affineS.
move => U_sub_U'.
have U'_neq0: [affine U'] `>` [affine0] by apply/lt_le_trans: U_sub_U'.
move/dirS: (U_sub_U'); rewrite ?dir_affine // orthS.
case/affine_proper0P : U_neq0 => x x_in_U.
have x_in_U' : x \in [affine U'] by apply/(affine_leP U_sub_U').
by move/(limgS (be_lift x)); rewrite ?be_liftE -?in_affineE.
Qed.

Notation "'[' 'hp' e  ']'" := [affine <[e]> ].

Lemma in_hp :
  (forall e x, (x \in [hp e]) = ('[e.1,x] == e.2))
  * (forall c α (x : 'cV[R]_n), (x \in [hp [<c, α>]]) = ('[c,x] == α)).
Proof. (* RK *)
split => [ e x | c α x]; apply/in_affineP/idP => [in_hp | /eqP in_hp ? /vlineP [?] ->];
  rewrite ?vdotZl ?in_hp ?memv_line //.
by apply/eqP/(in_hp [<c, α>])/memv_line.
Qed.

Lemma hpN (e : lrel[R]_n) : [hp -e] = [hp e].
Proof.
by apply/affine_eqP => x; rewrite !in_hp /= vdotNl eqr_opp.
Qed.

Lemma be_lift_hp (x : 'cV[R]_n) (e : lrel[R]_n) :
  x \in [hp e] -> (be_lift x (befst e)) = e.
Proof.
rewrite lfunE /= /be_lift0 lfunE /=.
by rewrite in_hp => /eqP ->; rewrite beE.
Qed.

Lemma affineS1 (U : {vspace lrel[R]_n}) e :
  e \in U -> ([affine U] `<=` [hp e]).
Proof. (* RK *)
by apply/affineS.
Qed.

Definition affineT : 'affine[R]_n := [hp 0].

Notation "'[' 'affineT' ']'" := affineT : polyh_scope.

Lemma in_affineT x : x \in affineT = true.
Proof.
by rewrite in_hp vdot0l eq_refl.
Qed.

Lemma dir_affineT : dir affineT = fullv.
Proof.
have nullv_in_affineT : 0 \in affineT by rewrite in_affineT.
by apply/vspaceP => ?; rewrite memvf (in_dirP nullv_in_affineT) in_affineT.
Qed.

Program Definition affine_topMixin :=
  @TopMixin polyh_display [porderType of 'affine[R]_n] affineT _.

Next Obligation. by apply/affine_leP=> ? _; rewrite in_affineT. Qed.

Canonical affine_tPOrderType := TPOrderType 'affine[R]_n affine_topMixin.
Canonical affine_tbPOrderType := [tbPOrderType of 'affine[R]_n].

Canonical affine_tMeetSemilatticeType := [tMeetSemilatticeType of 'affine[R]_n].
Canonical affine_tbMeetSemilatticeType := [tbMeetSemilatticeType of 'affine[R]_n].

Lemma in_big_affineIP (I : finType) (P : pred I) (F : I -> 'affine[R]_n) x :
  reflect (forall i : I, P i -> x \in (F i)) (x \in \meet_(i | P i) (F i)).
Proof.
apply: (iffP idP) => [? i Pi | x_in_F].
- by apply: (affine_leP (meets_inf F Pi)).
- elim/big_rec: _ => [|i V Pi ?]; first by rewrite in_affineT.
  by rewrite in_affineI; apply/andP; split; [apply: (x_in_F i) | done].
Qed.

Lemma in_big_affineI (I : finType) (P : pred I) (F : I -> 'affine[R]_n) x :
  (x \in \meet_(i | P i) (F i)) = [forall i, P i ==> (x \in F i)].
Proof. (* RK *)
apply/in_big_affineIP/idP.
- by move => Hforall; apply/forallP => i; apply/implyP/Hforall.
- by move/forallP => Hforall i; apply/implyP/Hforall.
Qed.

Lemma affine_span (I : base_t[R,n]) :
  [affine <<I>>] = \meet_(e : I) [hp (val e)].
Proof. (* RK *)
apply/affine_eqP => x.
rewrite in_affineE.
apply/idP/idP => [/satP sat_I | /in_big_affineIP in_all_hps].
- apply/in_big_affineIP => i _; rewrite (fst (in_hp)).
  by apply/eqP/(sat_I (val i))/memv_span/valP.
- apply/satP => e e_in.
  rewrite (coord_span e_in) sum_lrel_fst sum_lrel_snd vdot_sumDl /=.
  apply: eq_bigr => i _.
  have in_enum_fset_I: (I`_i) \in (enum_fset I) by apply/memt_nth.
  rewrite vdotZl; apply/congr1/eqP; rewrite -(fst (in_hp)).
  by apply: (in_all_hps (FSetSub in_enum_fset_I)).
Qed.

Lemma affine_vbasis (U : {vspace lrel[R]_n}) :
  let base := [fset e in ((vbasis U) : seq _)]%fset : {fset lrel[R]_n} in
  [affine U] = [affine << base >>].
Proof.
set base := [fset e in ((vbasis U) : seq _)]%fset : {fset lrel[R]_n}.
suff ->: U = << base >>%VS by [].
move: (vbasisP U) => /andP [/eqP <- _].
apply/subv_anti/andP; split; apply/sub_span; by move => ?; rewrite inE.
Qed.

Notation "'[' 'line' d & Ω ']'" := [affine <[d]> & Ω].

Lemma in_lineP {d Ω x : 'cV[R]_n} :
  reflect (exists μ, x = Ω + μ *: d) (x \in [line d & Ω]).
Proof.
apply/(iffP in_mk_affineP) => [[y /vlineP [μ ->]]| [μ ->] ].
+ by exists μ.
+ by exists (μ *: d); rewrite ?memvZ ?memv_line.
Qed.

Lemma line_subset_hp e v v' :
  (v \in [hp e]) -> (v' \in [hp e]) -> ([line (v' - v) & v] `<=` [hp e]).
Proof.
rewrite !in_hp => /eqP v_in /eqP v'_in.
apply/affine_leP => ? /in_lineP [μ -> ]; rewrite in_hp.
by rewrite vdotDr vdotZr vdotBr v_in v'_in addrN mulr0 addr0.
Qed.

Notation "'[' 'pt' Ω ']'" := [affine 0%VS & Ω].

Lemma in_pt Ω x : (x \in [pt Ω]) = (x == Ω).
Proof.
by rewrite in_mk_affine memv0 subr_eq0.
Qed.

End BasicObjects.

Notation "'[' 'hp' e  ']'" := [affine <[e]> ] : polyh_scope.
Notation "'[' 'line' d & Ω ']'" := [affine <[d]> & Ω] : polyh_scope.
Notation "'[' 'pt' Ω ']'" := [affine 0%VS & Ω] : polyh_scope.
Notation "'[' 'affineT' ']'" := (@affineT _ _) : polyh_scope.

Section Dimension.

Context {R : realFieldType} {n : nat}.

Implicit Type (V : 'affine[R]_n) (U : {vspace lrel[R]_n}).

Definition adim V :=
  if V == [affine0] then 0%N
  else (\dim (dir V)).+1%N.

Lemma adim0 : adim [affine0] = 0%N.
Proof.
by rewrite /adim ifT //.
Qed.

Lemma adimN0 V : (adim V > 0)%N = (V `>` affine0).
Proof.
by rewrite /adim; case: ifP => [/eqP -> // |]; rewrite lt0x => ->.
Qed.

Lemma adim_eq0 V : adim V = 0%N -> V = [affine0].
Proof.
by rewrite /adim; case: ifP => [/eqP ->|].
Qed.

Lemma adimN0_eq V : V `>` [affine0] -> adim V = (\dim (dir V)).+1%N.
Proof.
by rewrite lt0x /adim => /negbTE ->.
Qed.

Lemma adimS : {homo adim : V V' / (V `<=` V') >-> (V <= V')%N}.
Proof.
move => V V' sub.
rewrite /adim; case: ifPn => // V_neq0.
have V'_neq0: V' != [affine0].
- move: V_neq0; apply/contra_neq => V'_eq0.
  by rewrite V'_eq0 lex0 in sub; move/eqP: sub.
rewrite ifF ?ltnS; last by apply/negbTE.
by apply/dimvS/dirS.
Qed.

Lemma adim_leqif_eq V V' :
  (V `<=` V') -> (adim V <= adim V' ?= iff (V == V'))%N.
Proof.
move => V_sub_V'; split; rewrite ?adimS //.
apply/eqP/eqP; last by move => ->.
rewrite {1}/adim; case: ifP.
- by move/eqP ->; symmetry; apply/adim_eq0.
- move/negbT => V_neq0.
  have V'_neq0: V' != [affine0].
    rewrite -!lt0x in V_neq0 *.
    by apply/lt_le_trans: V_sub_V'.
  rewrite /adim ifF; last by apply/negbTE.
  move/succn_inj => adim_dir_eq.
  suff: dir V = dir V'.
  - case/affineN0: V_neq0 => x x_in.
    by apply/(dir_eq x_in)/(affine_leP V_sub_V').
  - by apply/eqP; rewrite -(eq_leqif (dimv_leqif_eq (dirS _))) ?adim_dir_eq.
Qed.

Lemma sub_geq_adim V V' :
  (V `<=` V') -> (adim V >= adim V')%N -> V = V'.
Proof. (* RK *)
move => V_sub_V' adimV_gte_adimV'; apply/eqP/contraT => V_neq_V'.
by move/leqifP: (adim_leqif_eq V_sub_V'); rewrite ifF;
  [rewrite ltnNge adimV_gte_adimV' | apply/negbTE].
Qed.

Lemma sub_eq_adim V V' :
  (V `<=` V') -> adim V = adim V' -> V = V'.
Proof. (* RK *)
move => ? adimV_eq_adimV'.
by apply/sub_geq_adim; [done | rewrite adimV_eq_adimV'].
Qed.

Lemma adim_affine_lt V V' :
  (V `<` V') -> (adim V < adim V')%N.
Proof. (* RK *)
move/andP => [V'_neq_V ?].
rewrite ltn_neqAle; apply/andP; split; last by apply/adimS.
move: V'_neq_V; apply/contra_neqN => /eqP ?; symmetry.
by apply/sub_eq_adim.
Qed.

Lemma adim_line Ω d : adim [line d & Ω] = (d != 0).+1.
Proof.
rewrite /adim ifF; last by apply/negbTE/mk_affineN0.
by rewrite dir_mk_affine dim_vline.
Qed.

Lemma affine_addv U U' :
  [affine (U + U')] = [affine U] `&` [affine U'].
Proof.
apply/affine_eqP=> x; rewrite in_affineI.
apply/in_affineP/andP.
- by move=> x_in_UU'; split; apply/in_affineP => e e_in;
     apply: x_in_UU'; apply/subvP: e_in; rewrite ?addvSl ?addvSr.
- case=> /in_affineP x_in_U /in_affineP x_in_U' e /memv_addP.
  case=> [e0 e0_in_U] [e1 e1_in_U'] -> /=.
  by rewrite vdotDl; apply: congr2; by [exact: x_in_U | exact: x_in_U'].
Qed.

Lemma dim_affineI V e :
  let V' := V `&` [hp e] in
  ~~ (V `<=` [hp e]) -> V' `>` [affine0] ->
  adim V = (adim V').+1%N.
Proof.
case/affineP: V; rewrite ?le0x // => [U] _ /= U_subN_e V'_prop0.
have [U_prop0 e_prop0]:
  ([affine0] `<` [affine U]) /\ ([affine0] `<` [hp e]).
- by split; apply: (lt_le_trans V'_prop0); rewrite ?leIl ?leIr.
have e_notin: (befst e \notin befst @: U)%VS.
- move: U_subN_e; apply: contraNN.
  case/affine_proper0P: V'_prop0 => x.
  rewrite in_affineI => /andP [x_in_U x_in_e].
  move/(memv_img (be_lift x)).
  rewrite be_liftE -?in_affineE ?be_lift_hp //.
  exact: affineS.
rewrite -affine_addv in V'_prop0 *.
rewrite ?adimN0_eq ?dir_affine //; apply congr1; rewrite !dim_orthv.
move/dir_affine: V'_prop0.
rewrite limgD limg_line.
move/(canLR orthK)/(congr1 (@dimv _ _)).
rewrite dim_add_line // => dim_eq.
by rewrite subnSK -?dim_eq ?dim_leqn.
Qed.

Lemma adim_pt Ω : adim [pt Ω] = 1%N.
Proof.
by rewrite adim_line eq_refl.
Qed.

Lemma dimv_eq1P (K : fieldType) (vT : vectType K) (V : {vspace vT}) :
  reflect (exists2 v, v != 0 & V = <[v]>%VS) (\dim V == 1%N).
(* TODO: move to extra_vector.v *)
Proof.
apply/(iffP idP) => [/eqP dim_V_eq1 |[? neq0 ->]];
  last by rewrite dim_vline neq0.
have : ~~ (V <= 0)%VS.
  move: dim_V_eq1; apply/contra_eqN.
  by rewrite subv0; move/eqP => ->; rewrite dimv0.
move/subvPn => [v ? v_not_in_V].
exists v; first by move: v_not_in_V; apply/contra; rewrite memv0.
apply/eqP; rewrite eqEsubv; apply/andP; split;
  last by rewrite -memvE.
suff ->: (V = <[v]>)%VS by done.
apply/eqP; rewrite eq_sym eqEdim; apply/andP; split;
  first by rewrite -memvE.
suff ->: \dim <[v]> = 1%N by rewrite dim_V_eq1.
rewrite memv0 in v_not_in_V.
by rewrite dim_vline v_not_in_V.
Qed.

Lemma adim2P V :
  adim V = 2%N -> exists Ω, exists2 d, d != 0 & V = [line d & Ω].
Proof. (* RK *)
move => adim_V_eq2.
have V_neq0 : V != affine0.
  apply/contraT => V_eq0; rewrite negbK in V_eq0.
  by rewrite (eqP V_eq0) adim0 in adim_V_eq2.
have dim_dir_V_eq1: (\dim (dir V)) = 1%N
  by apply/eq_add_S; rewrite /adim ifF // in adim_V_eq2; apply/negbTE.
move/eqP/dimv_eq1P: (dim_dir_V_eq1) => [d ? dir_V_eq].
move/affineN0: V_neq0 => [Ω Ω_in_V].
exists Ω; exists d; first by done.
by rewrite -dir_V_eq; apply/mk_affine_dir.
Qed.

Lemma adim1P V :
  adim V = 1%N -> exists Ω, V = [pt Ω].
Proof. (* RK *)
move => adim_V_eq1.
have V_neq0 : V != affine0.
  apply/contraT => V_eq0; rewrite negbK in V_eq0.
  by rewrite (eqP V_eq0) adim0 in adim_V_eq1.
move: (affineN0 _ V_neq0) => [Ω Ω_in_V].
exists Ω.
suff <-: (dir V) = 0%VS by apply/mk_affine_dir.
apply/eqP; rewrite -dimv_eq0.
by apply/eqP/eq_add_S; rewrite /adim ifF // in adim_V_eq1; apply/negbTE.
Qed.

Lemma adim_leSn V :
  (adim V <= n.+1)%N.
Proof. (* RK *)
rewrite /adim; case: (boolP (V == affine0)) => [_|_]; first by done.
rewrite ltnS.
by apply/(@leq_trans (n * 1)); [apply/rank_leq_col | rewrite muln1].
Qed.

Lemma dim_affine_le (U : {vspace lrel[R]_n}) :
  [affine U] `>` [affine0] -> (\dim U <= n)%N.
Proof. (* RK *)
apply/contraTT; rewrite -ltnNge lt0x negbK => dimU.
have {dimU} -> : U = fullv
  by apply/eqP; rewrite eqEdim; apply/andP; split;
    [exact: subvf | rewrite dimvf /Vector.dim /= addn1].
apply/eqP/affine_eqP => x; rewrite in_affine0; apply/negbTE/negP.
pose e := [<0, 1>]: lrel[R]_n.
have e_in_U: e \in fullv by rewrite memvf.
move/in_affineP/(_ _ e_in_U); rewrite vdot0l /= => /esym/eqP.
by rewrite oner_eq0.
Qed.

Lemma adimT : (adim affineT = n.+1)%N.
Proof. (* RK *)
rewrite /adim ifF.
- by rewrite dir_affineT dimvf /Vector.dim /= muln1.
- apply/(contraFF _ (erefl false)).
  move/eqP/affine_eqP => aff_eq.
  by move: (aff_eq 0); rewrite in_affine0 in_affineT.
Qed.

Lemma adimTP V : adim V = n.+1%N -> V = affineT.
Proof. (* RK *)
rewrite -adimT => ?.
apply/sub_eq_adim; last by done.
by apply/affine_leP => ?; rewrite in_affineT.
Qed.

Lemma adim_hp e :
  [hp e] `>` [affine0] -> adim [hp e] = ((e.1 == 0%R) + n)%N.
Proof. (* RK *)
move => hp_neq0.
rewrite /adim ifF; last by apply/negbTE; move/andP: hp_neq0 => [? _].
case: (boolP (e.1 == 0)) => [/eqP e1_eq0 | e1_neq0].
- suff ->: [hp e] = affineT
    by rewrite dir_affineT dimvf /Vector.dim /= muln1 add1n.
  apply/affine_eqP => ?; rewrite in_affineT in_hp e1_eq0 vdot0l.
  move/affineN0: (proj1 (andP hp_neq0)) => [?].
  by rewrite in_hp e1_eq0 vdot0l => ?.
- case: (boolP (0 < n)%N) => [? | n_eq0].
  + rewrite /adim (dir_affine hp_neq0) dim_orthv.
    have ->: ((befst @: <[e]>) = <[e.1]>)%VS
      by rewrite limg_line lfunE.
    rewrite dim_vline e1_neq0 add0n subn1.
    by apply/prednK.
  + rewrite -eqn0Ngt in n_eq0.
    rewrite extra_matrix.col_neq_0 in e1_neq0.
    move/existsP: e1_neq0 => [i _].
    by rewrite (eqP n_eq0) in i; move: (ord0_false i).
Qed.

Lemma subset_hp (V : {fset 'cV[R]_n}) :
  (0 < #|` V | <= n)%N ->
  exists2 e : lrel[R]_n, (e.1 != 0) & {subset V <= [hp e]}.
Proof.
rewrite cardfs_gt0 => /andP [/fset0Pn [v v_in] cardV_le].
pose U := <<[seq w - v | w <- (V `\ v)%fset]>>%VS.
have: ((\dim U).+1 <= n)%N.
- apply/leq_trans: cardV_le.
  have ->: #|` V| = #|` (V `\  v)|%fset.+1%N by rewrite (@cardfsD1 _ v) v_in.
  rewrite ltnS; apply/(leq_trans (dim_span _)).
  by rewrite size_map.
rewrite -subn_gt0 -dim_orthv lt0n dimv_eq0 => h.
pose c := vpick (U^OC)%VS.
pose e := [< c, '[c,v] >]; exists e; first by rewrite vpick0.
move => w; case/altP : (w =P v) => [-> _| w_neq_v w_in_V].
- by rewrite in_hp.
- rewrite in_hp /=.
  have ->: w = v + (w - v) by rewrite addrCA addrN addr0.
  rewrite vdotDr; suff ->: '[c, w-v] = 0 by rewrite addr0.
  rewrite vdotC; apply/(orthvP (V := U)); first exact: memv_pick.
  by rewrite memv_span //; apply/map_f; rewrite !inE w_neq_v.
Qed.

End Dimension.