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

Require Export milieu.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter DR : Type.
Parameter droite : PO -> PO -> DR.

Axiom
  droite_permute : forall A B : PO, A <> B :>PO -> droite A B = droite B A.
#[export] Hint Resolve droite_permute: geo.

Axiom
  alignes_droite :
    forall A B C : PO,
    A <> B :>PO -> A <> C :>PO -> alignes A B C -> droite A B = droite A C.

Lemma alignes_droite2 :
 forall A B C : PO,
 A <> B :>PO -> B <> C :>PO -> alignes A B C -> droite A B = droite B C.
intros.
rewrite droite_permute; auto.
apply alignes_droite; auto with geo.
Qed.
#[export] Hint Resolve alignes_droite alignes_droite2: geo.
Parameter paralleles : DR -> DR -> Prop.

Axiom
  def_paralleles :
    forall (A B C D : PO) (k : R),
    A <> B :>PO ->
    C <> D :>PO ->
    add_PP (cons 1 B) (cons (-1) A) = add_PP (cons k D) (cons (- k) C) ->
    paralleles (droite A B) (droite C D).

Axiom
  def_paralleles2 :
    forall A B C D : PO,
    A <> B :>PO ->
    C <> D :>PO ->
    paralleles (droite A B) (droite C D) ->
    exists k : R,
      add_PP (cons 1 B) (cons (-1) A) = add_PP (cons k D) (cons (- k) C) :>PP.

Lemma paralleles_refl :
 forall A B : PO, A <> B :>PO -> paralleles (droite A B) (droite A B).
intros A B H; try assumption.
apply def_paralleles with (k := 1); auto.
Qed.
#[export] Hint Resolve paralleles_refl: geo.

Lemma paralleles_sym :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 paralleles (droite A B) (droite C D) -> paralleles (droite C D) (droite A B).
intros A B C D H H1 H0; try assumption.
elim def_paralleles2 with (3 := H0); intros; auto.
elim (classic (x = 0)); intros.
rewrite H3 in H2.
absurd (A = B); auto.
apply conversion_PP with (a := 1) (b := 1); auto.
RingPP1 H2; RingPP; auto with *.
auto with *.
apply def_paralleles with (k := / x); auto.
apply mult_PP_regulier with x; auto.
VReplace (mult_PP x (add_PP (cons 1 D) (cons (-1) C)))
 (add_PP (cons x D) (cons (- x) C)).
rewrite <- H2.
FieldPP x.
Qed.

Lemma paralleles_trans :
 forall A B C D E F : PO,
 A <> B ->
 C <> D :>PO ->
 E <> F :>PO ->
 paralleles (droite A B) (droite C D) ->
 paralleles (droite C D) (droite E F) -> paralleles (droite A B) (droite E F).
intros A B C D E F H H10 H11 H0 H1; try assumption.
elim def_paralleles2 with (3 := H0); intros; auto.
elim def_paralleles2 with (3 := H1); intros; auto.
apply def_paralleles with (k := x * x0); auto.
rewrite H2.
elim (classic (x = 0)); intros.
rewrite H4 in H2.
absurd (A = B); auto.
apply conversion_PP with (a := 1) (b := 1); auto.
RingPP1 H2; RingPP; auto with *.
auto with *.
replace (add_PP (cons x D) (cons (- x) C)) with
 (mult_PP x (add_PP (cons 1 D) (cons (-1) C))).
rewrite H3.
RingPP.
RingPP.
Qed.

Lemma paralleles_vecteur :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 paralleles (droite A B) (droite C D) ->
 exists k : R, vec A B = mult_PP k (vec C D) :>PP.
unfold vec in |- *; intros.
elim def_paralleles2 with (3 := H1); auto.
intros k H2; try assumption.
exists k.
RingPP1 H2; RingPP.
Qed.

Lemma colineaires_paralleles :
 forall (k : R) (A B C D : PO),
 A <> B :>PO ->
 C <> D :>PO ->
 vec A B = mult_PP k (vec C D) -> paralleles (droite A B) (droite C D).
unfold vec in |- *; intros.
apply def_paralleles with k; auto.
RingPP1 H1; RingPP.
Qed.

Lemma alignes_paralleles :
 forall A B C : PO,
 A <> B -> A <> C -> alignes A B C -> paralleles (droite A B) (droite A C).
intros.
apply paralleles_sym; auto.
halignes H1 x.
apply colineaires_paralleles with x; intros; auto.
Qed.

Lemma paralleles_ABBA :
 forall A B : PO, A <> B -> paralleles (droite A B) (droite B A).
intros.
apply def_paralleles with (-1); auto.
RingPP.
Qed.
#[export] Hint Immediate paralleles_ABBA paralleles_sym: geo.

Lemma non_paralleles_trans :
 forall A B C D E F : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 E <> F :>PO ->
 paralleles (droite A B) (droite C D) ->
 ~ paralleles (droite A B) (droite E F) ->
 ~ paralleles (droite C D) (droite E F).
intros; red in |- *; intros.
apply H3.
apply paralleles_trans with (4 := H2); auto.
Qed.
#[export] Hint Resolve alignes_paralleles: geo.

Lemma paralleles_alignes :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 paralleles (droite A B) (droite C D) -> alignes A B C -> alignes A B D.
intros.
elim (paralleles_vecteur (A:=C) (B:=D) (C:=A) (D:=B)); intros; auto with geo.
halignes H2 x0.
apply colineaire_alignes with (x + x0).
VReplace (vec A D) (add_PP (vec A C) (vec C D)).
rewrite H3; rewrite H4; Ringvec.
Qed.

Lemma paralleles_alignes1 :
 forall A B C D E F : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 vec E F = vec A B :>PP ->
 paralleles (droite A B) (droite C D) -> alignes C D E -> alignes C D F.
intros A B C D E F H H0 H1 H2 H3; try assumption.
elim (paralleles_vecteur (A:=A) (B:=B) (C:=C) (D:=D)); intros; auto.
halignes H3 x0.
apply colineaire_alignes with (x0 + x).
VReplace (vec C F) (add_PP (vec C E) (vec E F)).
rewrite H5; rewrite H1; rewrite H4.
Ringvec.
Qed.

Lemma paralleles_alignes2 :
 forall A B C D E F : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 vec E F = vec A B :>PP ->
 paralleles (droite A B) (droite C D) -> alignes C D E -> alignes F C E.
intros A B C D E F H H0 H1 H2 H3; try assumption.
elim (paralleles_vecteur (A:=C) (B:=D) (C:=A) (D:=B)); intros; auto with geo.
halignes H3 x0.
rewrite H4 in H5.
discrimine F C.
cut (1 + x0 * x <> 0); intros.
apply colineaire_alignes with (/ (1 + x0 * x)).
VReplace (vec F C) (add_PP (vec F E) (mult_PP (-1) (vec C E))).
VReplace (vec F E) (mult_PP (-1) (vec E F)).
rewrite H1; rewrite H5.
Fieldvec (1 + x0 * x).
red in |- *; intros; apply H6.
apply vecteur_nul_conf.
VReplace (vec F C) (add_PP (mult_PP (-1) (vec E F)) (mult_PP (-1) (vec C E))).
rewrite H1; rewrite H5.
VReplace
 (add_PP (mult_PP (-1) (vec A B))
    (mult_PP (-1) (mult_PP x0 (mult_PP x (vec A B)))))
 (mult_PP (-1) (mult_PP (1 + x0 * x) (vec A B))).
rewrite H7; Ringvec.
Qed.

Lemma paralleles_alignes3 :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 paralleles (droite A B) (droite C D) -> alignes C D A -> alignes A C B.
intros A B C D H H0 H1 H2; try assumption.
elim (paralleles_vecteur (A:=A) (B:=B) (C:=C) (D:=D)); intros; auto.
discrimine C A.
assert (alignes C A D); auto with geo.
halignes H5 x0.
rewrite H6 in H3.
apply colineaire_alignes with (- (x * x0)).
rewrite H3; Ringvec.
Qed.

Lemma alignes_paralleles_confondus :
 forall A B C J : PO,
 triangle A B C ->
 alignes A C J -> paralleles (droite B C) (droite B J) -> J = C :>PO.
intros.
cut (triangle B C A); auto with geo; intros.
deroule_triangle B C A.
apply (concours_unique (A:=B) (B:=A) (A1:=C) (B1:=C) (I:=J) (J:=C));
 auto with geo.
cut (B <> J); intros.
elim paralleles_vecteur with (A := B) (B := J) (C := B) (D := C);
 [ intros k0 H8 | auto | auto | auto with geo ].
apply colineaire_alignes with k0; auto.
cut (triangle A C B); auto with geo; intros.
deroule_triangle A C B.
red in |- *; intros; apply H8.
rewrite H12; auto.
Qed.
Parameter concours : DR -> DR -> Prop.

Axiom
  def_concours :
    forall A B C D I : PO,
    A <> B ->
    C <> D ->
    alignes A B I -> alignes C D I -> concours (droite A B) (droite C D).

Axiom
  def_concours2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    concours (droite A B) (droite C D) ->
    exists I : PO, alignes A B I /\ alignes C D I.

Lemma paralleles_non_concours :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 ~ alignes A B D ->
 paralleles (droite C D) (droite A B) -> ~ concours (droite C D) (droite A B).
intros A B C D H10 H11 H H0.
elim def_paralleles2 with (3 := H0); intros; auto.
unfold not in |- *; intros.
elim def_concours2 with (3 := H2); intros; auto.
elim H3; [ intros H4 H5; try clear H3; try exact H5 ].
elim H4; clear H4; (unfold alignes1 in |- *; intros); [ tauto | idtac ].
elim H3; [ intros k H4; try clear H3; try exact H4 ].
elim H5; clear H5; (unfold alignes1 in |- *; intros); [ tauto | idtac ].
elim H3; [ intros k0 H5; try clear H3; try exact H5 ].
apply H.
cut
 (add_PP (cons k0 A) (cons (1 + - k0) B) =
  add_PP (cons k C) (cons (1 + - k) D)); intros.
unfold alignes, alignes1 in |- *.
right; try assumption.
exists (k0 + - (x * k)).
pattern 1 at 1 in |- *.
replace 1 with (k + (1 + - k)); try ring.
replace (cons (k + (1 + - k)) D) with (add_PP (cons k D) (cons (1 + - k) D)).
replace (cons k D) with (mult_PP k (cons 1 D)).
RingPP1 H1.
replace (cons (k0 + - (x * k)) A) with
 (add_PP (cons k0 A) (cons (- (x * k)) A)).
replace (1 + - (k0 + - (x * k))) with (1 + - k0 + x * k); try ring.
RingPP1 H3.
RingPP.
RingPP.
RingPP.
RingPP.
rewrite <- H4; auto.
Qed.

Lemma concours_non_paralleles :
 forall A B C D : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 ~ alignes A B D ->
 concours (droite C D) (droite A B) -> ~ paralleles (droite C D) (droite A B).
intros A B C D H10 H20 H H0; try assumption.
cut (~ ~ concours (droite C D) (droite A B)); intros.
unfold not in |- *; intros.
apply H1.
apply paralleles_non_concours; auto.
intuition.
Qed.
Parameter pt_intersection : DR -> DR -> PO.

Axiom
  def_pt_intersection :
    forall A B C D I : PO,
    A <> B ->
    C <> D ->
    ~ alignes A B C \/ ~ alignes A B D ->
    alignes A B I ->
    alignes C D I -> I = pt_intersection (droite A B) (droite C D).

Axiom
  def_pt_intersection2 :
    forall A B C D I : PO,
    A <> B ->
    C <> D ->
    ~ alignes A B C \/ ~ alignes A B D ->
    I = pt_intersection (droite A B) (droite C D) ->
    alignes A B I /\ alignes C D I.

Lemma existence_pt_intersection :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 ~ alignes A B C \/ ~ alignes A B D ->
 concours (droite A B) (droite C D) ->
 exists I : PO, I = pt_intersection (droite A B) (droite C D) :>PO.
intros.
elim def_concours2 with (A := A) (B := B) (C := C) (D := D);
 [ intros I H3; elim H3; intros H4 H5; try clear H3 def_concours2;
    try exact H5
 | auto
 | auto
 | auto ].
exists I.
apply def_pt_intersection; auto.
Qed.

Lemma ordre_alignement_4points :
 forall A B C D : PO,
 A <> B :>PO ->
 alignes A B C /\ alignes A B D -> alignes C D A /\ alignes C D B.
intros.
elim H0; intros H1 H2; try clear H0; try exact H2.
split; [ try assumption | idtac ].
eauto with geo.
eauto with geo.
Qed.

Lemma pt_intersection_commute :
 forall A B C D I : PO,
 A <> B :>PO ->
 C <> D :>PO ->
 ~ alignes A B C \/ ~ alignes A B D ->
 I = pt_intersection (droite A B) (droite C D) :>PO ->
 I = pt_intersection (droite C D) (droite A B) :>PO.
intros.
elim def_pt_intersection2 with (A := A) (B := B) (C := C) (D := D) (I := I);
 [ try clear def_pt_intersection2; intros | auto | auto | auto | auto ].
apply def_pt_intersection; auto.
apply not_and_or; auto.
cut (~ (alignes A B C /\ alignes A B D)); intros.
red in |- *; intros; apply H5.
apply ordre_alignement_4points; auto.
apply or_not_and; auto.
Qed.

Lemma concours_barycentre :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 concours (droite A B) (droite C D) ->
 exists I : PO,
   ex
     (fun a : R =>
      ex
        (fun b : R =>
         I = barycentre (cons (1 + - a) A) (cons a B) :>PO /\
         I = barycentre (cons (1 + - b) C) (cons b D) :>PO)).
intros A B C D H10 H11 H; try assumption.
elim def_concours2 with (3 := H); auto.
intros I H0; elim H0; intros H1 H2; clear H0 H; try exact H2.
elim alignes_barycentre with (A := A) (B := B) (C := I);
 [ intros a H; try clear alignes_barycentre; try exact H | auto | auto ].
elim alignes_barycentre with (A := C) (B := D) (C := I);
 [ intros b H'; try clear alignes_barycentre | auto | auto ].
exists I; exists (1 + - a); exists (1 + - b).
replace (1 + - (1 + - a)) with a; try ring.
replace (1 + - (1 + - b)) with b; try ring.
split; [ try assumption | try assumption ].
Qed.

Lemma barycentre_concours :
 forall (a b c d : R) (A B C D I : PO),
 A <> B ->
 C <> D :>PO ->
 a + b <> 0 :>R ->
 barycentre (cons a A) (cons b B) = I :>PO ->
 c + d <> 0 :>R ->
 barycentre (cons c C) (cons d D) = I :>PO ->
 concours (droite A B) (droite C D).
intros a b c d A B C D I H H0 H1 H2 H3 H4; try assumption.
apply def_concours with I; auto.
rewrite <- H2.
apply barycentre_alignes; auto.
rewrite <- H4.
apply barycentre_alignes; auto.
Qed.

Lemma add_PP_concours :
 forall (a b c d : R) (A B C D I : PO),
 A <> B :>PO ->
 C <> D :>PO ->
 a + b <> 0 :>R ->
 add_PP (cons a A) (cons b B) = cons (a + b) I :>PP ->
 c + d <> 0 :>R ->
 add_PP (cons c C) (cons d D) = cons (c + d) I :>PP ->
 concours (droite A B) (droite C D).
intros a b c d A B C D I H H0 H1 H2 H3 H4; try assumption.
apply def_concours with I; auto.
apply add_PP_alignes with (a := a) (b := b); auto.
apply add_PP_alignes with (a := c) (b := d); auto.
Qed.

Lemma concours_mediane :
 forall A B C : PO,
 A <> milieu B C :>PO ->
 milieu A B <> C :>PO ->
 concours (droite A (milieu B C)) (droite (milieu A B) C).
intros A B C H H0; try assumption.
generalize (add_PP_milieu_asso A B C); intros.
generalize
 (add_PP_concours (a:=1) (b:=2) (c:=2) (d:=1) (A:=A) (B:=
    milieu B C) (C:=milieu A B) (D:=C)
    (I:=barycentre (cons 1 A) (cons 2 (milieu B C))));
 intros H8; apply H8; auto.
try discrR; auto with *.
rewrite add_PP_barycentre; try discrR; auto with *.
try discrR; auto with *.
rewrite <- H1; auto.
rewrite add_PP_barycentre; try discrR; auto with *.
apply cons_comp; try ring; auto.
Qed.

Definition concours_3 (A B C D E F : PO) :=
  exists I : PO, alignes A B I /\ alignes C D I /\ alignes E F I.

Lemma concours_3_mediane :
 forall A B C : PO, concours_3 A (milieu B C) (milieu A B) C (milieu A C) B.
intros A B C; try assumption.
generalize (add_PP_milieu_asso A B C); intros.
generalize (add_PP_milieu_permute A B C); intros.
unfold concours_3 in |- *.
exists (barycentre (cons 1 A) (cons 2 (milieu B C))).
split; [ try assumption | idtac ].
apply barycentre_alignes; try discrR; auto with *.
split; [ try assumption | idtac ].
apply add_PP_alignes with (a := 2) (b := 1); try discrR; auto with *.
rewrite <- H; auto.
rewrite add_PP_barycentre; try discrR; auto with *.
apply cons_comp; (try ring; auto).
apply add_PP_alignes with (a := 2) (b := 1); try discrR; auto with *.
rewrite <- H0; auto.
rewrite add_PP_barycentre; try discrR; auto with *.
apply cons_comp; try ring; auto.
Qed.

Lemma concours_3_barycentre :
 forall (a b c : R) (A B C : PO),
 a + (b + c) <> 0 :>R ->
 a + b <> 0 :>R ->
 b + c <> 0 :>R ->
 a + c <> 0 :>R ->
 concours_3 A (barycentre (cons b B) (cons c C))
   (barycentre (cons a A) (cons b B)) C (barycentre (cons a A) (cons c C)) B.
unfold concours_3 in |- *.
intros a b c A B C H H0 H1 H2; try assumption.
exists
 (barycentre (cons a A) (cons (b + c) (barycentre (cons b B) (cons c C)))).
generalize (add_PP_assoc (cons a A) (cons b B) (cons c C)); intros.
generalize (add_PP_assoc_permute (cons a A) (cons b B) (cons c C)); intros.
split; [ try assumption | idtac ].
apply add_PP_alignes with (a := a) (b := b + c); auto with geo.
split; [ try assumption | idtac ].
apply add_PP_alignes with (a := a + b) (b := c); auto with geo.
unfold not in |- *; intros; apply H.
rewrite <- H5; ring.
rewrite <- add_PP_barycentre; auto with geo.
rewrite <- H3; auto.
repeat rewrite add_PP_barycentre; auto with geo.
apply cons_comp; auto.
ring.
apply add_PP_alignes with (a := a + c) (b := b); auto with geo.
unfold not in |- *; intros; apply H.
rewrite <- H5; ring.
rewrite <- add_PP_barycentre; auto.
rewrite <- H4; auto.
repeat rewrite add_PP_barycentre; auto.
apply cons_comp; auto.
ring.
Qed.

Lemma centre_gravite_intersection_medianes :
 forall A B C I J G : PO,
 triangle A B C ->
 I = milieu B C :>PO ->
 J = milieu A B :>PO ->
 G = centre_gravite A B C :>PO ->
 G = pt_intersection (droite A I) (droite C J) :>PO.
intros.
deroule_triangle A B C.
cut (triangle B C A); auto with geo; unfold triangle in |- *; intros.
cut (C <> J); intros.
cut (A <> I); intros.
cut (3 <> 0); intros; auto with real.
replace (droite C J) with (droite J C); auto with geo.
apply def_pt_intersection; auto.
left.
apply triangle_medianes_triangle with (1 := H); auto.
apply colineaire_alignes with (/ 3 * 2); auto.
rewrite (centre_gravite_mediane_vecteur (A:=A) (B:=B) (C:=C) (I:=I) (G:=G));
 auto.
Fieldvec 3.
apply permute_alignes; auto.
apply colineaire_alignes with (/ 3 * 2); auto.
rewrite (centre_gravite_mediane_vecteur (A:=C) (B:=A) (C:=B) (I:=J) (G:=G));
 auto.
Fieldvec 3.
rewrite H2; auto with geo.
rewrite H0.
apply triangle_milieu_distinct; auto.
rewrite H1.
apply triangle_milieu_distinct; auto.
Qed.

Lemma centre_gravite_intersection_trois_medianes :
 forall A B C I J K G : PO,
 triangle A B C ->
 I = milieu B C :>PO ->
 J = milieu A B :>PO ->
 K = milieu A C :>PO ->
 G = centre_gravite A B C :>PO ->
 G = pt_intersection (droite A I) (droite B K) :>PO /\
 G = pt_intersection (droite A I) (droite C J) :>PO.
intros.
split; [ idtac | try assumption ].
apply centre_gravite_intersection_medianes with (B := C); auto with geo.
rewrite H3; auto with geo.
apply centre_gravite_intersection_medianes with (B := B); auto.
Qed.


Require Import String.
Local Open Scope string.

Definition instance_para_open := true.
Definition local_lib_file := "HypotheticalExternLib".
Definition implementation_file := "implementation_1".
Definition result_module := "T".
Definition instance_para := "para".

Require Import Coq.Lists.List.
Require Import Logic.LogicGenerator.Utils.
Require Import Logic.LogicGenerator.ConfigLang.

Import ListNotations.

Definition how_connectives :=
  [primitive_connective impp
  ;primitive_connective andp
  ;primitive_connective orp
  ;primitive_connective falsep
  ;FROM_andp_impp_TO_iffp
  ;FROM_falsep_impp_TO_negp
  ;FROM_falsep_impp_TO_truep
  ;FROM_impp_TO_multi_imp
  ;FROM_empty_set_TO_empty_context
  ].

Definition how_judgements :=
  [primitive_judgement provable
  ;FROM_provable_TO_derivable
  ].

Definition transparent_names :=
  [expr:parameter].

Definition primitive_rule_classes :=
  [ provability_OF_impp
  ; provability_OF_andp
  ; provability_OF_orp
  ; provability_OF_falsep
  ; provability_OF_classical_logic
  ].


Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.sepalg.
Require Import VST.msl.sepalg_generators.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.
Require Import VST.msl.subtypes.

Local Open Scope pred.

Lemma unfash_derives {A} `{agA : ageable A}:
  forall {P Q}, (P |-- Q) -> @derives A _ (! P) (! Q).
Proof.
intros. intros w ?. simpl in *. apply H. auto.
Qed.

Lemma subp_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- P * Q >=> P' * Q'.
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2).
  specialize (H1 _ H2).
  clear G H2.
  destruct H5 as [w1 [w2 [? [? ?]]]].
  exists w1; exists w2; split; auto.
  split.
  eapply H0; auto.
  assert (level w1 = level a').
  apply comparable_fashionR.  eapply join_sub_comparable; eauto.
 apply necR_level in H4. lia.
  eapply H1; auto.
  assert (level w2 = level a').
  apply comparable_fashionR. eapply join_sub_comparable; eauto.
 apply necR_level in H4. lia.
Qed.

Lemma sub_wand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P' >=> P ->
  G |-- Q >=> Q' ->
  G |-- (P -* Q) >=> (P' -* Q').
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2); specialize (H1 _ H2); clear G H2; pose (H2:=True).
  eapply H0 in H8; try apply necR_refl.
  eapply H1; try apply necR_refl.
  apply necR_level in H4. apply necR_level in H6. apply join_comparable in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. lia.
  eapply H5; eauto.
  apply necR_level in H4. apply necR_level in H6.
   apply join_comparable2 in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. lia.
Qed.

Lemma find_superprecise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
   forall Q, Q |-- EX P:_, P && !(P >=> Q) && !!superprecise (P).
Proof.
intros.
intros w ?.
exists (exactly w).
split; auto.
split; auto.
hnf; apply necR_refl.
intros w' ? w'' ? ?.
hnf in H2.
apply pred_nec_hereditary with w; auto.
do 3 red.
apply superprecise_exactly.
Qed.

Lemma sepcon_subp' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall (P P' Q Q' : pred A) (st: nat),
    (P >=> P') st ->
    (Q >=> Q') st ->
    (P * Q >=> P' * Q') st.
Proof.
 pose proof I.
intros.
intros w' ? w'' ? [w1 [w2 [? [? ?]]]].
destruct (nec_join4 _ _ _ _ H4 H3) as [w1' [w2' [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
eapply (H0 w1'); eauto.
simpl in *.
subst.
replace (level w1') with (level w'); auto.
symmetry; apply comparable_fashionR; eapply join_comparable; eauto.
eapply (H1 w2'); eauto.
replace (level w2') with (level w'); auto.
symmetry. apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Lemma subp_refl'  {A} `{agA : ageable A} :  forall (Q: pred A) (st: nat), (Q >=> Q) st.
Proof.
intros.
intros ? ? ? ?; auto.
Qed.

Lemma subp_trans' {A} `{agA : ageable A}:
  forall (B C D: pred A) (w: nat), (B >=> C)%pred w -> (C >=> D)% pred w -> (B >=> D)%pred w.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H0; eauto.
eapply H; eauto.
Qed.

Lemma andp_subp'  {A} `{agA : ageable A} :
 forall (P P' Q Q': pred A) (w: nat), (P >=> P') w -> (Q >=> Q') w -> (P && Q >=> P' && Q') w.
Proof.
intros.
intros w' ? w'' ? [? ?]; split.
eapply H; eauto.
eapply H0; eauto.
Qed.

Lemma allp_subp' {A} `{agA : ageable A}: forall T (F G: T -> pred A) (w: nat),
   (forall x,  (F x >=> G x) w) -> (allp (fun x:T => (F x >=> G x)) w).
Proof.
intros.
intro x; apply H; auto.
Qed.

Lemma pred_eq_e1 {A} `{agA : ageable A}: forall (P Q: pred A) w,
       ((P <=> Q) w -> (P >=> Q) w).
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Lemma pred_eq_e2 {A} `{agA : ageable A}: forall (P Q: pred A)  w,
     ((P <=> Q) w -> (Q >=> P) w).
Proof.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

#[export] Hint Resolve sepcon_subp' : core.
#[export] Hint Resolve subp_refl' : core.
#[export] Hint Resolve andp_subp' : core.
#[export] Hint Resolve allp_subp' : core.
#[export] Hint Resolve derives_subp : core.
#[export] Hint Resolve pred_eq_e1 : core.
#[export] Hint Resolve pred_eq_e2 : core.

Lemma allp_imp2_later_e2 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> Q y >=> |> P y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e2. auto.
Qed.
Lemma allp_imp2_later_e1 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> P y >=> |> Q y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e1. auto.
Qed.

(*
Lemma subp_later {A} `{agA:  ageable A} (SS: natty A):
 forall (P Q: pred A), |> (P >=> Q) |-- |> P >=> |> Q.
Proof.
intros.
rewrite later_fash; auto.
apply fash_derives.
apply axiomK.
Qed.
*)

Lemma extend_unfash {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P: pred nat), boxy extendM (! P).
Proof.
intros.
apply boxy_i; auto; intros.
unfold unfash in *.
simpl in H. destruct H.
hnf in H0|-*.
replace (level w') with (level w); auto.
apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

#[export] Hint Resolve extend_unfash : core.

Lemma subp_unfash {A} `{Age_alg A}:
  forall (P Q : pred nat) (n: nat), (P >=> Q) n -> ( ! P >=> ! Q) n.
Proof.
intros.
intros w ?. specialize (H0 _ H1).
intros w' ? ?. apply (H0 _ (necR_level' H2)).
auto.
Qed.
#[export] Hint Resolve subp_unfash : core.

Lemma unfash_sepcon_distrib:
        forall {T}{agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T}
           (P: pred nat) (Q R: pred T),
               unfash P && (Q*R) = (unfash P && Q) * (unfash P && R).
Proof.
intros.
apply pred_ext.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; repeat split; auto.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
intros w [w1 [w2 [? [[? ?] [? ?]]]]].
split.
apply join_level in H. destruct H.
hnf in H0|-*. congruence.
exists w1; exists w2; repeat split; auto.
Qed.


Require Import Primitives Simulation Layer1 Layer2 BlockAllocator.
Close Scope pred_scope.
Import ListNotations.

Fixpoint compile {T} (p2: Layer2.prog T) : Layer1.prog T :=
    match p2 with
    | Read a => read a
    | Write a v => write a v
    | Alloc v => alloc v
    | Free a => free a
    | Ret v => Layer1.Ret v
    | Bind px py => Layer1.Bind (compile px) (fun x => compile (py x))
    end.

(* October 12: I need oracle_ok in here because specifications of block allocator requires it as a precondition *)
Fixpoint oracle_refines_to T (d1: State layer1_lts) (p: Layer2.prog T)  (o1: Oracle layer1_lts) (o2: Layer2.oracle) : Prop :=
  oracle_ok _ (compile p) o1 d1 /\
    match p with
    | Alloc v =>
      if (in_dec Layer1.token_dec Layer1.Crash o1) then
        forall d1',
          Layer1.exec o1 d1 (compile p) (Crashed d1') ->
          let sv := Disk.read d1 0 in
          let sv' := Disk.read d1' 0 in
          match sv, sv' with
          | Some v, Some v' =>
            (v = v' ->
             o2 = [Crash1]) /\
            (v <> v' ->
             let bits := bits (value_to_bits v) in
             let index := get_first_zero bits in
             o2 = [CrashAlloc index])
          | _, _ => False
          end
      else
        let sv := Disk.read d1 0 in
        match sv with
        | Some v =>
          let bits := bits (value_to_bits v) in
          let index := get_first_zero bits in

          if Compare_dec.lt_dec index block_size then
            o2 = [BlockNum index]
          else
            o2 = [DiskFull]
        | None => False
        end
    | @Bind T1 T2 p1 p2 =>
      exists o1' o1'',
      o1 = o1'++o1'' /\
     ((exists d1', Layer1.exec o1 d1 (compile p1) (Crashed d1') /\
         oracle_refines_to T1 d1 p1 o1 o2 /\ o1'' = []) \/
      (exists d1' r ret,
          Layer1.exec o1' d1 (compile p1) (Finished d1' r) /\
          Layer1.exec o1'' d1' (compile (p2 r)) ret /\
         exists o2' o2'',
         oracle_refines_to T1 d1 p1 o1' o2' /\
         oracle_refines_to T2 d1' (p2 r) o1'' o2'' /\
         o2 = o2' ++ o2''))
    | Read _ =>
      if (in_dec Layer1.token_dec Layer1.Crash o1) then
        o2 = [Crash1]
      else
        o2 = [Cont]
    | Ret _ =>
      if (in_dec Layer1.token_dec Layer1.Crash o1) then
        o2 = [Crash1]
      else
        o2 = [Cont]
    | Free _ =>
      if (in_dec Layer1.token_dec Layer1.Crash o1) then
        o2 = [Crash1]
      else
        o2 = [Cont]
    | Write a _ =>
      if (in_dec Layer1.token_dec Layer1.Crash o1) then
         forall d1',
          Layer1.exec o1 d1 (compile p) (Crashed d1') ->
          let sv := d1 a in
          let sv' := d1' a in
          match sv, sv' with
          | Some v, Some v' =>
            (v = v' ->
             o2 = [Crash1]) /\
            (v <> v' ->
             o2 = [Crash2])
          | _, _ => False
          end
      else
        o2 = [Cont]
    end.

  Definition refines_to d1 d2 :=
    exists F, (F * rep d2)%pred d1.

  Definition compilation_of T p1 p2 :=
    p1 = @compile T p2.


Require Import DACandMAC.

Section Close.

Variable s : SFSstate.

(*********************************************************************)
(*                   Some Useful Synonymous                          *)
(*********************************************************************)

Definition NEWRW (u : SUBJECT) (o : OBJECT) (y : ReadersWriters) :
  ReadersWriters :=
  mkRW (set_remove SUBeq_dec u (ActReaders y))
    (set_remove SUBeq_dec u (ActWriters y)).

Let NEWSET (u : SUBJECT) (o : OBJECT) (y : ReadersWriters) :
  set (OBJECT * ReadersWriters) :=
  match
    set_remove SUBeq_dec u (ActReaders y),
    set_remove SUBeq_dec u (ActWriters y)
  with
  | nil, nil => set_remove SECMATeq_dec (o, y) (secmat s)
  | _, _ =>
      set_add SECMATeq_dec (o, NEWRW u o y)
        (set_remove SECMATeq_dec (o, y) (secmat s))
  end.

(*close_sm is assuming the precondition of close (i.e, that u is an  *)
(*active reader or an active writer of o); with this assumption,     *)
(*(ActReaders z)=(ActWriters z)=nil, means that the only active      *)
(*reader and writer of o was u, and so, if he is closing the file, it*)
(*should be erased from memory.                                      *)

Definition close_sm (u : SUBJECT) (o : OBJECT) :
  set (OBJECT * ReadersWriters) :=
  match fsecmat (secmat s) o with
  | None => secmat s
  | Some y => NEWSET u o y
  end.

Let t (u : SUBJECT) (o : OBJECT) : SFSstate :=
  mkSFS (groups s) (primaryGrp s) (subjectSC s) (AllGrp s)
    (RootGrp s) (SecAdmGrp s) (objectSC s) (acl s)
    (close_sm u o) (files s) (directories s).

(*********************************************************************)
(*                            Close                                  *)
(*********************************************************************)

(*This operation closes an open object. Acctually the user           *)
(*requesting the operation is removed from the set of active readers *)
(*or writers associated with the object.                             *)

Inductive close (u : SUBJECT) (o : OBJECT) : SFSstate -> Prop :=
    CloseOK :
      match fsecmat (secmat s) o with
      | None => False
      | Some y =>
          set_In u (set_union SUBeq_dec (ActReaders y) (ActWriters y))
      end -> close u o (t u o).

Hint Unfold close_sm t.

End Close.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Relation.
Require Import Syntax.
Require Import Ofe.
Require Import Uniform.
Require Import Spaces.
Require Import Dynamic.
Require Import Hygiene.
Require Import Equivalence.
Require Import Intensional.
Require Import Ordinal.
Require Import Candidate.
Require Import System.
Require Import MapTerm.
Require Import Extend.
Require Import Model.
Require Import Standard.
Require Import Truncate.
Require Import Equivalences.
Require Import Ceiling.
Require Import Page.
Require Import Urelsp.

Definition ext_action (w u : ordinal) (hu : u << w) (i : nat) : nat -> relation (wterm w)
  :=
  fun j m m' =>
    j <= i
    /\ exists Q Q' (h : level (pi1 Q) <<= u) (h' : level (pi1 Q') <<= u),
         hygiene clo m
         /\ hygiene clo m'
         /\ star step m (ext (objin (objsome Q (le_lt_ord_trans _#3 h hu))))
         /\ star step m' (ext (objin (objsome Q' (le_lt_ord_trans _#3 h' hu))))
         /\ projc j Q = projc j Q'.

Definition ext_uniform :
  forall w u hu i, uniform _ (ext_action w u hu i).
Proof.
intros w u hu i.
do2 3 split.

(* closed *)
{
intros j m n H.
decompose H; auto.
}

(* equiv *)
{
intros j m m' n n' Hclm Hcln Hm Hn H.
destruct H as (Hj & Q & Q' & h & h' & _ & _ & Hstepsm & Hstepsn & Heq).
split; auto.
exists Q, Q', h, h'.
do2 4 split; auto.
  {
  so (equiv_eval _#4 Hm (conj Hstepsm value_ext)) as (x & (Hstepsm' & _) & Hmc).
  invertc_mc Hmc.
  intros <-.
  exact Hstepsm'.
  }

  {
  so (equiv_eval _#4 Hn (conj Hstepsn value_ext)) as (x & (Hstepsn' & _) & Hmc).
  invertc_mc Hmc.
  intros <-.
  exact Hstepsn'.
  }
}

(* zigzag *)
{
intros j m n p q Hmn Hpn Hpq.
destruct Hmn as (Hj & Q1 & Q2 & h1 & h2 & Hclm & _ & Hstepsm & Hstepsn & Heq12).
destruct Hpn as (_ & Q3 & Q2' & h3 & h2' & _ & _ & Hstepsp & Hstepsn' & Heq32).
destruct Hpq as (_ & Q3' & Q4 & h3' & h4 & _ & Hclq & Hstepsp' & Hstepsq & Heq34).
so (determinism_eval _#4 (conj Hstepsn value_ext) (conj Hstepsn' value_ext)) as H.
injectionc H.
intros H.
so (objin_inj _ _ _ H) as H'.
injection H'.
intros <-.
clear H H'.
so (determinism_eval _#4 (conj Hstepsp value_ext) (conj Hstepsp' value_ext)) as H.
injectionc H.
intros H.
so (objin_inj _ _ _ H) as H'.
injection H'.
intros <-.
clear H H'.
split; auto.
exists Q1, Q4, h1, h4.
do2 4 split; auto.
exact (eqtrans Heq12 (eqtrans (eqsymm Heq32) Heq34)).
}

(* downward *)
{
intros j m n H.
destruct H as (Hj & Q & Q' & h & h' & Hclm & Hcln & Hstepsm & Hstepsn & Heq).
split.
  {
  omega.
  }
exists Q, Q', h, h'.
do2 4 split; auto.
so (f_equal (projc j) Heq) as Heq'.
rewrite -> !projc_combine_le in Heq'; auto.
}
Qed.

Definition ext_urel w u huw i :=
  mk_urel (ext_action w u huw i) (ext_uniform w u huw i).

Lemma rel_ext_intro :
  forall w u i j Q Q' h h' (hu : u << w),
    level (pi1 Q) <<= u
    -> level (pi1 Q') <<= u
    -> j <= i
    -> projc j Q = projc j Q'
    -> rel (ext_urel w u hu i) j (ext (objin (objsome Q h))) (ext (objin (objsome Q' h'))).
Proof.
intros w u i j Q Q' h h' Huw Hlev Hlev' Hj Heq.
cbn.
split; auto.
exists Q, Q', Hlev, Hlev'.
so (proof_irrelevance _ h (le_lt_ord_trans _#3 Hlev Huw)); subst h.
so (proof_irrelevance _ h' (le_lt_ord_trans _#3 Hlev' Huw)); subst h'.
do2 4 split; auto using star_refl.
  {
  apply hygiene_auto; cbn; auto.
  }

  {
  apply hygiene_auto; cbn; auto.
  }
Qed.

Lemma rel_ext_refl :
  forall w u (hu : u << w) i j Q h,
    level (pi1 Q) <<= u
    -> j <= i
    -> rel (ext_urel w u hu i) j (ext (objin (objsome Q h))) (ext (objin (objsome Q h))).
Proof.
intros w u hu i j Q h Hlev Hj.
apply rel_ext_intro; auto.
Qed.

Lemma rel_ext_invert :
  forall w u (hu : u << w) i j Q Q' h h',
    rel (ext_urel w u hu i) j (ext (objin (objsome Q h))) (ext (objin (objsome Q' h')))
    -> projc j Q = projc j Q'.
Proof.
intros w u hu i j Q1 Q2 h1 h2 H.
destruct H as (Hj & Q1' & Q2' & h1' & h2' & _ & _ & Hsteps1 & Hsteps2 & Heq).
so (determinism_normal_value _#3 value_ext Hsteps1) as H.
injectionc H.
intros H.
so (objin_inj _ _ _ H) as H'.
injection H'.
intros <-.
clear H H'.
so (determinism_normal_value _#3 value_ext Hsteps2) as H.
injectionc H.
intros H.
so (objin_inj _ _ _ H) as H'.
injection H'.
intros <-.
clear H H'.
exact Heq.
Qed.

Lemma ceiling_ext_urel :
  forall w u hu i j,
    ceiling (S i) (ext_urel w u hu j) = ext_urel w u hu (min i j).
Proof.
intros w u hu i j.
apply urel_extensionality.
fextensionality 3.
intros k m p.
cbn.
pextensionality.
  {
  intros (Hki & H).
  destruct H as (Hkj & H).
  split; auto.
  apply Nat.min_glb; omega.
  }

  {
  intros (Hk & H).
  do2 2 split; auto.
    {
    so (Nat.min_glb_l _#3 Hk).
    omega.
    }

    {
    exact (Nat.min_glb_r _#3 Hk).
    }
  }
Qed.

Lemma extend_ext_urel :
  forall v w u hu i (hvw : v <<= w),
    extend_urel v w (ext_urel v u hu i) = ext_urel w u (lt_le_ord_trans _#3 hu hvw) i.
Proof.
intros v w u hu i Hvw.
apply urel_extensionality.
fextensionality 3.
intros j m p.
cbn.
pextensionality.
  {
  intro H.
  destruct H as (Hj & Q & Q' & h & h' & Hclm & Hclp & Hstepsm & Hstepsp & Heq).
  split; auto.
  exists Q, Q', h, h'.
  do2 4 split; eauto using map_hygiene_conv.
    {
    so (map_steps_form _#5 Hstepsm) as (m' & Heqm & Hsteps).
    so (map_eq_ext_invert _#5 (eqsymm Heqm)) as (x & -> & Heqx).
    so (extend_eq_objsome_form _#5 Heqx) as (h'' & ->).
    so (proof_irrelevance _ h'' (le_lt_ord_trans _#3 h (lt_le_ord_trans _#3 hu Hvw))); subst h''.
    exact Hsteps.
    }

    {
    so (map_steps_form _#5 Hstepsp) as (m' & Heqm & Hsteps).
    so (map_eq_ext_invert _#5 (eqsymm Heqm)) as (x & -> & Heqx).
    so (extend_eq_objsome_form _#5 Heqx) as (h'' & ->).
    so (proof_irrelevance _ h'' (le_lt_ord_trans _#3 h' (lt_le_ord_trans _#3 hu Hvw))); subst h''.
    exact Hsteps.
    }
  }

  {
  intro H.
  destruct H as (Hj & Q & Q' & h & h' & Hclm & Hclp & Hstepsm & Hstepsp & Heq).
  split; auto.
  exists Q, Q', h, h'.
  do2 4 split; auto using map_hygiene.
    {
    so (map_steps _ _ (extend w v) _ _ Hstepsm) as Hsteps.
    simpmapin Hsteps.
    rewrite -> (extend_some _#4 (le_lt_ord_trans _#3 h hu)) in Hsteps.
    exact Hsteps.
    }

    {
    so (map_steps _ _ (extend w v) _ _ Hstepsp) as Hsteps.
    simpmapin Hsteps.
    rewrite -> (extend_some _#4 (le_lt_ord_trans _#3 h' hu)) in Hsteps.
    exact Hsteps.
    }
  }
Qed.

Definition meta_ext {w : ordinal} u (hu : u << w) i (Q : candidate) (h : level (pi1 Q) <<= u) : meta (obj w)
  :=
  meta_term (ext_urel w u hu i) (urelspinj (ext_urel w u hu i) i _ _ (rel_ext_refl w u hu i i Q (le_lt_ord_trans _#3 h hu) h (le_refl _))).

Lemma meta_ext_inj :
  forall w u hu i Q Q' h h',
    @meta_ext w u hu i Q h = @meta_ext w u hu i Q' h'
    -> projc i Q = projc i Q'.
Proof.
intros w u hu i Q Q' h h' Heqmeta.
unfold meta_ext in Heqmeta.
so (meta_term_inj _#5 Heqmeta) as Heq.
injectionT Heq.
intros Heq.
so (urelspinj_equal_invert _#10 Heq) as (_ & Hrel).
exact (rel_ext_invert _#9 Hrel).
Qed.

Lemma meta_truncate_ext :
  forall cur u (hu : u << cur) n i Q (h : level (pi1 Q) <<= u) (h' : level (approx n (pi1 Q)) <<= u),
    meta_truncate (S n) (meta_ext u hu i Q h)
    =
    meta_ext u hu (min n i) (projc n Q) h'.
Proof.
intros cur u hu  n i Q h h'.
unfold meta_ext.
assert (S n > 0) as Hpos by omega.
rewrite -> (meta_truncate_term _#4 Hpos).
apply f_equal_dep.
apply (eq_impl_eq_dep _#6 (ceiling_ext_urel cur u hu n i)).
set (h'' := le_lt_ord_trans _#3 h hu).
assert (rel (ceiling (S n) (ext_urel cur u hu i)) (min i n) (ext (objin (objsome Q h''))) (ext (objin (objsome Q h'')))) as Hrel.
  {
  cbn.
  split.
    {
    apply Nat.min_lt_iff.
    right; omega.
    }
  apply rel_ext_refl; auto.
  apply Nat.le_min_l.
  }
rewrite -> (proj_ceiling_urelspinj _#8 Hrel).
so (rel_ext_refl cur u hu (min i n) (min i n) Q (le_lt_ord_trans _#3 h hu) h (le_refl _)) as Hrel'.
rewrite -> Nat.min_comm in Hrel' at 1.
rewrite -> (transport_urelspinj _#3 (ceiling_ext_urel cur u hu n i) _#4 Hrel').
apply urelspinj_equal'.
  {
  apply Nat.min_comm.
  }
apply rel_ext_intro; auto.
  {
  rewrite -> Nat.min_comm.
  apply le_refl.
  }
rewrite -> projc_combine_le; auto.
apply Nat.le_min_r.
Qed.

Lemma extend_meta_ext :
  forall v w (h : v <<= w) u (hu : u << v) i Q (lev : level (pi1 Q) <<= u),
    extend_meta h (meta_ext u hu i Q lev)
    =
    meta_ext u (lt_le_ord_trans _#3 hu h) i Q lev.
Proof.
intros v w hvw u huv i Q lev.
unfold meta_ext.
rewrite -> extend_meta_term.
apply f_equal_dep.
apply (eq_impl_eq_dep _#6 (extend_ext_urel v w u huv i hvw)).
set (lev' := le_lt_ord_trans _#3 lev (lt_le_ord_trans _#3 huv hvw)).
erewrite -> extend_urelspinj.
Unshelve.
2:{
  unfold extend_urel.
  cbn [rel].
  rewrite -> !extend_term_cancel; auto.
  apply rel_ext_refl; auto.
  }
erewrite -> (transport_urelspinj _ _ _ (extend_ext_urel v w u huv i hvw)).
Unshelve.
2:{
  simpmap.
  erewrite -> (extend_some _#4 lev').
  apply rel_ext_refl; auto.
  }
apply urelspinj_equal.
simpmap.
erewrite -> (extend_some _#4 lev').
apply rel_ext_refl; auto.
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.monads MathClasses.theory.functors.

#[global]
Instance default_mon_join `{MonadBind M} : MonadJoin M | 20 := λ _, bind id.
#[global]
Instance default_mon_map `{MonadReturn M} `{MonadBind M} : SFmap M | 20 := λ _ _ f, bind (ret ∘ f).
#[global]
Instance default_mon_bind `{SFmap M} `{MonadJoin M} : MonadBind M | 20 := λ _ _ f, join ∘ (sfmap f).

#[global]
Hint Extern 0 (ProperProxy (@respectful _ _ _ _) _) =>
  class_apply @proper_proper_proxy : typeclass_instances.

#[global]
Instance equiv_ext_equiv `{Equiv A} `{Equiv B} :
  Setoid A -> Setoid B ->
  Proper ((equiv ==> equiv) ==> (equiv ==> equiv) ==> flip impl)
         (@equiv _ (@ext_equiv A _ B _)).
Proof.
  unfold ext_equiv. repeat (red; intros).
  assert ((equiv ==> equiv)%signature x x0).
  eapply transitivity. eauto.
  eapply transitivity. eauto.
  eapply symmetry. eauto.
  eapply H7. eapply H6.
Qed.

#[global]
Instance equiv_ext_equiv_partial `{Equiv A} `{Equiv B} (f : A -> B) :
  Setoid A -> Setoid B ->
  Proper (equiv ==> equiv) f ->
  Proper ((equiv ==> equiv) ==> flip impl)
         (@equiv _ (@ext_equiv A _ B _) f).
Proof. intros. partial_application_tactic; eauto. apply equiv_ext_equiv; eauto. Qed.

Section monad.
  Context `{Monad M}.

  Lemma bind_lunit_applied `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)} (x : A) :
    ret x ≫= f = f x.
  Proof. pose proof (setoidmor_a f). now apply bind_lunit. Qed.

  Lemma bind_runit_applied `{Setoid A} (m : M A) :
    m ≫= ret = m.
  Proof. now apply bind_runit. Qed.

  Lemma bind_assoc_applied `{Equiv A} `{Equiv B} `{Setoid C}
       `{!Setoid_Morphism (f : A → M B)} `{!Setoid_Morphism (g : B → M C)} (m : M A) :
    (m ≫= f) ≫= g = x ← m ; f x ≫= g.
  Proof. pose proof (setoidmor_a f). now apply bind_assoc. Qed.

  Global Instance ret_mor `{Setoid A} : Setoid_Morphism (@ret _ _ A) := {}.
  Global Instance bind_mor `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)} :
    Setoid_Morphism (bind f).
  Proof. pose proof (setoidmor_a f). split; try apply _. Qed.

  Definition liftM2 `(f: A → B → C) (m : M A) (n : M B) : M C :=
    x ← m ; y ← n ; ret (f x y).

  Section to_strong_monad.
  Context `{MonadJoin M} `{SFmap M}
    (map_proper : ∀ `{Setoid A} `{Setoid B}, Proper (((=) ==> (=)) ==> ((=) ==> (=))) (@sfmap M _ A B))
    (map_correct : ∀ `{Equiv A} `{Equiv B} `{!Setoid_Morphism (f : A → B)}, sfmap f = bind (ret ∘ f))
    (join_correct : ∀ `{Setoid A}, join = bind id).
  Existing Instance map_proper.

  Let bind_correct `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)} :
    bind f = join ∘ sfmap f.
  Proof.
    pose proof (setoidmor_a f). pose proof (setoidmor_b f).
    rewrite join_correct, map_correct by apply _.
    rewrite bind_assoc.
    change (bind f = bind ((bind id ∘ ret) ∘ f)).
    rewrite bind_lunit.
    now apply setoids.ext_equiv_refl.
  Qed.

  Instance: SFunctor M.
  Proof.
    split; try apply _.
     intros A ? ?.
     rewrite map_correct by apply _.
     now apply bind_runit.
    intros A ? B ? C ? f ? g ?.
    pose proof (setoidmor_a g). pose proof (setoidmor_b g). pose proof (setoidmor_b f).
    rewrite !map_correct by apply _.
    rewrite bind_assoc.
    change (bind (ret ∘ (f ∘ g)) = bind ((bind (ret ∘ f) ∘ ret) ∘ g)).
    rewrite bind_lunit.
    now apply setoids.ext_equiv_refl.
  Qed.

  Instance: ∀ `{Setoid A}, Setoid_Morphism (@join _ _ A).
  Proof.
    split; try apply _. intros x y E1.
    assert (∀ z, join z = bind id z) as E2 by (intros; now apply join_correct).
    now rewrite !E2, E1.
  Qed.

  Instance monad_strong_monad: StrongMonad M.
  Proof.
    split; try apply _.
        intros A ? B ? f ?. pose proof (setoidmor_a f). pose proof (setoidmor_b f).
        rewrite map_correct by apply _.
        rewrite bind_lunit.
        now apply setoids.ext_equiv_refl.
       intros A ? B ? f ?. pose proof (setoidmor_a f). pose proof (setoidmor_b f).
       rewrite <-bind_correct.
       rewrite !join_correct by apply _.
       rewrite map_correct by apply _.
       rewrite bind_assoc.
       now apply setoids.ext_equiv_refl.
      intros A ??. rewrite join_correct by apply _.
      rewrite bind_lunit.
      now apply setoids.ext_equiv_refl.
     intros A ??.
     rewrite <-bind_correct.
     rewrite bind_runit.
     now apply setoids.ext_equiv_refl.
    intros A ??. rewrite <-bind_correct.
    rewrite !join_correct by apply _.
    rewrite bind_assoc.
    now apply setoids.ext_equiv_refl.
  Qed.

  Instance monad_full_monad: FullMonad M.
  Proof. split; try apply _; auto. Qed.
  End to_strong_monad.

  Instance monad_default_full_monad: FullMonad M.
  Proof.
    apply monad_full_monad; unfold sfmap, default_mon_map.
      intros A ?? B ?? f g E1 m n E2.
      apply mon_bind_proper.
       intros x y E3. now apply mon_ret_proper, E1.
      easy.
     intros A ? B ? f ??? E. pose proof (setoidmor_a f). pose proof (setoidmor_b f).
     now rewrite E.
    intros A ?? ?? E. unfold join, default_mon_join.
    now rewrite E.
  Qed.
End monad.

Section strong_monad.
  Context `{StrongMonad M}.

  Global Instance sret_mor `{Setoid A} : Setoid_Morphism (@ret _ _ A) := {}.
  Global Instance join_mor `{Setoid A} : Setoid_Morphism (@join _ _ A) := {}.

  Hint Immediate setoidmor_a : typeclass_instances.
  Hint Immediate setoidmor_b : typeclass_instances.

  Lemma sfmap_ret_applied `{Equiv A} `{Equiv B} `{!Setoid_Morphism (f : A → B)} (x : A) :
    sfmap f (ret x) = ret (f x).
  Proof. now apply sfmap_ret. Qed.

  Lemma sfmap_join_applied `{Equiv A} `{Equiv B} `{!Setoid_Morphism (f : A → B)} (m : M (M A)) :
    sfmap f (join m) = join (sfmap (sfmap f) m).
  Proof. now apply sfmap_join. Qed.

  Lemma join_ret_applied `{Setoid A} (m : M A) :
    join (ret m) = m.
  Proof. now apply join_ret. Qed.

  Lemma join_sfmap_ret_applied `{Setoid A} (m : M A):
    join (sfmap ret m) = m.
  Proof. now apply join_sfmap_ret. Qed.

  Lemma join_sfmap_join_applied `{Setoid A} (m : M (M (M A))) :
    join (sfmap join m) = join (join m).
  Proof. now apply join_sfmap_join. Qed.

  Section to_monad.
  Context `{MonadBind M}
    (bind_proper : ∀ `{Setoid A} `{Setoid B}, Proper (((=) ==> (=)) ==> ((=) ==> (=))) (@bind M _ A B))
    (bind_correct : ∀ `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)}, bind f = join ∘ sfmap f).

  Instance: ∀ `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)},
    Setoid_Morphism (bind f).
  Proof. intros. split; try apply _. Qed.

  Let bind_correct_applied `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)} m :
    bind f m = join (sfmap f m).
  Proof. now eapply bind_correct. Qed.

  Instance strong_monad_monad: Monad M.
  Proof.
    split; try apply _.
      intros A ? B ?? f ?. pose proof (setoidmor_a f). pose proof (setoidmor_b f).
      rewrite bind_correct by apply _.
      rewrite compose_assoc, sfmap_ret.
      rewrite <-compose_assoc, join_ret.
      now apply setoids.ext_equiv_refl.
     intros A ? ?.
     rewrite bind_correct by apply _.
     now apply join_sfmap_ret.
    intros A ? B ? C ?? f ? g ? m n E. pose proof (setoidmor_a f). pose proof (setoidmor_a g).
    unfold compose at 1. rewrite !bind_correct_applied.
    rewrite bind_correct by apply _.
    rewrite sfmap_join_applied.
    rewrite !sfmap_comp_applied.
    rewrite join_sfmap_join_applied.
    now rewrite E.
  Qed.

  Instance strong_monad_full_monad: FullMonad M.
  Proof. split; try apply _; auto. Qed.
  End to_monad.

  Instance strong_monad_default_full_monad: FullMonad M.
  Proof.
    apply strong_monad_full_monad; unfold bind, default_mon_bind.
     intros A ?? B ?? f g E1 m n E2.
     apply smon_join_proper. apply sfmap_proper; intuition.
    intros A ? B ?? f ? ?? E.
    now rewrite E.
  Qed.
End strong_monad.

Section full_monad.
  Context `{FullMonad M}.

  Lemma bind_as_join_sfmap_applied `{Equiv A} `{Setoid B} `{!Setoid_Morphism (f : A → M B)} (m : M A) :
    m ≫= f = join (sfmap f m).
  Proof. pose proof (setoidmor_a f). now  apply bind_as_join_sfmap. Qed.

  Lemma sfmap_as_bind_ret `{Equiv A} `{Equiv B} `{!Setoid_Morphism (f : A → B)} :
     sfmap f = bind (ret ∘ f).
  Proof.
    pose proof (setoidmor_a f). pose proof (setoidmor_b f).
    rewrite bind_as_join_sfmap.
    rewrite sfmap_comp.
    rewrite <-compose_assoc.
    rewrite join_sfmap_ret.
    now apply setoids.ext_equiv_refl.
  Qed.

  Lemma sfmap_as_bind_ret_applied `{Equiv A} `{Equiv B} `{!Setoid_Morphism (f : A → B)} (m : M A) :
    sfmap f m = x ← m ; ret (f x).
  Proof. pose proof (setoidmor_a f). now apply sfmap_as_bind_ret. Qed.

  Lemma join_as_bind `{Setoid A} :
    join = bind id.
  Proof.
    rewrite bind_as_join_sfmap.
    rewrite sfmap_id.
    now apply setoids.ext_equiv_refl.
  Qed.

  Lemma join_as_bind_applied `{Setoid A} (m : M (M A)) :
    join m = m ≫= id.
  Proof. now apply join_as_bind. Qed.

  Lemma join_spec_applied_alt `{Setoid A} (m : M (M A)) :
    join m = x ← m ; x.
  Proof. now apply join_as_bind. Qed.

  Lemma bind_twice `{Equiv A} `{Equiv B} `{Setoid C}
       `{!Setoid_Morphism (f : B → M C)} `{!Setoid_Morphism (g : A → M B)} :
    bind (bind f) = bind f ∘ join.
  Proof.
    pose proof (setoidmor_a f). pose proof (setoidmor_b f).
    pose proof (setoidmor_b g).
    rewrite join_as_bind.
    rewrite bind_assoc.
    now apply setoids.ext_equiv_refl.
  Qed.

  Lemma bind_twice_applied `{Equiv A} `{Equiv B} `{Setoid C}
       `{!Setoid_Morphism (f : B → M C)} `{!Setoid_Morphism (g : A → M B)} (m : M (M B)) :
    m ≫= bind f = join m ≫= f.
  Proof. pose proof (setoidmor_a f). now apply bind_twice. Qed.

  Lemma bind_join `{Setoid A} :
    bind join = join ∘ join.
  Proof.
    rewrite !join_as_bind.
    rewrite bind_assoc.
    now apply setoids.ext_equiv_refl.
  Qed.

  Lemma bind_join_applied `{Setoid A} (m : M (M (M A))) :
    m ≫= join = join (join m).
  Proof. now apply bind_join. Qed.
End full_monad.


(* En este archivo se definen lemas auxiliares utilizados en
* la demostración de las propiedades postuladas *)
Require Export Exec.
Require Export Estado.
Require Export Operaciones.
Require Export Semantica.
Require Export ErrorManagement.
Require Export DefBasicas.
Require Export Implementacion.
Require Export ValidityInvariance.
Require Export Soundness.

Lemma stepIsInvariant :forall (s:System) (sValid:validstate s) (act:Action), validstate (system (step s act)).
Proof.
    intros.
    apply (validityIsInvariant s (system (step s act)) act (response (step s act)));auto.
    apply stepIsSound;auto.
Qed.

Lemma grantPreservesEnv : forall (s s':System) (p:Perm) (a:idApp), environment s=environment s'-> environment s = environment (system (step s' (grant p a))).
Proof.
    intros.
    unfold step.
    unfold grant_safe.
    case_eq (grant_pre p a s');intros;simpl;auto.
Qed.

Lemma revokePreservesEnv : forall (s s':System) (p:Perm) (a:idApp), environment s=environment s'-> environment s = environment (system (step s' (revoke p a))).
Proof.
    intros.
    unfold step.
    unfold revoke_safe.
    case_eq (revoke_pre p a s');intros;simpl;auto.
Qed.

Lemma grantPPreservesEnv : forall (s s':System) (ic:iCmp) (cp:CProvider) (a:idApp) (u:uri) (pt:PType), environment s=environment s'-> environment s = environment (system (step s' (grantP ic cp a u pt))).
Proof.
    intros.
    unfold step.
    unfold grantP_safe.
    case_eq (grantP_pre ic cp a u pt s');intros;simpl;auto.
Qed.

Lemma grantPreservesResCont : forall (s s':System) (p:Perm) (a:idApp), resCont (state s)=resCont (state s')-> resCont (state s) = resCont (state (system (step s' (grant p a)))).
Proof.
    intros.
    unfold step.
    unfold grant_safe.
    case_eq (grant_pre p a s');intros;simpl;auto.
Qed.

Lemma revokePreservesResCont : forall (s s':System) (p:Perm) (a:idApp), resCont (state s)=resCont (state s')-> resCont (state s )= resCont (state (system (step s' (revoke p a)))).
Proof.
    intros.
    unfold step.
    unfold revoke_safe.
    case_eq (revoke_pre p a s');intros;simpl;auto.
Qed.

Lemma grantPPreservesResCont : forall (s s':System) (ic:iCmp) (cp:CProvider) (a:idApp) (u:uri) (pt:PType), resCont (state s)=resCont (state s')-> resCont (state s) = resCont (state (system (step s' (grantP ic cp a u pt)))).
Proof.
    intros.
    unfold step.
    unfold grantP_safe.
    case_eq (grantP_pre ic cp a u pt s');intros;simpl;auto.
Qed.

Lemma grantPreservesRunning : forall (s s':System) (p:Perm) (a:idApp), running (state s)=running (state s')-> running (state s) = running (state (system (step s' (grant p a)))).
Proof.
    intros.
    unfold step.
    unfold grant_safe.
    case_eq (grant_pre p a s');intros;simpl;auto.
Qed.

Lemma revokePreservesRunning : forall (s s':System) (p:Perm) (a:idApp), running (state s)=running (state s')-> running (state s )= running (state (system (step s' (revoke p a)))).
Proof.
    intros.
    unfold step.
    unfold revoke_safe.
    case_eq (revoke_pre p a s');intros;simpl;auto.
Qed.

Lemma grantPPreservesRunning : forall (s s':System) (ic:iCmp) (cp:CProvider) (a:idApp) (u:uri) (pt:PType), running (state s)=running (state s')-> running (state s) = running (state (system (step s' (grantP ic cp a u pt)))).
Proof.
    intros.
    unfold step.
    unfold grantP_safe.
    case_eq (grantP_pre ic cp a u pt s');intros;simpl;auto.
Qed.

Lemma grantPreservesDelPPerms : forall (s s':System) (p:Perm) (a:idApp), delPPerms (state s)=delPPerms (state s')-> delPPerms (state s) = delPPerms (state (system (step s' (grant p a)))).
Proof.
    intros.
    unfold step.
    unfold grant_safe.
    case_eq (grant_pre p a s');intros;simpl;auto.
Qed.

Lemma revokePreservesDelPPerms : forall (s s':System) (p:Perm) (a:idApp), delPPerms (state s)=delPPerms (state s')-> delPPerms (state s )= delPPerms (state (system (step s' (revoke p a)))).
Proof.
    intros.
    unfold step.
    unfold revoke_safe.
    case_eq (revoke_pre p a s');intros;simpl;auto.
Qed.


Set Implicit Arguments.

Section TopSection.

  Require Import IsGoodModule.

  Notation MName := SyntaxModule.Name.
  Notation FName := SyntaxFunc.Name.
  Notation Funcs := SyntaxModule.Functions.

  Require Import GoodModule.

  Open Scope bool_scope.
  Notation "! b" := (negb b) (at level 35).

  Require Import List.

  Require Import SyntaxModule.

  Definition goodSize_bool n := proj1_sig (Sumbool.bool_of_sumbool (Malloc.goodSize_dec n)).

  Fixpoint wellformed_bool s :=
    match s with
      | Syntax.Call _ _ args => goodSize_bool (2 + length args)
      | Syntax.Skip => true
      | Syntax.Seq a b => wellformed_bool a && wellformed_bool b
      | Syntax.If _ a b => wellformed_bool a && wellformed_bool b
      | Syntax.While _ body => wellformed_bool body
      | Syntax.Assign _ _ => true
      | Syntax.Label _ _ => true
    end.

  Require Import GetLocalVars.

  Definition NoUninitialized_bool (f : FuncCore) := true.

  Require Import Depth.
  Require Import GoodModuleFacts.
  Require Import ListFacts3.

  Definition GoodFunc_bool f :=
    let body := Body f in
    let local_vars := get_local_vars body (ArgVars f) (RetVar f) in
    let all_vars := ArgVars f ++ local_vars in
    NoDup_bool string_bool (ArgVars f) &&
    NoUninitialized_bool f &&
    wellformed_bool body &&
    goodSize_bool (length local_vars + depth body).

  Definition GoodFuncs_bool fs := forallb GoodFunc_bool fs.

  Definition GoodModule_bool (m : Module) :=
    GoodModuleName_bool (MName m) &&
    GoodFuncs_bool (map Core (Funcs m)) &&
    NoDup_bool string_bool (map FName (Funcs m)).

  Require Import Bool.
  Require Import GeneralTactics.
  Require Import GeneralTactics2.

  Require Import Program.Basics.
  Require Import GoodFunc.
(*
  Lemma NoUninitialized_bool_sound : forall f, NoUninitialized_bool f = true -> NoUninitialized (ArgVars f) (RetVar f) (Body f).
  Qed.

  Require Import WellFormed.

  Lemma goodSize_bool_sound : forall n, goodSize_bool n = true -> goodSize n.
    intros.
    unfold goodSize_bool in *.
    destruct (Malloc.goodSize_dec n); simpl in *; intuition.
  Qed.

  Hint Constructors args_not_too_long.

  Lemma wellformed_bool_sound : forall s, wellformed_bool s = true -> wellformed s.
    unfold wellformed.
    induction s; simpl; intuition eauto.
    eapply andb_true_iff in H; openhyp; eauto.
    eapply andb_true_iff in H; openhyp; eauto.
    econstructor.
    eapply goodSize_bool_sound; eauto.
  Qed.

  Lemma GoodFunc_bool_sound : forall f, GoodFunc_bool f = true -> GoodFunc f.
    unfold GoodFunc_bool.
    intros.
    repeat (eapply andb_true_iff in H; openhyp).
    econstructor.
    eapply NoDup_bool_string_eq_sound; eauto.
    split.
    eapply NoUninitialized_bool_sound; eauto.
    split.
    eapply wellformed_bool_sound; eauto.
    eapply goodSize_bool_sound; eauto.
  Qed.

  Lemma GoodFuncs_bool_sound : forall ls, GoodFuncs_bool (map Core ls) = true -> Forall (compose GoodFunc Core) ls.
    intros.
    unfold GoodFuncs_bool in *.
    eapply Forall_forall.
    intros.
    eapply forallb_forall in H.
    2 : eapply in_map; eauto.
    unfold compose.
    eapply GoodFunc_bool_sound; eauto.
  Qed.

  Lemma GoodModule_bool_sound : forall m, GoodModule_bool m = true -> IsGoodModule m.
    intros.
    unfold GoodModule_bool in *.
    destruct m; simpl in *.
    eapply andb_true_iff in H.
    openhyp.
    eapply andb_true_iff in H.
    openhyp.
    econstructor; simpl.
    eapply GoodModuleName_bool_sound; eauto.
    split.
    eapply GoodFuncs_bool_sound; eauto.
    eapply NoDup_bool_string_eq_sound; eauto.
  Qed.
*)
End TopSection.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Lia.
Require Import Ascii.

Require Import FinProof.All.

Require Import UMLang.All.
Require Import UMLang.LocalClassGenerator.ClassGenerator.
Require Import UMLang.GlobalClassGenerator.ClassGenerator.

Require Import UrsusStdLib.Solidity.All.
Require Import UrsusStdLib.Solidity.unitsNotations.
Require Import UrsusTVM.Solidity.All.

Import UrsusNotations.
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.

From elpi Require Import elpi.

Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Require Import SetcodeMultisig.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import FinProof.CommonInstances.

Require Import CommonQCEnvironment.
Require Import SetcodeMultisig_LocalState.
Require Import CommonForProps.

Definition dummyTransaction : TransactionLRecord := Eval compute in default.

Definition ETR_1 l u (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l) in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let MAX_CLEANUP_TXNS := uint2N (toValue (eval_state (sRReader (MAX_CLEANUP_TXNS_right rec def) ) l)) in
  let m_updateRequests := toValue (eval_state (sRReader (m_updateRequests_right rec def) ) l) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let id := (getPruvendoRecord Transaction_ι_id u) in
  let l' := exec_state (Uinterpreter (_removeExpiredTransactions rec def)) l in
  let m_transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = false ->
  hmapIsMember id m_updateRequests = true ->
  (N.shiftr (uint2N id) 32) + lifetime <= tvm_now  ->
  length_ (xHMapFilter (fun _k t => (eqb (getPruvendoRecord Transaction_ι_id t) id)) transactions) < MAX_CLEANUP_TXNS  <->
  hmapIsMember id transactions = true /\
  hmapIsMember id m_transactions = false.

Definition MTS_1 l (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  correctState l ->
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = false ->
  hmapIsMember msgPubkey custodians = true.

Definition MTS_2 l id (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let l' := exec_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  let u := xMaybeMapDefault (fun x => x) (hmapLookup id transactions) dummyTransaction  in
  correctState l ->
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = true ->
  hmapIsMember msgPubkey custodians = true ->
  hmapIsMember id transactions = true ->
  ETR_1 l' u dest value bounce allBalance payload stateInit.

Definition MTS_3 l (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let requestsMask := toValue (eval_state (sRReader (m_requestsMask_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let i := uint2N (hmapFindWithDefault (Build_XUBInteger 0) msgPubkey custodians) in
  let bitsMask := N.land (N.shiftr (uint2N requestsMask) (8 * i)) 255 in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l) in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let MAX_QUEUED_REQUESTS := uint2N (toValue (eval_state (sRReader (MAX_QUEUED_REQUESTS_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let expiredTransactions := xHMapFilter (fun k v =>
    let index := uint2N (getPruvendoRecord Transaction_ι_index v) in
    andb (N.eqb index i) (N.leb ((N.shiftr (uint2N k) 32) + lifetime) tvm_now)
  ) transactions in
  let bitsMask' := bitsMask - length_ expiredTransactions in
  correctState l ->
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = false ->
  bitsMask' < MAX_QUEUED_REQUESTS.

Definition MTS_4 l id (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let FLAG_IGNORE_ERRORS := uint2N (toValue (eval_state (sRReader (FLAG_IGNORE_ERRORS_right rec def) ) l)) in
  let FLAG_SEND_ALL_REMAINING := uint2N (toValue (eval_state (sRReader (FLAG_SEND_ALL_REMAINING_right rec def) ) l)) in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let requestsMask :=  (toValue (eval_state (sRReader (m_requestsMask_right rec def) ) l)) in
  let m_defaultRequiredConfirmations :=  uint2N (toValue (eval_state (sRReader (m_defaultRequiredConfirmations_right rec def) ) l)) in (* ???? *)
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let l' := exec_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l in
  let messqueue := toValue ((eval_state (sRReader (ULtoRValue (IDefault_left rec def)))) l') in
  let stateInit' := xMaybeMapDefault (fun x => x) stateInit default in
  let mes := EmptyMessage IDefault (Build_XUBInteger 0, (bounce, (Build_XUBInteger (N.lor FLAG_IGNORE_ERRORS FLAG_SEND_ALL_REMAINING) , (payload, stateInit')))) in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  let u := xMaybeMapDefault (fun x => x) (hmapLookup id transactions) dummyTransaction  in
  let i := uint2N (hmapFindWithDefault (Build_XUBInteger 0) msgPubkey custodians) in
  let bitsMask := N.land (N.shiftr (uint2N requestsMask) (8 * i)) 255 in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let MAX_QUEUED_REQUESTS := uint2N (toValue (eval_state (sRReader (MAX_QUEUED_REQUESTS_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let expiredTransactions := xHMapFilter (fun k v =>
    let index := uint2N (getPruvendoRecord Transaction_ι_index v) in
    andb (N.eqb index i) (N.leb ((N.shiftr (uint2N k) 32) + lifetime) tvm_now)
  ) transactions in
  let bitsMask' := bitsMask - length_ expiredTransactions in
  correctState l ->
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = false ->
  hmapIsMember msgPubkey custodians = true ->
  ETR_1 l' u dest value bounce allBalance payload stateInit ->
  bitsMask' < MAX_QUEUED_REQUESTS ->
  m_defaultRequiredConfirmations < 2 ->
  allBalance = true ->
  isOnlyMessage messqueue = true /\
  isMessageSent mes dest 0 messqueue = true .

Definition MTS_5 l id (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let FLAG_IGNORE_ERRORS := uint2N (toValue (eval_state (sRReader (FLAG_IGNORE_ERRORS_right rec def) ) l)) in
  let FLAG_PAY_FWD_FEE_FROM_BALANCE := uint2N (toValue (eval_state (sRReader (FLAG_PAY_FWD_FEE_FROM_BALANCE_right rec def) ) l)) in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let requestsMask := (toValue (eval_state (sRReader (m_requestsMask_right rec def) ) l)) in
  let m_defaultRequiredConfirmations :=  uint2N (toValue (eval_state (sRReader (m_defaultRequiredConfirmations_right rec def) ) l)) in (* ???? *)
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let l' := exec_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l in
  let messqueue := toValue ((eval_state (sRReader (ULtoRValue (IDefault_left rec def)))) l') in
  let stateInit' := xMaybeMapDefault (fun x => x) stateInit default in
  let mes := EmptyMessage IDefault (value, (bounce, ((Build_XUBInteger  (N.lor FLAG_IGNORE_ERRORS FLAG_PAY_FWD_FEE_FROM_BALANCE)), (payload, stateInit')))) in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  let u := xMaybeMapDefault (fun x => x) (hmapLookup id transactions) dummyTransaction  in
  let i := uint2N (hmapFindWithDefault (Build_XUBInteger 0) msgPubkey custodians) in
  let bitsMask := N.land (N.shiftr (uint2N requestsMask) (8 * i)) 255 in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let MAX_QUEUED_REQUESTS := uint2N (toValue (eval_state (sRReader (MAX_QUEUED_REQUESTS_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let expiredTransactions := xHMapFilter (fun k v =>
    let index := uint2N (getPruvendoRecord Transaction_ι_index v) in
    andb (N.eqb index i) (N.leb ((N.shiftr (uint2N k) 32) + lifetime) tvm_now)
  ) transactions in
  let bitsMask' := bitsMask - length_ expiredTransactions in
  correctState l ->
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = false ->
  hmapIsMember msgPubkey custodians = true ->
  ETR_1 l' u dest value bounce allBalance payload stateInit ->
  bitsMask' < MAX_QUEUED_REQUESTS ->
  m_defaultRequiredConfirmations < 2 ->
  allBalance = false ->
  isOnlyMessage messqueue = true /\
  isMessageSent mes dest 0 messqueue = true .

(* MTS_6_1 checked as part of correctState *)
(* MTS_6_2 checked as part of correctState *)

Definition MTS_6_3  l (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let l' := exec_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l in
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l) in
  let transactions' := toValue (eval_state (sRReader (m_transactions_right rec def) ) l') in
  let newTransactions := xHMapFilter (fun k v =>
    negb (hmapIsMember k transactions)
  ) transactions' in
  let transaction := snd (hd (Build_XUBInteger 0, dummyTransaction) (unwrap newTransactions)) in
  let mask := uint2N (getPruvendoRecord Transaction_ι_confirmationsMask transaction) in
  let creator := getPruvendoRecord Transaction_ι_creator transaction in
  let index := getPruvendoRecord Transaction_ι_index transaction in
  let bounce' := getPruvendoRecord Transaction_ι_bounce transaction in
  let dest' := getPruvendoRecord Transaction_ι_dest transaction in
  let payload' := getPruvendoRecord Transaction_ι_payload transaction in
  let value' := getPruvendoRecord Transaction_ι_value transaction in
  let flags := getPruvendoRecord Transaction_ι_sendFlags transaction in
  let IGNORE_ERRORS := uint2N (toValue (eval_state (sRReader (FLAG_IGNORE_ERRORS_right rec def) ) l)) in
  let SEND_ALL_REMAINING := uint2N (toValue (eval_state (sRReader (FLAG_SEND_ALL_REMAINING_right rec def) ) l)) in
  let PAY_FWD_FEE_FROM_BALANCE := uint2N (toValue (eval_state (sRReader (FLAG_PAY_FWD_FEE_FROM_BALANCE_right rec def) ) l)) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  let i := uint2N (hmapFindWithDefault (Build_XUBInteger 0) msgPubkey custodians) in
  let m_defaultRequiredConfirmations := uint2N (toValue (eval_state (sRReader (m_defaultRequiredConfirmations_right rec def) ) l)) in
  let requestsMask := toValue (eval_state (sRReader (m_requestsMask_right rec def) ) l) in
  let bitsMask := N.land (N.shiftr (uint2N requestsMask) (8 * i)) 255 in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let expiredTransactions := xHMapFilter (fun k v =>
    let index := uint2N (getPruvendoRecord Transaction_ι_index v) in
    andb (N.eqb index i) (N.leb ((N.shiftr (uint2N k) 32) + lifetime) tvm_now)
  ) transactions in
  let bitsMask' := bitsMask - length_ expiredTransactions in
  let MAX_QUEUED_REQUESTS := uint2N (toValue (eval_state (sRReader (MAX_QUEUED_REQUESTS_right rec def) ) l)) in
  correctState l ->
  m_defaultRequiredConfirmations > 1 ->
  hmapIsMember msgPubkey custodians = true ->
  bitsMask' < MAX_QUEUED_REQUESTS ->
  length_ newTransactions = 1 /\
  mask = N.shiftl 1 i /\
  creator = msgPubkey /\
  i = uint2N index /\
  dest = dest' /\
  bounce = bounce' /\
  payload = payload' /\
  (allBalance = true ->
   uint2N value' = 0 /\
   uint2N flags = N.lor IGNORE_ERRORS SEND_ALL_REMAINING
  ) /\
  (allBalance = false ->
   value' = value /\
   uint2N flags = N.lor IGNORE_ERRORS PAY_FWD_FEE_FROM_BALANCE).

Definition equalExceptLocalExpired (l l': LedgerLRecord rec) :=
  let transactions := toValue (eval_state (sRReader (m_transactions_right rec def) ) l) in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  let newTransactions : field_type _m_transactions := xHMapFilter (fun k v =>
    negb (N.leb ((N.shiftr (uint2N k) 32) + lifetime) tvm_now)
  ) transactions in
  ledgerEqb {$$ {$$ l with Ledger_MainState :=
  {$$ {$$
   getPruvendoRecord Ledger_MainState l
   with _m_transactions := newTransactions $$} : @field_type (LedgerLRecord rec) _ _ Ledger_MainState with
   _m_requestsMask := getPruvendoRecord _m_requestsMask
     (getPruvendoRecord Ledger_MainState l')

 $$}
$$} with Ledger_LocalState := getPruvendoRecord Ledger_LocalState l'
$$} l'.

Definition equalExceptLocal (l l': LedgerLRecord rec) :=
  ledgerEqb {$$ l with Ledger_LocalState := getPruvendoRecord Ledger_LocalState l' $$} l'.

Definition MTS_7 l (dest :  address) (value :  uint128) (bounce :  boolean) (allBalance :  boolean) (payload :  cell_) (stateInit :  optional  ( TvmCell )) : Prop :=
  let l' := exec_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l in
  let lifetime := uint2N (toValue (eval_state (sRReader (m_lifetime_right rec def) ) l)) in
  let tvm_now := uint2N (toValue (eval_state (sRReader || now ||) l)) in
  correctState l ->
  isError (eval_state (Uinterpreter (submitTransaction rec def dest value bounce allBalance payload stateInit)) l) = true ->
  equalExceptLocalExpired l l' = true \/
  equalExceptLocal l l' = true.


Require Import RelationClasses.

From Paco Require Import paco.
From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.
Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import Behavior.
Require Import Cover.
Require Import Pred.
Require Import Trace.

Require Import MemoryProps.
Require Import Mapping.

Set Implicit Arguments.

Section CAPFLEX.

  Record cap_flex (mem1 mem2: Memory.t) (tm: TimeMap.t): Prop :=
    {
      cap_flex_le: Memory.le mem1 mem2;
      cap_flex_middle: forall loc from1 to1 from2 to2
                              (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem1)
                              (TO: Time.lt to1 from2),
          Memory.get loc from2 mem2 = Some (to1, Message.reserve);
      cap_flex_back: forall loc, Memory.get loc (tm loc) mem2 =
                                 Some (Memory.max_ts loc mem1, Message.reserve);
      cap_flex_complete: forall loc from to msg
                               (GET1: Memory.get loc to mem1 = None)
                               (GET2: Memory.get loc to mem2 = Some (from, msg)),
          (exists f m, Memory.get loc from mem1 = Some (f, m));
    }
  .

  Lemma cap_flex_inv
        mem1 mem2 tm
        loc from to msg
        (CLOSED: Memory.closed mem1)
        (CAP: cap_flex mem1 mem2 tm)
        (GET: Memory.get loc to mem2 = Some (from, msg))
        (TM: forall loc, Time.lt (Memory.max_ts loc mem1) (tm loc))
    :
    Memory.get loc to mem1 = Some (from, msg) \/
    (Memory.get loc to mem1 = None /\
     exists from1 to2,
        Memory.adjacent loc from1 from to to2 mem1 /\
        Time.lt from to /\
        msg = Message.reserve) \/
    (Memory.get loc to mem1 = None /\
     from = Memory.max_ts loc mem1 /\
     to = tm loc /\
     msg = Message.reserve).
  Proof.
    inv CAP. move GET at bottom.
    destruct (Memory.get loc to mem1) as [[]|] eqn:GET1.
    { exploit cap_flex_le0; eauto. i.
      rewrite GET in x. inv x. auto. }
    right. exploit cap_flex_complete0; eauto. i. des.
    exploit Memory.max_ts_spec; eauto. i. des. inv MAX.
    - left.
      exploit Memory.adjacent_exists; try eapply H; eauto. i. des.
      assert (LT: Time.lt from from2).
      { clear cap_flex_middle0 cap_flex_back0 cap_flex_complete0 GET0 H.
        (* clear MIDDLE BACK COMPLETE GET0 H. *)
        inv x1. rewrite GET0 in x. inv x.
        exploit Memory.get_ts; try exact GET2. i. des.
        { subst. inv TS. }
        destruct (Time.le_lt_dec from2 from); auto.
        inv l.
        - exfalso.
          exploit Memory.get_ts; try exact GET0. i. des.
          { subst. inv H. }
          exploit Memory.get_disjoint; [exact GET0|exact GET2|..]. i. des.
          { subst. timetac. }
          apply (x2 from); econs; ss.
          + refl.
          + econs. auto.
        - exfalso. inv H.
          exploit cap_flex_le0; try exact GET2. i.
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. rewrite GET1 in GET0. inv GET0. }
          exploit Memory.get_disjoint; [exact GET|exact x|..]. i. des.
          { subst. rewrite GET1 in GET2. inv GET2. }
          destruct (Time.le_lt_dec to to2).
          + apply (x3 to); econs; ss. refl.
          + apply (x3 to2); econs; ss.
            * econs. auto.
            * refl.
      }
      exploit cap_flex_middle0; try eapply x1; eauto. i.
      destruct (Time.eq_dec to from2).
      + subst. rewrite GET in x0. inv x0. esplits; eauto.
      + exfalso. inv x1.
        exploit Memory.get_ts; try exact GET. i. des.
        { subst. rewrite GET1 in x. inv x. }
        exploit Memory.get_ts; try exact x0. i. des.
        { subst. exploit cap_flex_le0; try exact GET3. i.
          exploit Memory.get_disjoint; [exact GET|exact x1|..]. i. des.
          { subst. rewrite GET1 in GET3. inv GET3. }
          destruct (Time.le_lt_dec to to2).
          - apply (x4 to); econs; ss. refl.
          - apply (x4 to2); econs; ss.
            + econs. auto.
            + refl.
        }
        exploit Memory.get_disjoint; [exact GET|exact x0|..]. i. des; try congr.
        destruct (Time.le_lt_dec to from2).
        * apply (x4 to); econs; ss. refl.
        * apply (x4 from2); econs; ss.
          { econs. auto. }
          { refl. }
    - right. inv H. do 2 (split; auto).
      rewrite GET0 in x. inv x.
      specialize (cap_flex_back0 loc).
      exploit Memory.get_ts; try exact GET. i. des; try congr.
      exploit Memory.get_disjoint; [exact GET|exact cap_flex_back0|..]. i. des.
      { subst. esplits; eauto. }
      exfalso.
      destruct (Time.le_lt_dec to (tm loc)).
      + apply (x1 to); econs; ss. refl.
      + apply (x1 (tm loc)); econs; s;
          eauto using TM; try refl.
        econs. ss.
  Qed.

  Lemma cap_flex_exists
        mem1 tm
        (CLOSED1: Memory.closed mem1)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem1) (tm loc))
    :
      exists mem2, (<<CAP: cap_flex mem1 mem2 tm>>).
  Proof.
    hexploit Memory.cap_exists; eauto. i. des.
    hexploit (@choice
                Loc.t Cell.t
                (fun loc cell =>
                   forall ts,
                     Cell.get ts cell =
                     if (Time.eq_dec ts (tm loc))
                     then Some (Memory.max_ts loc mem1, Message.reserve)
                     else if (Time.eq_dec ts (Time.incr (Memory.max_ts loc mem1)))
                          then None
                          else Memory.get loc ts mem2)).
    { intros loc.
      hexploit (@Cell.remove_exists (mem2 loc)).
      { inv CAP. eapply BACK. } i. des.
      hexploit (@Cell.add_exists cell2 (Memory.max_ts loc mem1) (tm loc) Message.reserve).
      { i. erewrite Cell.remove_o in GET2; eauto. des_ifs.
        eapply Memory.cap_inv in GET2; eauto. des; clarify.
        { symmetry. eapply interval_le_disjoint.
          eapply Memory.max_ts_spec in GET2. des. auto. }
        { inv GET0. symmetry. eapply interval_le_disjoint.
          transitivity to0.
          { eapply memory_get_ts_le; eauto. }
          { eapply Memory.max_ts_spec in GET4. des. auto. }
        }
      }
      { eauto. }
      { econs. } i. des.
      exists cell0. i.
      erewrite Cell.add_o; eauto. erewrite Cell.remove_o; eauto. des_ifs. }
    intros [mem3 SPEC].

    exists mem3. dup CAP. inv CAP. econs.
    { ii. unfold Memory.get. rewrite SPEC. des_ifs.
      { eapply Memory.max_ts_spec in LHS. des.
        exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
        { eapply TM. }
        { eapply MAX. }
      }
      { eapply Memory.max_ts_spec in LHS. des.
        exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
        { eapply Time.incr_spec. }
        { eapply MAX. }
      }
      { eapply SOUND; auto. }
    }
    { i. unfold Memory.get. erewrite SPEC. dup ADJ. inv ADJ. des_ifs.
      { dup GET2. apply Memory.max_ts_spec in GET2. des.
        apply Memory.get_ts in GET0. des; subst.
        { exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
          { eapply TS. }
          { eapply Time.bot_spec. }
        }
        { exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
          { eapply GET0. } etrans.
          { eapply MAX. }
          { left. eauto. }
        }
      }
      { dup GET2. apply Memory.max_ts_spec in GET2. des.
        apply Memory.get_ts in GET0. des; subst.
        { exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
          { eapply TS. }
          { eapply Time.bot_spec. }
        }
        { exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
          { eapply GET0. } etrans.
          { eapply MAX. }
          { left. eapply Time.incr_spec. }
        }
      }
      { eapply MIDDLE; eauto. }
    }
    { i. unfold Memory.get. erewrite SPEC. des_ifs. }
    { i. unfold Memory.get in GET2. rewrite SPEC in GET2. des_ifs.
      { hexploit (@Memory.max_ts_spec loc).
        { inv CLOSED1. eapply INHABITED. }
        i. des. eauto. }
      { eapply COMPLETE; eauto. }
    }
  Qed.

  Lemma cap_cap_flex mem1 mem2
        (CAP: Memory.cap mem1 mem2)
    :
      cap_flex mem1 mem2 (fun loc => Time.incr (Memory.max_ts loc mem1)).
  Proof.
    inv CAP. econs; eauto.
  Qed.

  Lemma cap_flex_max_ts mem1 mem2 tm
        (CLOSED: Memory.closed mem1)
        (CAP: cap_flex mem1 mem2 tm)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem1) (tm loc))
    :
      forall loc,
        Memory.max_ts loc mem2 = tm loc.
  Proof.
    i. set (BACK:=(cap_flex_back CAP) loc).
    exploit Memory.max_ts_spec; try exact BACK. i. des.
    apply TimeFacts.antisym; ss.
    destruct (Time.le_lt_dec (Memory.max_ts loc mem2) (tm loc)); ss.
    exploit cap_flex_inv; try exact GET; eauto. i. des.
    - exploit Memory.max_ts_spec; try exact x0. i. des.
      exploit TimeFacts.lt_le_lt; try exact l; try exact MAX0. i.
      specialize (TM loc). rewrite x1 in TM. timetac.
    - inv x1. exploit Memory.get_ts; try exact GET2. i. des.
      { rewrite x1 in *. inv l. }
      exploit Memory.max_ts_spec; try exact GET2. i. des.
      exploit TimeFacts.lt_le_lt; try exact x1; try exact MAX0. i.
      rewrite x3 in l. specialize (TM loc). rewrite l in TM. timetac.
    - subst. rewrite x2 in *. timetac.
  Qed.

  Lemma cap_flex_covered
        mem0 mem1 tm
        (CAP: cap_flex mem0 mem1 tm)
        (CLOSED: Memory.closed mem0)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem0) (tm loc))
        loc to
    :
      Interval.mem (Time.bot, (tm loc)) to
      <->
      covered loc to mem1.
  Proof.
    split; i.
    {
      inv H. set (@cell_elements_least
                             (mem0 loc)
                             (fun to' => Time.le to to')). des; cycle 1.
      { destruct (Time.le_lt_dec to (Memory.max_ts loc mem0)).
        - exfalso. exploit Memory.max_ts_spec.
          + eapply CLOSED.
          + i. des. exploit EMPTY; eauto.
        - econs.
          + eapply cap_flex_back; eauto.
          + econs; eauto. }
      set (@cell_elements_greatest
             (mem0 loc)
             (fun to' => Time.lt to' to)). des; cycle 1.
      { exfalso. exploit EMPTY.
        - eapply CLOSED.
        - eauto.
        - ss. }
      destruct (Time.le_lt_dec to from).
      - exploit (cap_flex_middle CAP).
        + econs.
          * eapply GET0.
          * eapply GET.
          * eapply TimeFacts.lt_le_lt; eauto.
          * i. destruct (Memory.get loc ts mem0) eqn:GET1; auto.
            exfalso. destruct p.
            destruct (Time.le_lt_dec to ts).
            { exploit LEAST; eauto. i.
              eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
              { eapply x. }
              eapply TimeFacts.le_lt_lt.
              { eapply TS2. }
              { eapply memory_get_ts_strong in GET. des; clarify; ss.
                exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
                - eapply l.
                - eauto. } }
            { exploit GREATEST; eauto. i.
              eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
              { eapply x. }
              { eauto. } }
        + eapply TimeFacts.lt_le_lt; eauto.
        + i. econs; eauto. econs; eauto.
      - econs.
        + eapply (cap_flex_le CAP). eapply GET.
        + econs; eauto.
    }
    {
      inv H. apply Memory.max_ts_spec in GET. des.
      inv ITV. ss. econs; ss.
      - eapply TimeFacts.le_lt_lt; eauto. apply Time.bot_spec.
      - etrans; eauto. erewrite <- cap_flex_max_ts; eauto.
    }
  Qed.

  Record cap_flex_map_loc (max tm0 tm1: Time.t)
         (times: list Time.t)
         (f: Time.t -> Time.t -> Prop): Prop :=
    {
      cap_flex_map_loc_map_lt:
        mapping_map_lt_loc f;
      cap_flex_map_loc_map_bot:
        f Time.bot Time.bot;
      cap_flex_map_loc_ident:
        forall ts (TS: Time.le ts max),
          f ts ts;
      cap_flex_map_loc_max:
        exists fts,
          (<<MAP: f tm0 fts>>) /\
          (<<TS: Time.le tm1 fts>>);
      cap_flex_map_loc_bound:
        forall ts fts (TS: Time.lt max ts) (MAP: f ts fts),
          Time.le tm1 fts;
      cap_flex_map_loc_complete:
        forall ts (IN: List.In ts times),
        exists fts, <<MAP: f ts fts>>;
    }.

  Record cap_flex_map (max tm0 tm1: TimeMap.t)
         (times: Loc.t -> list Time.t)
         (f: Loc.t -> Time.t -> Time.t -> Prop): Prop :=
    {
      cap_flex_map_map_lt:
        mapping_map_lt f;
      cap_flex_map_map_bot:
        mapping_map_bot f;
      cap_flex_map_ident:
        forall loc ts (TS: Time.le ts (max loc)),
          f loc ts ts;
      cap_flex_map_max:
        forall loc,
        exists fts,
          (<<MAP: f loc (tm0 loc) fts>>) /\
          (<<TS: Time.le (tm1 loc) fts>>);
      cap_flex_map_bound:
        forall loc ts fts (TS: Time.lt (max loc) ts) (MAP: f loc ts fts),
          Time.le (tm1 loc) fts;
      cap_flex_map_complete:
        forall loc ts (IN: List.In ts (times loc)),
          mappable_time f loc ts;
    }.

  Lemma cap_flex_map_locwise (max tm0 tm1: TimeMap.t)
        (times: Loc.t -> list Time.t)
        (f: Loc.t -> Time.t -> Time.t -> Prop)
        (LOCWISE: forall loc, cap_flex_map_loc (max loc) (tm0 loc) (tm1 loc) (times loc) (f loc))
    :
      cap_flex_map max tm0 tm1 times f.
  Proof.
    econs.
    { eapply mapping_map_lt_locwise.
      eapply LOCWISE. }
    { ii. eapply LOCWISE. }
    { ii. eapply LOCWISE. auto. }
    { ii. eapply LOCWISE. }
    { ii. eapply LOCWISE; eauto. }
    { ii. eapply LOCWISE. auto. }
  Qed.

  Lemma cap_flex_map_loc_exists max tm0 tm1 times
        (TM0: Time.lt max tm0)
        (TM1: Time.lt max tm1)
    :
      exists f,
        (<<MAP: cap_flex_map_loc max tm0 tm1 times f>>).
  Proof.
    hexploit (@shift_map_exists
                max tm1 (Time.incr tm1)
                (tm0::times)); ss.
    { left. auto. }
    { apply Time.incr_spec. }
    intros [f SPEC]. exists f. des. splits; auto.
    econs; eauto.
    { eapply SAME. eapply Time.bot_spec. }
    { exploit (COMPLETE tm0); auto. i. des. esplits; eauto.
      eapply BOUND in MAPPED; eauto. left. des. auto. }
    { i. exploit BOUND; eauto. i. des. left. auto. }
  Qed.

  Lemma cap_flex_map_exists max tm0 tm1 times
        (TM0: forall loc, Time.lt (max loc) (tm0 loc))
        (TM1: forall loc, Time.lt (max loc) (tm1 loc))
    :
      exists f,
        (<<MAP: cap_flex_map max tm0 tm1 times f>>).
  Proof.
    hexploit (@choice Loc.t (Time.t -> Time.t -> Prop)
                      (fun loc f =>
                         cap_flex_map_loc (max loc) (tm0 loc) (tm1 loc) (times loc) f)).
    { i. eapply cap_flex_map_loc_exists; eauto. }
    intros [f SPEC]. exists f.
    eapply cap_flex_map_locwise; eauto.
  Qed.

  Lemma cap_flex_map_ident_concrete maxmap max tm0 tm1 times f mem0
        (MAP: cap_flex_map max tm0 tm1 times f)
        (MAXMAP: Memory.max_concrete_timemap mem0 maxmap)
        (MAX: TimeMap.le maxmap max)
    :
      map_ident_concrete f mem0.
  Proof.
    ii. inv CONCRETE. eapply Memory.max_concrete_ts_spec in GET; eauto.
    des. eapply MAP; eauto.
  Qed.

  Lemma concrete_messages_le_cap_flex_memory_map
        mem0 mem1 maxmap max tm0 tm1 cap0 cap1 times f
        (CONCRETE: concrete_messages_le mem0 mem1)
        (MAXMAP: Memory.max_concrete_timemap mem0 maxmap)
        (MAX: TimeMap.le maxmap max)
        (TM0: forall loc, Time.lt (Memory.max_ts loc mem0) (tm0 loc))
        (TM1: forall loc, Time.lt (Memory.max_ts loc mem1) (tm1 loc))
        (CAP0: cap_flex mem0 cap0 tm0)
        (CAP1: cap_flex mem1 cap1 tm1)
        (MEM0: Memory.closed mem0)
        (MEM1: Memory.closed mem1)
        (MAP: cap_flex_map max tm0 tm1 times f)
    :
      memory_map f cap0 cap1.
  Proof.
    assert (IDENT: map_ident_concrete f mem0).
    { ii. inv CONCRETE0. eapply Memory.max_concrete_ts_spec in GET; eauto.
      des. eapply MAP; eauto. }
    econs.
    { i. eapply (@cap_flex_inv mem0 cap0 tm0) in GET; eauto. des; eauto.
      destruct msg as [val released|]; auto. right.
      exploit CONCRETE; eauto. i. des. esplits.
      { eapply cap_flex_map_ident; eauto. transitivity (maxmap loc); auto.
        eapply Memory.max_concrete_ts_spec; eauto. }
      { eapply map_ident_concrete_closed_message; eauto.
        eapply MEM0 in GET. des; auto. }
      { refl. }
      { eapply (cap_flex_le CAP1) in GET1. eauto. }
    }
    { i. hexploit ((cap_flex_map_max MAP) loc). i. des.
      left. exists (tm0 loc), Time.bot, fts, Time.bot. splits; auto.
      { eapply Time.bot_spec. }
      { hexploit (@cap_flex_max_ts mem1 cap1 tm1); eauto.
        i. eapply Memory.max_ts_spec in GET. des.
        erewrite H in MAX0. etrans; eauto. }
      { eapply (cap_flex_map_map_bot MAP). }
      { i. eapply cap_flex_covered; eauto. }
    }
  Qed.

  Lemma cap_flex_closed mem cap tm
        (CAP: cap_flex mem cap tm)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem) (tm loc))
        (CLOSED: Memory.closed mem)
    :
      Memory.closed cap.
  Proof.
    dup CLOSED. inv CLOSED. econs.
    { i. eapply cap_flex_inv in MSG; eauto. des; subst.
      { exploit CLOSED1; eauto. i. des. splits; auto.
        eapply concrete_promised_le_closed_message; eauto.
        eapply concrete_messages_le_concrete_promised_le; eauto.
        eapply memory_le_concrete_messages_le; eauto.
        eapply cap_flex_le; eauto. }
      { esplits; eauto. econs. }
      { esplits; eauto. econs. }
    }
    { ii. specialize (INHABITED loc).
      eapply cap_flex_le in INHABITED; eauto.
    }
  Qed.

  Lemma cap_left_end mem1 mem2 tm loc ts1 ts2 msg1
        (MEM: Memory.closed mem1)
        (CAP: cap_flex mem1 mem2 tm)
        (GET: Memory.get loc ts2 mem1 = Some (ts1, msg1))
    :
      exists ts0 msg0,
        (<<GET: Memory.get loc ts1 mem2 = Some (ts0, msg0)>>).
  Proof.
    destruct (Memory.get loc ts1 mem1) as [[ts0 msg0]|] eqn:GETORG.
    { eapply cap_flex_le in GETORG; eauto. }
    { hexploit (@cell_elements_greatest
                  (mem1 loc)
                  (fun ts => Time.lt ts ts1)). i. des; cycle 1.
      { inv MEM. specialize (INHABITED loc).
        hexploit EMPTY; eauto. intros TS.
        destruct (Time.le_lt_dec ts1 Time.bot); ss. destruct l.
        { exfalso. eapply Time.lt_strorder.
          eapply TimeFacts.lt_le_lt; eauto. eapply Time.bot_spec. }
        { inv H. clarify. }
      }
      hexploit (cap_flex_middle CAP).
      { econs.
        { eapply GET0. }
        { eapply GET. }
        { eapply TimeFacts.lt_le_lt; eauto. eapply memory_get_ts_le; eauto. }
        { i. destruct TS2.
          { destruct (Memory.get loc ts mem1) eqn:GETTS; auto. destruct p.
            eapply GREATEST in GETTS; eauto. timetac. }
          { inv H. eauto. }
        }
      }
      { auto. }
      eauto.
    }
  Qed.

  Lemma cap_flex_wf
        lc mem1 mem2 tm
        (CAP: cap_flex mem1 mem2 tm)
        (WF: Local.wf lc mem1):
    Local.wf lc mem2.
  Proof.
    eapply memory_concrete_le_local_wf.
    { eapply memory_concrete_le_le. eapply CAP. }
    { etrans.
      { eapply WF. }
      { eapply CAP. }
    }
    { eauto. }
  Qed.

  Lemma cap_flex_future_memory_map
        mem0 mem1 tm cap
        (TM0: forall loc, Time.lt (Memory.max_ts loc mem0) (tm loc))
        (TM1: TimeMap.le (Memory.max_timemap mem1) tm)
        (CAP: cap_flex mem0 cap tm)
        (MEM0: Memory.closed mem0)
        (FUTURE: Memory.future_weak mem0 mem1)
    :
      memory_map ident_map cap mem1.
  Proof.
    econs.
    { i. destruct msg as [val released|]; auto. right.
      eapply cap_flex_inv in GET; eauto. des; clarify.
      eapply Memory.future_weak_get1 in GET; eauto. des.
      esplits; eauto; ss. eapply ident_map_message. }
    { i. left. exists (tm loc), Time.bot, (tm loc), Time.bot.
      splits; ss; auto.
      { eapply Time.bot_spec. }
      { eapply Memory.max_ts_spec in GET. des. etrans; eauto. }
      { i. eapply cap_flex_covered; eauto. }
    }
  Qed.

  Lemma cap_flex_future_weak
        mem1 mem2 tm
        (CAP: cap_flex mem1 mem2 tm)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem1) (tm loc))
        (CLOSED: Memory.closed mem1):
    Memory.future_weak mem1 mem2.
  Proof.
    econs; ii.
    { eapply CAP in GET. esplits; eauto. refl. }
    { eapply cap_flex_inv in GET2; eauto. des; clarify. }
    { eapply cap_flex_inv in GET2; eauto. des; clarify. }
  Qed.

  Lemma cap_flex_concrete_messages_le mem cap tm
        (CAP: cap_flex mem cap tm)
        (CLOSED: Memory.closed mem)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem) (tm loc))
    :
      concrete_messages_le cap mem.
  Proof.
    ii. eapply cap_flex_inv in GET0; eauto. des; clarify. eauto.
  Qed.

End CAPFLEX.


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

(** this module provides a denotational/axiomatic semantics to c++ compilation
    units.
 *)
Require Import bedrock.prelude.base.
Require Import bedrock.lang.cpp.ast.
From bedrock.lang.cpp Require Import
     semantics logic.pred logic.path_pred logic.heap_pred.
Require Import iris.proofmode.proofmode.

Import ChargeNotation.

Section with_cpp.
  Context `{Σ : cpp_logic} {resolve:genv}.

  Set Default Proof Using "Σ resolve".

  Definition denoteSymbol (tu : translation_unit) (n : obj_name) (o : ObjValue) : mpred :=
    _global n |->
        match o with
        | Ovar t e =>
          (* no need for [erase_qualifiers], we only check the head *)
          match drop_qualifiers t with
          | Tarray _ 0 =>
            (* TODO: maybe arrays of unknown size should also use [validR]? *)
            validR
          | _ =>
            svalidR
          end
        | Ofunction f =>
          match f.(f_body) with
          | None => svalidR
          | Some body => as_Rep (code_at resolve tu f)
          end
        | Omethod m =>
          match m.(m_body) with
          | None => svalidR
          | Some body => as_Rep (method_at resolve tu m)
          end
        | Oconstructor c =>
          match c.(c_body) with
          | None => svalidR
          | Some body => as_Rep (ctor_at resolve tu c)
          end
        | Odestructor d =>
          match d.(d_body) with
          | None => svalidR
          | Some body => as_Rep (dtor_at resolve tu d)
          end
        end.

  #[global] Instance denoteSymbol_persistent {tu n o} : Persistent (denoteSymbol tu n o).
  Proof. rewrite /denoteSymbol; repeat case_match; apply _. Qed.

  #[global] Instance denoteSymbol_affine {tu n o} : Affine (denoteSymbol tu n o) := _.

  (** [is_strict_valid o] states that if the declaration [o] occurs in a
      translation unit, the pointer to it is guaranteed to be strictly valid.
   *)
  Definition is_strict_valid o : Prop :=
    match o with
    | None => False
    | Some (Ovar t _) =>
        match drop_qualifiers t with
        | Tarray _ 0 => False
        | _ => True
        end
    | Some _ => True
    end.

  Lemma denoteSymbol_strict_valid tu n o :
    is_strict_valid (Some o) ->
    denoteSymbol tu n o |-- strict_valid_ptr (_global n).
  Proof.
    rewrite /is_strict_valid/denoteSymbol; destruct o.
    { case_match; intros; try by rewrite _at_svalidR.
      destruct n0; try tauto. by rewrite _at_svalidR. }
    all: case_match; by
        intros;rewrite !(_at_as_Rep, _at_svalidR,
      code_at_strict_valid, method_at_strict_valid, ctor_at_strict_valid, dtor_at_strict_valid).
  Qed.

  Lemma denoteSymbol_valid tu n o :
    denoteSymbol tu n o |-- valid_ptr (_global n).
  Proof.
    case: o. {
      rewrite /denoteSymbol => t o; repeat case_match => //=; intros;
        rewrite (_at_validR, _at_svalidR); trivial using strict_valid_valid.
    }
    all: intros; rewrite denoteSymbol_strict_valid //; apply strict_valid_valid.
  Qed.

  (** TODO incomplete *)
  Definition initSymbol (n : obj_name) (o : ObjValue) : mpred :=
    _at (_global n)
        match o with
        | Ovar t (Some e) =>
          emp (*
      Exists Q : FreeTemps -> mpred,
      □ (_at (_eq a) (uninitR (resolve:=resolve) t 1) -*
         Forall ρ ti, wp_init (resolve:=resolve) ti ρ t (Vptr a) e Q) ** Q emp
*)
      (* ^^ todo(gmm): static initialization is not yet supported *)
        | Ovar t None =>
          uninitR (resolve:=resolve) t (cQp.m 1)
        | _ => emp
        end.

  Definition denoteModule_def (tu : translation_unit) : mpred :=
    ([∗list] sv ∈ map_to_list tu.(symbols), denoteSymbol tu sv.1 sv.2) **
    [| module_le tu resolve.(genv_tu) |].
  Definition denoteModule_aux : seal (@denoteModule_def). Proof. by eexists. Qed.
  Definition denoteModule := denoteModule_aux.(unseal).
  Definition denoteModule_eq : @denoteModule = _ := denoteModule_aux.(seal_eq).

  #[global] Hint Opaque denoteModule : typeclass_instances.

  #[global] Instance denoteModule_persistent {module} : Persistent (denoteModule module).
  Proof.
    red. rewrite denoteModule_eq /denoteModule_def; intros.
    destruct module; simpl.
    iIntros "[#M #H]"; iFrame "#".
  Qed.

  #[global] Instance denoteModule_affine {module} : Affine (denoteModule module).
  Proof using . refine _. Qed.

  Lemma denoteModule_denoteSymbol n m o :
    m.(symbols) !! n = Some o ->
    denoteModule m |-- denoteSymbol m n o.
  Proof.
    rewrite denoteModule_eq/denoteModule_def.
    intros; iIntros "[M _]".
    rewrite /lookup /symbol_lookup /= /lookup in H.
    rewrite /map_to_list /avl.IM_maptolist.
    assert (exists xs ys, avl.IM.elements (symbols m) = xs ++ (n, o) :: ys) as [ ? [ ? -> ] ].
    { apply avl.IM.find_2 in H.
      apply avl.IM.elements_1 in H.
      eapply SetoidList.InA_alt in H.
      destruct H as [ ? [ ? H ]].
      do 2 red in H0; simpl in H0. destruct H0; subst.
      eapply in_split in H.
      destruct x; apply H. }
    rewrite big_opL_app.
    rewrite big_opL_cons.
    by iDestruct "M" as "[_ [M _]]".
  Qed.

  Lemma denoteModule_strict_valid n m :
    is_strict_valid (m.(symbols) !! n) ->
    denoteModule m |-- strict_valid_ptr (_global n).
  Proof.
    rewrite /is_strict_valid.
    case_match; try tauto.
    intros; iIntros "M".
    iDestruct (denoteModule_denoteSymbol with "M") as "M"; eauto.
    iApply denoteSymbol_strict_valid; eauto.
  Qed.

  Lemma denoteModule_valid n m :
    m.(symbols) !! n <> None ->
    denoteModule m |-- valid_ptr (_global n).
  Proof.
    intros; iIntros "M".
    destruct (symbols m !! n) eqn:?; try congruence.
    iDestruct (denoteModule_denoteSymbol with "M") as "M"; eauto.
    by iApply denoteSymbol_valid.
  Qed.

  #[global] Instance denoteModule_models_observe tu : Observe [| tu ⊧ resolve |] (denoteModule tu).
  Proof.
    apply observe_intro_only_provable.
    rewrite denoteModule_eq/denoteModule_def.
    iIntros "[_ %]". iPureIntro. constructor.
    destruct (module_le_spec tu (genv_tu resolve)); eauto.
    destruct H.
  Qed.

End with_cpp.

Arguments denoteModule _ : simpl never.