(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    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 General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool seq eqtype.
From LemmaOverloading
Require Import heaps.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(******************************************************************************)
(* noaliasR :                                                                 *)
(*    lemma automated with Canonical Structures to prove/rewrite expressions  *)
(*    with the form                                                           *)
(*      x1 != x2                                                              *)
(*    for x1, x2 : ptr. Usage:                                                *)
(*      rewrite/apply: (noaliasR D)                                           *)
(*    where D : def h, and exists expressions h1 h2 in h, where               *)
(*    hi = xi :-> vi for i in [1,2] and some v1 v2                            *)
(*                                                                            *)
(* The lemma uses several structures. They are defined in different modules.  *)
(* - The module Scan stores in a list all the pointers in h                   *)
(* - The module Search finds a pointer in a list                              *)
(* - The module Search2 finds for two distinct pointers in a list             *)
(* - The module NoAlias combines the above to prove our goal                  *)
(******************************************************************************)

(* Collect pointers in a heap *)
Module Scan.
Section ScanSection.
(* The algorithm is defined as follows:
   - if the heap is h1 :+ h2, then recurse over h1 and h2 and concatenate the
     results.
   - if the heap is x :-> v, then return [x]
   - otherwise, return []
*)

(* Structure to control the flow of the algorithm *)
Structure tagged_heap := Tag {untag : heap}.
Local Coercion untag : tagged_heap >-> heap.

Definition default_tag := Tag.
Definition ptr_tag := default_tag.
Canonical Structure union_tag h := ptr_tag h.

Definition axiom h s :=
  def h -> uniq s /\ forall x, x \in s -> x \in dom h.

(* Main structure *)
Structure form s := Form {heap_of : tagged_heap; _ : axiom heap_of s}.
Local Coercion heap_of : form >-> tagged_heap.

Lemma union_pf s1 s2 (h1 : form s1) (h2 : form s2) :
        axiom (union_tag (h1 :+ h2)) (s1 ++ s2).
Proof.
move:h1 h2=>[[i1]] H1 [[i2]] H2; rewrite /axiom /= in H1 H2 * => D.
case/(_ (defUnl D)): H1=>U1 H1; case/(_ (defUnr D)): H2=>U2 H2.
split=>[|x]; last first.
- rewrite mem_cat; case/orP; [move/H1 | move/H2];
  by rewrite domUn !inE /= D => -> //=; rewrite orbT.
rewrite cat_uniq U1 U2 andbT -all_predC.
apply/allP=>x; move/H2=>H3; apply: (introN idP); move/H1=>H4.
by case: defUn D=>// _ _; move/(_ _ H4); rewrite H3.
Qed.

Canonical Structure union_form s1 s2 h1 h2 :=
  Form (@union_pf s1 s2 h1 h2).

Lemma ptr_pf A x (v : A) : axiom (ptr_tag (x :-> v)) [:: x].
Proof.
rewrite /axiom /= defPt => D; split=>//.
by move=>y; rewrite inE; move/eqP=>->; rewrite domPt inE /= eq_refl D.
Qed.

Canonical Structure ptr_form A x (v : A) :=
  Form (@ptr_pf A x v).

Lemma default_pf h : axiom (default_tag h) [::].
Proof. by move=>D; split. Qed.

Canonical Structure default_form h := Form (@default_pf h).

Lemma scanE s (h : form s) x : def h -> x \in s -> x \in dom h.
Proof. by case: h=>hp /= A D H; exact: ((proj2 (A D)) _ H). Qed.

End ScanSection.

(* Pack the exports, as they are not automatically exported by Coq *)
Module Exports.
Canonical Structure union_tag.
Canonical Structure union_form.
Canonical Structure ptr_form.
Canonical Structure default_form.
Coercion untag : tagged_heap >-> heap.
Coercion heap_of : form >-> tagged_heap.
End Exports.

End Scan.

Export Scan.Exports.

Example ex_scan x y h :
          let: hp := (y :-> 1 :+ h :+ x :-> 2) in def hp -> x \in dom hp.
Proof.
move=>D; apply: Scan.scanE=>//=.
by rewrite ?in_cons ?eqxx ?orbT.
Abort.

(* Search a pointer in a list. Could be generalize to any type *)
Module Search.
Section SearchSection.
(* The algorithm is defined as follow:
   - test if the list is (x :: s) for x being the element we are looking for
   - if the list is (y :: s), then recurse using s
*)

(* Stucture for controlling the flow of the algorithm *)
Structure tagged_seq := Tag {untag : seq ptr}.
Local Coercion untag : tagged_seq >-> seq.

Definition recurse_tag := Tag.
Canonical Structure found_tag s := recurse_tag s.

Definition axiom x (s : tagged_seq) := x \in untag s.

(* Main structure *)
Structure form x := Form {seq_of : tagged_seq; _ : axiom x seq_of}.
Local Coercion seq_of : form >-> tagged_seq.

Lemma found_pf x s : axiom x (found_tag (x :: s)).
Proof. by rewrite /axiom inE eq_refl. Qed.

Canonical Structure found_form x s :=
  Form (found_pf x s).

Lemma recurse_pf x y (f : form x) : axiom x (recurse_tag (y :: f)).
Proof. by move:f=>[[s]]; rewrite /axiom /= inE orbC => ->. Qed.

Canonical Structure recurse_form x y (f : form x) :=
  Form (recurse_pf y f).

Lemma findE x (f : form x) : x \in untag f.
Proof. by move:f=>[s]; apply. Qed.

End SearchSection.

Module Exports.
Canonical Structure found_tag.
Canonical Structure found_form.
Canonical Structure recurse_form.
Coercion untag : tagged_seq >-> seq.
Coercion seq_of : form >-> tagged_seq.
End Exports.

End Search.

Export Search.Exports.

Example ex_find (x y z : ptr) : x \in [:: z; x; y].
by apply: Search.findE.
Abort.

(* Search for two different pointers in a list *)
Module Search2.
Section Search2Section.
(* The algorithm works as follow: Let x and y be the pointers we are looking for
   - If we found x, then search for y using the previous module
   - If we found y, then search for x using the previous module
   - If, instead, we found some pointer z, then recurse
*)

(* Stucture for controlling the flow of the algorithm *)
Structure tagged_seq := Tag {untag : seq ptr}.
Local Coercion untag : tagged_seq >-> seq.

Definition foundz_tag := Tag.
Definition foundy_tag := foundz_tag.
Canonical Structure foundx_tag s := foundy_tag s.

Definition axiom (x y : ptr) (s : tagged_seq) :=
  [/\ x \in untag s, y \in untag s & uniq s -> x != y].

(* Main structure *)
Structure form x y := Form {seq_of : tagged_seq; _ : axiom x y seq_of}.
Local Coercion seq_of : form >-> tagged_seq.

Lemma foundx_pf x y (s : Search.form y) : axiom x y (foundx_tag (x :: s)).
Proof.
move: s=>[[s]]; rewrite /Search.axiom /= /axiom !inE eq_refl /= => H1.
by rewrite H1 orbT; split=>//; case/andP=>H2 _; case: eqP H1 H2=>// -> ->.
Qed.

Canonical Structure foundx_form x y (s : Search.form y) :=
  Form (foundx_pf x s).

Lemma foundy_pf x y (s : Search.form x) : axiom x y (foundy_tag (y :: s)).
Proof.
move: s=>[[s]]; rewrite /Search.axiom /= /axiom !inE eq_refl /= => H1.
by rewrite H1 orbT; split=>//; case/andP=>H2 _; case: eqP H1 H2=>// -> ->.
Qed.

Canonical Structure foundy_form x y (s : Search.form x) :=
  Form (foundy_pf y s).

Lemma foundz_pf x y z (s : form x y) : axiom x y (foundz_tag (z :: s)).
Proof.
move: s=>[[s]]; case=>/= H1 H2 H3.
rewrite /axiom /= !inE /= H1 H2 !orbT; split=>//.
by case/andP=>_; apply: H3.
Qed.

Canonical Structure foundz_form x y z (s : form x y) :=
  Form (foundz_pf z s).

Lemma find2E x y (s : form x y) : uniq s -> x != y.
Proof. by move: s=>[s /= [_ _]]; apply. Qed.

End Search2Section.

Module Exports.
Canonical Structure foundx_tag.
Canonical Structure foundx_form.
Canonical Structure foundy_form.
Canonical Structure foundz_form.
Coercion untag : tagged_seq >-> seq.
Coercion seq_of : form >-> tagged_seq.
End Exports.

End Search2.

Export Search2.Exports.

Example ex_find2 (x y z : ptr) : uniq [:: z; x; y] -> x != y.
move=>H.
move: (Search2.find2E H).
Abort.

(* Now package everything together *)
Module NoAlias.
Section NoAliasSection.
(* The paper describes the reason for this module *)

Structure tagged_ptr (y : ptr) := Tag {untag : ptr}.
Local Coercion untag : tagged_ptr >-> ptr.

(* Force the unification of y with what appears in the goal *)
Definition singleton y := @Tag y y.

(* Main structure *)
Structure form x y (s : seq ptr) :=
  Form {y_of : tagged_ptr y;
        _ : uniq s -> x != untag y_of}.
Local Coercion y_of : form >-> tagged_ptr.

Arguments Form : clear implicits.

Lemma noalias_pf (x y : ptr) (f : Search2.form x y) :
        uniq f -> x != singleton y.
Proof. by move: f=>[[s]][]. Qed.

Canonical Structure start x y (f : Search2.form x y) :=
  Form x y f (singleton y) (@noalias_pf x y f).

End NoAliasSection.

Module Exports.
Canonical Structure singleton.
Canonical Structure start.
Coercion untag : tagged_ptr >-> ptr.
Coercion y_of : form >-> tagged_ptr.
End Exports.

End NoAlias.

Export NoAlias.Exports.

Lemma noaliasR s x y (f : Scan.form s) (g : NoAlias.form x y s) :
               def f -> x != NoAlias.y_of g.
Proof. by move: f g=>[[h]] H1 [[y']] /= H2; case/H1=>U _; apply: H2. Qed.

Arguments noaliasR {s x y f g}.

Example exnc A (x1 x2 x3 x4 : ptr) (v1 v2 : A) (h1 h2 : heap) :
  def (h1 :+ x2 :-> 1 :+ h2 :+ x1 :-> v2 :+ (x3 :-> v1 :+ empty)) ->
     (x1 != x2) /\
     (x1 != x2) && (x2 != x3) && (x3 != x1) /\
     (x2 == x3) = false /\ (x1 == x2) = false /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     ((x1 != x2) && (x2 != x3)) = (x1 != x2) /\
     (x1 != x2) && (x2 != x3) && (x1 != x4) && (x3 != x1).

Proof.
move=>D.
split.
- by apply: (noaliasR D).
split.
  (* backwards reasoning works *)
- by rewrite !(noaliasR D).
split.
  (* subterm selection works *)
- by rewrite [x2 == x3](negbTE (noaliasR D)).
split.
- (* composition works *)
  by rewrite (negbTE (noaliasR D)).
split.
- by rewrite [x2 != x3](noaliasR D) andbT.
split.
- by rewrite (noaliasR (x := x2) D) andbT.
split.
- by rewrite (noaliasR (y := x3) D) andbT.
split.
- by rewrite (noaliasR (x := x2) (y := x3) D) andbT.
(* rewriting skips the subgoals that don't apply *)
(* just as it should *)
rewrite !(negbTE (noaliasR D)).
admit.
Abort.

Lemma noaliasR_fwd1 s (f : Scan.form s) (D : def f) x y (g : Search2.form x y) :
  s = g ->
  x != y.
Proof.
case: g=>[l/=[_ _]] H U.
apply: H.
move: U=><-.
case: f D=>[h/=].
move=>H D; by case: H.
Qed.

Arguments noaliasR_fwd1 [s f] D x y [g].

Notation noaliasR_fwd D x y := (noaliasR_fwd1 D x y (Logic.eq_refl _)).
Notation "()" := (Logic.eq_refl _).

Example exnc A (x1 x2 x3 x4 : ptr) (v1 v2 : A) (h1 h2 : heap) :
  def (h1 :+ x2 :-> 1 :+ h2 :+ x1 :-> v2 :+ (x3 :-> v1 :+ empty)) ->
     (x1 != x2) /\
     (x1 != x2) && (x2 != x3) && (x3 != x1) /\
     (x2 == x3) = false /\ (x1 == x2) = false.
Proof.
move=>D.
split.
- apply: (noaliasR_fwd1 D x1 x2 ()).
split.
  set H := noaliasR_fwd1 D.
  by rewrite (H x1 x2 _ ()) (H x2 x3 _ ()) (H x3 x1 _ ()).
split.
  (* subterm selection works *)
- by rewrite [x2 == x3](negbTE (noaliasR_fwd D x2 x3)).
- (* composition works *)
  by rewrite (negbTE (noaliasR_fwd D x1 x2)).
Abort.

Lemma scan_it s (f : Scan.form s) : def f -> uniq s.
case: f=>/= h A D.
by case: A.
Qed.
Arguments scan_it [s f].

Definition search_them x y g := @Search2.find2E x y g.
Arguments search_them x y [g].

Example without_notation
 A (x1 x2 x3 : ptr) (v1 v2 v3 : A) (h1 h2 : heap) :
 def (h1 :+ (x1 :-> v1 :+ x2 :-> v2) :+ (h2 :+ x3 :-> v3))
 -> (x1 != x3).
Proof.
move=>D.
by apply: (search_them x1 x3 (scan_it D)).
Abort.

Lemma noaliasR_fwd_wrong1 x y (g : Search2.form x y) (f : Scan.form g) : def f -> x != y.
case: f=>h /= A D.
move: (A D)=>{A D} [U _].
case: g U=>s /= [_ _].
by apply.
Qed.

(*
Lemma noaliasR_fwd_wrong2 s (f : Scan.form s) (d : def f) x y (g : Search2.form x y)
  : (@search_them x y g (@scan_it s f d)).
*)
Notation noaliasR_fwd' x y D := (search_them x y (scan_it D)).

Example exnc A (x1 x2 x3 x4 : ptr) (v1 v2 : A) (h1 h2 : heap) :
  def (h1 :+ x2 :-> 1 :+ h2 :+ x1 :-> v2 :+ (x3 :-> v1 :+ empty)) ->
     (x1 != x2) /\
     (x1 != x2) && (x2 != x3) && (x3 != x1) /\
     (x2 == x3) = false /\ (x1 == x2) = false.
Proof.
move=>D.
split.
  apply: (noaliasR_fwd' x1 x2 D).
split.
- by rewrite (noaliasR_fwd' x1 x2 D) (noaliasR_fwd' x2 x3 D) (noaliasR_fwd' x3 x1 D).
split.
  (* subterm selection works *)
- by rewrite [x2 == x3](negbTE (noaliasR_fwd' x2 x3 D)).
- (* composition works *)
  by rewrite (negbTE (noaliasR_fwd' x1 x2 D)).
Abort.

(* Main structure *)
Structure check (x y : ptr) (s : seq ptr) :=
  Check {y_of :> ptr;
         _ : y_of = y;
         _ : uniq s -> x != y_of}.

Program
Canonical Structure start x y (f : Search2.form x y) :=
  @Check x y f y (Logic.eq_refl _) _.
Next Obligation.
case: f H=>[s H /= U].
by case: H=>_ _; apply.
Qed.

Lemma noaliasR_fwd3 s (f : Scan.form s) (D : def f) x y
  (g : check x y s) : x != y_of g.
Proof.
case: f D=>h A /= D.
case: A g=>// U _ [y' /= ->].
by apply.
Qed.

Arguments noaliasR_fwd3 [s f] D x y {g}.

Example triggered
 A (x1 x2 x3 : ptr) (v1 v2 v3 : A) (h1 h2 : heap) :
 def (h1 :+ (x1 :-> v1 :+ x2 :-> v2) :+ (h2 :+ x3 :-> v3))
 -> (x1 != x3) && (x2 != x3) && (x1 != x2).
Proof.
move=>D.
have F := noaliasR_fwd3 D.
by rewrite !(F _ x3) (F _ x2).
Abort.

(* Main structure *)
Structure check' (x : ptr) (s : seq ptr) :=
  Check' {y_of' :> ptr;
         _ : uniq s -> x != y_of'}.

Program
Canonical Structure start' x y (f : Search2.form x y) :=
  @Check' x f y _.
Next Obligation.
case: f H=>[s H /= U].
by case: H=>_ _; apply.
Qed.

Lemma noaliasR_fwd3' s (f : Scan.form s) (D : def f) x
  (g : check' x s) : x != y_of' g.
Proof.
case: f D=>h A /= D.
case: A g=>// U _[y' /= ->] //.
Qed.


(** * Implementation of Section 3.7 *)
Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.
Require Import RL.hr.tech_lemmas.

Require Import CMorphisms.
Require Import Lra.

Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

(** Proof of Lemma 3.40 *)
Lemma hrr_mul_vec : forall L,
    HR_T (map (fun x => snd x) L) ->
    HR_T (map (fun x => seq_mul_vec (fst x) (snd x)) L).
Proof.
  intros L pi.
  remember (map (fun x => snd x) L) as G.
  revert L HeqG; induction pi; intros L HeqG.
  - destruct L; [ | destruct L]; try now inversion HeqG.
    destruct p as [r T]; destruct T; try now inversion HeqG.
    simpl; rewrite seq_mul_vec_nil_r; apply hrr_INIT.
  - destruct L; try now inversion HeqG.
    simpl; apply hrr_W.
    apply IHpi.
    simpl in HeqG; inversion HeqG.
    reflexivity.
  - destruct L; try now inversion HeqG.
    simpl; apply hrr_C.
    change (seq_mul_vec (fst p) (snd p)
                    :: seq_mul_vec (fst p) (snd p) :: map (fun x => seq_mul_vec (fst x) (snd x)) L)
      with
        (map (fun x => seq_mul_vec (fst x) (snd x)) (p :: p :: L)).
    apply IHpi.
    simpl in HeqG; inversion HeqG.
    reflexivity.
  - destruct L; [ | destruct L]; try destruct p as [r1 T1']; try destruct p0 as [r2 T2']; inversion HeqG; subst.
    destruct r1 ; [ | destruct r2].
    + simpl.
      apply hrr_ex_hseq with ((seq_mul_vec r2 T2' :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) ++ (nil :: nil)); [ Permutation_Type_solve |] .
      apply hrr_W_gen.
      apply hrr_INIT.
    + simpl.
      apply hrr_ex_hseq with ((seq_mul_vec (r :: r1) T1' :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) ++ (nil :: nil)); [ Permutation_Type_solve |] .
      apply hrr_W_gen.
      apply hrr_INIT.
    + simpl.
      unfold HR_T; change hr_frag_T with (hr_frag_add_T hr_frag_T).
      apply hrr_T_vec with (r0 :: r2); try now auto.
      eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      change hr_frag_T with (hr_frag_add_T hr_frag_T).
      apply hrr_T_vec with (r :: r1); try now auto.
      eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      apply hrr_S.
      apply hrr_ex_seq with (seq_mul_vec (vec_mul_vec (r :: r1) (r0 :: r2)) (T1' ++ T2')).
      { etransitivity; [ symmetry; apply seq_mul_vec_twice | ].
        etransitivity ; [ apply seq_mul_vec_perm_r; apply (seq_mul_vec_app_r _ _ (r0 :: r2)) | ].
        etransitivity ; [ apply seq_mul_vec_app_r | ].
        etransitivity ; [ apply Permutation_Type_app ; [ apply seq_mul_vec_twice_comm | reflexivity ] | ].
        Permutation_Type_solve. }
      change (seq_mul_vec (vec_mul_vec (r :: r1) (r0 :: r2)) (T1' ++ T2') :: map (fun x => seq_mul_vec (fst x) (snd x)) L)
        with
          (map (fun x => seq_mul_vec (fst x) (snd x)) ((vec_mul_vec (r :: r1) (r0 :: r2) , T1' ++ T2') :: L)).
      apply IHpi; reflexivity.
  - inversion f.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    apply hrr_T with r; try assumption.
    rewrite seq_mul_seq_mul_vec.
    change (seq_mul_vec r1 (seq_mul r T1) :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L)
      with (map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) ((r1, seq_mul r T1) :: L)).
    apply IHpi.
    reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    apply hrr_ex_seq with (vec (vec_mul_vec r1 s) (HR_covar n) ++ vec (vec_mul_vec r1 r) (HR_var n) ++ seq_mul_vec r1 T).
    { etransitivity ; [ | symmetry ; apply seq_mul_vec_app_r].
      etransitivity ; [ | symmetry; apply Permutation_Type_app; try apply seq_mul_vec_app_r; reflexivity ].
      apply Permutation_Type_app ; [ | apply Permutation_Type_app]; try rewrite seq_mul_vec_vec_mul_vec; reflexivity. }
    apply hrr_ID.
    { rewrite ? sum_vec_vec_mul_vec.
      nra. }
    change (seq_mul_vec r1 T :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, T) :: L)).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_Z.
    change (seq_mul_vec r1 T :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, T) :: L)).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_plus.
    rewrite <- ? seq_mul_vec_vec_mul_vec.
    apply hrr_ex_seq with (seq_mul_vec r1 (vec r A ++ vec r B ++ T)).
    { etransitivity ; [apply seq_mul_vec_app_r | ].
      apply Permutation_Type_app; try apply seq_mul_vec_app_r; reflexivity. }
    change (seq_mul_vec r1 (vec r A ++ vec r B ++ T) :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, vec r A ++ vec r B ++ T) :: L)).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_mul.
    rewrite <- vec_mul_vec_mul_vec_comm.
    rewrite <- ? seq_mul_vec_vec_mul_vec.
    eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ].
    change (seq_mul_vec r1 (vec (mul_vec r0 r) A ++ T) :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, vec (mul_vec r0 r) A ++ T) :: L)).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_max.
    rewrite <- ? seq_mul_vec_vec_mul_vec.
    eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    change (seq_mul_vec r1 (vec r B ++ T) :: seq_mul_vec r1 (vec r A ++ T) :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, vec r B ++ T) :: (r1, vec r A ++ T) :: L)).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_min;
      rewrite <- ? seq_mul_vec_vec_mul_vec;
      (eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ]);
      [ change (seq_mul_vec r1 (vec r A ++ T) :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, vec r A ++ T) :: L)) ; apply IHpi1
      | change (seq_mul_vec r1 (vec r B ++ T) :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) with (map (fun x => seq_mul_vec (fst x) (snd x)) ((r1, vec r B ++ T) :: L)) ; apply IHpi2 ];
      reflexivity.
  - destruct L; try destruct p0 as [r1 T1']; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ apply seq_mul_vec_perm_r; apply p | ].
    change (seq_mul_vec r1 T1 :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L)
      with
        (map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) ((r1 , T1) :: L)).
    apply IHpi; reflexivity.
  - subst.
    apply Permutation_Type_map_inv in p as [L' Heq Hperm].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_map ; symmetry; apply Hperm | ].
    apply IHpi.
    apply Heq.
  - inversion f.
Qed.

(** Proof of Lemma 3.39 *)
Lemma hrr_M_gen : forall L H D,
    HR_T (map (fun x => snd x) L) ->
    HR_T (D :: H) ->
    HR_T (map (fun x => snd x ++ seq_mul_vec (fst x) D) L ++ H).
Proof.
  intros L H D pi pi2.
  remember (map (fun x => snd x) L) as G.
  revert L HeqG.
  induction pi; intros L HeqG.
  - destruct L; try (destruct p as [r1 T1]; destruct T1); inversion HeqG; simpl.
    destruct L; inversion H1; simpl.
    assert {L & prod
                  (H = map (fun x => snd x) L)
                  (H = map (fun x => seq_mul_vec (fst x) (snd x)) L)} as [L [Heq1 Heq2]].
    { clear; induction H.
      - split with nil; split; reflexivity.
      - destruct IHlist as [L [H1 H2]].
        split with (((One :: nil), a) :: L).
        simpl; split ; [ rewrite H1; reflexivity |  rewrite H2].
        rewrite app_nil_r; rewrite seq_mul_One.
        reflexivity. }
    rewrite Heq2.
    change (seq_mul_vec r1 D :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L)
      with
        (map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) ((r1 , D) :: L)).
    apply hrr_mul_vec.
    simpl; rewrite <- Heq1.
    apply pi2.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_W.
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_C.
    change ((T1 ++ seq_mul_vec r1 D)
              :: (T1 ++ seq_mul_vec r1 D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, T1) :: (r1 , T1) :: L) ++ H).
    apply IHpi; reflexivity.
  - destruct L; [ | destruct L]; try destruct p as [r1 T1']; try destruct p0 as [r2 T2']; inversion HeqG; subst; simpl.
    apply hrr_S.
    apply hrr_ex_seq with ((T1' ++ T2') ++ seq_mul_vec (r1 ++ r2) D).
    { rewrite seq_mul_vec_app_l.
      Permutation_Type_solve. }
    change (((T1' ++ T2') ++ seq_mul_vec (r1 ++ r2) D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1 ++ r2, T1' ++ T2') :: L) ++ H).
    apply IHpi; reflexivity.
  - inversion f.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_T with r; try assumption.
    rewrite seq_mul_app; rewrite seq_mul_seq_mul_vec_2.
    change ((seq_mul r T1 ++ seq_mul_vec (mul_vec r r1) D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((mul_vec r r1, seq_mul r T1) :: L) ++ H).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    rewrite <- ? app_assoc; apply hrr_ID; try assumption.
    change ((T ++ seq_mul_vec r1 D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, T) :: L) ++ H).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    rewrite <- ? app_assoc; apply hrr_Z; try assumption.
    change ((T ++ seq_mul_vec r1 D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, T) :: L) ++ H).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    rewrite <- ? app_assoc; apply hrr_plus; try assumption.
    replace ((vec r A ++ vec r B ++ T ++ seq_mul_vec r1 D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, vec r A ++ vec r B ++ T) :: L) ++ H) by (simpl; rewrite <- ? app_assoc; reflexivity).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    rewrite <- ? app_assoc; apply hrr_mul; try assumption.
    replace ((vec (mul_vec r0 r) A ++ T ++ seq_mul_vec r1 D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, vec (mul_vec r0 r) A ++ T) :: L) ++ H) by (simpl; rewrite <- ? app_assoc; reflexivity).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    rewrite <- ? app_assoc; apply hrr_max; try assumption.
    replace ((vec r B ++ T ++ seq_mul_vec r1 D) :: (vec r A ++ T ++ seq_mul_vec r1 D)
              :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with
        (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, vec r B ++ T) :: (r1, vec r A ++ T) :: L) ++ H) by (simpl; rewrite <- ? app_assoc; reflexivity).
    apply IHpi; reflexivity.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    rewrite <- ? app_assoc; apply hrr_min; try assumption;
      [ replace ((vec r A ++ T ++ seq_mul_vec r1 D) :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
          with (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, vec r A ++ T) :: L) ++ H) by (simpl; rewrite <- ? app_assoc; reflexivity); apply IHpi1
       | replace ((vec r B ++ T ++ seq_mul_vec r1 D) :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
           with (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, vec r B ++ T) :: L) ++ H)  by (simpl; rewrite <- ? app_assoc; reflexivity); apply IHpi2];
      reflexivity.
  - destruct L; try destruct p0 as [r1 T1']; inversion HeqG; subst; simpl.
    eapply hrr_ex_seq ; [ apply Permutation_Type_app ; [ apply p | reflexivity] | ].
    change ((T1 ++ seq_mul_vec r1 D) :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) L ++ H)
      with (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) D) ((r1, T1) :: L) ++ H).
    apply IHpi; reflexivity.
  - subst.
    apply Permutation_Type_map_inv in p as [L' Heq Hperm].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_app ; [ apply Permutation_Type_map ; symmetry; apply Hperm | reflexivity ] | ].
    apply IHpi.
    apply Heq.
  - inversion f.
Qed.

(** Proof of Theorem 3.12 *)
Lemma hrr_M_elim : forall G,
    HR_T_M G ->
    HR_T G.
Proof.
  intros G pi; induction pi; try now constructor.
  - assert {L & prod
                  (G = map (fun x => snd x) L)
                  (G = map (fun x => snd x ++ seq_mul_vec (fst x) T2) L)} as [L [Heq1 Heq2]].
    { clear; induction G.
      - split with nil; split; reflexivity.
      - destruct IHG as [L [H1 H2]].
        split with ((nil, a) :: L).
        simpl; split ; [ rewrite H1; reflexivity |  rewrite H2].
        rewrite app_nil_r; reflexivity. }
    apply hrr_ex_hseq with (G ++ ((T1 ++ T2) :: nil)); [ Permutation_Type_solve | ].
    change (hr_frag_T) with hr_frag_T; apply hrr_C_gen.
    apply hrr_ex_hseq with (((T1 ++ T2) :: G) ++ G); [ Permutation_Type_solve | ].
    pattern G at 1; rewrite Heq2.
    replace ((T1 ++ T2)
               :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) T2) L)
      with (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) T2) ((One :: nil , T1) :: L)) by (simpl; rewrite app_nil_r; now rewrite seq_mul_One).
    apply hrr_M_gen; try assumption.
    simpl.
    rewrite <- Heq1; apply IHpi1.
  - now apply hrr_T with r.
  - now apply hrr_ex_seq with T1.
  - now apply hrr_ex_hseq with G.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolProxyContractProofs (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

(* DePoolProxyContract_Ф_Constructor5 *)

Lemma DePoolProxyContract_Ф_Constructor5_exec : forall (l: Ledger) ,
let b := default in
let ok := false in
let b' := builder_store b ( eval_state ( msg_sender ) l )  0 in
let publicKey := tvm_hash ( toCell b' ) in
let ok' := ( ok || ( ( eval_state ( tvm_pubkey ) l ) =? publicKey ) )%bool in
let b'' := default in
let b''' := builder_store b'' ( eval_state ( msg_sender ) l ) 1 in
let publicKey' := tvm_hash ( toCell b''' )  in
let ok'' := ( ok' || ( ( eval_state ( tvm_pubkey ) l ) =? publicKey' ) )%bool in
let req : bool := ( ok'' ) in

exec_state ( ↓ DePoolProxyContract_Ф_constructor5 ) l =
                 if req then {$ l With DePoolProxyContract_ι_m_dePool := eval_state msg_sender l $}
                        else l.
Proof.
   intros.
   destruct l.
   destruct Ledger_ι_VMState.
   compute. destructIf; auto.
Qed.

Lemma DePoolProxyContract_Ф_Constructor5_eval : forall (l: Ledger) ,

let b := default in
let ok := false in
let b' := builder_store b ( eval_state msg_sender l ) 0 in
let publicKey := tvm_hash ( toCell b' ) in
let ok' := ( ok || (eval_state tvm_pubkey l =? publicKey) )%bool in
let b'' := default in
let b''' := builder_store b'' ( eval_state msg_sender l ) 1 in
let publicKey' := tvm_hash ( toCell b''' )  in
let ok'' := ( ok' || ( eval_state tvm_pubkey l =? publicKey' ) )%bool in
let req : bool := ( ok'' ) in

eval_state (↓ DePoolProxyContract_Ф_constructor5 ) l =
    if req then Value I
           else Error DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL .
Proof.
  intros.
  destruct l.
  compute. destructIf; auto.
Qed.

(* DePoolProxyContract_Ф_process_new_stake *)

Lemma DePoolProxyContract_Ф_process_new_stake_exec : forall ( Л_queryId : XInteger64 )
                                                             ( Л_validatorKey : XInteger256 )
                                                             ( Л_stakeAt : XInteger32 )
                                                             ( Л_maxFactor : XInteger32 )
                                                             ( Л_adnlAddr : XInteger256 )
                                                             ( Л_signature :  XList XInteger8 )
                                                             ( Л_elector : XAddress )
                                                             (l: Ledger) ,
let msgSender := eval_state msg_sender l in
let dePoolAddress := eval_state (↑10 ε DePoolProxyContract_ι_m_dePool) l in
let msgValue := eval_state msg_value l in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let carry := msgValue - proxyFee in
let oldMessages := eval_state (↑16 ε VMState_ι_messages) l in
let newMessage :ContractsFunctionWithMessage  := {| contractAddress :=  Л_elector;
                      contractFunction := IElector_И_process_new_stakeF Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr  Л_signature ;
                      contractMessage :=  {| messageValue := carry;
                                            messageFlag := 0 ;
                                            messageBounce := false |} |} in
let balance := eval_state ( tvm_balance ) l in
let minBalance := DePoolLib_ι_MIN_PROXY_BALANCE in
let req2 : bool := balance >=? carry + minBalance in

    exec_state ( ↓ DePoolProxyContract_Ф_process_new_stake Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr Л_signature Л_elector ) l =

    if ( msgSender =? dePoolAddress) then
      if req2 then  {$ l With VMState_ι_messages := newMessage :: oldMessages $}
      else l
    else l.
 Proof.
   intros.
   destruct l. destruct Ledger_ι_VMState , Ledger_ι_DePoolProxyContract(* , Ledger_ι_DePoolLib *).
   compute.
   repeat destructIf; auto.
 Qed.

Lemma DePoolProxyContract_Ф_process_new_stake_eval : forall ( Л_queryId : XInteger64 )
                                                             ( Л_validatorKey : XInteger256 )
                                                             ( Л_stakeAt : XInteger32 )
                                                             ( Л_maxFactor : XInteger32 )
                                                             ( Л_adnlAddr : XInteger256 )
                                                             ( Л_signature : XList XInteger8 )
                                                             ( Л_elector : XAddress )
                                                             (l: Ledger) ,
let msgSender := eval_state msg_sender l in
let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
let error1 := DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL in
let error2 := DePoolProxyContract_ι_ERROR_BAD_BALANCE in
let msgValue := eval_state msg_value l in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let carry := msgValue - proxyFee in
let balance := eval_state ( tvm_balance ) l in
let minBalance := DePoolLib_ι_MIN_PROXY_BALANCE in
let req2 : bool := balance >=? carry + minBalance in

    eval_state (↓ DePoolProxyContract_Ф_process_new_stake Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr Л_signature Л_elector ) l =

    if (msgSender =? dePoolAddress) then
      if req2 then Value I
              else Error error2
    else Error error1 .
 Proof.
  intros.
  destruct l. destruct Ledger_ι_VMState , Ledger_ι_DePoolProxyContract (*, Ledger_ι_DePoolLib*).
  compute.
  repeat destructIf; auto.
 Qed.

(* DePoolProxyContract_Ф_onStakeAccept *)

Lemma DePoolProxyContract_Ф_onStakeAccept_exec : forall ( Л_queryId : XInteger64 ) ( Л_comment : XInteger32 ) (l: Ledger) ,
let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
let msgValue := eval_state msg_value l in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let value := msgValue - proxyFee in
let msgSender := eval_state msg_sender l in
let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
let newMessage  := {| contractAddress  := dePoolAddress;
                      contractFunction := DePoolContract_Ф_onStakeAcceptF Л_queryId Л_comment msgSender ;
                      contractMessage  := {$ default with messageValue := value $} |} in

    exec_state (↓ DePoolProxyContract_Ф_onStakeAccept Л_queryId Л_comment ) l =  {$ l With VMState_ι_messages := newMessage :: oldMessages $}.
Proof.
  intros. auto.
Qed.

Lemma DePoolProxyContract_Ф_onStakeAccept_eval : forall ( Л_queryId : XInteger64 ) ( Л_comment : XInteger32 ) (l: Ledger) ,
 	 eval_state (↓ DePoolProxyContract_Ф_onStakeAccept Л_queryId Л_comment ) l = I .
Proof.
  intros. auto.
Qed.

(* DePoolProxyContract_Ф_onStakeReject *)

Lemma DePoolProxyContract_Ф_onStakeReject_exec : forall ( Л_queryId : XInteger64 ) ( Л_comment : XInteger32 ) (l: Ledger) ,
let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
let msgValue := eval_state msg_value l in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let value := msgValue - proxyFee in
let msgSender := eval_state msg_sender l in
let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
let newMessage  := {| contractAddress  := dePoolAddress;
                      contractFunction := DePoolContract_Ф_onStakeRejectF Л_queryId Л_comment msgSender ;
                      contractMessage  := {$ default with messageValue := value $} |} in

    exec_state ( ↓ DePoolProxyContract_Ф_onStakeReject Л_queryId Л_comment ) l = {$ l With VMState_ι_messages := newMessage :: oldMessages $}.
 Proof.
   intros. auto.
 Qed.

 Lemma DePoolProxyContract_Ф_onStakeReject_eval : forall ( Л_queryId : XInteger64 )
                                                         ( Л_comment : XInteger32 )
                                                         (l: Ledger) ,
 	 eval_state ( ↓ DePoolProxyContract_Ф_onStakeReject Л_queryId Л_comment ) l = I .
 Proof.
   intros. auto.
 Qed.

(* DePoolProxyContract_Ф_recover_stake *)

Lemma DePoolProxyContract_Ф_recover_stake_exec : forall ( Л_queryId : XInteger64 )
                                                        ( Л_elector : XAddress )
                                                        (l: Ledger) ,
let dePoolAddress := eval_state (↑10 ε DePoolProxyContract_ι_m_dePool) l in
let msgValue := eval_state msg_value l in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let value := msgValue - proxyFee in
let msgSender := eval_state msg_sender l in
let oldMessages := eval_state (↑16 ε VMState_ι_messages) l in
let newMessage  := {| contractAddress  := Л_elector;
                      contractFunction := IElector_И_recover_stakeF Л_queryId ;
                      contractMessage  := {$ default with messageValue := value $} |} in
let carry := msgValue - proxyFee in
let balance := eval_state ( tvm_balance ) l in
let minBalance := DePoolLib_ι_MIN_PROXY_BALANCE in
let req2 : bool := balance >=? carry + minBalance in

    exec_state ( ↓ DePoolProxyContract_Ф_recover_stake Л_queryId Л_elector ) l =
    if (msgSender =? dePoolAddress)
        then if req2
            then {$ l With VMState_ι_messages := newMessage :: oldMessages $}
            else l
        else l.
 Proof.
  intros.
  destruct l.
  compute; repeat destructIf; auto.
 Qed.

Lemma DePoolProxyContract_Ф_recover_stake_eval : forall ( Л_queryId : XInteger64 )
                                                        ( Л_elector : XAddress )
                                                        (l: Ledger),
let msgSender := eval_state msg_sender l in
let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
let error1 := DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL in
let error2 := DePoolProxyContract_ι_ERROR_BAD_BALANCE in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let msgValue := eval_state msg_value l in
let carry := msgValue - proxyFee in
let balance := eval_state ( tvm_balance ) l in
let minBalance := DePoolLib_ι_MIN_PROXY_BALANCE in
let req2 : bool := balance >=? carry + minBalance in

    eval_state (DePoolProxyContract_Ф_recover_stake Л_queryId Л_elector ) l =
    if (msgSender =? dePoolAddress) then
       if req2 then xValue I
               else xError error2
    else xError error1 .
 Proof.
  intros.
  destruct l.
  compute; repeat destructIf; auto.
 Qed.

(* DePoolProxyContract_Ф_onSuccessToRecoverStake *)

Lemma DePoolProxyContract_Ф_onSuccessToRecoverStake_exec : forall ( Л_queryId : XInteger64 ) (l: Ledger) ,
let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
let msgValue := eval_state msg_value l in
let proxyFee := DePoolLib_ι_PROXY_FEE in
let value := msgValue - proxyFee in
let msgSender := eval_state msg_sender l in
let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
let newMessage  := {| contractAddress  := dePoolAddress;
                      contractFunction := DePoolContract_Ф_onSuccessToRecoverStakeF Л_queryId msgSender ;
                      contractMessage  := {$ default with messageValue := value $} |} in

    exec_state (DePoolProxyContract_Ф_onSuccessToRecoverStake Л_queryId) l =
               {$ l With VMState_ι_messages := newMessage :: oldMessages $}.
 Proof.
  intros.  auto.
 Qed.

 Lemma DePoolProxyContract_Ф_onSuccessToRecoverStake_eval : forall ( Л_queryId : XInteger64 ) (l: Ledger) ,
 	 eval_state (DePoolProxyContract_Ф_onSuccessToRecoverStake Л_queryId ) l = I .
 Proof.
   intros. auto.
 Qed.

(* DePoolProxyContract_Ф_getProxyInfo *)

Lemma DePoolProxyContract_Ф_getProxyInfo_exec : forall (l: Ledger) ,
 	 exec_state ( ↓ DePoolProxyContract_Ф_getProxyInfo ) l = l .
Proof.
    intros. destruct l; compute; auto.
Qed.

Lemma DePoolProxyContract_Ф_getProxyInfo_eval : forall (l: Ledger) ,
                           (*  LedgerT ( XAddress # XInteger64 ) *)
let dePool := eval_state (↑10 ε DePoolProxyContract_ι_m_dePool) l in
let minBalance := DePoolLib_ι_MIN_PROXY_BALANCE in

    eval_state ( ↓ DePoolProxyContract_Ф_getProxyInfo ) l = (dePool, minBalance).
Proof.
  intros. destruct l ; compute ; auto.
Qed.

End DePoolProxyContractProofs.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.

Require Import lib.utils common.types.

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

Import DoNotation.

Module Symbolic.

(* BCP/AAA: Should some of this be shared with the concrete machine? *)

(* CH: These could move to types.v?  But they would be useful only if
       we want to make the concrete machine dependently typed too; and
       we probably don't want to do that. *)

Inductive tag_kind : Type := R | M | P.

Module Import TagKindEq.
Definition tag_kind_eq (tk1 tk2 : tag_kind) : bool :=
  match tk1, tk2 with
  | R, R | M, M | P, P => true | _, _ => false
  end.

Lemma tag_kind_eqP : Equality.axiom tag_kind_eq.
Proof. by do !case; constructor. Qed.

Definition tag_kind_eqMixin := EqMixin tag_kind_eqP.
Canonical tag_kind_eqType := Eval hnf in EqType tag_kind tag_kind_eqMixin.
End TagKindEq.

Definition inputs (op : opcode) : seq tag_kind :=
  match op with
  | NOP     => [:: ]
  | CONST   => [:: R]
  | MOV     => [:: R;R]
  | BINOP _ => [:: R;R;R]
  | LOAD    => [:: R;M;R]
  | STORE   => [:: R;R;M]
  | JUMP    => [:: R]
  | BNZ     => [:: R]
  | JAL     => [:: R;R]
  (* the other opcodes are not used by the symbolic machine *)
  | JUMPEPC => [:: P]
  | ADDRULE => [::]
  | GETTAG  => [:: R;R]
  | PUTTAG  => [:: R;R;R]
  | HALT    => [::] (* CH: in a way this is used by symbolic machine;
                           it just causes it to get stuck as it should *)
  end.

(* Returns true iff an opcode can only be executed by the monitor *)
Definition privileged_op (op : vopcode) : bool :=
  match op with
  | JUMPEPC
  | ADDRULE
  | GETTAG
  | PUTTAG => true
  | _ => false
  end.

Definition vinputs (vop : vopcode) : seq tag_kind :=
  match vop with
  | OP op => inputs op
  | SERVICE => [::]
  end.

Definition outputs (op : opcode) : option tag_kind :=
  match op with
  | NOP     => None
  | CONST   => Some R
  | MOV     => Some R
  | BINOP _ => Some R
  | LOAD    => Some R
  | STORE   => Some M
  | JUMP    => None
  | BNZ     => None
  | JAL     => Some R
  (* the other opcodes are not used by the symbolic machine *)
  | JUMPEPC => None
  | ADDRULE => None
  | GETTAG  => Some R
  | PUTTAG  => None
  | HALT    => None
  end.

Section WithTagTypes.

Structure tag_types := {
  pc_tag_type : eqType;
  reg_tag_type : eqType;
  mem_tag_type : eqType;
  entry_tag_type : eqType
}.

Variable tty : tag_types.

Definition tag_type tk :=
  match tk with
  | P => pc_tag_type tty
  | R => reg_tag_type tty
  | M => mem_tag_type tty
  end.

Definition instr_tag (op : vopcode) :=
  match op with
  | SERVICE => entry_tag_type tty
  | _ => mem_tag_type tty
  end.

Record ivec : Type := IVec {
  op  : vopcode;
  tpc : tag_type P;
  ti  : instr_tag op;
  ts  : hseq tag_type (vinputs op)
}.

Lemma ivec_eq_inv op op' tpc tpc' ti ti' ts ts'
                  (p : @IVec op tpc ti ts = @IVec op' tpc' ti' ts') :
  [/\ op = op', tpc = tpc',
      Tagged instr_tag ti = Tagged instr_tag ti' &
      Tagged (hseq tag_type \o vinputs) ts = existT _ op' ts'].
Proof. inversion p. by constructor. Qed.

Definition type_of_result (o : option tag_kind) :=
  odflt [eqType of unit] (option_map tag_type o).

Record ovec (op : opcode) : Type := OVec {
  trpc : tag_type P;
  tr   : type_of_result (outputs op)
}.

Definition vovec (vop : vopcode) : Type :=
  match vop with
  | OP op => ovec op
  | SERVICE => unit
  end.

End WithTagTypes.

Arguments IVec {_} _ _ _ _.

Open Scope bool_scope.

Section WithClasses.

Context (mt : machine_types)
        {ops : machine_ops mt}.

Class params := {
  ttypes :> tag_types;

  transfer : forall (iv : ivec ttypes), option (vovec ttypes (op iv));

  internal_state : eqType
}.

Context {sp : params}.

Open Scope word_scope.

Local Notation word := (mword mt).
Let atom := (atom word).
Local Notation "x .+1" := (x + 1).

Local Notation memory := {fmap word -> atom (tag_type ttypes M)}.
Local Notation registers := {fmap reg mt -> atom (tag_type ttypes R)}.

Record state := State {
  mem : memory;
  regs : registers;
  pc : atom (tag_type ttypes P);
  internal : internal_state
}.

Definition pcv (s : state) := vala (pc s).
Definition pct (s : state) := taga (pc s).

Lemma state_eta st :
  st = State (mem st) (regs st) (pcv st)@(pct st) (internal st).
Proof. by case: st=> ? ? [? ?] ?. Qed.

(* CH: TODO: should make the entry_tags part of the state
   (for compartmentalization they need to be mutable) *)
Record syscall := Syscall {
  entry_tag : entry_tag_type ttypes;
  sem : state -> option state
}.

Definition syscall_table := {fmap mword mt -> syscall}.

Variable table : syscall_table.

Definition run_syscall (sc : syscall) (st : state) : option state :=
  match transfer (IVec SERVICE (taga (pc st)) (entry_tag sc) [hseq]) with
  | Some _ => sem sc st
  | None => None
  end.

Definition next_state (st : state) (iv : ivec ttypes)
                      (k : vovec ttypes (op iv) -> option state) : option state :=
  do! ov <- transfer iv;
    k ov.

Definition next_state_reg_and_pc (st : state) (iv : @ivec ttypes)
  (r : reg mt) (x : word) (pc' : word) : option state :=
  next_state st (
    match op iv as o return vovec _ o -> option state with
    | OP op => fun ov =>
      match outputs op as o return (type_of_result _ o -> option state) with
        | Some R => fun tr' =>
            do! regs' <- updm (regs st) r x@tr';
            Some (State (mem st) regs' pc'@(trpc ov) (internal st))
        | _ => fun _ => None
      end (tr ov)
    | SERVICE => fun _ => None
    end
  ).

Definition next_state_reg (st : state) (mvec : @ivec ttypes) r x : option state :=
  next_state_reg_and_pc st mvec r x (vala (pc st)).+1.

Definition next_state_pc (st : state) (iv : @ivec ttypes)
  (x : word) : option state :=
  next_state st (
    match op iv as o return vovec _ o -> option state with
    | OP op => fun ov =>
                 Some (State (mem st) (regs st) x@(trpc ov) (internal st))
    | SERVICE => fun _ => None
    end
  ).

Inductive step (st st' : state) : Prop :=
| step_nop : forall mem reg pc tpc i ti extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Nop _)),
    let mvec := IVec NOP tpc ti [hseq] in forall
    (NEXT : next_state_pc st mvec (pc.+1) = Some st'),    step st st'
| step_const : forall mem reg pc tpc i ti n r old (told : tag_type ttypes R) extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Const n r))
    (OLD  : reg r = Some old@told),
    let mvec := IVec CONST tpc ti [hseq told] in forall
    (NEXT : next_state_reg st mvec r (swcast n) = Some st'),   step st st'
| step_mov : forall mem reg pc tpc i ti r1 w1 t1 r2 old told extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Mov r1 r2))
    (R1W  : reg r1 = Some w1@t1)
    (OLD  : reg r2 = Some old@told),
    let mvec := IVec MOV tpc ti [hseq t1; told] in forall
    (NEXT : next_state_reg st mvec r2 w1 = Some st'),   step st st'
| step_binop : forall mem reg pc tpc i ti op r1 r2 r3 w1 w2 t1 t2 old told extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Binop op r1 r2 r3))
    (R1W  : reg r1 = Some w1@t1)
    (R2W  : reg r2 = Some w2@t2)
    (OLD  : reg r3 = Some old@told),
    let mvec := IVec (BINOP op) tpc ti [hseq t1; t2; told] in forall
    (NEXT : next_state_reg st mvec r3 (binop_denote op w1 w2) = Some st'),
      step st st'
| step_load : forall mem reg pc tpc i ti r1 r2 w1 w2 t1 t2 old told extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Load r1 r2))
    (R1W  : reg r1 = Some w1@t1)
    (MEM1 : mem w1 = Some w2@t2)
    (OLD  : reg r2 = Some old@told),
    let mvec := IVec LOAD tpc ti [hseq t1; t2; told] in forall
    (NEXT : next_state_reg st mvec r2 w2 = Some st'),    step st st'
| step_store : forall mem reg pc i r1 r2 w1 w2 tpc ti t1 t2 old told extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Store r1 r2))
    (R1W  : reg r1 = Some w1@t1)
    (R2W  : reg r2 = Some w2@t2)
    (OLD  : mem w1 = Some old@told),
    let mvec := IVec STORE tpc ti [hseq t1; t2; told] in forall
    (NEXT : @next_state st mvec (fun ov =>
                 do! mem' <- updm mem w1 w2@(tr ov);
                 Some (State mem' reg (pc.+1)@(trpc ov) extra)) = Some st'),
              step st st'
| step_jump : forall mem reg pc i r w tpc ti t1 extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Jump r))
    (RW   : reg r = Some w@t1),
    let mvec := IVec JUMP tpc ti [hseq t1] in forall
    (NEXT : next_state_pc st mvec w = Some st'),    step st st'
| step_bnz : forall mem reg pc i r n w tpc ti t1 extra
    (ST   : st = State mem reg pc@tpc extra)
    (PC   : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Bnz r n))
    (RW   : reg r = Some w@t1),
     let mvec := IVec BNZ tpc ti [hseq t1] in
     let pc' := pc + (if w == 0%w
                      then 1%w else swcast n) in forall
    (NEXT : next_state_pc st mvec pc' = Some st'),     step st st'
| step_jal : forall mem reg pc i r w tpc ti t1 old told extra
    (ST : st = State mem reg pc@tpc extra)
    (PC : mem pc = Some i@ti)
    (INST : decode_instr i = Some (Jal r))
    (RW : reg r = Some w@t1)
    (OLD : reg ra = Some old@told),
     let mvec := IVec JAL tpc ti [hseq t1; told] in forall
    (NEXT : next_state_reg_and_pc st mvec ra (pc.+1) w = Some st'), step st st'
| step_syscall : forall mem reg pc sc tpc extra
    (ST : st = State mem reg pc@tpc extra)
    (PC : mem pc = None)
    (GETCALL : table pc = Some sc)
    (CALL : run_syscall sc st = Some st'), step st st'.

End WithClasses.

Notation memory mt s := {fmap mword mt -> atom (mword mt) (@tag_type (@ttypes s) M)}.
Notation registers mt s := {fmap reg mt -> atom (mword mt) (@tag_type (@ttypes s) R)}.

End Symbolic.

Module Exports.

Import Symbolic.

Definition state_eqb mt p : rel (@state mt p) :=
  [rel s1 s2 | [&& mem s1 == mem s2,
                   regs s1 == regs s2,
                   pc s1 == pc s2 &
                   internal s1 == internal s2 ] ].

Lemma state_eqbP mt p : Equality.axiom (@state_eqb mt p).
Proof.
  move => [? ? ? ?] [? ? ? ?].
  apply (iffP and4P); simpl.
  - by move => [/eqP -> /eqP -> /eqP -> /eqP ->].
  - by move => [-> -> -> ->].
Qed.

Definition state_eqMixin mt p := EqMixin (@state_eqbP mt p).
Canonical state_eqType mt p := Eval hnf in EqType _ (@state_eqMixin mt p).

Export TagKindEq.

End Exports.

Export Exports.

Arguments Symbolic.state mt {_}.
Arguments Symbolic.State {_ _} _ _ _ _.
Arguments Symbolic.syscall mt {_}.
Arguments Symbolic.syscall_table mt {_}.
Arguments Symbolic.IVec {tty} op _ _ _.
Arguments Symbolic.OVec {tty op} _ _.


Require Import Coq.Program.Equality.
Require Export Coq.Program.Tactics.
Require Export DeclarationEvaluation.
Set Implicit Arguments.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma shift_value {t} :
  ∀ {c}, Value t → Value (shiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma tshift_value {t} :
  ∀ {c}, Value t → Value (tshiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma weaken_value u :
  ∀ {t}, Value t → Value (weakenTm t u).
Proof.
  induction u as [|[]]; simpl; auto using shift_value, tshift_value.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_texist {Γ t T} (v: Value t) (wt: Typing Γ t (texist T)) :
  ∃ T11 t12, t = pack T11 t12 (texist T).
Proof.
  depind wt; try contradiction; exists U, t2; reflexivity.
Qed.

Lemma can_form_tprod {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tprod T1 T2)) :
  ∃ t1 t2, t = prod t1 t2 ∧ Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt; try contradiction; exists t1, t2; auto.
Qed.

Lemma matching_defined {Γ p T1 Δ} (wp: PTyping Γ p T1 Δ) :
  ∀ {t1}, Value t1 → Typing Γ t1 T1 → ∀ t2, ∃ t2', Match p t1 t2 t2'.
Proof.
  induction wp; intros t1 v1 wt1 t2; isimpl.
  - exists (substTm X0 t1 t2).
    refine M_Var.
  - destruct (can_form_tprod v1 wt1) as (t11 & t12 & eq & wt11 & wt12); subst.
    destruct v1 as [v11 v12].
    apply (weaken_Typing G) in wt12.
    assert (val12' : Value (weakenTm t12 (domainEnv G)))
       by (apply weaken_value; auto).
    rewrite <- (domain_PTyping_bindPat _ _ _ _  wp1) in *.
    destruct (IHwp2 (weakenTm t12 (domainEnv G)) val12' wt12 t2) as [t2' m2].
    destruct (IHwp1 _ v11 wt11 t2') as [t2'' m1].
    rewrite (domain_PTyping_bindPat _ _ _ _ wp1) in m2.
    exists t2''.
    exact (M_Prod m2 m1).
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
  - destruct IHwt as [vt|[t1' r1]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (can_form_texist v1 wt1) as [? [? ?]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (matching_defined wtp v1 wt1 t2)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma local_preservation_lett {p t1 t2 t2'} (m: Match p t1 t2 t2') :
  ∀ {Γ T1 T2 Δ}, PTyping Γ p T1 Δ → Typing Γ t1 T1 →
    Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) → Typing Γ t2' T2.
Proof.
  induction m; intros Γ T1 T2 Δ wp wt1 wt2; isimpl.
  - dependent destruction wp; simpl in *.
    eauto using subst_evar_Typing with infra.
  - dependent destruction wp. dependent destruction wt1. isimpl.
    eapply IHm2; eauto.
    eapply IHm1; eauto.
    rewrite <- (domain_PTyping_bindPat _ _ _ _ wp1) in *.
    eauto using weaken_Typing with infra.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - inversion wt1; eauto using subst_evar_Typing with subst.
  - inversion wt; eauto using subst_etvar_Typing with subst.
  - inversion wt1; subst; clear wt1; rewrite tsubstTm_substTm0_comm; isimpl.
    eapply subst_evar_Typing; eauto with infra.
    generalize (subst_etvar_Typing _ _ H47 _ _ _ wt2
                 (evar G2 (tsubstTy X0 T11 T12)) (XS tm X0)).
    isimpl; eauto with infra.
  - eapply local_preservation_lett; eauto; isimpl.
    rewrite <- (domain_PTyping_bindPat _ _ _ _ wtp) in *; eauto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.

Axiom daemon : False. Ltac myadmit := case: daemon.

Ltac T1 x := match goal with |- _ => set t := (x in X in _ = X) end.
Ltac T2 x := first [set t := (x in RHS)].
Ltac T3 x := first [set t := (x in Y in _ = Y)|idtac].
Ltac T4 x := set t := (x in RHS); idtac.
Ltac T5 x := match goal with |- _ => set t := (x in RHS) | |- _ => idtac end.

Require Import ssrbool TestSuite.ssr_mini_mathcomp.

Open Scope nat_scope.

Lemma foo x y : x.+1 = y + x.+1.
set t := (_.+1 in RHS). match goal with |- x.+1 = y + t => rewrite /t {t} end.
set t := (x in RHS). match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end.
set t := (x in _ = x). match goal with |- x.+1 = t => rewrite /t {t} end.
set t := (x in X in _ = X).
  match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end.
set t := (x in RHS). match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end.
set t := (y + (1 + x) as X in _ = X).
  match goal with |- x.+1 = t => rewrite /t addSn add0n {t} end.
set t := x.+1. match goal with |- t = y + t => rewrite /t {t} end.
set t := (x).+1. match goal with |- t = y + t => rewrite /t {t} end.
set t := ((x).+1 in X in _ = X).
  match goal with |- x.+1 = y + t => rewrite /t {t} end.
set t := (x.+1 in RHS). match goal with |- x.+1 = y + t => rewrite /t {t} end.
T1 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end.
T2 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end.
T3 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end.
T4 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end.
T5 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end.
rewrite [RHS]addnC.
  match goal with |- x.+1 = x.+1 + y => rewrite -[RHS]addnC end.
rewrite -[in RHS](@subnK 1 x.+1) //.
  match goal with |- x.+1 = y + (x.+1 - 1 + 1) => rewrite subnK // end.
have H : x.+1 = y by myadmit.
set t := _.+1 in H |- *.
  match goal with H : t = y |- t = y + t => rewrite /t {t} in H * end.
set t := (_.+1 in X in _ + X) in H |- *.
  match goal with H : x.+1 = y |- x.+1 = y + t => rewrite /t {t} in H * end.
set t := 0. match goal with t := 0 |- x.+1 = y + x.+1 => clear t end.
set t := y + _. match goal with |- x.+1 = t => rewrite /t {t} end.
set t : nat := 0. clear t.
set t : nat := (x in RHS).
  match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end.
set t : nat := RHS. match goal with |- x.+1 = t => rewrite /t {t} end.
(* set t := 0 + _. *)
(* set t := (x).+1 in X in _ + X in H |-. *)
(* set t := (x).+1 in X in _ = X.*)
Admitted.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import Lia.
Require Import DataRuntime.
Require Import NRA.

Section NRASize.
  Context {fruntime:foreign_runtime}.

  Fixpoint nra_size (a:nra) : nat :=
    match a with
    | NRAGetConstant s => 1
    | NRAID => 1
    | NRAConst d => 1
    | NRABinop op a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRAUnop op a₁ => S (nra_size a₁)
    | NRAMap a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRAMapProduct a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRAProduct a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRASelect a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRADefault a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRAEither a₁ a₂=> S (nra_size a₁ + nra_size a₂)
    | NRAEitherConcat a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    | NRAApp a₁ a₂ => S (nra_size a₁ + nra_size a₂)
    end.

  Lemma nra_size_nzero (a:nra) : nra_size a <> 0.
  Proof.
    induction a; simpl; lia.
  Qed.

  Fixpoint nra_depth (a:nra) : nat :=
    (* Better to start at zero, level one is at least one nested plan *)
    match a with
    | NRAGetConstant s => 0
    | NRAID => 0
    | NRAConst d => 0
    | NRABinop op a₁ a₂ => max (nra_depth a₁) (nra_depth a₂)
    | NRAUnop op a₁ => nra_depth a₁
    | NRAMap a₁ a₂ => max (S (nra_depth a₁)) (nra_depth a₂)
    | NRAMapProduct a₁ a₂ => max (S (nra_depth a₁)) (nra_depth a₂)
    | NRAProduct a₁ a₂ => max (nra_depth a₁) (nra_depth a₂)
    | NRASelect a₁ a₂ => max (S (nra_depth a₁)) (nra_depth a₂)
    | NRADefault a₁ a₂ => max (nra_depth a₁) (nra_depth a₂)
    | NRAEither a₁ a₂=> max (nra_depth a₁) (nra_depth a₂)
    | NRAEitherConcat a₁ a₂ => max (nra_depth a₁) (nra_depth a₂)
    | NRAApp a₁ a₂ => max (nra_depth a₁) (nra_depth a₂)
    end.

End NRASize.


(******************************************************************************)
(** * C11 is weaker than IMM_S   *)
(******************************************************************************)

Require Import Classical Peano_dec.
From hahn Require Import Hahn.

Require Import Events.
Require Import Execution.
Require Import Execution_eco.
Require Import imm_bob imm_s_ppo.
Require Import imm_s_hb.
Require Import imm_s C11.

Set Implicit Arguments.

Section C11_TO_IMM_S.

Variable G : execution.

(******************************************************************************)
(** relations are contained in the corresponding ones **  *)
(******************************************************************************)

Lemma s_imm_consistentimplies_c11_consistent (WF: Wf G) sc
      (IPC : imm_s.imm_psc_consistent G sc) :
  c11_consistent G.
Proof using.
  cdes IPC. cdes IC. red. splits; auto.
Qed.

End C11_TO_IMM_S.


Require Import Classical Peano_dec Setoid PeanoNat.
From hahn Require Import Hahn.
Require Import Omega.

Require Import Events.
Require Import Execution.
Require Import imm_s.
Require Import TraversalConfig.
Require Import Traversal.
Require Import SimTraversal.
Require Import SimTraversalProperties.

Set Implicit Arguments.
Remove Hints plus_n_O.

Definition countP (f: actid -> Prop) l :=
  length (filterP f l).

Add Parametric Morphism : countP with signature
    set_subset ==> eq ==> le as countP_mori.
Proof using.
  ins. unfold countP.
  induction y0.
  { simpls. }
  ins. desf; simpls.
  1,3: omega.
  exfalso. apply n. by apply H.
Qed.

Add Parametric Morphism : countP with signature
    set_equiv ==> eq ==> eq as countP_more.
Proof using.
  ins. unfold countP.
  erewrite filterP_set_equiv; eauto.
Qed.

Section TraversalCounting.
  Variable G : execution.
  Variable sc : relation actid.
  Variable WF : Wf G.

  Notation "'E'" := G.(acts_set).
  Notation "'lab'" := G.(lab).
  Notation "'W'" := (fun x => is_true (is_w lab x)).
  Notation "'Rel'" := (fun x => is_true (is_rel lab x)).
  Notation "'rmw'" := G.(rmw).

  Definition trav_steps_left (T : trav_config) :=
    countP (set_compl (covered T)) G.(acts) +
    countP (W ∩₁ set_compl (issued T)) G.(acts).

  Lemma trav_steps_left_decrease (T T' : trav_config)
        (STEP : trav_step G sc T T') :
    trav_steps_left T > trav_steps_left T'.
  Proof using.
    red in STEP. desc. red in STEP.
    desf.
    { unfold trav_steps_left.
      rewrite ISSEQ.
      assert (countP (set_compl (covered T)) (acts G) >
              countP (set_compl (covered T')) (acts G)) as HH.
      2: omega.
      rewrite COVEQ.
      unfold countP.
      assert (List.In e (acts G)) as LL.
      { apply COV. }
      induction (acts G).
      { done. }
      destruct l as [|h l].
      { assert (a = e); subst.
        { inv LL. }
        simpls. desf.
        exfalso. apply s0. by right. }
      destruct LL as [|H]; subst.
      2: { apply IHl in H. clear IHl.
           simpls. desf; simpls; try omega.
           all: try by (exfalso; apply s0; left; apply NNPP).
             by exfalso; apply s; left; apply NNPP. }
      clear IHl.
      assert (exists l', l' = h :: l) as [l' HH] by eauto.
      rewrite <- HH. clear h l HH.
      simpls. desf; simpls.
      { exfalso. apply s0. by right. }
      assert (length (filterP (set_compl (covered T ∪₁ eq e)) l') <=
              length (filterP (set_compl (covered T)) l')).
      2: omega.
      eapply countP_mori; auto.
      basic_solver. }
    unfold trav_steps_left.
    rewrite COVEQ.
    assert (countP (W ∩₁ set_compl (issued T )) (acts G) >
            countP (W ∩₁ set_compl (issued T')) (acts G)) as HH.
    2: omega.
    rewrite ISSEQ.
    unfold countP.
    assert (List.In e (acts G)) as LL.
    { apply ISS. }
    assert (W e) as WE.
    { apply ISS. }
    induction (acts G).
    { done. }
    destruct l as [|h l].
    { assert (a = e); subst.
      { inv LL. }
      simpls. desf.
      { exfalso. apply s0. by right. }
      all: by exfalso; apply n; split. }
    destruct LL as [|H]; subst.
    2: { apply IHl in H. clear IHl.
         simpls. desf; simpls; try omega.
         1-2: by exfalso; apply n; destruct s0 as [H1 H2];
           split; auto; intros HH; apply H2; left.
         all: by exfalso; apply n; destruct s as [H1 H2];
           split; auto; intros HH; apply H2; left. }
    clear IHl.
    assert (exists l', l' = h :: l) as [l' HH] by eauto.
    rewrite <- HH. clear h l HH.
    simpls. desf; simpls.
    { exfalso. apply s0. by right. }
    2: { exfalso. apply s. by right. }
    2: { exfalso. apply n. by split. }
    assert (length (filterP (W ∩₁ set_compl (issued T ∪₁ eq e)) l') <=
            length (filterP (W ∩₁ set_compl (issued T)) l')).
    2: omega.
    eapply countP_mori; auto.
    basic_solver.
  Qed.

  Lemma trav_steps_left_decrease_sim (T T' : trav_config)
        (STEP : sim_trav_step G sc T T') :
    trav_steps_left T > trav_steps_left T'.
  Proof using.
    red in STEP. desc.
    destruct STEP.
    1-4: by apply trav_steps_left_decrease; red; eauto.
    { eapply lt_trans.
      all: apply trav_steps_left_decrease; red; eauto. }
    { eapply lt_trans.
      all: apply trav_steps_left_decrease; red; eauto. }
    eapply lt_trans.
    eapply lt_trans.
    all: apply trav_steps_left_decrease; red; eauto.
  Qed.

  Lemma trav_steps_left_null_cov (T : trav_config)
        (NULL : trav_steps_left T = 0) :
    E ⊆₁ covered T.
  Proof using.
    unfold trav_steps_left in *.
    assert (countP (set_compl (covered T)) (acts G) = 0) as HH by omega.
    clear NULL.
    unfold countP in *.
    apply length_zero_iff_nil in HH.
    intros x EX.
    destruct (classic (covered T x)) as [|NN]; auto.
    exfalso.
    assert (In x (filterP (set_compl (covered T)) (acts G))) as UU.
    2: { rewrite HH in UU. inv UU. }
    apply in_filterP_iff. by split.
  Qed.

  Lemma trav_steps_left_ncov_nnull (T : trav_config) e
        (EE : E e) (NCOV : ~ covered T e):
    trav_steps_left T <> 0.
  Proof using.
    destruct (classic (trav_steps_left T = 0)) as [EQ|NEQ]; auto.
    exfalso. apply NCOV. apply trav_steps_left_null_cov; auto.
  Qed.

  Lemma trav_steps_left_nnull_ncov (T : trav_config) (TCCOH : tc_coherent G sc T)
        (NNULL : trav_steps_left T > 0):
    exists e, E e /\ ~ covered T e.
  Proof using.
    unfold trav_steps_left in *.
    assert (countP (set_compl (covered T)) (acts G) > 0 \/
            countP (W ∩₁ set_compl (issued T)) (acts G) > 0) as YY by omega.
    assert (countP (set_compl (covered T)) (acts G) > 0) as HH.
    { destruct YY as [|YY]; auto.
      assert (countP (set_compl (covered T)) (acts G) >=
              countP (W ∩₁ set_compl (issued T)) (acts G)).
      2: omega.
      apply countP_mori; auto.
      intros x [WX NN] COV.
      apply NN. eapply w_covered_issued; eauto. by split. }
    clear YY.
    unfold countP in HH.
    assert (exists h l, filterP (set_compl (covered T)) (acts G) = h :: l) as YY.
    { destruct (filterP (set_compl (covered T)) (acts G)); eauto.
      inv HH. }
    desc. exists h.
    assert (In h (filterP (set_compl (covered T)) (acts G))) as GG.
    { rewrite YY. red. by left. }
    apply in_filterP_iff in GG. simpls.
  Qed.

  Lemma trav_steps_left_decrease_sim_trans (T T' : trav_config)
        (STEPS : (sim_trav_step G sc)⁺ T T') :
    trav_steps_left T > trav_steps_left T'.
  Proof using.
    induction STEPS.
    { by apply trav_steps_left_decrease_sim. }
    eapply lt_trans; eauto.
  Qed.

  Theorem nat_ind_lt (P : nat -> Prop)
          (HPi : forall n, (forall m, m < n -> P m) -> P n) :
    forall n, P n.
  Proof using.
    set (Q n := forall m, m <= n -> P m).
    assert (forall n, Q n) as HH.
    2: { ins. apply (HH n). omega. }
    ins. induction n.
    { unfold Q. ins. inv H. apply HPi. ins. inv H0. }
    unfold Q in *. ins.
    apply le_lt_eq_dec in H.
    destruct H as [Hl | Heq].
    { unfold lt in Hl. apply le_S_n in Hl. by apply IHn. }
    rewrite Heq. apply HPi. ins.
    apply le_S_n in H. by apply IHn.
  Qed.

  Lemma sim_traversal_helper T
        (IMMCON : imm_consistent G sc)
        (TCCOH : tc_coherent G sc T)
        (RELCOV :  W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
        (RMWCOV : forall r w (RMW : rmw r w), covered T r <-> covered T w) :
    exists T', (sim_trav_step G sc)＊ T T' /\ (G.(acts_set) ⊆₁ covered T').
  Proof using WF.
    assert
      (exists T' : trav_config, (sim_trav_step G sc)＊ T T' /\ trav_steps_left T' = 0).
    2: { desc. eexists. splits; eauto. by apply trav_steps_left_null_cov. }
    assert (exists n, n = trav_steps_left T) as [n NN] by eauto.
    generalize dependent T. generalize dependent n.
    set (P n :=
           forall T,
             tc_coherent G sc T ->
             W ∩₁ Rel ∩₁ issued T ⊆₁ covered T ->
             (forall r w, rmw r w -> covered T r <-> covered T w) ->
             n = trav_steps_left T ->
             exists T', (sim_trav_step G sc)＊ T T' /\ trav_steps_left T' = 0).
    assert (forall n, P n) as YY.
    2: by apply YY.
    apply nat_ind_lt. unfold P.
    ins.
    destruct (classic (trav_steps_left T = 0)) as [EQ|NEQ].
    { eexists. splits; eauto. apply rt_refl. }
    assert (trav_steps_left T > 0) as HH by omega.
    eapply trav_steps_left_nnull_ncov in HH; auto.
    desc. eapply exists_next in HH0; eauto. desc.
    eapply exists_trav_step in HH1; eauto.
    desc.
    apply exists_sim_trav_step in HH1; eauto. desc.
    clear T'. subst.
    specialize (H (trav_steps_left T'')).
    edestruct H as [T' [II OO]].
    { by apply trav_steps_left_decrease_sim. }
    { eapply sim_trav_step_coherence; eauto. }
    { eapply sim_trav_step_rel_covered; eauto. }
    { eapply sim_trav_step_rmw_covered; eauto. }
    { done. }
    exists T'. splits; auto. apply rt_begin.
    right. eexists. eauto.
  Qed.

  Lemma sim_traversal (IMMCON : imm_consistent G sc) :
    exists T, (sim_trav_step G sc)＊ (init_trav G) T /\ (G.(acts_set) ⊆₁ covered T).
  Proof using WF.
    apply sim_traversal_helper; auto.
    { by apply init_trav_coherent. }
    { unfold init_trav. simpls. basic_solver. }
    ins. split; intros [HH AA].
    { apply WF.(init_w) in HH.
      apply (dom_l WF.(wf_rmwD)) in RMW. apply seq_eqv_l in RMW.
      type_solver. }
    apply WF.(rmw_in_sb) in RMW. apply no_sb_to_init in RMW.
    apply seq_eqv_r in RMW. desf.
  Qed.

  Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).
  Notation "'Tid_' t"  := (fun x => tid x =  t) (at level 1).

  Lemma sim_step_cov_full_thread T T' thread thread'
        (TCCOH : tc_coherent G sc T)
        (TS : isim_trav_step G sc thread' T T')
        (NCOV : NTid_ thread ∩₁ G.(acts_set) ⊆₁ covered T) :
    thread' = thread.
  Proof using.
    destruct (classic (thread' = thread)) as [|NEQ]; [by subst|].
    exfalso.
    apply sim_trav_step_to_step in TS; auto. desf.
    red in TS. desf.
    { apply NEXT. apply NCOV. split; eauto. apply COV. }
    apply NISS. eapply w_covered_issued; eauto.
    split; auto.
    { apply ISS. }
    apply NCOV. split; auto. apply ISS.
  Qed.

  Lemma sim_step_cov_full_traversal T thread
        (IMMCON : imm_consistent G sc)
        (TCCOH : tc_coherent G sc T) (NCOV : NTid_ thread ∩₁ G.(acts_set) ⊆₁ covered T)
        (RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T)
        (RMWCOV : forall r w : actid, rmw r w -> covered T r <-> covered T w) :
    exists T', (isim_trav_step G sc thread)＊ T T' /\ (G.(acts_set) ⊆₁ covered T').
  Proof using WF.
    edestruct sim_traversal_helper as [T']; eauto.
    desc. exists T'. splits; auto.
    clear H0.
    induction H.
    2: ins; apply rt_refl.
    { ins. apply rt_step. destruct H as [thread' H].
      assert (thread' = thread); [|by subst].
      eapply sim_step_cov_full_thread; eauto. }
    ins.
    set (NCOV' := NCOV).
    apply IHclos_refl_trans1 in NCOV'; auto.
    eapply rt_trans; eauto.
    eapply IHclos_refl_trans2.
    { eapply sim_trav_steps_coherence; eauto. }
    { etransitivity; eauto.
      eapply sim_trav_steps_covered_le; eauto. }
    { eapply sim_trav_steps_rel_covered; eauto. }
    eapply sim_trav_steps_rmw_covered; eauto.
  Qed.
End TraversalCounting.