Require Import oeuf.Common.
Require oeuf.StepLib.
Require Import Psatz.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.

Require Export oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive insn :=
| Arg (dst : nat)
| Self (dst : nat)
| Deref (dst : nat) (e : nat) (off : nat)
| Call (dst : nat) (f : nat) (a : nat)
| MkConstr (dst : nat) (tag : nat) (args : list nat)
| Switch (dst : nat) (cases : list (list insn))
| MkClose (dst : nat) (f : function_name) (free : list nat)
| OpaqueOp (dst : nat) (op : opaque_oper_name) (args : list nat)
| Copy (dst : nat) (src : nat)
.

Definition env := list (list insn * nat).

(* Continuation-based step relation *)

Record frame := Frame {
    arg : value;
    self : value;
    locals : list (nat * value)
}.

Definition set f l v :=
    Frame (arg f) (self f) ((l, v) :: locals f).

Definition local f l := lookup (locals f) l.

Inductive cont :=
| Kseq (code : list insn) (k : cont)
| Kswitch (code : list insn) (k : cont)
| Kret (code : list insn) (ret : nat) (dst : nat) (f : frame) (k : cont)
| Kstop (ret : nat).

Inductive state :=
| Run (i : list insn) (f : frame) (k : cont)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SSeq : forall i is f k,
        is <> [] ->
        sstep E (Run (i :: is) f k)
                (Run [i] f (Kseq is k))

| SArg : forall dst f k,
        sstep E (Run [Arg dst] f k)
                (Run [] (set f dst (arg f)) k)
| SSelf : forall dst f k,
        sstep E (Run [Self dst] f k)
                (Run [] (set f dst (self f)) k)

| SDerefinateConstr : forall dst e off f k  tag args v,
        local f e = Some (Constr tag args) ->
        nth_error args off = Some v ->
        sstep E (Run [Deref dst e off] f k)
                (Run [] (set f dst v) k)
| SDerefinateClose : forall dst e off f k  fname free v,
        local f e = Some (Close fname free) ->
        nth_error free off = Some v ->
        sstep E (Run [Deref dst e off] f k)
                (Run [] (set f dst v) k)

| SConstrDone : forall dst tag args f k vs,
        Forall2 (fun l v => local f l = Some v) args vs ->
        sstep E (Run [MkConstr dst tag args] f k)
                (Run [] (set f dst (Constr tag vs)) k)
| SCloseDone : forall dst fname free f k vs,
        Forall2 (fun l v => local f l = Some v) free vs ->
        sstep E (Run [MkClose dst fname free] f k)
                (Run [] (set f dst (Close fname vs)) k)
| SOpaqueOpDone : forall dst op args f k vs v,
        Forall2 (fun l v => local f l = Some v) args vs ->
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run [OpaqueOp dst op args] f k)
                (Run [] (set f dst v) k)

| SMakeCall : forall dst fl a f k  fname free arg body ret,
        local f fl = Some (Close fname free) ->
        local f a = Some arg ->
        nth_error E fname = Some (body, ret) ->
        sstep E (Run [Call dst fl a] f k)
                (Run body (Frame arg (Close fname free) [])
                    (Kret [] ret dst f k))

(* NB: `Switch` still has an implicit target of `Arg` *)
| SSwitchinate : forall dst cases f k  tag args case,
        arg f = Constr tag args ->
        nth_error cases tag = Some case ->
        sstep E (Run [Switch dst cases] f k)
                (Run case f (Kswitch [] k))

| SCopy : forall dst src f k v,
        local f src = Some v ->
        sstep E (Run [Copy dst src] f k)
                (Run [] (set f dst v) k)

| SContSeq : forall code f k,
        sstep E (Run [] f (Kseq code k))
                (Run code f k)
| SContSwitch : forall code f k,
        sstep E (Run [] f (Kswitch code k))
                (Run code f k)
| SContRet : forall f code ret dst f' k v,
        local f ret = Some v ->
        sstep E (Run [] f (Kret code ret dst f' k))
                (Run code (set f' dst v) k)
| SContStop : forall ret f v,
        local f ret = Some v ->
        sstep E (Run [] f (Kstop ret))
                (Stop v)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

Require Import oeuf.Metadata.
Require oeuf.Semantics.

Definition prog_type : Type := env * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body ret,
        nth_error (fst prog) fname = Some (body, ret) ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body
                 (Frame av fv [])
                 (Kstop ret)).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

(*

Definition prog_type : Type := env * list metadata.

Inductive initial_state (prog : prog_type) : state -> Prop :=.

Inductive final_state (prog : prog_type) : state -> Prop :=
| FinalState : forall v, final_state prog (Stop v).

Definition initial_env (prog : prog_type) : env := fst prog.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env
                 (sstep)
                 (initial_state prog)
                 (final_state prog)
                 (initial_env prog).

*)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition insn_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HArg :     forall dst, P (Arg dst))
    (HSelf :    forall dst, P (Self dst))
    (HDeref :   forall dst e off, P (Deref dst e off))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pll cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HCopy :    forall dst src, P (Copy dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (i : insn) : P i :=
    let fix go i :=
        let fix go_list is :=
            match is as is_ return Pl is_ with
            | [] => Hnil
            | i :: is => Hcons i is (go i) (go_list is)
            end in
        let fix go_list_list iss :=
            match iss as iss_ return Pll iss_ with
            | [] => Hnil2
            | is :: iss => Hcons2 is iss (go_list is) (go_list_list iss)
            end in
        match i as i_ return P i_ with
        | Arg dst => HArg dst
        | Self dst => HSelf dst
        | Deref dst e off => HDeref dst e off
        | Call dst f a => HCall dst f a
        | MkConstr dst tag args => HConstr dst tag args
        | Switch dst cases => HSwitch dst cases (go_list_list cases)
        | MkClose dst fname free => HClose dst fname free
        | OpaqueOp dst op args => HOpaqueOp dst op args
        | Copy dst src => HCopy dst src
        end in go i.

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition insn_ind' (P : insn -> Prop)
    (HArg :     forall dst, P (Arg dst))
    (HSelf :    forall dst, P (Self dst))
    (HDeref :   forall dst e off, P (Deref dst e off))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Forall (Forall P) cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HCopy :    forall dst src, P (Copy dst src))
    (i : insn) : P i :=
    ltac:(refine (@insn_rect_mut P (Forall P) (Forall (Forall P))
        HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp HCopy _ _ _ _ i); eauto).

Definition insn_list_rect_mut
        (P : insn -> Type)
        (Pl : list insn -> Type)
        (Pll : list (list insn) -> Type)
    (HArg :     forall dst, P (Arg dst))
    (HSelf :    forall dst, P (Self dst))
    (HDeref :   forall dst e off, P (Deref dst e off))
    (HCall :    forall dst f a, P (Call dst f a))
    (HConstr :  forall dst tag args, P (MkConstr dst tag args))
    (HSwitch :  forall dst cases, Pll cases -> P (Switch dst cases))
    (HClose :   forall dst fname free, P (MkClose dst fname free))
    (HOpaqueOp : forall dst op args, P (OpaqueOp dst op args))
    (HCopy :    forall dst src, P (Copy dst src))
    (Hnil :     Pl [])
    (Hcons :    forall i is, P i -> Pl is -> Pl (i :: is))
    (Hnil2 :    Pll [])
    (Hcons2 :   forall is iss, Pl is -> Pll iss -> Pll (is :: iss))
    (is : list insn) : Pl is :=
    let go := insn_rect_mut P Pl Pll
            HArg HSelf HDeref HCall HConstr HSwitch HClose HOpaqueOp HCopy
            Hnil Hcons Hnil2 Hcons2 in
    let fix go_list is :=
        match is as is_ return Pl is_ with
        | [] => Hnil
        | i :: is => Hcons i is (go i) (go_list is)
        end in go_list is.

Definition dest e :=
    match e with
    | Arg dst => dst
    | Self dst => dst
    | Deref dst _ _ => dst
    | Call dst _ _ => dst
    | MkConstr dst _ _ => dst
    | Switch dst _ => dst
    | MkClose dst _ _ => dst
    | OpaqueOp dst _ _ => dst
    | Copy dst _ => dst
    end.


(** OBS!: This is taken directly from Iris, and should instead be obtained
from bumping the Iris version. *)

(** Authoritative CMRA of append-only lists, where the fragment represents a
  snap-shot of the list, and the authoritative element can only grow by
  appending. *)
From iris.algebra Require Export auth dfrac max_prefix_list.
From iris.algebra Require Import updates local_updates proofmode_classes.
From iris.prelude Require Import options.

Definition mono_listR (A : ofe) : cmra  := authR (max_prefix_listUR A).
Definition mono_listUR (A : ofe) : ucmra  := authUR (max_prefix_listUR A).

Definition mono_list_auth {A : ofe} (q : dfrac) (l : list A) : mono_listR A :=
  ●{q} (to_max_prefix_list l) ⋅ ◯ (to_max_prefix_list l).
Definition mono_list_lb {A : ofe} (l : list A) : mono_listR A :=
  ◯ (to_max_prefix_list l).
Global Instance: Params (@mono_list_auth) 2 := {}.
Global Instance: Params (@mono_list_lb) 1 := {}.
Typeclasses Opaque mono_list_auth mono_list_lb.

(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Notation "●ML{ dq } l" :=
  (mono_list_auth dq l) (at level 20, format "●ML{ dq }  l").
Notation "●ML{# q } l" :=
  (mono_list_auth (DfracOwn q) l) (at level 20, format "●ML{# q }  l").
Notation "●ML□ l" := (mono_list_auth DfracDiscarded l) (at level 20).
Notation "●ML l" := (mono_list_auth (DfracOwn 1) l) (at level 20).
Notation "◯ML l" := (mono_list_lb l) (at level 20).

Section mono_list_props.
  Context {A : ofe}.
  Implicit Types l : list A.
  Implicit Types q : frac.
  Implicit Types dq : dfrac.

  (** Setoid properties *)
  Global Instance mono_list_auth_ne dq : NonExpansive (@mono_list_auth A dq).
  Proof. solve_proper. Qed.
  Global Instance mono_list_auth_proper dq : Proper ((≡) ==> (≡)) (@mono_list_auth A dq).
  Proof. solve_proper. Qed.
  Global Instance mono_list_lb_ne : NonExpansive (@mono_list_lb A).
  Proof. solve_proper. Qed.
  Global Instance mono_list_lb_proper : Proper ((≡) ==> (≡)) (@mono_list_lb A).
  Proof. solve_proper. Qed.

  Global Instance mono_list_lb_dist_inj n : Inj (dist n) (dist n) (@mono_list_lb A).
  Proof. rewrite /mono_list_lb. by intros ?? ?%(inj _)%(inj _). Qed.
  Global Instance mono_list_lb_inj : Inj (≡) (≡) (@mono_list_lb A).
  Proof. rewrite /mono_list_lb. by intros ?? ?%(inj _)%(inj _). Qed.

  (** * Operation *)
  Global Instance mono_list_lb_core_id l : CoreId (◯ML l).
  Proof. rewrite /mono_list_lb. apply _. Qed.
  Global Instance mono_list_auth_core_id l : CoreId (●ML□ l).
  Proof. rewrite /mono_list_auth. apply _. Qed.

  Lemma mono_list_auth_dfrac_op dq1 dq2 l :
    ●ML{dq1 ⋅ dq2} l ≡ ●ML{dq1} l ⋅ ●ML{dq2} l.
  Proof.
    rewrite /mono_list_auth auth_auth_dfrac_op.
    rewrite (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)).
    by rewrite -core_id_dup (comm _ (◯ _)).
  Qed.

  Lemma mono_list_lb_op_l l1 l2 : l1 `prefix_of` l2 → ◯ML l1 ⋅ ◯ML l2 ≡ ◯ML l2.
  Proof. intros ?. by rewrite /mono_list_lb -auth_frag_op to_max_prefix_list_op_l. Qed.
  Lemma mono_list_lb_op_r l1 l2 : l1 `prefix_of` l2 → ◯ML l2 ⋅ ◯ML l1 ≡ ◯ML l2.
  Proof. intros ?. by rewrite /mono_list_lb -auth_frag_op to_max_prefix_list_op_r. Qed.
  Lemma mono_list_auth_lb_op dq l : ●ML{dq} l ≡ ●ML{dq} l ⋅ ◯ML l.
  Proof.
    by rewrite /mono_list_auth /mono_list_lb -!assoc -auth_frag_op -core_id_dup.
  Qed.

  Global Instance mono_list_auth_dfrac_is_op dq dq1 dq2 l :
    IsOp dq dq1 dq2 → IsOp' (●ML{dq} l) (●ML{dq1} l) (●ML{dq2} l).
  Proof. rewrite /IsOp' /IsOp=> ->. rewrite mono_list_auth_dfrac_op //. Qed.

  (** * Validity *)
  Lemma mono_list_auth_dfrac_validN n dq l : ✓{n} (●ML{dq} l) ↔ ✓ dq.
  Proof.
    rewrite /mono_list_auth auth_both_dfrac_validN.
    naive_solver apply to_max_prefix_list_validN.
  Qed.
  Lemma mono_list_auth_validN n l : ✓{n} (●ML l).
  Proof. by apply mono_list_auth_dfrac_validN. Qed.

  Lemma mono_list_auth_dfrac_valid dq l : ✓ (●ML{dq} l) ↔ ✓ dq.
  Proof.
    rewrite /mono_list_auth auth_both_dfrac_valid.
    naive_solver apply to_max_prefix_list_valid.
  Qed.
  Lemma mono_list_auth_valid l : ✓ (●ML l).
  Proof. by apply mono_list_auth_dfrac_valid. Qed.

  Lemma mono_list_auth_dfrac_op_validN n dq1 dq2 l1 l2 :
    ✓{n} (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 ≡{n}≡ l2.
  Proof.
    rewrite /mono_list_auth (comm _ (●{dq2} _)) -!assoc (assoc _ (◯ _)).
    rewrite -auth_frag_op (comm _ (◯ _)) assoc. split.
    - move=> /cmra_validN_op_l /auth_auth_dfrac_op_validN.
      rewrite (inj_iff to_max_prefix_list). naive_solver.
    - intros [? ->]. rewrite -core_id_dup -auth_auth_dfrac_op auth_both_dfrac_validN.
      naive_solver apply to_max_prefix_list_validN.
  Qed.
  Lemma mono_list_auth_op_validN n l1 l2 : ✓{n} (●ML l1 ⋅ ●ML l2) ↔ False.
  Proof. rewrite mono_list_auth_dfrac_op_validN. naive_solver. Qed.

  Lemma mono_list_auth_dfrac_op_valid dq1 dq2 l1 l2 :
    ✓ (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 ≡ l2.
  Proof.
    rewrite cmra_valid_validN equiv_dist.
    setoid_rewrite mono_list_auth_dfrac_op_validN. naive_solver eauto using O.
  Qed.
  Lemma mono_list_auth_op_valid l1 l2 : ✓ (●ML l1 ⋅ ●ML l2) ↔ False.
  Proof. rewrite mono_list_auth_dfrac_op_valid. naive_solver. Qed.

  Lemma mono_list_auth_dfrac_op_valid_L `{!LeibnizEquiv A} dq1 dq2 l1 l2 :
    ✓ (●ML{dq1} l1 ⋅ ●ML{dq2} l2) ↔ ✓ (dq1 ⋅ dq2) ∧ l1 = l2.
  Proof. unfold_leibniz. apply mono_list_auth_dfrac_op_valid. Qed.

  Lemma mono_list_both_dfrac_validN n dq l1 l2 :
    ✓{n} (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ ∃ l, l1 ≡{n}≡ l2 ++ l.
  Proof.
    rewrite /mono_list_auth /mono_list_lb -assoc
      -auth_frag_op auth_both_dfrac_validN -to_max_prefix_list_includedN.
    f_equiv; split.
    - intros [Hincl _]. etrans; [apply: cmra_includedN_r|done].
    - intros. split; [|by apply to_max_prefix_list_validN].
      rewrite {2}(core_id_dup (to_max_prefix_list l1)). by f_equiv.
  Qed.
  Lemma mono_list_both_validN n l1 l2 :
    ✓{n} (●ML l1 ⋅ ◯ML l2) ↔ ∃ l, l1 ≡{n}≡ l2 ++ l.
  Proof. rewrite mono_list_both_dfrac_validN. split; [naive_solver|done]. Qed.

  Lemma mono_list_both_dfrac_valid dq l1 l2 :
    ✓ (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ ∃ l, l1 ≡ l2 ++ l.
  Proof.
    rewrite /mono_list_auth /mono_list_lb -assoc -auth_frag_op
      auth_both_dfrac_valid -max_prefix_list_included_includedN
      -to_max_prefix_list_included.
    f_equiv; split.
    - intros [Hincl _]. etrans; [apply: cmra_included_r|done].
    - intros. split; [|by apply to_max_prefix_list_valid].
      rewrite {2}(core_id_dup (to_max_prefix_list l1)). by f_equiv.
  Qed.
  Lemma mono_list_both_valid l1 l2 :
    ✓ (●ML l1 ⋅ ◯ML l2) ↔ ∃ l, l1 ≡ l2 ++ l.
  Proof. rewrite mono_list_both_dfrac_valid. split; [naive_solver|done]. Qed.

  Lemma mono_list_both_dfrac_valid_L `{!LeibnizEquiv A} dq l1 l2 :
    ✓ (●ML{dq} l1 ⋅ ◯ML l2) ↔ ✓ dq ∧ l2 `prefix_of` l1.
  Proof. rewrite /prefix. rewrite mono_list_both_dfrac_valid. naive_solver. Qed.
  Lemma mono_list_both_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (●ML l1 ⋅ ◯ML l2) ↔ l2 `prefix_of` l1.
  Proof. rewrite /prefix. rewrite mono_list_both_valid. naive_solver. Qed.

  Lemma mono_list_lb_op_validN n l1 l2 :
    ✓{n} (◯ML l1 ⋅ ◯ML l2) ↔ (∃ l, l2 ≡{n}≡ l1 ++ l) ∨ (∃ l, l1 ≡{n}≡ l2 ++ l).
  Proof. by rewrite auth_frag_op_validN to_max_prefix_list_op_validN. Qed.
  Lemma mono_list_lb_op_valid l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) ↔ (∃ l, l2 ≡ l1 ++ l) ∨ (∃ l, l1 ≡ l2 ++ l).
  Proof. by rewrite auth_frag_op_valid to_max_prefix_list_op_valid. Qed.
  Lemma mono_list_lb_op_valid_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) ↔ l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. rewrite mono_list_lb_op_valid / prefix. naive_solver. Qed.

  Lemma mono_list_lb_op_valid_1_L `{!LeibnizEquiv A} l1 l2 :
    ✓ (◯ML l1 ⋅ ◯ML l2) → l1 `prefix_of` l2 ∨ l2 `prefix_of` l1.
  Proof. by apply mono_list_lb_op_valid_L. Qed.
  Lemma mono_list_lb_op_valid_2_L `{!LeibnizEquiv A} l1 l2 :
    l1 `prefix_of` l2 ∨ l2 `prefix_of` l1 → ✓ (◯ML l1 ⋅ ◯ML l2).
  Proof. by apply mono_list_lb_op_valid_L. Qed.

  Lemma mono_list_lb_mono l1 l2 : l1 `prefix_of` l2 → ◯ML l1 ≼ ◯ML l2.
  Proof. intros. exists (◯ML l2). by rewrite mono_list_lb_op_l. Qed.

  Lemma mono_list_included dq l : ◯ML l ≼ ●ML{dq} l.
  Proof. apply cmra_included_r. Qed.

  (** * Update *)
  Lemma mono_list_update {l1} l2 : l1 `prefix_of` l2 → ●ML l1 ~~> ●ML l2.
  Proof. intros ?. by apply auth_update, max_prefix_list_local_update. Qed.
  Lemma mono_list_auth_persist dq l : ●ML{dq} l ~~> ●ML□ l.
  Proof.
    rewrite /mono_list_auth. apply cmra_update_op; [|done].
    by apply auth_update_auth_persist.
  Qed.
End mono_list_props.

Definition mono_listURF (F : oFunctor) : urFunctor :=
  authURF (max_prefix_listURF F).

Global Instance mono_listURF_contractive F :
  oFunctorContractive F → urFunctorContractive (mono_listURF F).
Proof. apply _. Qed.

Definition mono_listRF (F : oFunctor) : rFunctor :=
  authRF (max_prefix_listURF F).

Global Instance mono_listRF_contractive F :
  oFunctorContractive F → rFunctorContractive (mono_listRF F).
Proof. apply _. Qed.


From iris.program_logic Require Import lifting.
From iris.algebra Require Import frac dec_agree gmap list.
From iris.base_logic Require Import big_op auth.
From iris_logrel.F_mu_ref Require Export rules.
From iris.proofmode Require Import tactics.
Import uPred.

Definition specN := nroot .@ "spec".

(** The CMRA for the heap of the specification. *)
Definition cfgUR := prodUR (optionUR (exclR exprC)) heapUR.

(** The CMRA for the thread pool. *)
Class cfgSG Σ :=
  CFGSG { ctg_heapG :> heapG Σ; cfg_inG :> authG Σ cfgUR; cfg_name : gname }.

Section definitionsS.
  Context `{cfgSG Σ}.

  Definition heapS_mapsto (l : loc) (q : Qp) (v: val) : iProp Σ :=
    own cfg_name (◯ (∅, {[ l := (q, DecAgree v) ]})).

  Definition tpool_mapsto (e: expr) : iProp Σ :=
    own cfg_name (◯ (Excl' e, ∅)).

  Definition spec_inv (ρ : cfg lang) : iProp Σ :=
    (∃ e σ, own cfg_name (● (Excl' e , to_heap σ)) ∗ ■ rtc step ρ ([e],σ))%I.
  Definition spec_ctx (ρ : cfg lang) : iProp Σ :=
    inv specN (spec_inv ρ).

  Global Instance heapS_mapsto_timeless l q v : TimelessP (heapS_mapsto l q v).
  Proof. apply _. Qed.
  Global Instance spec_ctx_persistent ρ : PersistentP (spec_ctx ρ).
  Proof. apply _. Qed.
End definitionsS.
Typeclasses Opaque heapS_mapsto tpool_mapsto.

Notation "l ↦ₛ{ q } v" := (heapS_mapsto l q v)
  (at level 20, q at level 50, format "l  ↦ₛ{ q }  v") : uPred_scope.
Notation "l ↦ₛ v" := (heapS_mapsto l 1 v) (at level 20) : uPred_scope.
Notation "⤇ e" := (tpool_mapsto e) (at level 20) : uPred_scope.

Section cfg.
  Context `{cfgSG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.
  Implicit Types σ : state.
  Implicit Types g : heapUR.
  Implicit Types e : expr.
  Implicit Types v : val.

  (** Conversion to tpools and back *)
  Lemma step_insert_no_fork K e σ e' σ' :
    head_step e σ e' σ' [] → step ([fill K e], σ) ([fill K e'], σ').
  Proof. intros Hst. eapply (step_atomic _ _ _ _ _ _ [] [] []); eauto.
         by apply: Ectx_step'.
  Qed.

  Lemma step_pure E ρ K e e' :
    (∀ σ, head_step e σ e' σ []) →
    nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K e ={E}=∗ ⤇ fill K e'.
  Proof.
    iIntros (??) "[#Hspec Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as ">Hinv" "Hclose". iDestruct "Hinv" as (e2 σ) "[Hown %]".
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
       (exclusive_local_update _ (Excl (fill K e'))). }
    iFrame "Hj". iApply "Hclose". iNext. iExists (fill K e'), σ.
    iFrame. iPureIntro. eapply rtc_r, step_insert_no_fork; eauto.
  Qed.

  Lemma step_alloc E ρ K e v:
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Alloc e) ={E}=∗ ∃ l, ⤇ fill K (Loc l) ∗ l ↦ₛ v.
  Proof.
    iIntros (??) "[#Hinv Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e2 σ) "[Hown %]".
    destruct (exist_fresh (dom (gset positive) σ)) as [l Hl%not_elem_of_dom].
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
       (exclusive_local_update _ (Excl (fill K (Loc l)))). }
    iMod (own_update with "Hown") as "[Hown Hl]".
    { eapply auth_update_alloc, prod_local_update_2,
        (alloc_singleton_local_update _ l (1%Qp,DecAgree v)); last done.
      by apply lookup_to_heap_None. }
    iExists l. rewrite /heapS_mapsto. iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (fill K (Loc l)), (<[l:=v]>σ).
    rewrite to_heap_insert; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_load E ρ K l q v:
    nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Load (Loc l)) ∗ l ↦ₛ{q} v
    ={E}=∗ ⤇ fill K (of_val v) ∗ l ↦ₛ{q} v.
  Proof.
    iIntros (?) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e2 σ) "[Hown %]".
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iDestruct (own_valid_2 _ with "Hown Hl")
      as %[[_ ?%heap_singleton_included]%prod_included _]%auth_valid_discrete_2.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
        (exclusive_local_update _ (Excl (fill K (of_val v)))). }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (fill K (of_val v)), σ.
    iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_store E ρ K l v' e v:
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Store (Loc l) e) ∗ l ↦ₛ v'
    ={E}=∗ ⤇ fill K Unit ∗ l ↦ₛ v.
  Proof.
    iIntros (??) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e2 σ) "[Hown %]".
    iDestruct (own_valid_2 _ with "Hown Hj")
      as %[[?%Excl_included%leibniz_equiv _]%prod_included ?]%auth_valid_discrete_2.
    subst.
    iDestruct (own_valid_2 _ with "Hown Hl")
      as %[[_ Hl%heap_singleton_included]%prod_included _]%auth_valid_discrete_2.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { by eapply auth_update, prod_local_update_1, option_local_update,
        (exclusive_local_update _ (Excl (fill K Unit))). }
    iMod (own_update_2 with "Hown Hl") as "[Hown Hl]".
    { eapply auth_update, prod_local_update_2, singleton_local_update,
        (exclusive_local_update _ (1%Qp, DecAgree v)); last done.
      by rewrite /to_heap lookup_fmap Hl. }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (fill K Unit), (<[l:=v]>σ).
    rewrite to_heap_insert; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_lam E ρ K e1 e2 v :
    to_val e2 = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (App (Lam e1) e2)
    ={E}=∗ ⤇ fill K (e1.[e2/]).
  Proof. intros ?; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_tlam E ρ K e :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (TApp (TLam e)) ={E}=∗ ⤇ fill K e.
  Proof. apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_Fold E ρ K e v :
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Unfold (Fold e)) ={E}=∗ ⤇ fill K e.
  Proof. intros H1; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_fst E ρ K e1 v1 e2 v2 :
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Fst (Pair e1 e2)) ={E}=∗ ⤇ fill K e1.
  Proof. intros H1 H2; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_snd E ρ K e1 v1 e2 v2 :
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Snd (Pair e1 e2)) ={E}=∗ ⤇ fill K e2.
  Proof. intros H1 H2; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_case_inl E ρ K e0 v0 e1 e2 :
    to_val e0 = Some v0 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Case (InjL e0) e1 e2)
      ={E}=∗ ⤇ fill K (e1.[e0/]).
  Proof. intros H1; apply step_pure => σ; econstructor; eauto. Qed.

  Lemma step_case_inr E ρ K e0 v0 e1 e2 :
    to_val e0 = Some v0 → nclose specN ⊆ E →
    spec_ctx ρ ∗ ⤇ fill K (Case (InjR e0) e1 e2)
      ={E}=∗ ⤇ fill K (e2.[e0/]).
  Proof. intros H1; apply step_pure => σ; econstructor; eauto. Qed.

End cfg.


From iris.algebra Require Export cmra.
From iris.algebra Require Import proofmode_classes.
From iris.prelude Require Import options.
Require Import cpdt.CpdtTactics.

From stdpp Require Import gmap.
From stdpp Require Import mapset.
From stdpp Require Import sets.
From stdpp Require Import list.
Require Import Burrow.gmap_utils.
Require Import Burrow.trees.
Require Import Burrow.indexing.
Require Import Burrow.locations.
Require Import Burrow.tactics.

Require Import coq_tricks.Deex.

Section ExchangeProof.

Context {M} `{!EqDecision M} `{!TPCM M}.
Context {RI} `{!EqDecision RI, !Countable RI, !RefinementIndex M RI}.

Definition specific_exchange_cond (ref: Refinement M M) (p m f h s m' f' h' s' : M) :=
  ∃ j l l' ,
  rel_defined M M ref (dot f p) ->
  m_valid (dot m (rel M M ref (dot f p))) ->
      dot j s' = f' /\ m = dot l h /\ m' = dot l' h' /\
      rel_defined M M ref (dot (dot j s) p) /\
      mov (dot l (rel M M ref (dot f p))) (dot l' (rel M M ref (dot (dot j s) p))).

Definition specific_flow_cond p i (t t': Branch M) (active: Lifetime) (down up : PathLoc -> M) :=
  let q := (p, i) in
  let r := (p, S i) in
  let s := (p ++ [i], 0) in
  specific_exchange_cond (refinement_of_nat M RI i)
      (node_total_minus_live (refinement_of_nat M RI) (node_of_pl t q) active)
      (down q) (node_live (node_of_pl t q))
      (down r) (down s)
      (up q) (node_live (node_of_pl t' q))
      (up r) (up s).

Lemma dot_kjha k j a : (dot (dot a k) j) = (dot (dot j a) k).
Proof.  rewrite tpcm_comm. rewrite tpcm_assoc. trivial. Qed.

Lemma valid_reduce m k a :
  m_valid (dot (dot m k) a) -> m_valid (dot m a).
Proof. intro. apply valid_monotonic with (y := k).
  rewrite dot_comm_right2. trivial. Qed.

Lemma dot_aklh a k l h
  : (dot (dot a k) (dot l h)) = dot (dot l a) (dot k h).
Proof.
  rewrite tpcm_assoc. rewrite tpcm_assoc. f_equal.
  apply dot_kjha. Qed.

Lemma dot_aklh2 a k l h
    : (dot (dot (dot l h) k) a) = (dot (dot l a) (dot k h)).
Proof.
  rewrite <- tpcm_assoc. rewrite <- tpcm_assoc. rewrite <- tpcm_assoc. f_equal.
  rewrite tpcm_assoc. rewrite tpcm_assoc. rewrite dot_kjha.
  rewrite dot_comm_right2. trivial. Qed.

Lemma dot_jszr (j s z r : M)
        : dot (dot j s) (dot z r) = dot (dot r s) (dot j z).
Proof.
  replace (dot j s) with (dot s j) by (apply tpcm_comm).
  replace (dot r s) with (dot s r) by (apply tpcm_comm).
  rewrite <- tpcm_assoc. rewrite <- tpcm_assoc. f_equal.
  replace (dot z r) with (dot r z) by (apply tpcm_comm).
  rewrite tpcm_assoc. rewrite tpcm_assoc. f_equal. apply tpcm_comm. Qed.

Lemma dot_jszr2 (j s z r : M)
        : (dot (dot (dot j s) z) r) = dot (dot r s) (dot j z).
Proof.
  rewrite <- tpcm_assoc.
  apply dot_jszr. Qed.

Lemma dot_qklh (q k l h : M)
  : dot (dot q k) (dot l h) = dot (dot k h) (dot q l).
Proof.
  replace (dot k h) with (dot h k) by (apply tpcm_comm).
  apply dot_jszr.
Qed.

Lemma all_the_movs (z m f h s r k m' f' h' s' r' k' : M) i
  (mo: mov (dot r s) (dot r' s'))
  (mo2: mov (dot k h) (dot k' h'))
  (inr: in_refinement_domain (refinement_of_nat M RI) i (dot f (dot z r)))
  (myflow : specific_exchange_cond (refinement_of_nat M RI i) (dot z r) m f h s m' f' h' s')
  (val : m_valid (dot (dot m k) (project (refinement_of_nat M RI) i (dot (dot f z) r))))
  : mov (dot (dot (project (refinement_of_nat M RI) i (dot (dot f z) r)) k) m)
        (dot (dot (project (refinement_of_nat M RI) i (dot (dot f' z) r')) k') m').
Proof.
  unfold specific_exchange_cond in myflow. deex.
  unfold in_refinement_domain in inr.
  unfold project in *.
  assert ((dot (dot f z) r) = (dot f (dot z r))) as A by (rewrite tpcm_assoc; trivial).
  rewrite A in val. rewrite A. clear A.
  (*destruct (rel M M (refinement_of_nat M RI i) (dot f (dot z r))) eqn:fzr.
  - rename m0 into a.*)
    have myf := myflow inr (valid_reduce m k _ val). clear myflow.
    destruct_ands.
    subst m.
    subst m'. subst f'.
    set a := (rel M M (refinement_of_nat M RI i) (dot f (dot z r))).
    set a' := (rel M M (refinement_of_nat M RI i) ((dot (dot j s) (dot z r)))).
      assert (m_valid (dot (dot a' k) (dot l' h)) /\
        (mov (dot (dot a k) (dot l h)) (dot (dot a' k) (dot l' h)))).
      * assert (dot (dot a k) (dot l h) = dot (dot l a) (dot k h)) as r1 by (apply dot_aklh).
        assert (dot (dot a' k) (dot l' h) = dot (dot l' a') (dot k h)) as r2 by (apply dot_aklh).
        rewrite r1.
        rewrite r2.
        subst a. subst a'.
        apply mov_monotonic; trivial.
        rewrite <- dot_aklh2. trivial.
      * destruct_ands.
        apply trans with (y := dot (dot a' k) (dot l' h)); trivial.

        subst a. subst a'.

        rewrite dot_jszr in H2.
        rewrite dot_jszr in H3.

        rewrite dot_jszr2.

        assert (m_valid (dot (dot r s) (dot j z))) as m_valid_srjz
         by ( apply (rel_valid_left M M (refinement_of_nat M RI i) (dot (dot r s) (dot j z))); trivial).
        assert (mov (dot (dot r s) (dot j z)) (dot (dot r' s') (dot j z))) as mov_rsjz
          by (apply mov_monotonic; trivial).

        have movr := mov_refines M M (refinement_of_nat M RI i)
            (dot (dot r s) (dot j z)) (dot (dot r' s') (dot j z)) mov_rsjz H2.
        deex. destruct_ands.

        assert (m_valid (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z))) k) (dot l' h)) /\
          (mov (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r))) k) (dot l' h)) (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z))) k) (dot l' h)))).
          -- replace
            ((dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r))) k) (dot l' h))) with
            ((dot ((rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r)))) (dot k (dot l' h)))) by (apply tpcm_assoc).
            replace
            ((dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r))) k) (dot l' h))) with
            ((dot ((rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r)))) (dot k (dot l' h)))) in H by (apply tpcm_assoc).
             replace
            ((dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z))) k) (dot l' h))) with
            ((dot ((rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z)))) (dot k (dot l' h)))) by (apply tpcm_assoc).
            rewrite <- dot_jszr in H4.
             apply mov_monotonic; trivial.
          -- destruct_ands.
              apply trans with (y := (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z))) k) (dot l' h))); trivial.
              rewrite dot_qklh.
              rewrite dot_qklh in H5.
              assert (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z))) k') (dot l' h') = dot (dot k' h') (dot (rel M M (refinement_of_nat M RI i) (dot (dot r' s') (dot j z))) l'))
                  by (apply dot_qklh).
              rewrite H7.
              apply mov_monotonic; trivial.
Qed.

Lemma all_the_movs_ird (z m f h s r k m' f' h' s' r' k' : M) i
  (mo: mov (dot r s) (dot r' s'))
  (mo2: mov (dot k h) (dot k' h'))
  (inr: in_refinement_domain (refinement_of_nat M RI) i (dot f (dot z r)))
  (myflow : specific_exchange_cond (refinement_of_nat M RI i) (dot z r) m f h s m' f' h' s')
  (val : m_valid (dot (dot m k) (project (refinement_of_nat M RI) i (dot (dot f z) r))))
  : in_refinement_domain (refinement_of_nat M RI) i (dot (dot f' z) r').
Proof.
  unfold specific_exchange_cond in myflow. deex.
  unfold in_refinement_domain in inr.
  unfold project in *.
  assert ((dot (dot f z) r) = (dot f (dot z r))) as A by (rewrite tpcm_assoc; trivial).
  rewrite A in val. clear A.
    have myf := myflow inr (valid_reduce m k _ val). clear myflow.
    destruct_ands.
    subst m.
    subst m'.
    subst f'.
      assert (m_valid (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r))) k) (dot l' h)) /\
        (mov (dot (dot (rel M M (refinement_of_nat M RI i) (dot f (dot z r))) k) (dot l h)) (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r))) k) (dot l' h)))).
      * assert (dot (dot (rel M M (refinement_of_nat M RI i) (dot f (dot z r))) k) (dot l h) = dot (dot l (rel M M (refinement_of_nat M RI i) (dot f (dot z r)))) (dot k h)) as r1 by (apply dot_aklh).
        assert (dot (dot (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r))) k) (dot l' h) = dot (dot l' (rel M M (refinement_of_nat M RI i) (dot (dot j s) (dot z r)))) (dot k h)) as r2 by (apply dot_aklh).
        rewrite r1.
        rewrite r2.
        apply mov_monotonic; trivial.
        rewrite <- dot_aklh2. trivial.
      * destruct_ands.

        (*rewrite dot_jszr in jszr.
        rewrite dot_jszr2.*)

        rewrite dot_jszr in H2.
        rewrite dot_jszr in H3.

        rewrite dot_jszr2.

        assert (m_valid (dot (dot r s) (dot j z))) as m_valid_srjz
         by (apply (rel_valid_left M M (refinement_of_nat M RI i) (dot (dot r s) (dot j z)) ); trivial).
        assert (mov (dot (dot r s) (dot j z)) (dot (dot r' s') (dot j z))) as mov_rsjz
          by (apply mov_monotonic; trivial).

        have movr := mov_refines M M (refinement_of_nat M RI i)
            (dot (dot r s) (dot j z)) (dot (dot r' s') (dot j z))  mov_rsjz H2.
        deex. destruct_ands.

        unfold in_refinement_domain.
        trivial.
Qed.

Lemma m_valid_ca a b c
: m_valid (dot (dot a b) c) -> m_valid (dot c a).
Proof.
  intro. apply valid_monotonic with (y := b).
  rewrite dot_kjha in H. trivial.
Qed.

Lemma m_valid_bd (a b c d : M)
: m_valid (dot (dot a b) (dot c d)) -> m_valid (dot b d).
Proof.
  intro. apply valid_monotonic with (y := dot a c).
  rewrite dot_aklh. replace (dot d c) with (dot c d) by (apply tpcm_comm). trivial. Qed.

Lemma m_valid_db (a b c d : M)
: m_valid (dot (dot a b) (dot c d)) -> m_valid (dot d b).
Proof.
  intro. apply valid_monotonic with (y := dot a c).
  rewrite <- dot_aklh.
  replace (dot b a) with (dot a b) by (apply tpcm_comm).
  replace (dot d c) with (dot c d) by (apply tpcm_comm). trivial.
Qed.

Lemma rec_m_valid_branch
  (t t' : Branch M)
  (active : Lifetime)
  (branch : Branch M) p i
  (down up : PathLoc -> M)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (branch_is : branch ≡ branch_of_pl t (p, i))
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i))))
  (batird : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch active i)
  : m_valid (dot
                  (branch_total (refinement_of_nat M RI) (branch_of_pl t (p, S i)) active
                     (S i)) (down (p, S i))).
Proof.
  setoid_rewrite branch_is in amval.
  setoid_rewrite branchcons_pl in amval.
  rewrite branch_total_unfold in amval.
  have fl := flow_update p i.
  unfold specific_flow_cond in fl.
  unfold specific_exchange_cond in fl. deex.

  setoid_rewrite branch_is in batird.
  setoid_rewrite branchcons_pl in batird.
  rewrite branch_all_total_in_refinement_domain_unfold in batird.
  destruct_ands. clear H0. rename H into natird.
  setoid_rewrite cellnode_pl in natird.
  rewrite node_all_total_in_refinement_domain_unfold in natird.
  destruct_ands. rename H into Y. clear H0.
  unfold in_refinement_domain in Y.
  assert ((node_total (refinement_of_nat M RI)
             (CellNode (cell_of_pl t (p, i)) (branch_of_pl t (p ++ [i], 0))) active)
             = node_total (refinement_of_nat M RI) (node_of_pl t (p, i)) active).
   - setoid_rewrite cellnode_pl. trivial.
   - rewrite H in Y.
     rewrite <- node_live_plus_node_total_minus_live in Y.

     rewrite <- node_live_plus_node_total_minus_live in amval.
     unfold project in amval.

     full_generalize (rel M M (refinement_of_nat M RI i)
          (dot (node_live (node_of_pl t (p, i)))
             (node_total_minus_live (refinement_of_nat M RI) (node_of_pl t (p, i)) active))) as x.
     + have fl' := fl Y (m_valid_ca _ _ _ amval).
       destruct_ands.
       rewrite H1 in amval.
       have am := m_valid_bd _ _ _ _ amval.
       trivial.
Qed.

Lemma rec_m_valid_node
  (t t' : Branch M)
  (active : Lifetime)
  (branch : Branch M) p i
  (down up : PathLoc -> M)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (branch_is : branch ≡ branch_of_pl t (p, i))
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i))))
  (batird : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch active i)
      : m_valid
             (dot
                (branch_total (refinement_of_nat M RI) (branch_of_node (node_of_pl t (p, i)))
                   active 0) (down (p ++ [i], 0))).
Proof.
  (*setoid_rewrite branch_is in amval.
  setoid_rewrite branchcons_pl in amval.
  rewrite branch_total_unfold in amval.
  setoid_rewrite cellnode_pl in amval.
  rewrite node_total_unfold in amval.*)

  setoid_rewrite branch_is in amval.
  setoid_rewrite branchcons_pl in amval.
  rewrite branch_total_unfold in amval.
  have fl := flow_update p i.
  unfold specific_flow_cond in fl.
  unfold specific_exchange_cond in fl. deex.

  setoid_rewrite branch_is in batird.
  setoid_rewrite branchcons_pl in batird.
  rewrite branch_all_total_in_refinement_domain_unfold in batird.
  destruct_ands. clear H0. rename H into natird.
  setoid_rewrite cellnode_pl in natird.
  rewrite node_all_total_in_refinement_domain_unfold in natird.
  destruct_ands. rename H into Y. clear H0.
  unfold in_refinement_domain in Y.
  assert ((node_total (refinement_of_nat M RI)
             (CellNode (cell_of_pl t (p, i)) (branch_of_pl t (p ++ [i], 0))) active)
             = node_total (refinement_of_nat M RI) (node_of_pl t (p, i)) active).
   - setoid_rewrite cellnode_pl. trivial.
   - rewrite H in Y.
     rewrite <- node_live_plus_node_total_minus_live in Y.

     rewrite <- node_live_plus_node_total_minus_live in amval.
     unfold project in amval.

     full_generalize (rel M M (refinement_of_nat M RI i)
          (dot (node_live (node_of_pl t (p, i)))
             (node_total_minus_live (refinement_of_nat M RI) (node_of_pl t (p, i)) active))) as x.
     + have fl' := fl Y (m_valid_ca _ _ _ amval).
       destruct_ands.
       (*destruct (rel M M (refinement_of_nat M RI i)
           (dot (dot j (down (p ++ [i], 0)))
              (node_total_minus_live (refinement_of_nat M RI) (node_of_pl t (p, i)) active))) eqn:de.*)
       * have rvl := rel_valid_left M M (refinement_of_nat M RI i) ((dot (dot j (down (p ++ [i], 0))) (node_total_minus_live (refinement_of_nat M RI) (node_of_pl t (p, i)) active))) H3.
         setoid_rewrite cellnode_pl in rvl.
         unfold node_total_minus_live in rvl.
         have q := m_valid_db _ _ _ _ rvl .
         setoid_rewrite branch_of_node_node_of_pl.
         trivial.
Qed.

Lemma dot_cba a b c
  : (dot (dot a b) c) = (dot (dot c b) a).
Proof.
  rewrite dot_kjha. rewrite <- tpcm_assoc. rewrite <- tpcm_assoc. f_equal.
  apply tpcm_comm. Qed.

Lemma listset_max_fn (se : gset PathLoc) (fn: PathLoc -> nat)
  : ∃ lmax , ∀ pl , pl ∈ se -> fn pl ≤ lmax.
Proof. exists (set_fold (λ r k, k `max` fn r) 1 se).
  intros.
  replace (se) with ((se ∖ {[ pl ]}) ∪ {[ pl ]}).
  - rewrite set_fold_add_1_element.
    + lia.
    + set_solver.
    + intros. lia.
  - apply set_eq. intros. rewrite elem_of_union.
    rewrite elem_of_difference. rewrite elem_of_singleton. intuition.
    + subst. trivial.
    + have h : Decision (x = pl) by solve_decision. destruct h; intuition.
Qed.

Lemma listset_max_len (se : gset PathLoc)
  : ∃ lmax , ∀ p i , (p, i) ∈ se -> length p ≤ lmax.
Proof. have h := listset_max_fn se (λ pl , match pl with (p, i) => length p end).
  deex. exists lmax. intros. have q := h (p, i). apply q. trivial.
Qed.

Lemma listset_max_i (se : gset PathLoc)
  : ∃ imax , ∀ p i , (p, i) ∈ se -> i ≤ imax.
Proof. have h := listset_max_fn se (λ pl , match pl with (p, i) => i end).
  deex. exists lmax. intros. have q := h (p, i). apply q. trivial.
Qed.

Lemma batird_BranchNil active idx:
  branch_all_total_in_refinement_domain (refinement_of_nat M RI) BranchNil active idx.
Proof. unfold branch_all_total_in_refinement_domain. trivial. Qed.

Lemma branch_total_is_unit active i
 : branch_total (refinement_of_nat M RI) BranchNil active i = unit.
Proof. unfold branch_total. trivial. Qed.

Lemma resolve_trivial branch branch' active i
  (bt : branch_trivial branch)
  (bt' : branch_trivial branch')
  : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch' active i
  ∧ mov (dot (branch_total (refinement_of_nat M RI) branch active i) unit)
      (dot (branch_total (refinement_of_nat M RI) branch' active i) unit).
Proof.
  assert (branch ≡ BranchNil) as bn
   by (apply branch_equiv_of_trivial; trivial; unfold branch_trivial; trivial).
  assert (branch' ≡ BranchNil) as bn'
   by (apply branch_equiv_of_trivial; trivial; unfold branch_trivial; trivial).
  split.
  - setoid_rewrite bn'.
    apply batird_BranchNil.
  - setoid_rewrite bn.
    setoid_rewrite bn'.
    rewrite branch_total_is_unit.
    apply reflex.
Qed.

Lemma do_trivial_movs (m h s m' h' s': M) i
  (mov1 : mov h h')
  (mov2 : mov s s')
  (is_valid_m: m_valid m)
  (fl : specific_exchange_cond (refinement_of_nat M RI i) unit m unit h s m' unit h' s')
  : mov m m'.
Proof.
  have t : mov (dot (dot (project (refinement_of_nat M RI) i (dot (dot unit unit) unit)) unit) m) (dot (dot (project (refinement_of_nat M RI) i (dot (dot unit unit) unit)) unit) m').
  - apply all_the_movs with (h := h) (s := s) (h' := h') (s' := s').
    + rewrite unit_dot_left. rewrite unit_dot_left. trivial.
    + rewrite unit_dot_left. rewrite unit_dot_left. trivial.
    + rewrite unit_dot_left. rewrite unit_dot_left.
        unfold in_refinement_domain. apply rel_defined_unit.
    + rewrite unit_dot_left. trivial.
    + repeat (rewrite unit_dot_left).
      repeat (rewrite unit_dot).
      unfold project. rewrite rel_unit.
      repeat (rewrite unit_dot).
      trivial.
  - unfold project in t.
    repeat (rewrite unit_dot_left in t).
    repeat (rewrite unit_dot in t).
    rewrite rel_unit in t.
    repeat (rewrite unit_dot_left in t).
    trivial.
Qed.

Lemma specexc_branch_tt_ind (t t': Branch M) (active: Lifetime) (se: gset PathLoc) : ∀ len_add i_add p i
  branch branch'
  (indl: ∀ p0 i0 , (p0, i0) ∈ se -> length p0 < len_add + length p)
  (indi: ∀ p0 i0 , (p0, i0) ∈ se -> i0 < i_add + i)
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (branch_is : branch ≡ branch_of_pl t (p, i))
  (branch'_is : branch' ≡ branch_of_pl t' (p, i))
  (reserved_untouched : ∀ pl, cell_total_minus_live (cell_of_pl t pl) active = cell_total_minus_live (cell_of_pl t' pl) active)
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i))))
  (branch_is_trivial : branch_trivial branch)
  (branch'_is_trivial : branch_trivial branch')
  (batird : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch active i)
  ,
            branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch' active i
      /\ mov
        (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i)))
        (dot (branch_total (refinement_of_nat M RI) branch' active i) (up (p, i))).
  induction len_add as [len_add IHnLen] using lt_wf_ind.
  induction i_add as [i_add IHnI] using lt_wf_ind.
Proof.
  intros.
  destruct len_add.
  - assert ((p, i) ∉ se).
    + intro. have indl_a := indl p i H. lia.
    + have d := flow_se p i H. destruct_ands. rewrite H0. rewrite H1.
        apply resolve_trivial; trivial.
  - destruct i_add.
    + assert ((p, i) ∉ se).
      * intro. have indi_a := indi p i H. lia.
      * have d := flow_se p i H. destruct_ands. rewrite H0. rewrite H1.
          apply resolve_trivial; trivial.
    +
      assert (len_add < S len_add) as len_add_lt_S by lia.
      assert (∀ (p0 : list nat) (i0 : nat),
           (p0, i0) ∈ se → length p0 < len_add + length (p ++ [i])) as afl
        by  (intros; have indla := indl p0 i0 H; rewrite app_length; simpl; lia).
      assert ((∀ (p0 : list nat) (i0 : nat), (p0, i0) ∈ se → i0 < S i_add + i + 0)) as ifl
        by (intros; have india := indi p0 i0 H; lia).
      assert (BranchNil ≡ branch_of_pl t (p ++ [i], 0)) as branch_nil_n_child
        by (apply branch_nil_of_n_child; setoid_rewrite branch_is in branch_is_trivial;
            trivial).
      assert (BranchNil ≡ branch_of_pl t' (p ++ [i], 0)) as branch_nil_n_child'
        by (apply branch_nil_of_n_child; setoid_rewrite branch'_is in branch'_is_trivial;
            trivial).

      assert (BranchNil ≡ branch_of_pl t (p, S i)) as branch_nil_b_child
        by (apply branch_nil_of_b_child; setoid_rewrite branch_is in branch_is_trivial;
            trivial).
      assert (BranchNil ≡ branch_of_pl t' (p, S i)) as branch_nil_b_child'
        by (apply branch_nil_of_b_child; setoid_rewrite branch'_is in branch'_is_trivial;
            trivial).

      have mval_b := rec_m_valid_branch t t' active branch p i down up flow_update branch_is
    amval batird.
      setoid_rewrite <- branch_nil_b_child in mval_b.

      have mval_n := rec_m_valid_node t t' active branch p i down up flow_update branch_is
    amval batird.
      setoid_rewrite branch_of_node_node_of_pl in mval_n.
      setoid_rewrite <- branch_nil_n_child in mval_n.

      assert (branch_trivial BranchNil) as bt_bn by (unfold branch_trivial; trivial).

      have Ih1 := IHnLen len_add len_add_lt_S (S i_add + i) (p ++ [i]) 0
          BranchNil BranchNil afl ifl down up flow_se flow_update branch_nil_n_child
          branch_nil_n_child' reserved_untouched mval_n bt_bn bt_bn
          (batird_BranchNil active 0).

      assert (i_add < S i_add) as i_add_lt_S by lia.

      assert (∀ (p0 : list nat) (i0 : nat), (p0, i0) ∈ se → length p0 < S len_add + length p)
          as merf by (intros; have q := indl p0 i0 H; lia).

      assert (∀ (p0 : list nat) (i0 : nat), (p0, i0) ∈ se → i0 < i_add + S i)
          as gerf by (intros; have q := indi p0 i0 H; lia).

      have Ih2 := IHnI i_add i_add_lt_S p (S i) BranchNil BranchNil merf gerf
          down up flow_se flow_update branch_nil_b_child
          branch_nil_b_child' reserved_untouched mval_b bt_bn bt_bn
          (batird_BranchNil active (S i)).

      clear IHnLen. clear IHnI.
      destruct_ands. rename H0 into mov1. rename H2 into mov2.

      assert (branch ≡ BranchNil) as b_bn by (apply branch_equiv_of_trivial; trivial).
      assert (branch' ≡ BranchNil) as b'_bn by (apply branch_equiv_of_trivial; trivial).

      split.
      * setoid_rewrite b'_bn. apply batird_BranchNil.
      * setoid_rewrite b'_bn. setoid_rewrite b_bn.
        rewrite branch_total_is_unit.
        rewrite branch_total_is_unit in mov1.
        rewrite branch_total_is_unit in mov2.
        setoid_rewrite b_bn in amval.
        rewrite branch_total_is_unit in amval.
        rewrite unit_dot_left.
        rewrite unit_dot_left.
        rewrite unit_dot_left in mov1.
        rewrite unit_dot_left in mov1.
        rewrite unit_dot_left in mov2.
        rewrite unit_dot_left in mov2.
        have fl := flow_update p i.
        unfold specific_flow_cond in fl.

        assert (node_of_pl t (p, i) ≡ triv_node) as is_triv_node
          by (apply node_triv_of_triv_branch; setoid_rewrite branch_is in branch_is_trivial;
              trivial).

        assert (node_of_pl t' (p, i) ≡ triv_node) as is_triv_node'
          by (apply node_triv_of_triv_branch; setoid_rewrite branch'_is in branch'_is_trivial;
              trivial).

        setoid_rewrite is_triv_node in fl.
        setoid_rewrite is_triv_node' in fl.
        rewrite node_total_minus_live_triv in fl.
        unfold node_live, triv_node, cell_live, triv_cell in fl.

        full_generalize (down (p, S i)) as h.
        full_generalize (up (p, S i)) as h'.
        full_generalize (down (p, i)) as m.
        full_generalize (up (p, i)) as m'.
        full_generalize ((down (p ++ [i], 0))) as s.
        full_generalize ((up(p ++ [i], 0))) as s'.
        apply do_trivial_movs with (h:=h) (s:=s) (h':=h') (s':=s') (i:=i); trivial.
        rewrite unit_dot_left in amval. trivial.
Qed.

Lemma specexc_branch_tt (t t': Branch M) (active: Lifetime) (se: gset PathLoc) p i
  branch branch'
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (branch_is : branch ≡ branch_of_pl t (p, i))
  (branch'_is : branch' ≡ branch_of_pl t' (p, i))
  (reserved_untouched : ∀ pl, cell_total_minus_live (cell_of_pl t pl) active = cell_total_minus_live (cell_of_pl t' pl) active)
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i))))
  (branch_is_trivial : branch_trivial branch)
  (branch'_is_trivial : branch_trivial branch')
  (batird : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch active i)
          : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch' active i
      /\ mov
        (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i)))
        (dot (branch_total (refinement_of_nat M RI) branch' active i) (up (p, i))).
Proof.
  have lmax_h := listset_max_len se.
  have imax_h := listset_max_i se. deex.
  assert ( ∀ (p0 : list nat) (i0 : nat), (p0, i0) ∈ se → length p0 < (lmax+1) + length p).
   - intros. have g := lmax_h p0 i0 H. lia.
   - assert (∀ (p0 : list nat) (i0 : nat), (p0, i0) ∈ se → i0 < imax + 1 + i).
    + intros. have g := imax_h p0 i0 H0. lia.
    + eapply (specexc_branch_tt_ind t t' active se (lmax+1) (imax+1) p i branch branch' H H0 down up flow_se flow_update branch_is
      branch'_is reserved_untouched amval branch_is_trivial branch'_is_trivial batird).
Qed.

Lemma specexc_branch_t (t t': Branch M) (active: Lifetime) (branch branch': Branch M) (se: gset PathLoc) p i
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (branch_is : branch ≡ branch_of_pl t (p, i))
  (branch'_is : branch' ≡ branch_of_pl t' (p, i))
  (reserved_untouched : ∀ pl, cell_total_minus_live (cell_of_pl t pl) active = cell_total_minus_live (cell_of_pl t' pl) active)
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i))))
  (branch'_is_trivial : branch_trivial branch')
  (batird : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch active i)
          : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch' active i
      /\ mov
        (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i)))
        (dot (branch_total (refinement_of_nat M RI) branch' active i) (up (p, i)))
with specexc_node_t (t t': Branch M) (active: Lifetime) (node node': Node M) (se: gset PathLoc) p i
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (node_is : node ≡ node_of_pl t (p, i))
  (node'_is : node' ≡ node_of_pl t' (p, i))
  (reserved_untouched : ∀ pl, cell_total_minus_live (cell_of_pl t pl) active = cell_total_minus_live (cell_of_pl t' pl) active)
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) (branch_of_node node) active 0) (down (p++[i], 0))))
  (node'_is_trivial : node_trivial node')
  (batird : node_all_total_in_refinement_domain (refinement_of_nat M RI) node active i)
          : branch_all_total_in_refinement_domain (refinement_of_nat M RI) (branch_of_node node') active 0
      /\ mov
        (dot (branch_total (refinement_of_nat M RI) (branch_of_node node) active 0) (down (p++[i], 0)))
        (dot (branch_total (refinement_of_nat M RI) (branch_of_node node') active 0) (up (p++[i], 0))).
Proof.
 -
  have mval_b := rec_m_valid_branch t t' active branch p i down up flow_update branch_is
    amval batird.

  have mval_n := rec_m_valid_node t t' active branch p i down up flow_update branch_is
    amval batird.

   destruct branch.
   + have branch_destruct := branchcons_pl t p i.
     have triv_equiv : (branch_of_pl t' (p, S i) ≡ branch_of_pl t' (p, S i)) by trivial.
     have triv_equiv2 : (node_of_pl t' (p, i) ≡ node_of_pl t' (p, i)) by trivial.
     have b_equiv : branch ≡ branch_of_pl t (p, S i)
        by (apply branchcons_pl_inv_b with (n0 := n); symmetry; trivial).
     have n_equiv : n ≡ node_of_pl t (p, i)
        by (apply branchcons_pl_inv_n with (b := branch); symmetry; trivial).

     setoid_rewrite branch'_is in branch'_is_trivial.
     assert (branch_trivial (branch_of_pl t' (p, S i))) as rec_bt by
      (apply rec_branch_branch_triv; trivial).
     assert (node_trivial (node_of_pl t' (p, i))) as rec_nt by
      (apply rec_branch_node_triv; trivial).

     setoid_rewrite <- b_equiv in mval_b.
     have IHbranch := specexc_branch_t t t' active branch (branch_of_pl t' (p, S i)) se p (S i)
                          down up flow_se flow_update b_equiv triv_equiv reserved_untouched mval_b rec_bt.
     clear specexc_branch_t.
     setoid_rewrite <- n_equiv in mval_n.
     have IHnode := specexc_node_t t t' active n (node_of_pl t' (p, i)) se p i
                          down up flow_se flow_update n_equiv triv_equiv2 reserved_untouched mval_n rec_nt.
     clear specexc_node_t.

     setoid_rewrite branch_is in batird.
     setoid_rewrite branch_destruct in batird.
     rewrite branch_all_total_in_refinement_domain_unfold in batird.
     destruct_ands.
     rename H into natird.
     rename H0 into batird.
     setoid_rewrite <- n_equiv in natird.
     setoid_rewrite <- b_equiv in batird.

     have IHbranch' := IHbranch batird. clear IHbranch.
     have IHnode' := IHnode natird. clear IHnode.
        destruct_ands. rename H1 into Q1. rename H2 into Q2.
        rename H into Q3. rename H0 into Q4.

     setoid_rewrite branch_is. setoid_rewrite branch_destruct.
     rewrite branch_total_unfold.
     have myflow := flow_update p i.
     unfold specific_flow_cond in myflow.
     setoid_rewrite cellnode_pl.
     setoid_rewrite cellnode_pl in myflow.
     unfold node_total_minus_live in myflow.

     unfold node_live in myflow.
     setoid_rewrite branchcons_pl in Q1.
     (*setoid_rewrite branchcons_pl in Q2.*)
     setoid_rewrite b_equiv in Q2.

     setoid_rewrite n_equiv in natird.
     setoid_rewrite cellnode_pl in natird.
     rewrite node_all_total_in_refinement_domain_unfold in natird.
     rewrite node_total_unfold in natird.
     rewrite cell_total_split in natird.
     destruct_ands. rename H into ird.

     assert ((cell_total_minus_live (cell_of_pl t (p, i)) active)
            = (cell_total_minus_live (cell_of_pl t' (p, i)) active)) as ctml_pres
            by (apply reserved_untouched).

     setoid_rewrite branch_is in amval.
     setoid_rewrite branchcons_pl in amval.
     rewrite branch_total_unfold in amval.
     setoid_rewrite cellnode_pl in amval.
     rewrite node_total_unfold in amval.
     rewrite cell_total_split in amval.
     rewrite ctml_pres in amval.

     setoid_rewrite branch_of_node_node_of_pl in Q4.
     setoid_rewrite n_equiv in Q4.
     setoid_rewrite branch_of_node_node_of_pl in Q4.

     rewrite ctml_pres in myflow.
     rewrite ctml_pres in ird.
     rewrite <- tpcm_assoc in ird.

     (*rewrite (branch_total_unfold (refinement_of_nat M RI) (BranchCons n' branch')).*)

     split.

        * setoid_rewrite branch'_is.
          setoid_rewrite branchcons_pl.
          rewrite branch_all_total_in_refinement_domain_unfold.

          split.

          -- setoid_rewrite cellnode_pl.
             rewrite node_all_total_in_refinement_domain_unfold.
             rewrite node_total_unfold.
             split.

            (* ++ setoid_rewrite cellnode_pl in Q3.
              rewrite branch_all_total_in_refinement_domain_unfold in Q3.
              unfold branch_of_node in Q3.
              destruct (branch_of_pl t' (p ++ [i], 0)) eqn:ye.
              ** destruct Q3.
                 rewrite ye in H.*)

           ++ rewrite cell_total_split.

        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t (p, S i)) active (S i))
          as k.
        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p, S i)) active (S i))
          as k'.
        full_generalize (cell_live (cell_of_pl t (p, i))) as f.
        full_generalize (cell_live (cell_of_pl t' (p, i))) as f'.
        (*full_generalize (cell_total_minus_live (cell_of_pl t (p, i)) active) as z.*)
        full_generalize (cell_total_minus_live (cell_of_pl t' (p, i)) active) as z.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t (p ++ [i], 0)) active 0) as r.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p ++ [i], 0)) active 0) as r'.
        full_generalize (down (p, S i)) as h.
        full_generalize (up (p, S i)) as h'.
        full_generalize (down (p, i)) as m.
        full_generalize (up (p, i)) as m'.
        full_generalize ((down (p ++ [i], 0))) as s.
        full_generalize ((up(p ++ [i], 0))) as s'.

        apply all_the_movs_ird
          with (m:=m) (f:=f) (h:=h) (s:=s) (r:=r) (k:=k) (m':=m') (h':=h') (s':=s') (k':=k');
          trivial.
          ** rewrite dot_cba. trivial.

        ++ setoid_rewrite cellnode_pl in Q3. unfold branch_of_node in Q3. trivial.
      -- setoid_rewrite <- branchcons_pl in Q1. trivial.

        *
        (*
        (*setoid_rewrite n_equiv.*)
        rewrite branch_total_unfold.
        (*setoid_rewrite b_equiv.*)
        rewrite cell_total_split.
        (*rewrite cell_total_split.*)
        *)

        setoid_rewrite branch'_is.
        rewrite node_total_unfold.
        setoid_rewrite (branchcons_pl t' p i).
        rewrite (branch_total_unfold _ (BranchCons (node_of_pl t' (p, i)) (branch_of_pl t' (p, S i)))).
        setoid_rewrite (cellnode_pl t' p i).
        rewrite node_total_unfold.
        rewrite cell_total_split.
        rewrite cell_total_split.

        rewrite ctml_pres.

        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t (p, S i)) active (S i))
          as k.
        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p, S i)) active (S i))
          as k'.
        full_generalize (cell_live (cell_of_pl t (p, i))) as f.
        full_generalize (cell_live (cell_of_pl t' (p, i))) as f'.
        (*full_generalize (cell_total_minus_live (cell_of_pl t (p, i)) active) as z.*)
        full_generalize (cell_total_minus_live (cell_of_pl t' (p, i)) active) as z.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t (p ++ [i], 0)) active 0) as r.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p ++ [i], 0)) active 0) as r'.
        full_generalize (down (p, S i)) as h.
        full_generalize (up (p, S i)) as h'.
        full_generalize (down (p, i)) as m.
        full_generalize (up (p, i)) as m'.
        full_generalize ((down (p ++ [i], 0))) as s.
        full_generalize ((up(p ++ [i], 0))) as s'.

        apply all_the_movs with (h := h) (s := s) (h' := h') (s' := s'); trivial.
        rewrite dot_cba. trivial.
      + eapply specexc_branch_tt with (t := t) (t' := t') (se:=se); trivial.
 - clear specexc_node_t.
  assert (branch_trivial (branch_of_pl t' (p ++ [i], 0))) as rec_bt
   by (apply rec_node_branch_triv; setoid_rewrite <- node'_is; trivial).
  destruct node, node'. rename b into branch. rename b0 into branch'.
  assert (branch ≡ branch_of_pl t (p ++ [i], 0)) as branch1_equiv
      by (apply cellnode_pl_inv_b with (c1 := c); symmetry; trivial).
  assert (branch' ≡ branch_of_pl t' (p ++ [i], 0)) as branch2_equiv
      by (apply cellnode_pl_inv_b with (c1 := c0); symmetry; trivial).
  unfold branch_of_node in amval.
  rewrite node_all_total_in_refinement_domain_unfold in batird.
  destruct_ands. rename H into ird. rename H0 into batird.
  setoid_rewrite <- branch2_equiv in rec_bt.
  have Ihb := specexc_branch_t t t' active branch branch' se (p++[i]) 0 down up flow_se flow_update
      branch1_equiv branch2_equiv reserved_untouched amval rec_bt batird.
  destruct_ands.
  repeat split; trivial.
Qed.

Lemma specexc_branch (t t': Branch M) (active: Lifetime) (branch branch': Branch M) (se: gset PathLoc) p i
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (branch_is : branch ≡ branch_of_pl t (p, i))
  (branch'_is : branch' ≡ branch_of_pl t' (p, i))
  (reserved_untouched : ∀ pl, cell_total_minus_live (cell_of_pl t pl) active = cell_total_minus_live (cell_of_pl t' pl) active)
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i))))
  (batird : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch active i)
          : branch_all_total_in_refinement_domain (refinement_of_nat M RI) branch' active i
      /\ mov
        (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i)))
        (dot (branch_total (refinement_of_nat M RI) branch' active i) (up (p, i)))
with specexc_node (t t': Branch M) (active: Lifetime) (node node': Node M) (se: gset PathLoc) p i
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (node_is : node ≡ node_of_pl t (p, i))
  (node'_is : node' ≡ node_of_pl t' (p, i))
  (reserved_untouched : ∀ pl, cell_total_minus_live (cell_of_pl t pl) active = cell_total_minus_live (cell_of_pl t' pl) active)
  (amval : m_valid (dot (branch_total (refinement_of_nat M RI) (branch_of_node node) active 0) (down (p++[i], 0))))
  (batird : node_all_total_in_refinement_domain (refinement_of_nat M RI) node active i)
          : branch_all_total_in_refinement_domain (refinement_of_nat M RI) (branch_of_node node') active 0
      /\ mov
        (dot (branch_total (refinement_of_nat M RI) (branch_of_node node) active 0) (down (p++[i], 0)))
        (dot (branch_total (refinement_of_nat M RI) (branch_of_node node') active 0) (up (p++[i], 0))).
Proof.
 - destruct branch'.
   + rename n into n'.
     have branch_destruct := branchcons_pl t p i.
     have triv_equiv : (branch_of_pl t (p, S i) ≡ branch_of_pl t (p, S i)) by trivial.
     have triv_equiv2 : (node_of_pl t (p, i) ≡ node_of_pl t (p, i)) by trivial.
     have b_equiv : branch' ≡ branch_of_pl t' (p, S i)
        by (apply branchcons_pl_inv_b with (n := n'); symmetry; trivial).
     have n_equiv : n' ≡ node_of_pl t' (p, i)
        by (apply branchcons_pl_inv_n with (b := branch'); symmetry; trivial).

     have mval_b := rec_m_valid_branch t t' active branch p i down up flow_update branch_is
        amval batird.

     have mval_n := rec_m_valid_node t t' active branch p i down up flow_update branch_is
        amval batird.

     have IHbranch := specexc_branch t t' active (branch_of_pl t (p, S i)) branch' se p (S i)
                          down up flow_se flow_update triv_equiv b_equiv reserved_untouched mval_b.
     clear specexc_branch.
     have IHnode := specexc_node t t' active (node_of_pl t (p, i)) n' se p i
                          down up flow_se flow_update triv_equiv2 n_equiv reserved_untouched mval_n.
     clear specexc_node.

     setoid_rewrite branch_is in batird.
     setoid_rewrite branch_destruct in batird.
     rewrite branch_all_total_in_refinement_domain_unfold in batird.
     destruct_ands.
     rename H into natird.
     rename H0 into batird.

     have IHbranch' := IHbranch batird. clear IHbranch.
     have IHnode' := IHnode natird. clear IHnode.
        destruct_ands. rename H1 into Q1. rename H2 into Q2.
        rename H into Q3. rename H0 into Q4.

       rewrite branch_all_total_in_refinement_domain_unfold.

       enough (
  (node_all_total_in_refinement_domain (refinement_of_nat M RI) n' active i)
  ∧ mov (dot (branch_total (refinement_of_nat M RI) branch active i) (down (p, i)))
      (dot (branch_total (refinement_of_nat M RI) (BranchCons n' branch') active i)
         (up (p, i))))
       by (destruct_ands; repeat split; trivial).

       setoid_rewrite branch_is. setoid_rewrite branch_destruct.
        rewrite branch_total_unfold.
        have myflow := flow_update p i.
        unfold specific_flow_cond in myflow.
        setoid_rewrite cellnode_pl.
        setoid_rewrite cellnode_pl in myflow.
        unfold node_total_minus_live in myflow.
        rewrite (branch_total_unfold (refinement_of_nat M RI) (BranchCons n' branch')).

        (*assert (node_all_total_in_refinement_domain (refinement_of_nat M RI) (node_of_pl t' (p, i)) active i <->
             node_all_total_in_refinement_domain (refinement_of_nat M RI) n' active i) by (split; setoid_rewrite n_equiv; trivial).
        rewrite <- H.*)

        unfold node_live in myflow.
        setoid_rewrite b_equiv in Q1.
        setoid_rewrite b_equiv in Q2.

        setoid_rewrite cellnode_pl in natird.
        rewrite node_all_total_in_refinement_domain_unfold in natird.
        rewrite node_total_unfold in natird.
        rewrite cell_total_split in natird.
        destruct_ands. rename H into ird.

        assert ((cell_total_minus_live (cell_of_pl t (p, i)) active)
            = (cell_total_minus_live (cell_of_pl t' (p, i)) active)) as ctml_pres
            by (apply reserved_untouched).

        setoid_rewrite branch_is in amval.
        setoid_rewrite branchcons_pl in amval.
        rewrite branch_total_unfold in amval.
        setoid_rewrite cellnode_pl in amval.
        rewrite node_total_unfold in amval.
        rewrite cell_total_split in amval.
        rewrite ctml_pres in amval.

        setoid_rewrite branch_of_node_node_of_pl in Q4.
        setoid_rewrite n_equiv in Q4.
        setoid_rewrite branch_of_node_node_of_pl in Q4.

        rewrite ctml_pres in myflow.
        rewrite ctml_pres in ird.
        rewrite <- tpcm_assoc in ird.

        split.

        * setoid_rewrite n_equiv.
          setoid_rewrite cellnode_pl.
          rewrite node_all_total_in_refinement_domain_unfold.
          rewrite node_total_unfold.
          split; trivial.
          -- rewrite cell_total_split.

        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t (p, S i)) active (S i))
          as k.
        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p, S i)) active (S i))
          as k'.
        full_generalize (cell_live (cell_of_pl t (p, i))) as f.
        full_generalize (cell_live (cell_of_pl t' (p, i))) as f'.
        (*full_generalize (cell_total_minus_live (cell_of_pl t (p, i)) active) as z.*)
        full_generalize (cell_total_minus_live (cell_of_pl t' (p, i)) active) as z.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t (p ++ [i], 0)) active 0) as r.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p ++ [i], 0)) active 0) as r'.
        full_generalize (down (p, S i)) as h.
        full_generalize (up (p, S i)) as h'.
        full_generalize (down (p, i)) as m.
        full_generalize (up (p, i)) as m'.
        full_generalize ((down (p ++ [i], 0))) as s.
        full_generalize ((up(p ++ [i], 0))) as s'.

        apply all_the_movs_ird
          with (m:=m) (f:=f) (h:=h) (s:=s) (r:=r) (k:=k) (m':=m') (h':=h') (s':=s') (k':=k');
          trivial.
          rewrite dot_cba. trivial.

          -- setoid_rewrite n_equiv in Q3.
             setoid_rewrite cellnode_pl in Q3. trivial.

        *
        setoid_rewrite n_equiv.
        rewrite node_total_unfold.
        setoid_rewrite (cellnode_pl t' p i).
        rewrite node_total_unfold.
        setoid_rewrite b_equiv.
        rewrite cell_total_split.
        rewrite cell_total_split.

        rewrite ctml_pres.

        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t (p, S i)) active (S i))
          as k.
        full_generalize
          (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p, S i)) active (S i))
          as k'.
        full_generalize (cell_live (cell_of_pl t (p, i))) as f.
        full_generalize (cell_live (cell_of_pl t' (p, i))) as f'.
        (*full_generalize (cell_total_minus_live (cell_of_pl t (p, i)) active) as z.*)
        full_generalize (cell_total_minus_live (cell_of_pl t' (p, i)) active) as z.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t (p ++ [i], 0)) active 0) as r.
        full_generalize (branch_total (refinement_of_nat M RI) (branch_of_pl t' (p ++ [i], 0)) active 0) as r'.
        full_generalize (down (p, S i)) as h.
        full_generalize (up (p, S i)) as h'.
        full_generalize (down (p, i)) as m.
        full_generalize (up (p, i)) as m'.
        full_generalize ((down (p ++ [i], 0))) as s.
        full_generalize ((up(p ++ [i], 0))) as s'.
        unfold specific_exchange_cond in myflow.

        apply all_the_movs with (h := h) (s := s) (h' := h') (s' := s'); trivial.
        rewrite dot_cba. trivial.
      + eapply specexc_branch_t with (t := t) (t' := t') (se := se); trivial.
        unfold branch_trivial. trivial.
 - clear specexc_node.
  destruct node, node'. rename b into branch. rename b0 into branch'.
  assert (branch ≡ branch_of_pl t (p ++ [i], 0)) as branch1_equiv
      by (apply cellnode_pl_inv_b with (c1 := c); symmetry; trivial).
  assert (branch' ≡ branch_of_pl t' (p ++ [i], 0)) as branch2_equiv
      by (apply cellnode_pl_inv_b with (c1 := c0); symmetry; trivial).
  unfold branch_of_node in amval.
  rewrite node_all_total_in_refinement_domain_unfold in batird.
  destruct_ands. rename H into ird. rename H0 into batird.
  have Ihb := specexc_branch t t' active branch branch' se (p++[i]) 0 down up flow_se flow_update
      branch1_equiv branch2_equiv reserved_untouched amval batird.
  destruct_ands.
  repeat split; trivial.
Qed.

Lemma valid_of_mov (x y : M) : m_valid x -> mov x y -> m_valid y.
Proof.
  intros.
  have h := mov_monotonic x y unit.
  have j := h EqDecision0 TPCM0 EqDecision0 TPCM0.
  rewrite unit_dot in j.
  rewrite unit_dot in j.
  have l := j H0 H. destruct_ands. trivial.
Qed.

Lemma specific_flows_preserve_branch_all_total_in_refinement_domain
  (t t': Branch M) (active: Lifetime)
  (se: gset PathLoc)
  (down up : PathLoc -> M)
  (flow_se : ∀ p i , (p, i) ∉ se -> up (p, i) = unit /\ down (p, i) = unit)
  (flow_update : ∀ p i , specific_flow_cond p i t t' active down up)
  (down_0 : down ([], 0) = unit)
  (up_0 : up ([], 0) = unit)
  (reserved_untouched : ∀ pl, cell_reserved (cell_of_pl t pl) ≡ cell_reserved (cell_of_pl t' pl))
  (vts : valid_totals (refinement_of_nat M RI) t active)
       : valid_totals (refinement_of_nat M RI) t' active.
Proof.
  unfold valid_totals in *. destruct_ands.
  assert ((∀ pl : PathLoc,
         cell_total_minus_live (cell_of_pl t pl) active =
         cell_total_minus_live (cell_of_pl t' pl) active)) as ru2.
  - intros. have ru := reserved_untouched pl.
        unfold cell_reserved in ru.
        unfold cell_total_minus_live.
        destruct (cell_of_pl t pl).
        destruct (cell_of_pl t' pl).
        setoid_rewrite ru.
        trivial.
  -
  assert (t ≡ branch_of_pl t ([], 0)) as tb0 by (rewrite <- branch_of_pl_zero; trivial).
  assert (t' ≡ branch_of_pl t' ([], 0)) as tb1 by (rewrite <- branch_of_pl_zero; trivial).
  have h := specexc_branch t t' active t t' se [] 0 down up flow_se flow_update
      tb0 tb1 ru2 _ _.
  rewrite down_0 in h.
  rewrite up_0 in h.
  rewrite unit_dot in h.
  rewrite unit_dot in h.
  have j := h H0 H.
  destruct_ands.
  split; trivial.
  apply valid_of_mov with (x := (branch_total (refinement_of_nat M RI) t active 0)); trivial.
Qed.

End ExchangeProof.


Require Import VerifiedVerifier.Machine.
Require Import VerifiedVerifier.Maps.
Require Import VerifiedVerifier.Safety.
Require Import Coq.Init.Nat.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Require Import VerifiedVerifier.BinaryLattice.
Require Import VerifiedVerifier.AbstractAnalysis.
Require Import VerifiedVerifier.Semantics.
Require Import Lia.

(* TODO: Don't really know how to encode this*)
(*
Definition function_safety (f : function_ty) :=
*)

Definition program_safety (p : program_ty) : Prop :=
  forall fuel,
    (fst (run_program_stream p fuel)).(error) = false.

(* NOTE: This probably isn't a useful definition *)
(*
Definition function_safety (p : program_ty) (f : function_ty) : Prop :=
  forall fuel s,
    s.(error) = false ->
    (run_function p f s fuel).(error) = false.
*)

Theorem program_maintains_error :
  forall s,
    s.(error) = true ->
    forall p cfg n fuel,
      (run_program' p cfg n s fuel).(error) = true.
Proof.
  intros. induction fuel.
  simpl. assumption.
  simpl. destruct (next_node cfg s n).
  - admit.
  - admit.
Admitted.

Theorem program_stream_maintains_error :
  forall p fuel,
    (fst (run_program_stream p fuel)).(error) = true ->
    (fst (run_program_stream p (S fuel))).(error) = true.
Proof.
  admit.
Admitted.

Definition function_safety (f : function_ty) : Prop :=
  forall f cfg p n s fuel,
    well_formed_program p ->
    s.(error) = false ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    (run_program' p cfg n s fuel).(error) = false.

Theorem well_formed_find_edge_ret :
  forall cfg n p f ,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    (last (fst n) Ret) = Ret ->
    forall b,
      find_edge cfg n b = None.
Proof.
  admit.
Admitted.

Theorem well_formed_find_edge_branch :
  forall cfg n p f c,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    (last (fst n) Ret) = Branch c ->
    exists n' n'',
      find_edge cfg n True_Branch = Some n' /\
      find_edge cfg n False_Branch = Some n'' /\
      find_edge cfg n Non_Branch = None.
Proof.
  admit.
Admitted.

(* TODO: Might have to change how the conditional is handled *)
Theorem well_formed_find_edge_non_branch :
  forall cfg n p f c,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
      (last (fst n) Ret) <> Ret ->
      (last (fst n) Ret) <> Branch c ->
      exists n',
        find_edge cfg n True_Branch = None /\
        find_edge cfg n False_Branch = None /\
        find_edge cfg n Non_Branch = Some n'.
Proof.
  admit.
Admitted.

Theorem verified_function_lookup :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel r hd_i,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Indirect_Call r ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

(* NOTE: shouldn't even need to run the verifier for this one, just well-formedness *)
Theorem verified_function_call :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i f_name,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Direct_Call f_name ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verified_heap_read :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i r_dst r_src r_base,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Heap_Read r_dst r_src r_base ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verified_heap_write :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i r_dst r_val r_base,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Heap_Write r_dst r_val r_base ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.
Proof.

Theorem verified_stack_contract :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i i,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Stack_Contract i ->
      (run_instr p hd_i.(instr) s).(error) = false.
  admit.
Admitted.

Theorem verified_stack_read :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i r i,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Stack_Read r i ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verified_stack_write :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    forall s istream fuel hd_i i r,
      (s, istream) = run_program_stream p fuel ->
      s.(error) = false ->
      Some hd_i = hd_error istream ->
      hd_i.(instr) = Stack_Write i r ->
      (run_instr p hd_i.(instr) s).(error) = false.
Proof.
  admit.
Admitted.

Theorem verify_get_instrs_till_terminal :
  forall cfg n fuel p f,
    well_formed_program p ->
    In f p.(fun_list) ->
    cfg = fst f ->
    In n cfg.(nodes) ->
    snd (get_instrs_till_terminal cfg n fuel) <> error_return.
Proof.
  intros. unfold get_instrs_till_terminal.
  induction fuel. unfold snd. discriminate.
  fold get_instrs_till_terminal. fold get_instrs_till_terminal in IHfuel.
  assert ((fst n) <> nil). unfold well_formed_program in H. destruct H. destruct H3. destruct H4. destruct H5.
  - specialize H6 with f. apply H6 in H0. unfold well_formed_fun in H0. unfold well_formed_cfg in H0.
    destruct H0. destruct H7. destruct H8. unfold non_empty_nodes in H8. specialize H8 with n. symmetry in H1.
    rewrite H1 in H8. apply H8. apply H2.
  - admit.
    (* case (last (fst n) Ret); intros. *)
Admitted.

Theorem verify_get_next_instrs :
  forall p cfg n i s fuel,
    well_formed_program p ->
    exists f,
      In f p.(fun_list) ->
      cfg = fst f ->
      In n cfg.(nodes) ->
      In i (fst n) ->
      verify_program p = true ->
      snd (get_next_instrs p cfg n i s fuel) <> error_return.
Proof.
  admit.
Admitted.

Theorem run_program_stream_equiv :
  forall p istream s fuel s' istream',
    well_formed_program p ->
    (s', istream') = run_program_stream' p istream s fuel ->
    fst (run_program_stream' p istream s (S fuel)) = fst (run_program_stream' p istream' s' 1).
Proof.
  admit.
Admitted.

Theorem function_safety_run :
  forall p s fuel,
    well_formed_program p ->
    verify_program p = true ->
    s = run_program_stream p fuel ->
    (fst s).(error) = false ->
    (fst (run_program_stream p (S fuel))).(error) = false.
Proof.
  intros. unfold run_program_stream.
  admit.
Admitted.

(* TODO: find official lemmas for these *)
Lemma distribute_fst {A : Type} {B : Type} :
  forall (c : bool) (x: A) (y : A) (a : B) (b : B),
    fst (if c then (x, a) else (y, b)) = if c then x else y.
Proof.
  intros. case c; auto.
Qed.

Lemma error_set_exit :
  forall s,
    s.(error) = (set_exit_state s).(error).
Proof.
  auto.
Qed.

Lemma distribute_error :
  forall (c : bool) s s',
    error (if c then s else s') = if c then (error s) else (error s').
Proof.
  intros. case c; auto.
Qed.

Lemma if_eq :
  forall (A : Type) (c : bool) (a : A),
    (if c then a else a) = a.
Proof.
  intros. case c; auto.
Qed.

Lemma tuple_eq :
  forall (x : (state * list instr_data)),
    (fst x, snd x) = x.
Proof.
  intros. destruct x. simpl. auto.
Qed.

(* TODO: Generalize these *)
Lemma tuple_eq' :
  forall (x y : (state * list instr_data)),
    x = y ->
    fst x = fst y /\ snd x = snd y.
Proof.
  intros.
  pose proof surjective_pairing as H1. specialize H1 with state (list instr_data) x.
  rewrite H1 in H. destruct y. inversion H. rewrite H2. rewrite H3.
  unfold fst. unfold snd. auto.
Qed.

Lemma tuple_split :
  forall (a : state) (b : list instr_data) (x : (state * list instr_data)),
    (a, b) = x ->
    a = fst x /\ b = snd x.
Proof.
  intros. destruct x. pose proof tuple_eq'.
  specialize H0 with (a, b) (s, l). apply H0 in H. inversion H.
  split; auto.
Qed.

Lemma tuple_ret_eq' :
  forall (x y : (list instr_data * return_state)),
    x = y ->
    fst x = fst y /\ snd x = snd y.
Proof.
  intros.
  pose proof surjective_pairing as H1. specialize H1 with (list instr_data) return_state x.
  rewrite H1 in H. destruct y. inversion H. rewrite H2. rewrite H3.
  unfold fst. unfold snd. auto.
Qed.

Lemma tuple_ret_split :
  forall (a : list instr_data) (b : return_state) (x : (list instr_data * return_state)),
    (a, b) = x ->
    a = fst x /\ b = snd x.
Proof.
  intros. destruct x. pose proof tuple_ret_eq'.
  specialize H0 with (a, b) (l, r). apply H0 in H. inversion H.
  split; auto.
Qed.

Lemma prog_stream_eq :
  forall p fuel start_stream,
    snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) = normal_return ->
    fst (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) = start_stream ->
    run_program_stream p fuel = run_program_stream' p start_stream (start_state p) fuel.
Proof.
  intros. unfold run_program_stream.
  remember (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) as g.
  destruct g. pose proof tuple_ret_split.
  specialize H1 with l r (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel).
  apply H1 in Heqg. inversion Heqg. simpl in H. simpl in H0. rewrite H. rewrite H0. reflexivity.
Qed.

Theorem function_safety_run_other :
  forall p s istream fuel start_stream s',
    well_formed_program p ->
    verify_program p = true ->
    (snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)) = normal_return ->
    start_stream = (fst (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)) ->
    (s, istream) = run_program_stream' p start_stream (start_state p) fuel ->
    s.(error) = false ->
    s' = fst (run_program_stream' p start_stream (start_state p) (S fuel)) ->
    s'.(error) = false.
Proof.
  intros. assert (Hwell := H).
  pose proof run_program_stream_equiv as Hequiv.
  specialize Hequiv with p start_stream (start_state p) fuel s istream.
  apply Hequiv in H.
  - rewrite H in H5. rewrite H5. induction istream.
    + unfold run_program_stream'.
      case (error s || exit s)%bool. assumption. assumption.
    + unfold run_program_stream'. case (error s || exit s)%bool. assumption.
      destruct (get_next_instrs p (cfg a) (node a) (instr a) s 1).
      destruct r. auto. admit.
      remember (run_instr p (instr a) s) as s''.

      assert ((fst (if (error s'' || exit s'')%bool
                        then (s'', l ++ istream)
                        else (set_exit_state s'', l ++ istream))) =
                  (if (error s'' || exit s'')%bool
                   then s''
                   else set_exit_state s'')) as Hdist.
      case (error s'' || exit s'')%bool; auto.

      rewrite Hdist.
      pose proof distribute_error as Herr.
      specialize Herr with (error s'' || exit s'')%bool s'' (set_exit_state s'').
      rewrite Herr.
      pose proof error_set_exit as Hexit. specialize Hexit with s''. symmetry in Hexit.
      rewrite Hexit.
      pose proof if_eq as Hif. specialize Hif with bool (error s'' || exit s'')%bool (error s'').
      rewrite Hif. rewrite Heqs''.
      remember (instr a) as instr_a.
      destruct instr_a; auto.
      * pose proof verified_heap_read as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a r r0 r1.
        assert (instr a = Heap_Read r r0 r1). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * pose proof verified_heap_write as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a r r0 r1.
        assert (instr a = Heap_Write r r0 r1). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * simpl. destruct (function_lookup p (get_register s r)); auto.
      * pose proof verified_stack_contract as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a n.
        assert (instr a = Stack_Contract n). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * pose proof verified_stack_read as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a r n.
        assert (instr a = Stack_Read r n). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
      * pose proof verified_stack_write as Hinstr.
        specialize Hinstr with p s (a :: istream) fuel a n r.
        assert (instr a = Stack_Write n r). symmetry in Heqinstr_a. assumption.
        rewrite H6 in Hinstr. apply Hinstr; auto. pose proof prog_stream_eq.
        specialize H7 with p fuel start_stream.
        symmetry in H7. rewrite H7 in H3. assumption. assumption. symmetry in H2. assumption.
  - assumption.
Admitted.

Theorem get_instrs_till_terminal_ret :
  forall cfg n fuel,
    snd (get_instrs_till_terminal cfg n fuel) = normal_return ->
    get_instrs_till_terminal cfg n fuel = get_instrs_till_terminal cfg n (S fuel).
Proof.
  admit.
Admitted.

Theorem verified_program :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    program_safety p.
Proof.
  intros. unfold program_safety. intros. unfold run_program_stream.
  pose proof verify_get_instrs_till_terminal as Hterminal.
  specialize Hterminal with (fst (main p)) (start_node (fst (main p))) fuel p (main p).
  assert (snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) <> error_return).
  apply Hterminal; auto.
  unfold well_formed_program in H. destruct H. destruct H1. destruct H2. destruct H3. assumption.
  unfold well_formed_program in H. destruct H. destruct H1. destruct H2. destruct H3.
  specialize H4 with (main p). apply H4 in H3. unfold well_formed_fun in H3.
  unfold well_formed_cfg in H3. destruct H3. destruct H5. destruct H6. assumption.

  destruct (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel) eqn:Htest.
  (*
  assert (l = fst (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)). admit.
  assert (r = snd (get_instrs_till_terminal (fst (main p)) (start_node (fst (main p))) fuel)). admit.
  *)
  (* TODO: I don't know why the context forgets this information *)
  unfold snd in H1. destruct r. auto. contradiction.
  induction fuel.
  simpl. reflexivity.
  pose proof function_safety_run_other as Hstream'.
  remember (run_program_stream' p l (start_state p) fuel) as s.
  remember (run_program_stream' p l (start_state p) (S fuel)) as s'.
  specialize Hstream' with p (fst (run_program_stream' p l (start_state p) fuel)) (snd s) fuel l (fst s').
  pose proof get_instrs_till_terminal_ret as Hget. (*assert (r = normal_return). admit.*)
  specialize Hget with (fst (main p)) (start_node (fst (main p))) fuel. symmetry in Hget.
  apply Hstream'; auto.
  - rewrite Hget. admit. admit.
  - rewrite Hget. admit. admit.
  - pose proof tuple_eq as Htup. specialize Htup with (run_program_stream' p l (start_state p) fuel).
    rewrite Heqs. rewrite Htup. auto.
  - admit.
  - pose proof tuple_eq' as Htup'. specialize Htup' with s' (run_program_stream' p l (start_state p) (S fuel)).
    apply Htup' in Heqs'. inversion Heqs'. assumption.
Admitted.

(* NOTE: old version *)
(*
Theorem verified_program :
  forall p,
    well_formed_program p ->
    verify_program p = true ->
    program_safety p.
Proof.
  intros. unfold program_safety. intros. unfold run_program.
  unfold run_program'. induction fuel.
  simpl. reflexivity. fold run_program'. fold run_program' in IHfuel.
  destruct (next_node (fst (main p)) (start_state p) (start_node (fst (main p)))).
  -
    + destruct (last (fst (start_node (fst (main p)))) Ret). unfold run_basic_block.
  -

  induction p.(fun_list).
  - unfold run_program'. induction fuel.
    + simpl. reflexivity.
    + destruct (next_node (fst (main p)) (start_state p) (start_node (fst (main p)))).
      *
*)


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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import LowerPromises.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.

Set Implicit Arguments.

Lemma read_step_cur_future
      lc1 mem1 loc val released ord lc2
      (WF1: Local.wf lc1 mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (READ: Local.read_step lc1 mem1 loc ((TView.cur (Local.tview lc1)).(View.rlx) loc) val released ord lc2):
  <<PROMISES: (Local.promises lc1) = (Local.promises lc2)>> /\
  <<TVIEW_RLX: (TView.cur (Local.tview lc1)).(View.rlx) = (TView.cur (Local.tview lc2)).(View.rlx)>> /\
  <<TVIEW_PLN: forall l (LOC: l <> loc),
      (TView.cur (Local.tview lc1)).(View.pln) l = (TView.cur (Local.tview lc2)).(View.pln) l>>.
Proof.
  destruct lc1 as [tview1 promises1]. inv READ. ss.
  esplits; eauto.
  - condtac; ss; try by destruct ord.
    apply TimeMap.antisym.
    + etrans; [|apply TimeMap.join_l]. apply TimeMap.join_l.
    + apply TimeMap.join_spec; auto using TimeMap.bot_spec.
      apply TimeMap.join_spec; try refl.
      unfold View.singleton_ur_if. condtac; ss.
      * ii. unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; try apply Time.bot_spec.
        subst. refl.
      * ii. unfold TimeMap.singleton, LocFun.add, LocFun.init, LocFun.find.
        condtac; try apply Time.bot_spec.
        subst. refl.
  - i. condtac; ss; try by destruct ord.
    unfold TimeMap.join, TimeMap.bot.
    rewrite TimeFacts.le_join_l; try apply Time.bot_spec.
    rewrite TimeFacts.le_join_l; ss.
    etrans; [|apply Time.bot_spec].
    unfold View.singleton_ur_if. condtac; ss; try refl.
    unfold TimeMap.singleton, LocFun.add, LocFun.init. condtac; ss. refl.
Qed.

Lemma fence_step_future
      lc1 sc1 ordr ordw lc2 sc2
      (ORDR: Ordering.le ordr Ordering.relaxed)
      (ORDW: Ordering.le ordw Ordering.acqrel)
      (FENCE: Local.fence_step lc1 sc1 ordr ordw lc2 sc2):
  <<PROMISES: (Local.promises lc1) = (Local.promises lc2)>> /\
  <<TVIEW: (TView.cur (Local.tview lc1)) = (TView.cur (Local.tview lc2))>>.
Proof.
  destruct lc1 as [tview1 promises1]. inv FENCE. split; ss.
  condtac; try by destruct ordw.
  condtac; try by destruct ordr.
Qed.

Lemma write_step_consistent
      lc1 sc1 mem1
      loc val ord
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1)
      (PROMISES1: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc1))
      (CONS1: Local.promise_consistent lc1):
  exists from to released lc2 sc2 mem2 kind,
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val None released ord lc2 sc2 mem2 kind>> /\
    <<CONS2: Local.promise_consistent lc2>>.
Proof.
  destruct (classic (exists f t m, Memory.get loc t (Local.promises lc1) = Some (f, m) /\
                              m <> Message.reserve)).
  { des.
    exploit Memory.min_concrete_ts_exists; eauto. i. des.
    exploit Memory.min_concrete_ts_spec; eauto. i. des.
    exploit Memory.get_ts; try exact GET. i. des.
    { subst. inv WF1. rewrite BOT in *. ss. }
    clear f t m H H0 MIN.
    exploit progress_write_step_split; try exact GET; eauto.
    { ss. unfold TimeMap.bot. apply Time.bot_spec. }
    i. des.
    esplits; eauto. ii.
    assert (TS: loc0 = loc -> Time.le ts ts0).
    { i. subst. inv x2. inv WRITE. inv PROMISE0. ss.
      revert PROMISE.
      erewrite Memory.remove_o; eauto. condtac; ss. des; ss.
      erewrite Memory.split_o; eauto. repeat condtac; ss; i.
      - des; ss. subst. refl.
      - des; ss.
        exploit Memory.min_concrete_ts_spec; try exact PROMISE; eauto. i. des. ss. }
    inv x2. inv WRITE. inv PROMISE0. ss.
    unfold TimeMap.join, TimeMap.singleton.
    unfold LocFun.add, LocFun.init, LocFun.find.
    condtac; ss.
    - subst. apply TimeFacts.join_spec_lt.
      + eapply TimeFacts.lt_le_lt; try eapply TS; eauto.
      + eapply TimeFacts.lt_le_lt; try eapply TS; eauto.
        apply Time.middle_spec. ss.
    - revert PROMISE.
      erewrite Memory.remove_o; eauto. condtac; ss.
      erewrite Memory.split_o; eauto. repeat condtac; ss; try by des; ss.
      guardH o. guardH o0. guardH o1. i.
      apply TimeFacts.join_spec_lt; eauto.
      destruct (TimeFacts.le_lt_dec ts0 Time.bot); ss.
      inv l; inv H.
      inv WF1. rewrite BOT in *. ss.
  }
  { exploit progress_write_step; eauto.
    { apply Time.incr_spec. }
    i. des.
    esplits; eauto. ii.
    inv x0. inv WRITE. inv PROMISE0. ss.
    revert PROMISE.
    erewrite Memory.remove_o; eauto. condtac; ss.
    erewrite Memory.add_o; eauto. condtac; ss. i.
    destruct (Loc.eq_dec loc0 loc).
    - subst. exfalso. apply H; eauto.
    - unfold TimeMap.join, TimeMap.singleton.
      unfold LocFun.add, LocFun.init, LocFun.find.
      condtac; ss.
      apply TimeFacts.join_spec_lt; eauto.
      destruct (TimeFacts.le_lt_dec ts Time.bot); ss.
      inv l; inv H0.
      inv WF1. rewrite BOT in *. ss.
  }
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for IA32 *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition big_endian := false.

Notation align_int64 := 4%Z (only parsing).
Notation align_float64 := 4%Z (only parsing).

Program Definition default_pl_64 : bool * nan_pl 53 :=
  (true, iter_nat 51 _ xO xH).

Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  false.                        (**r always choose first NaN *)

Program Definition default_pl_32 : bool * nan_pl 24 :=
  (true, iter_nat 22 _ xO xH).

Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
  false.                        (**r always choose first NaN *)

Definition float_of_single_preserves_sNaN := false.

Global Opaque big_endian
              default_pl_64 choose_binop_pl_64
              default_pl_32 choose_binop_pl_32
              float_of_single_preserves_sNaN.