From Coq Require Import ssreflect ssrfun ssrbool.
From PolyAI Require Export TotalMap ssrstring ssrZ Tactic.
From Coq Require Export Bool.Bool Strings.String Numbers.BinNums ZArith.BinInt.
From mathcomp.ssreflect Require Export seq.
Local Set Warnings "-notation-overridden".
From mathcomp.ssreflect Require Import ssrnat.

Local Open Scope type_scope.

(*
This is the definition of a loop aware SSA language.
 *)

Definition vid := string.
Definition bbid := string.
Definition bbid_eqType := string_eqType.

(* Every variable has a value, even the non defined ones *)
Definition RegisterMap := @total_map_eqType string_eqType Z_eqType.

(* The label is the program counter *)
Definition state := bbid * nat * RegisterMap.

(* Basics binary arithmetic opcodes *)
Inductive BinArithOpCode :=
| OpAdd
| OpMul
| OpLe.

(* An arithmetic instruction *)
Inductive Inst :=
| Const (v: vid) (c: Z)
| BinOp (v: vid) (b: BinArithOpCode) (op1 op2: vid): v <> op1 -> v <> op2 -> Inst.

(* A terminator of a basic block *)
Inductive Term :=
| Br (bb: bbid) (params: seq vid)
| BrC (c: vid) (bbT: bbid) (paramsT: seq vid)
      (bbF: bbid) (paramsF: seq vid).

(* A basic block. Has a list of parameters,
 a list of instructions, and a terminator *)
Definition BasicBlock :=
  (seq vid) * (seq Inst) * Term.

(* A program is a set of basic blocks indexed by their bbid *)
Definition Program := @partial_map string_eqType BasicBlock.

(* A program structure is either a basic block, a loop that contains a header and
 a body, or the concatenation of two program strutures *)
Inductive ProgramStructure :=
| Loop (header: bbid) (body: ProgramStructure)
| DAG (p1 p2: ProgramStructure)
| BB (bb: bbid).

Local Open Scope string_scope.
Local Open Scope seq_scope.

(* [affect_variables R [(o1,i1); ... ; (oN, iN)]] will affect i1 to o1, then i2 to o2... *)
Fixpoint affect_variables (R: RegisterMap) (vars inputs: seq vid) :=
  match (vars, inputs) with
  | (nil, _) => R
  | (_, nil) => R
  | (var::vars', input::inputs') => affect_variables (var !-> R input; R) vars' inputs'
  end.

(* Get inputs of a basic block given its id,
   and return nil if the id is not found *)
Fixpoint get_inputs (p: Program) (id: bbid) :=
  match p id with
  | Some (inputs, _, _) => inputs
  | None => nil
  end.

Definition vars_in_inst (i: Inst) :=
  match i with
  | Const v _ | BinOp v _ _ _ _ _ => [::v]
  end.

Fixpoint vars_in_program_ (p: Program) :=
  match p with
  | PEmpty => [::""]
  | PUpdate m' _ bb => (foldl (fun acc inst => acc ++ (vars_in_inst inst)) [::] bb.1.2) ++ (vars_in_program_ m')
  end.

Definition vars_in_program (p: Program) :=
  undup (vars_in_program_ p).

Theorem size_vars_in_program :
  forall p, 0 < size (vars_in_program p).
Proof.
  move => p.
  have: ("" \in (vars_in_program p)).
  - elim p => [ // | m Hind k v /= ]. rewrite /vars_in_program mem_undup /= mem_cat.
    apply /orP. right. by rewrite /vars_in_program mem_undup in Hind.
  - move => Hlt. rewrite -has_predT. apply /hasP. by exists "".
Qed.

Theorem uniq_vars_in_program :
  forall p, uniq (vars_in_program p).
Proof.
  move => p. by rewrite undup_uniq.
Qed.

Fixpoint bbs_in_program (p: ProgramStructure) :=
  match p with
  | Loop header body => header::(bbs_in_program body)
  | DAG p1 p2 => (bbs_in_program p1) ++ (bbs_in_program p2)
  | BB bb => bb::nil
  end.

(* Return list of basic blocks that are inside a loop body.
   Note that the body does not contain the header. *)
Fixpoint bbs_in_loops (p: ProgramStructure) :=
  match p with
  | Loop header body => bbs_in_program body
  | DAG p1 p2 => (bbs_in_loops p1) ++ (bbs_in_loops p2)
  | BB _ => nil
  end.

Definition term_successors (term: Term) :=
  match term with
  | Br succ _ => succ::nil
  | BrC _ succ1 _ succ2 _ => succ1::succ2::nil
  end.

Fixpoint program_successors (p: Program) (ps: ProgramStructure) :=
  match ps with
  | Loop header body =>
    match (p header) with
    | Some (_, t) => (term_successors t) ++ (program_successors p body)
    | None => program_successors p body
    end
  | DAG ps1 ps2 => (program_successors p ps1) ++ (program_successors p ps2)
  | BB bb =>
    match (p bb) with
    | Some (_, t) => (term_successors t)
    | None => nil
    end
  end.

Theorem program_successors_spec (p: Program) (ps: ProgramStructure) :
  forall bb_id, (exists in_id, (in_id \in bbs_in_program ps) /\
                    match (p in_id) with
                    | Some (_, t) => bb_id \in (term_successors t)
                    | None => false
                    end)
           -> (bb_id \in program_successors p ps).
Proof.
  elim: ps.
  - move => header_id body Hind bb_id [in_id [/= Hin_in Hin]].
    move: Hin_in. rewrite in_cons => /orP [/eqP Hineq | Hin_in].
    + move: Hin. rewrite Hineq. case (p header_id) => [ [[header_inputs header_insts] header_term]| // ].
        by rewrite mem_cat => ->.
    + move: Hin. case_eq (p in_id) => [[[in_inputs in_insts] in_term] Hin_id | //].
      case (p header_id) => [[[header_inputs header_insts] header_term] | ] Hbb_in_term.
      * move => /(_ bb_id) in Hind. rewrite mem_cat.
        have -> : (bb_id \in program_successors p body); last first. by rewrite orb_true_r.
        apply Hind. exists in_id. by rewrite Hin_id.
      * apply (Hind bb_id). exists in_id. by rewrite Hin_id.
  - move => ps1 Hind1 ps2 Hind2 bb_id [in_id [Hin_in ]] Hpin_id.
    move: Hin_in. rewrite /= mem_cat => /orP[Hin1 | Hin2].
    + rewrite mem_cat. apply /orP. left. eauto.
    + rewrite mem_cat. apply /orP. right. eauto.
  - move => bb_id bb /= [in_id [Hin Hin_in]].
    rewrite mem_seq1 in Hin. move => /eqP in Hin. rewrite -Hin.
    move: Hin_in. case (p in_id) => [ [[bb_inputs bb_insts] bb_term] // | //].
Qed.

Definition program_predecessors (p: Program) (bb_id: bbid) :=
  let keys := keys_list p in
  filter (fun k => match p k with
                | Some (_,t) => bb_id \in (term_successors t)
                | None => false
                end ) keys.

Theorem program_predecessors_spec (p: Program) (bb_id: bbid) :
  forall bb_id', bb_id' \in (program_predecessors p bb_id) =
                       match (p bb_id') with
                       | Some (_, t) => bb_id \in (term_successors t)
                       | None => false
                       end.
Proof.
  move => bb_id'.
  rewrite mem_filter.
  apply/idP/idP.
  - by move => /andP[].
  - move => Hbb. apply /andP.
    split; auto. apply keys_list_spec. move: Hbb.
      by case (p bb_id').
Qed.

Fixpoint structure_sound (p: Program) (ps: ProgramStructure) :=
  match ps with
  | Loop header body =>
    (header \notin (bbs_in_program body)) &&
    all (fun bb_id => all (fun bb_id' => bb_id' \in header::(bbs_in_program body)) (program_predecessors p bb_id)) (bbs_in_program body) &&
    (structure_sound p body) &&
    match p header with
    | None => false
    | Some _ => true
    end
  | DAG ps1 ps2 =>
    all (fun s => s \notin (bbs_in_program ps2)) (bbs_in_program ps1) &&
    all (fun s => s \notin (bbs_in_program ps1)) (bbs_in_program ps2) &&
    all (fun s => s \notin (bbs_in_program ps1)) (program_successors p ps2) &&
    structure_sound p ps1 &&
    structure_sound p ps2
  | BB bb =>
    match p bb with
    | None => false
    | Some (_,term) => bb \notin (term_successors term)
    end
  end.

Local Open Scope Z_scope.

(* The evaluation of a binary operation *)
Definition bin_op_eval (op : BinArithOpCode) (v1 v2 : Z) :=
  match op with
  | OpAdd => v1 + v2
  | OpMul => v1 * v2
  | OpLe => if v1 <=? v2 then 1 else 0
  end.

(* The semantics of arithmetic instructions *)
Inductive inst_step: Inst -> RegisterMap -> RegisterMap -> Prop :=
| ConstStep (v: vid) (c: Z) (R: RegisterMap):
    inst_step (Const v c) R (v !-> c; R)
| BinOpStep (v: vid) (opc: BinArithOpCode) (op1 op2: vid) (H1: v <> op1) (H2: v <> op2) (R: RegisterMap):
    inst_step (BinOp v opc op1 op2 H1 H2) R (v !-> bin_op_eval opc (R op1) (R op2); R).

(* The semantics of a terminator *)
Inductive term_step: Program -> Term -> RegisterMap -> (bbid * RegisterMap)
                           -> Prop :=
| BrStep (p: Program) (bb: bbid) (params: list vid) (R: RegisterMap) :
    term_step p (Br bb params) R (bb, (affect_variables R (get_inputs p bb) params))
| BrCTrueStep (p: Program) (c: vid) (bbT bbF: bbid) (paramsT paramsF: list vid) (R: RegisterMap) :
    R c <> 0 ->
    term_step p (BrC c bbT paramsT bbF paramsF) R
                    (bbT, (affect_variables R (get_inputs p bbT) paramsT))
| BrCFalseStep (p: Program) (c: vid) (bbT bbF: bbid) (paramsT paramsF: list vid) (R: RegisterMap) :
    R c = 0 ->
    term_step p (BrC c bbT paramsT bbF paramsF) R
                    (bbF, (affect_variables R (get_inputs p bbF) paramsF))
.

Theorem term_successors_spec (p: Program) (term: Term) :
  forall out_id R R', term_step p term R (out_id, R') ->
                 out_id \in term_successors term.
Proof.
  move => out_id R R' Hterm_step.
  inversion Hterm_step; subst.
  - by rewrite in_cons eq_refl.
  - by rewrite in_cons eq_refl.
  - by rewrite in_cons in_cons eq_refl orb_true_r.
Qed.

(* The small step semantics of a program *)
Inductive step: Program -> state -> state -> Prop :=
| InstStep (p: Program) (bb_id: bbid) (params: list vid) (insts: list Inst) (term: Term) :
    p bb_id = Some (params, insts, term) ->
    forall l inst, List.nth_error insts l = Some inst ->
            forall R R', inst_step inst R R' ->
                    step p (bb_id, l, R) (bb_id, S l, R')
| TermStep (p: Program) (bb_id: bbid) (params: list vid) (insts: list Inst) (term: Term) :
    p bb_id = Some (params, insts, term) ->
    forall l, List.nth_error insts l = None ->
         forall new_bbid R R', term_step p term R (new_bbid, R') ->
                          step p (bb_id, l, R) (new_bbid, O, R').

(* The reflexive and transitive closure of the trans relation *)
Inductive multi_step: Program -> state -> state -> Prop :=
| StepRefl : forall p s, multi_step p s s
| StepTrans : forall p s s' s'', multi_step p s s' -> step p s' s'' -> multi_step p s s''.

Definition reachable_states (p: Program) (R: RegisterMap) (s: state) :=
multi_step p ("entry", O, R) s.

Open Scope nat_scope.

Theorem multi_step_trans :
  forall p s0 s1 s2, multi_step p s0 s1 -> multi_step p s1 s2 -> multi_step p s0 s2.
Proof.
  move => p s0 s1 s2 H01 H12.
  induction H12 => [// | ].
  apply IHmulti_step in H01.
    by eapply StepTrans; eauto.
Qed.

Theorem reachable_states_pos (p: Program) (R: RegisterMap) (s: state) :
  reachable_states p R s ->
  match p s.1.1 with
  | Some (_, insts, _) => s.1.2 <= List.length insts
  | Non => true
  end.
Proof.
  rewrite /reachable_states.
  move s1 : ("entry", O, R) => Hs1 Hmulti_step.
  elim: Hmulti_step s1.
  - move => p0 s0 <- /= .
    case (p0 "entry") => [ [[_ insts] _] | //].
    case insts => [ // | i l /=].
      by apply leq0n.
  - move => p0 s0 s' s'' Hmulti_step Hind Hstep Hs0.
    inversion Hstep; subst.
    + move: Hind => /(_ (erefl _)) /=. case_eq (p0 bb_id) => [ [[inputs' insts'] term'] Hbb'| //].
      rewrite H in Hbb'. inversion Hbb'. subst.
      have Hne_None : (List.nth_error insts' l <> None). move: H0. case (List.nth_error insts' l) => //.
      apply List.nth_error_Some in Hne_None.
      by move => /ltP in Hne_None.
    + rewrite /=. case (p0 new_bbid) => [[[_ insts'] _] | //]. case insts' => [ // | i' l' /=].
      by apply leq0n.
Qed.

Theorem step_entering_loop :
  forall p header_id body,
    let loop := Loop header_id body in
    structure_sound p loop ->
    forall s_in, (s_in.1.1 \notin (bbs_in_program loop)) ->
            forall s_out, (s_out.1.1 \in (bbs_in_program loop)) ->
                     step p s_in s_out ->
                     s_out.1.1 = header_id /\ s_out.1.2 = 0.
Proof.
  move => p header_id body loop Hsound s_in Hs_in_notin s_out Hs_out_in Hstep.
  have H_s_in_out_ne: (s_in <> s_out). move => H_s_in_out_eq. subst. by rewrite Hs_out_in in Hs_in_notin.
  inversion Hstep. bigsubst. by rewrite Hs_out_in in Hs_in_notin.
  bigsubst. rewrite /=. split; auto.
  inversion Hsound. move: H3 => /andP[/andP[/andP[_ /allP Hpred] _] _].
  move => /= in Hs_out_in. rewrite in_cons in Hs_out_in. move => /orP in Hs_out_in.
  case: Hs_out_in; first by autossr.
  move => /Hpred /allP.
  apply term_successors_spec in H1.
  move: (program_predecessors_spec p new_bbid bb_id).
  rewrite H H1 => H_in_predecessors. move => /(_ bb_id H_in_predecessors).
    by autossr.
Qed.

Theorem multi_step_loop :
  forall p header_id body,
    let loop := Loop header_id body in
    structure_sound p loop ->
    forall s_entry, (s_entry.1.1 \notin (bbs_in_program loop)) ->
               forall s_bb, (s_bb.1.1 \in (bbs_in_program loop)) ->
                       multi_step p s_entry s_bb <->
                       exists R_header, multi_step p s_entry (header_id, 0, R_header) /\
                                   multi_step p (header_id, 0, R_header) s_bb.
Proof.
  move => p header_id body loop Hsound s_entry H_entry_notin s_bb H_bb_in.
  split => [ H_multi_step | [R_header [H01 H12]]]; last by eapply multi_step_trans; eauto.
  move Hp : p => p'. rewrite Hp in H_multi_step.
  elim: H_multi_step Hp H_bb_in H_entry_notin; first by move => p0 s _ ->.
  move => p0 s s' s'' Hmulti_step Hind Hstep Hp H_s''_in H_s_notin.
  case Hs'_in : (s'.1.1 \in bbs_in_program loop). by case: (Hind Hp Hs'_in H_s_notin) => R_header [H0 H1]; eexists; split; eauto; econstructor; eauto.
  have H_s'_s''_ne: (s' <> s''). move => H_s'_s''_eq. subst. by rewrite H_s''_in in Hs'_in.
  bigsubst. move => /negb_true_iff in Hs'_in. move: (step_entering_loop _ _ _ Hsound _ Hs'_in _ H_s''_in Hstep) => [H_s''_header H_s''_pos_0].
  exists s''.2. rewrite -H_s''_header -H_s''_pos_0.
  rewrite -!surjective_pairing. split; last by constructor.
  econstructor; eauto.
Qed.

Definition step_cond (p: Program) (s s': state) (avoid: seq bbid) :=
  step p s s' /\ ~~ ((s'.1.1 \in avoid) && (s'.1.2 != 0)).

Inductive multi_step_cond: Program -> state -> state -> seq bbid -> Prop :=
| StepCondRefl : forall p s l, multi_step_cond p s s l
| StepCondTrans : forall p s s' s'' l, multi_step_cond p s s' l -> step_cond p s' s'' l -> multi_step_cond p s s'' l.

Theorem multi_step_cond_trans:
  forall p s' s s'' l, multi_step_cond p s s' l ->
                     multi_step_cond p s' s'' l ->
                     multi_step_cond p s s'' l.
Proof.
  move => p s' s s'' l H01 H12.
  induction H12 => [ // | ].
  apply IHmulti_step_cond in H01.
    by eapply StepCondTrans; eauto.
Qed.

Theorem step_cond_cons:
  forall p s s' bb_id l, step_cond p s s' (bb_id::l) -> step_cond p s s' l.
Proof.
  move => p s s' bb_id l [Hstep /nandP [Hnotin | Hnot0]]; rewrite /step_cond; autossr.
Qed.

Theorem multi_step_cond_cons:
  forall p s s' bb_id l, multi_step_cond p s s' (bb_id::l) ->
                    multi_step_cond p s s' l.
Proof.
  move => p s s' bb_id l Hmulti.
  move Hl_cons : (bb_id :: l) => l_cons. rewrite Hl_cons in Hmulti.
  induction Hmulti; first by constructor.
  eapply StepCondTrans; eauto.
  rewrite -Hl_cons in H. by eapply step_cond_cons; eauto.
Qed.

Section Example.

  Definition y_ne_x : "y" <> "x".
  Proof.
      by apply /eqP.
  Qed.

  Definition y_ne_one : "y" <> "one".
  Proof.
      by apply /eqP.
  Qed.

  Definition c_ne_y : "c" <> "y".
  Proof.
      by apply /eqP.
  Qed.

  Definition c_ne_one : "c" <> "one".
  Proof.
      by apply /eqP.
  Qed.

  Definition entry_bb := (@nil string,
                          (Const "zero" 0)::(Const "one" 1)::nil,
                          (Br "loop" ("zero"::nil))).

  Definition loop_bb := ("x"::nil,
                         (BinOp "y" OpAdd "x" "one" y_ne_x y_ne_one)::
                         (BinOp "c" OpLe "y" "one" c_ne_y c_ne_one)::nil,
                         (BrC "c" "loop" ("y"::nil) "exit" ("y"::nil))).

  Definition dummy_bb := (@nil string, @nil Inst, (Br "loop" ([::"y"]))).

  Definition exit_bb := ("exitvalue"::nil, @nil Inst, (Br "finished" nil)).

  Definition prog := ("entry" !!-> entry_bb; "loop" !!-> loop_bb; "dummy" !!-> dummy_bb; "exit" !!-> exit_bb).

  Definition progstruct := DAG (BB "entry") (DAG (Loop "loop" (BB "dummy")) (BB "exit")).

  Example progstruct_correct :
    structure_sound prog progstruct.
  Proof.
      by [].
  Qed.

End Example.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitchAux.Specs.save_ns_state_sysreg_state.
Require Import CtxtSwitchAux.LowSpecs.save_ns_state_sysreg_state.
Require Import CtxtSwitchAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       sysreg_read_spec
       set_ns_state_spec
    .

  Lemma save_ns_state_sysreg_state_spec_exists:
    forall habd habd'  labd
           (Hspec: save_ns_state_sysreg_state_spec  habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', save_ns_state_sysreg_state_spec0  labd = Some labd' /\ relate_RData habd' labd'.
    Proof.
      Local Opaque ptr_eq get_reg set_reg.
      intros. destruct Hrel.
      unfold save_ns_state_sysreg_state_spec, save_ns_state_sysreg_state_spec0 in *.
      unfold sysreg_read_spec, set_ns_state_spec.
      autounfold in Hspec.
      hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec.
      destruct regs_is_int64_dec in C; [|inversion C].
      unfold Assertion.
      repeat (unfold bind64 at 1; rewrite e; repeat simpl_update_reg; repeat (simpl priv; simpl cpu_regs; simpl_field);
              unfold bind at 1; simpl ns_regs_el2).
      eexists; split. reflexivity. constructor. reflexivity.
    Qed.

End Refine.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Oprime Bprime Cprime Eprimeprime Bprimeprime C2 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ A Oprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Oprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Eprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O A A /\ (col_ O A Oprime /\ col_ Eprimeprime A Oprime))))))))))))))))))))))))))))) -> col_ Oprime O E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import CertiGraph.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.ramification_lemmas.
Require Import VST.msl.Coqlib2.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.lib.Morphisms_ext.
Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.iter_sepcon.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.dag.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.graph_morphism.
Require Import CertiGraph.graph.local_graph_copy.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.GraphBin.
Require Import CertiGraph.msl_application.Graph_Copy.
Require Import Coq.Logic.Classical.

Open Scope logic.

Section PointwiseGraph_Copy_Bin.

Context {pSGG_Bin: pPointwiseGraph_Graph_Bin}.
Context {sSGG_Bin: sPointwiseGraph_Graph_Bin addr (addr * LR)}.

Existing Instances pSGG_Bin sSGG_Bin SGAvn.

Local Coercion Graph'_LGraph: Graph' >-> LGraph.
Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion Graph'_GeneralGraph: Graph' >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation Graph := (@Graph pSGG_Bin addr (addr * LR) unit).
Notation Graph' := (@Graph' pSGG_Bin addr (addr * LR) unit).

#[global] Instance CCS: CompactCopySetting addr (addr * LR) unit.
  apply (Build_CompactCopySetting _ _ _ null (null, L) tt).
Defined.

Definition empty_Graph': Graph' := empty_Graph' null (null, L) tt.

Definition initial_copied_Graph (x x0: addr) (g: Graph): LGraph
  := single_vertex_labeledgraph (LocalGraphCopy.vmap (Graph_vgen g x x0) x) null (null, L) tt.

Opaque empty_Graph initial_copied_Graph.

Lemma vertex_at_not_null: forall (x: addr) (gx: addr * addr * addr),
  @derives pred _
    (vertex_at x gx) (!! (null <> x)).
Proof.
  intros.
  destruct (classic (null = x)).
  + subst x.
    apply derives_trans with FF.
    apply vertex_at_not_null.
    apply FF_left.
  + apply prop_right; auto.
Qed.

Lemma copy_null_refl: forall (g: Graph),
  copy null g g empty_Graph'.
Proof. intros; apply copy_invalid_refl, invalid_null; auto. Qed.

Lemma copy_vgamma_not_null_refl: forall (g: Graph) (root: addr) d l r,
  vgamma g root = (d, l, r) ->
  d <> null ->
  copy root g g empty_Graph'.
Proof.
  intros; apply marked_root_copy_refl.
  simpl.
  inversion H.
  subst; congruence.
Qed.

Lemma vmap_weaken: forall (g1: Graph) (g2: Graph') x x0 BLA,
  (x = null /\ x0 = null \/ x0 = BLA) ->
  (~ vvalid g1 x /\ ~ vvalid g2 x0 \/ x0 = BLA).
Proof.
  intros.
  destruct H; [left | right]; auto.
  destruct H.
  pose proof (@valid_not_null _ _ _ _ g1 _ (maGraph g1) x).
  pose proof (@valid_not_null' _ _ _ _ g2 _ (maGraph' g2) x0).
  unfold is_null_SGBA in *; simpl in *.
  auto.
Qed.

Lemma root_stable_ramify: forall (g: Graph) (x: addr) (gx: addr * addr * addr),
  vgamma g x = gx ->
  vvalid g x ->
  @derives pred _
    (reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx -* reachable_vertices_at x g)).
Proof. intros; apply va_reachable_root_stable_ramify; auto. Qed.

Lemma root_update_ramify1: forall (g: Graph) (x x0: addr) (lx: addr) (gx gx': addr * addr * addr),
  vvalid g x ->
  vertices_at (Intersection _ (vvalid (initial_copied_Graph x x0 g)) (fun u : addr => x0 <> u)) (initial_copied_Graph x x0 g) = emp.
Proof.
  intros.
    erewrite <- vertices_at_False.
    apply vertices_at_Same_set.
    rewrite Same_set_spec; intros ?.
Transparent initial_copied_Graph. simpl. Opaque initial_copied_Graph.
    unfold update_vlabel.
    if_tac; [| congruence].
    split; [intros [? ?]; congruence | tauto].
Qed.

Lemma root_update_ramify2: forall (g: Graph) (x x0: addr) (lx: addr) (gx gx': addr * addr * addr) F,
  vgamma g x = gx ->
  vgamma (Graph_vgen g x lx) x = gx' ->
  vvalid g x ->
  @derives pred _
    (F * reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx' -*
       F * (emp * reachable_vertices_at x (Graph_vgen g x lx)))).
Proof.
  intros.
  rewrite !(sepcon_comm F).
  apply RAMIF_PLAIN.frame.
  rewrite emp_sepcon.
  apply va_reachable_root_update_ramify; auto.
Qed.

Lemma root_update_ramify (* {sSGG_Bin': sPointwiseGraph_Graph_Bin addr (addr * LR)} *): forall (g: Graph) (x x0: addr) (lx: addr) (gx gx': addr * addr * addr) F,
  vgamma g x = gx ->
  vgamma (Graph_vgen g x lx) x = gx' ->
  vvalid g x ->
  @derives pred _
    (F * @reachable_vertices_at _ _ _ _ (@SGBA pSGG_Bin) _ _ _ (@SGC_Bin pSGG_Bin _ _ _) _ (@SGP pSGG_Bin _ _ sSGG_Bin) (@SGA pSGG_Bin _ _ sSGG_Bin) x g)
    (vertex_at x gx *
      (vertex_at x gx' -*
       F * (@vertices_at _ _ _ _ (@SGBA pSGG_Bin) _ (@SGP pSGG_Bin _ _ sSGG_Bin) _ (Intersection _ (vvalid (initial_copied_Graph x x0 g)) (fun u : addr => x0 <> u)) (initial_copied_Graph x x0 g) * reachable_vertices_at x (Graph_vgen g x lx)))).
Proof.
  intros.
  rewrite !(sepcon_comm F).
  apply RAMIF_PLAIN.frame.
  assert (@vertices_at _ _ _ _ (@SGBA pSGG_Bin) _ (@SGP pSGG_Bin _ _ sSGG_Bin) _ (Intersection _ (vvalid (initial_copied_Graph x x0 g)) (fun u : addr => x0 <> u)) (initial_copied_Graph x x0 g) = emp).
  {
    erewrite <- vertices_at_False.
    apply vertices_at_Same_set.
    rewrite Same_set_spec; intros ?.
Transparent initial_copied_Graph. simpl. Opaque initial_copied_Graph.
    unfold update_vlabel.
    if_tac; [| congruence].
    split; [intros [? ?]; congruence | tauto].
  }
  rewrite H2, emp_sepcon.
  apply va_reachable_root_update_ramify; auto.
Qed.

Lemma not_null_copy1: forall (G: Graph) (x x0: addr) l r,
  vgamma G x = (null, l, r) ->
  vvalid G x ->
  x0 <> null ->
  vcopy1 x G (Graph_vgen G x x0) (initial_copied_Graph x x0 G) /\
  x0 = LocalGraphCopy.vmap (Graph_vgen G x x0) x /\
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) (initial_copied_Graph x x0 G).
Proof.
  intros.
  split; [split; [| split] | split].
  + reflexivity.
  + split; [| split].
    - reflexivity.
    - simpl.
      unfold update_vlabel.
      destruct_eq_dec x x; congruence.
    - intros.
      simpl.
      unfold update_vlabel; simpl.
      destruct_eq_dec x n'; [congruence |].
      tauto.
  + split; [| split; [| split]].
    - reflexivity.
    - apply guarded_pointwise_relation_spec; intros.
      simpl.
      unfold update_vlabel; simpl.
      destruct_eq_dec x x1; [congruence | auto].
    - apply guarded_pointwise_relation_spec; intros.
      auto.
    - reflexivity.
  + simpl.
    unfold update_vlabel; simpl.
    destruct_eq_dec x x; [auto | congruence].
  + assert (LocalGraphCopy.vmap (Graph_vgen G x x0) x = x0).
    1: {
      simpl.
      unfold update_vlabel; simpl.
      destruct_eq_dec x x; auto; congruence.
    }
    pattern x0 at 1; rewrite <- H2.
    apply single_vertex_guarded_BinMaFin'.
Qed.

Lemma left_weak_valid: forall (G G1: Graph) (G1': LGraph) (x l r: addr),
  vgamma G x = (null, l, r) ->
  vvalid G x ->
  vcopy1 x G G1 G1' ->
  @weak_valid _ _ _ _ G1 _ (maGraph _) l.
Proof.
  intros.
  destruct H1 as [? _].
  eapply weak_valid_si; [symmetry; exact H1 |].
  eapply gamma_left_weak_valid; eauto.
Qed.

Lemma right_weak_valid: forall (G G1 G2 G3: Graph) (G1' G2' G3': LGraph) (x l r: addr),
  vgamma G x = (null, l, r) ->
  vvalid G x ->
  vcopy1 x G G1 G1' ->
  extended_copy l (G1: LGraph, G1') (G2: LGraph, G2') ->
  ecopy1 (x, L) (G2: LGraph, G2') (G3: LGraph, G3') ->
  @weak_valid _ _ _ _ G3 _ (maGraph _) r.
Proof.
  intros.
  destruct H1 as [? _], H2 as [? _], H3 as [? _].
  rewrite <- H2, <- H1 in H3.
  eapply weak_valid_si; [symmetry; eauto |].
  eapply gamma_right_weak_valid; eauto.
Qed.

Lemma graph_ramify_left: forall (g g1: Graph) (g1': LGraph) (x l r: addr) (F1 F2: pred) F3,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  F1 * (F2 * reachable_vertices_at x g1) |--
  reachable_vertices_at l g1 *
   (ALL a: Graph' * Graph * addr,
     !! (copy l g1 (snd (fst a)) (fst (fst a)) /\ (l = null /\ snd a = null \/ snd a = LocalGraphCopy.vmap (snd (fst a)) l)) -->
     (reachable_vertices_at l (snd (fst a)) * F3 (snd a) (fst (fst a)) -*
      F1 * (F2 * (reachable_vertices_at x (snd (fst a)) * F3 (snd a) (fst (fst a)))))).
Proof.
  intros.
  destruct H1 as [? [? ?]].
  rewrite <- sepcon_assoc, (sepcon_comm (F1 * F2)).
  RAMIF_Q'.formalize.
  match goal with
  | |- _ |-- _ * allp (_ --> (_ -* ?A)) =>
    replace A with
    (fun p : Graph' * Graph * addr =>
            reachable_vertices_at x (snd (fst p)) *
            F3 (snd p) (fst (fst p)) * (F1 * F2)) by
    (extensionality p; rewrite <- (sepcon_assoc F1 F2), (sepcon_comm _ (F1 * F2)); auto)
  end.
  apply RAMIF_Q'.frame; [auto |].
  apply RAMIF_Q'.frame_post; [auto |].
  simpl.

  eapply vertices_at_ramif_xQ.
  eexists.
  split; [| split].
  + rewrite <- H1.
    eapply Prop_join_reachable_left; eauto.
  + intros.
    destruct H4 as [[? [? ?]] _].
    rewrite <- H4, <- H1.
    eapply Prop_join_reachable_left; eauto.
  + intros [[? ?] ?] [? _].
    simpl in H4 |- *.
    rewrite vertices_identical_spec.
    intros.
    simpl.
    destruct H4 as [? [? ?]].
    f_equal; [f_equal |].
    - destruct H7 as [_ [? _]].
      rewrite guarded_pointwise_relation_spec in H7.
      apply H7; clear H7.
      unfold Complement, Ensembles.In.
      intro.
      apply reachable_by_is_reachable in H7.
      rewrite Intersection_spec in H5.
      rewrite <- H1 in H7.
      destruct H5; auto.
    - apply dst_L_eq; auto.
      rewrite Intersection_spec in H5.
      destruct H5 as [? _].
      rewrite H1 in H5.
      apply reachable_foot_valid in H5; auto.
    - apply dst_R_eq; auto.
      rewrite Intersection_spec in H5.
      destruct H5 as [? _].
      rewrite H1 in H5.
      apply reachable_foot_valid in H5; auto.
Qed.

Lemma graph_ramify_right: forall (g g1 g2 g3: Graph) (g1' g2' g3': LGraph) (x l r: addr) (F1 F2: pred) F3,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  F1 * (F2 * reachable_vertices_at x g3) |--
  reachable_vertices_at r g3 *
   (ALL a: Graph' * Graph * addr,
     !! (copy r g3 (snd (fst a)) (fst (fst a)) /\ (r = null /\ snd a = null \/ snd a = LocalGraphCopy.vmap (snd (fst a)) r)) -->
     (reachable_vertices_at r (snd (fst a)) * F3 (snd a) (fst (fst a)) -*
      F1 * (F2 * (reachable_vertices_at x (snd (fst a)) * F3 (snd a) (fst (fst a)))))).
Proof.
  intros.
  destruct H1 as [? [? ?]].
  rewrite <- sepcon_assoc, (sepcon_comm (F1 * F2)).
  RAMIF_Q'.formalize.
  match goal with
  | |- _ |-- _ * allp (_ --> (_ -* ?A)) =>
    replace A with
    (fun p : Graph' * Graph * addr =>
            reachable_vertices_at x (snd (fst p)) *
            F3 (snd p) (fst (fst p)) * (F1 * F2)) by
    (extensionality p; rewrite <- (sepcon_assoc F1 F2), (sepcon_comm _ (F1 * F2)); auto)
  end.
  apply RAMIF_Q'.frame; [auto |].
  apply RAMIF_Q'.frame_post; [auto |].
  simpl.

  eapply vertices_at_ramif_xQ.
  eexists.
  split; [| split].
  + destruct H2 as [? _], H3 as [? _]; rewrite <- s0, <- s, <- H1.
    eapply Prop_join_reachable_right; eauto.
  + intros.
    destruct H6 as [[? [? ?]] _].
    destruct H2 as [? _], H3 as [? _]. rewrite <- H6, <- H3, <- H2, <- H1.
    eapply Prop_join_reachable_right; eauto.
  + intros [[[? ?] ?] ?] [? _].
    destruct H2 as [? _], H3 as [? _]; rewrite H2, H3 in H1.
    simpl in H6 |- *.
    rewrite vertices_identical_spec.
    intros.
    simpl.
    destruct H6 as [? [? ?]].
    f_equal; [f_equal |].
    - destruct H9 as [_ [? _]].
      rewrite guarded_pointwise_relation_spec in H9.
      apply H9; clear H9.
      unfold Complement, Ensembles.In.
      intro.
      apply reachable_by_is_reachable in H9.
      rewrite Intersection_spec in H7.
      rewrite <- H1 in H9.
      destruct H7; auto.
    - apply dst_L_eq; auto.
      rewrite Intersection_spec in H7.
      destruct H7 as [? _].
      rewrite H1 in H7.
      apply reachable_foot_valid in H7; auto.
    - apply dst_R_eq; auto.
      rewrite Intersection_spec in H7.
      destruct H7 as [? _].
      rewrite H1 in H7.
      apply reachable_foot_valid in H7; auto.
Qed.

Lemma is_BinMaFin_disjoint_guard: forall (g1':  @LGraph pSGG_Bin (@addr pSGG_Bin) (prod (@addr pSGG_Bin) LR) unit) (g2'': Graph') x0 es0,
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e es0) g1' ->
  vvalid g1' x0 ->
  (forall e, In e es0 -> fst e = x0) ->
  Disjoint addr (vvalid g2'') (vvalid g1') ->
  disjointed_guard (vvalid g2'') (vvalid g1') (evalid g2'') (evalid g1').
Proof.
  intros.
  split; auto.
  rewrite Disjoint_spec in *.
  intros e ? ?.
  pose proof @valid_graph' _ _ _ _ g2'' _ (maGraph' _) e H3.
  apply (H2 _ H5).
  destruct (in_dec equiv_dec e es0); destruct e as [v lr].
  + specialize (H1 _ i).
    simpl in H1.
    rewrite left_right_sound0' by auto.
    subst; auto.
  + destruct H as [X _].
    pose (pg1 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e => ~ In e es0) g1') X: Graph').
    assert (evalid pg1 (v, lr)) by (simpl; rewrite Intersection_spec; split; auto).
    assert (src g2'' (v, lr) = src pg1 (v, lr)) by (rewrite !left_right_sound0'; auto).
    apply (@valid_graph' _ _ _ _ pg1 _ (maGraph' _)) in H.
    rewrite H6; auto.
    destruct H; auto.
Qed.

Lemma is_BinMaFin_not_evalid: forall (g1': @LGraph pSGG_Bin (@addr pSGG_Bin) (prod (@addr pSGG_Bin) LR) unit)x0 es0 e0,
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e es0) g1' ->
  vvalid g1' x0 ->
  (forall e, In e es0 -> fst e = x0) ->
  fst e0 = x0 ->
  ~ In e0 es0 ->
  ~ evalid g1' e0.
Proof.
  intros.
  intro.
  destruct H as [X ?].
  set (G := (Build_GeneralGraph _ _ _ (fun g => BinMaFin' (pg_lg g)) _ X: Graph')).
  assert (evalid G e0).
  1: {
    simpl.
    rewrite Intersection_spec; auto.
  }
  pose proof @valid_graph' _ _ _ _ G _ (maGraph' _) _ H5.
  destruct e0.
  simpl in H2; subst a.
  rewrite (left_right_sound0' _ _ _ H5) in H6.
  simpl in H6.
  rewrite Intersection_spec in H6.
  destruct H6.
  auto.
Qed.

Lemma extend_copy_left: forall (g g1 g2: Graph) (g1': LGraph) (g2'': Graph') (x l r x0 l0: addr) d0,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  copy l g1 g2 g2'' ->
  x0 = LocalGraphCopy.vmap g1 x ->
  l = null /\ l0 = null \/ l0 = LocalGraphCopy.vmap g2 l ->
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) g1' ->
  @derives pred _
  (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g1') (fun x => x0 <> x)) g1' * reachable_vertices_at l0 g2'')
  (EX g2': LGraph,
    !! (extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') /\ is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) g2') &&
    (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g2') (fun x => x0 <> x)) g2')).
Proof.
  intros.
  rename H5 into BMF.
  inversion H0.
  pose proof @vcopy1_edge_copy_list_weak_copy_extended_copy' _ _ _ _ _ _ _ _ _ _ BinMaFin'_Normal x ((x, L) :: (x, R) :: nil) nil (x, L) ((x, R) :: nil) g g1 g1 g1' g1' g2 g2'' x0 H.
  spec H5; [simpl; unfold Complement, Ensembles.In; congruence |].
  spec H5; [reflexivity |].
  spec H5; [intros; apply (binGraph_out_edges g (binGraph _)); auto |].
  spec H5; [repeat constructor; intro HH; inversion HH; inversion H9 |].
  spec H5; [auto |].
  spec H5; [hnf; auto |].
  spec H5; [auto |].
  spec H5; [subst l; auto |].

  unfold reachable_vertices_at.
  pose proof vertices_at_sepcon_unique_1x (Graph_PointwiseGraph g2'') x0 (reachable g2'' l0) d0.
  pose proof vertices_at_sepcon_unique_xx g1' (Graph_PointwiseGraph g2'') (Intersection _ (vvalid g1') (fun x => x0 <> x)) (reachable g2'' l0).

  rewrite sepcon_assoc, (add_andp _ _ H10); normalize.
  rewrite (sepcon_comm (vertices_at _ _)), <- sepcon_assoc, (add_andp _ _ H9); normalize.
  clear H9 H10.
  spec H5.
  {
    apply is_BinMaFin_disjoint_guard with (x0 := x0) (es0 := nil); auto.
    + eapply vcopy1_copied_root_valid in H1; auto.
      subst x0; auto.
    + intros ? [].
    + apply (vmap_weaken g1 g2'') in H4.
      rewrite (copy_vvalid_weak_eq g1 g2 g2'' l l0 H4 H2).
      apply Disjoint_comm.
      apply (Disjoint_x1' _ _ _ H11 H12).
  }

  unfold map in H5; rewrite H3 in BMF.
  rewrite <- H3 in BMF;
  specialize (H5 BMF).
  specialize (H5 (Graph'_is_BinMaFin' _)).

  destruct H5 as [g2' [? [? [? ?]]]].
  apply (exp_right g2').

  pose proof vertex_at_not_null x0 d0.
  rewrite (add_andp _ _ H14) at 1.
  rewrite andp_comm, !sepcon_andp_prop'.
  apply derives_extract_prop.
  intro.
  clear H14. assert (x0 <> null) by congruence; clear H15.

  apply andp_right; [apply prop_right; split; auto | rewrite sepcon_assoc; apply sepcon_derives; auto].
  assert (Prop_join (vvalid g1') (vvalid g2'') (vvalid g2')) as HPJ.
  1: {
    eapply copy_and_extended_copy; eauto.
    rewrite <- H7; auto.
  }
  assert (Prop_join (Intersection addr (vvalid g1') (fun x1 : addr => x0 <> x1))
                (vvalid g2'')
                (Intersection addr (vvalid g2') (fun x1 : addr => x0 <> x1))) as HPJ1.
  1: {
    apply Prop_join_shrink1; auto.
    eapply vcopy1_copied_root_valid in H1; auto.
    rewrite H3; auto.
  }
  rewrite (vertices_at_vertices_identical (Graph_PointwiseGraph g2'') (LGraph_SGraph g2')).
  rewrite (vertices_at_vertices_identical (LGraph_SGraph g1') (LGraph_SGraph g2')).
  + erewrite vertices_at_sepcon_xx; [apply derives_refl |].
    rewrite Prop_join_comm.
    apply (vmap_weaken g1 g2'') in H4.
    rewrite <- (copy_vvalid_weak_eq g1 g2 g2'' l l0 H4 H2).
    auto.
  + rewrite <- H3 in H13.
    apply H13.
    - unfold Included, Ensembles.In; intros.
      destruct BMF as [BMF _].
      pose (pg1 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e nil) g1') BMF: Graph').
      assert (vvalid pg1 x1) by (simpl; auto).
      apply vvalid_vguard' in H16.
      simpl in H16.
      rewrite !Intersection_spec in H16.
      simpl; tauto.
    - unfold Included, Ensembles.In; intros.
      destruct H9 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e nil) g2') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite Intersection_spec in H15 |- *. rewrite (proj1 HPJ); tauto.
      apply vvalid_vguard' in H9.
      simpl in H9.
      rewrite !Intersection_spec in H9.
      simpl; tauto.
  + apply (vmap_weaken g1 g2'') in H4.
    pose proof copy_vvalid_weak_eq _ _ _ _ _ H4 H2.
    rewrite <- H15.
    apply H10.
    - intros ? ?; apply vvalid_vguard'; auto.
    - unfold Included, Ensembles.In; intros.
      destruct H9 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e nil) g2') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite (proj1 HPJ1). tauto.
      apply vvalid_vguard' in H9.
      simpl in H9.
      rewrite !Intersection_spec in H9.
      simpl; tauto.
Qed.

Lemma labeledgraph_add_edge_ecopy1_left: forall (g g1 g2: Graph) (g1' g2': LGraph) (x l r x0 l0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  l = null /\ l0 = null \/ l0 = LocalGraphCopy.vmap g2 l ->
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) g2' ->
  x0 <> null ->
  let g3 := Graph_egen g2 (x, L) (x0, L): Graph in
  let g3' := labeledgraph_add_edge g2' (x0, L) x0 l0 (null, L): LGraph in
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') /\
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g3' /\
  (x0, L) = LocalGraphCopy.emap g3 (x, L) /\
  dst g3' (x0, L) = l0.
Proof.
  intros.
  unfold ecopy1.
  assert (~ evalid g2' (x0, L)) as HH.
  1: {
    eapply is_BinMaFin_not_evalid; eauto; [| intros ? []].
    eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    subst x0; auto.
  }
  split; [split; [| split] | split; [| split]].
  + reflexivity.
  + apply WeakMarkGraph.labeledgraph_egen_do_nothing.
  + assert (g ~=~ g2) as HH0.
    1: {
      destruct H1 as [? _], H2 as [? _].
      rewrite <- H2, <- H1; reflexivity.
    }
    assert (x0 = LocalGraphCopy.vmap g2 (src g2 (x, L))) as HH1.
    1: {
      rewrite left_right_sound by (rewrite <- (proj1 HH0); auto).
      destruct H1 as [_ [? _]], H2 as [_ [_ ?]].
      subst x0.
      destruct H2 as [_ [? _]].
      rewrite guarded_pointwise_relation_spec in H2.
      apply H2.
      unfold Complement, Ensembles.In; intro.
      apply reachable_by_foot_prop in H3.
      apply H3.
      destruct H1 as [_ [? _]]; auto.
    }
    destruct H4.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1_not_vvalid g2 g2' (x, L) (x0, L) x0 l0.
      apply H7; clear H7; auto.
      * destruct H4.
        subst l0.
        destruct H5 as [[? ? ?] _].
        pose proof @valid_not_null' _ _ _ _ (gpredicate_sub_labeledgraph (fun v : addr => x0 <> v)
            (fun e : addr * LR => ~ In e nil) g2') _ ma' null.
        intro.
        apply H5; [| reflexivity].
        simpl.
        rewrite Intersection_spec; split; auto.
      * inversion H0.
        rewrite <- (si_dst1 _ _ _ HH0); [| apply (@left_valid _ _ _ _ _ _ g (binGraph _)); auto].
        destruct H4; rewrite H9; subst l.
        intro.
        apply (@valid_not_null _ _ _ _ g2 _ (maGraph _) null); auto; reflexivity.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1 g2 g2' (x, L) (x0, L) x0 l0.
      apply H7; clear H7; auto.

      subst l0.
      f_equal.
      inversion H0.
      destruct H1 as [? _], H2 as [? _].
      rewrite <- H1 in H2.
      rewrite (si_dst1 _ _ _ H2); auto.
      apply (@left_valid _ _ _ _ _ _ g (binGraph _)); auto.
  + eapply is_guarded_BinMaFin'_labeledgraph_add_edge; [auto | | exact H5].
    rewrite Same_set_spec; intro e; simpl.
    rewrite Intersection_spec.
    assert (e = (x0, L) <-> (x0, L) = e) by (split; intros; congruence).
    tauto.
  + simpl.
    unfold update_elabel; simpl.
    destruct_eq_dec (x, L) (x, L); auto; congruence.
  + subst g3'.
    simpl.
    unfold updateEdgeFunc.
    rewrite if_true; reflexivity.
Qed.

Lemma va_labeledgraph_add_edge_left: forall (g g1 g2: Graph) (g1' g2': LGraph) (x l r x0 l0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  is_guarded_BinMaFin' (fun x => x0 <> x) (fun e => ~ In e nil) g2' ->
  vertices_at (Intersection _ (vvalid g2') (fun x => x0 <> x)) g2' = vertices_at (Intersection _ (vvalid (labeledgraph_add_edge g2' (x0, L) x0 l0 (null, L))) (fun x => x0 <> x)) (LGraph_SGraph (labeledgraph_add_edge g2' (x0, L) x0 l0 (null, L))).
Proof.
  intros.
  eapply va_labeledgraph_add_edge_eq'; eauto.
  eapply is_BinMaFin_not_evalid; eauto.
  + eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    subst x0; auto.
  + intros ? [].
Qed.

Lemma va_labeledgraph_egen_left: forall (g2: Graph) (x x0: addr),
  reachable_vertices_at x g2 = reachable_vertices_at x (Graph_egen g2 (x, L) (x0, L)).
Proof.
  intros.
  apply va_labeledgraph_egen_eq.
Qed.

Lemma extend_copy_right: forall (g g1 g2 g3 g4: Graph) (g1' g2' g3': LGraph) (g4'': Graph') (x l r x0 r0: addr) d0,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  copy r g3 g4 g4'' ->
  x0 = LocalGraphCopy.vmap g1 x ->
  (x0, L) = LocalGraphCopy.emap g3 (x, L) ->
  r = null /\ r0 = null \/ r0 = LocalGraphCopy.vmap g4 r ->
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g3' ->
  @derives pred _
  (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g3') (fun x => x0 <> x)) g3' * reachable_vertices_at r0 g4'')
  (EX g4': LGraph,
    !! (extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') /\ is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g4') &&
   (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g4') (fun x => x0 <> x)) g4')).
Proof.
  intros.
  rename H8 into BMF.
  inversion H0.
  pose proof @vcopy1_edge_copy_list_weak_copy_extended_copy' _ _ _ _ _ _ _ _ _ _ BinMaFin'_Normal x ((x, L) :: (x, R) :: nil) ((x, L) :: nil) (x, R) nil g g1 g3 g1' g3' g4 g4'' x0 H.
  spec H8; [simpl; unfold Complement, Ensembles.In; congruence |].
  spec H8; [reflexivity |].
  spec H8; [intros; apply (binGraph_out_edges g (binGraph _)); auto |].
  spec H8; [repeat constructor; intro HH; inversion HH; inversion H12 |].
  spec H8; [auto |].
  spec H8.
  1: {
    unfold edge_copy_list; simpl map.
    split_relation_list (@nil (@LGraph _ addr (addr * LR) unit * @LGraph _ addr (addr * LR) unit)).
    unfold edge_copy.
    split_relation_list ((g2: LGraph, g2') :: nil); auto.
    rewrite H10; auto.
  }
  spec H8; [subst r; auto |].
  spec H8; [subst r; auto |].

  unfold reachable_vertices_at.
  pose proof vertices_at_sepcon_unique_1x (Graph_PointwiseGraph g4'') x0 (reachable g4'' r0) d0.
  pose proof vertices_at_sepcon_unique_xx g3' (Graph_PointwiseGraph g4'') (Intersection _ (vvalid g3') (fun x => x0 <> x)) (reachable g4'' r0).

  rewrite sepcon_assoc, (add_andp _ _ H13); normalize.
  rewrite (sepcon_comm (vertices_at _ _)), <- sepcon_assoc, (add_andp _ _ H12); normalize.
  clear H12 H13.
  spec H8.
  1: {
    apply is_BinMaFin_disjoint_guard with (x0 := x0) (es0 := (x0, L) :: nil); auto.
    + eapply ecopy1_vvalid_mono in H3; [exact H3 |].
      eapply extended_copy_vvalid_mono in H2; [exact H2 |].
      eapply vcopy1_copied_root_valid in H1; auto.
      subst x0; auto.
    + intros ? [? | []].
      subst e; auto.
    + apply (vmap_weaken g3 g4'') in H7.
      rewrite (copy_vvalid_weak_eq g3 g4 g4'' r r0 H7 H4).
      apply Disjoint_comm.
      apply (Disjoint_x1' _ _ _ H14 H15).
  }

  unfold map in H8. rewrite H6 in BMF.
  specialize (H8 BMF).
  specialize (H8 (Graph'_is_BinMaFin' _)).

  destruct H8 as [g4' [? [? [? ?]]]].
  apply (exp_right g4').

  pose proof vertex_at_not_null x0 d0.
  rewrite (add_andp _ _ H17) at 1.
  rewrite andp_comm, !sepcon_andp_prop'.
  apply derives_extract_prop.
  intro.
  clear H17. assert (x0 <> null) by congruence; clear H18.

  pose proof (extend_copy_emap_root g g1 g3 g4 g1' g3' g4' x ((x, L) :: (x, R) :: nil) ((x, L) :: nil) (x, R) nil H).
  spec H18; [simpl; unfold Complement, Ensembles.In; congruence |].
  spec H18; [reflexivity |].
  spec H18; [intros; apply (binGraph_out_edges g (binGraph _)); auto |].
  spec H18; [repeat constructor; intro HH; inversion HH; inversion H19 |].
  spec H18; [auto |].
  spec H18.
  1: {
    unfold edge_copy_list; simpl map.
    split_relation_list (@nil (@LGraph _ addr (addr * LR) unit * @LGraph _ addr (addr * LR) unit)).
    unfold edge_copy.
    split_relation_list ((g2: LGraph, g2') :: nil); auto.
    rewrite H10; auto.
  }
  spec H18; [subst r; auto |].
  rewrite H6.
  replace ((@LocalGraphCopy.emap _ _ _ _ _ _ _ _ _ _ _ _ GMS g3 (x, L)) :: nil) with (LocalGraphCopy.emap g4 (x, L) :: nil) by (symmetry; auto).
  simpl in H18.

  apply andp_right; [apply prop_right; split; auto | rewrite sepcon_assoc; apply sepcon_derives; auto].
  assert (Prop_join (vvalid g3') (vvalid g4'') (vvalid g4')).
  1: {
    eapply copy_and_extended_copy; eauto.
    rewrite <- H11; auto.
  }
  assert (Prop_join (Intersection addr (vvalid g3') (fun x1 : addr => x0 <> x1))
                (vvalid g4'')
                (Intersection addr (vvalid g4') (fun x1 : addr => x0 <> x1))) as HPJ1.
  1: {
    apply Prop_join_shrink1; auto.
    eapply ecopy1_vvalid_mono in H3; [exact H3 |].
    eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    rewrite H5; auto.
  }
  rewrite (vertices_at_vertices_identical (Graph_PointwiseGraph g4'') (LGraph_SGraph g4')).
  rewrite (vertices_at_vertices_identical (LGraph_SGraph g3') (LGraph_SGraph g4')).
  + erewrite vertices_at_sepcon_xx; [apply derives_refl |].
    rewrite Prop_join_comm.
    apply (vmap_weaken g3 g4'') in H7.
    rewrite <- (copy_vvalid_weak_eq g3 g4 g4'' r r0 H7 H4).
    auto.
  + rewrite <- H5 in H16.
    apply H16.
    - unfold Included, Ensembles.In; intros.
      destruct BMF as [BMF _].
      pose (pg1 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e (LocalGraphCopy.emap g3 (x, L) :: nil)) g3') BMF: Graph').
      assert (vvalid pg1 x1) by (simpl; auto).
      apply vvalid_vguard' in H21.
      simpl in H21.
      rewrite !Intersection_spec in H21.
      simpl; tauto.
    - unfold Included, Ensembles.In; intros.
      destruct H12 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e (LocalGraphCopy.emap g4 (x, L) :: nil)) g4') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite (proj1 HPJ1); tauto.
      apply vvalid_vguard' in H12.
      simpl in H12.
      rewrite !Intersection_spec in H12.
      simpl; tauto.
  + apply (vmap_weaken g3 g4'') in H7.
    pose proof copy_vvalid_weak_eq _ _ _ _ _ H7 H4.
    rewrite <- H20.
    apply H13.
    - intros ? ?; apply vvalid_vguard'; auto.
    - unfold Included, Ensembles.In; intros.
      destruct H12 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BinMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e _) g4') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite (proj1 HPJ1). tauto.
      apply vvalid_vguard' in H12.
      simpl in H12.
      rewrite !Intersection_spec in H12.
      simpl; tauto.
Qed.

Lemma labeledgraph_add_edge_ecopy1_right: forall (g g1 g2 g3 g4: Graph) (g1' g2' g3' g4': LGraph) (x l r x0 r0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  (x0, L) = LocalGraphCopy.emap g3 (x, L) ->
  r = null /\ r0 = null \/ r0 = LocalGraphCopy.vmap g4 r ->
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g4' ->
  x0 <> null ->
  let g5 := Graph_egen g4 (x, R) (x0, R): Graph in
  let g5' := labeledgraph_add_edge g4' (x0, R) x0 r0 (null, L): LGraph in
  ecopy1 (x, R) (g4: LGraph, g4') (g5: LGraph, g5') /\
  is_guarded_BinMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: (x0, R) :: nil)) g5' /\
  (x0, R) = LocalGraphCopy.emap g5 (x, R) /\
  dst g5' (x0, R) = r0.
Proof.
  intros.
  unfold ecopy1.
  assert (~ evalid g4' (x0, R)) as HH.
  1: {
    eapply is_BinMaFin_not_evalid; eauto.
    + eapply extended_copy_vvalid_mono in H4; [exact H4 |].
      eapply ecopy1_vvalid_mono in H3; [exact H3 |].
      eapply extended_copy_vvalid_mono in H2; [exact H2 |].
      eapply vcopy1_copied_root_valid in H1; auto.
      subst x0; auto.
    + intros ? [? | []].
      subst e; auto.
    + intros [? | []].
      inversion H10.
  }
  split; [split; [| split] | split; [| split]].
  + reflexivity.
  + apply WeakMarkGraph.labeledgraph_egen_do_nothing.
  + assert (g ~=~ g4) as HH0.
    1: {
      destruct H1 as [? _], H2 as [? _], H3 as [? _], H4 as [? _].
      rewrite <- H4, <- H3, <- H2, <- H1; reflexivity.
    }
    assert (x0 = LocalGraphCopy.vmap g4 (src g4 (x, R))) as HH1.
    1: {
      rewrite left_right_sound by (rewrite <- (proj1 HH0); auto).
      subst x0.
      assert (WeakMarkGraph.marked g1 x).
      1: {
        destruct H1 as [_ [? _]].
        destruct H1 as [_ [? _]]; auto.
      }
      assert (WeakMarkGraph.marked g3 x).
      1: {
        destruct H3 as [_ [? _]].
        rewrite <- (proj2 H3).
        eapply WeakMarkGraph.mark_marked; [destruct H2 as [_ [H2 _]]; exact H2 | auto].
      }
      rewrite (extended_copy_vmap_root g1 g2 g1' g2' l x) by auto.
      rewrite (ecopy1_vmap_root g2 g3 g2' g3' (x, L) x H3).
      rewrite (extended_copy_vmap_root g3 g4 g3' g4' r x) by auto.
      reflexivity.
    }
    destruct H7.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1_not_vvalid g4 g4' (x, R) (x0, R) x0 r0.
      apply H10; clear H10; auto.
      * destruct H7.
        subst r0.
        destruct H8 as [[? ? ?] _].
        pose proof @valid_not_null' _ _ _ _ (gpredicate_sub_labeledgraph (fun v : addr => x0 <> v)
            (fun e : addr * LR => ~ In e ((x0, L) :: nil)) g4') _ ma' null.
        intro.
        apply H8; [| reflexivity].
        simpl.
        rewrite Intersection_spec; split; auto.
      * inversion H0.
        rewrite <- (si_dst1 _ _ _ HH0); [| apply (@right_valid _ _ _ _ _ _ g (binGraph _)); auto].
        destruct H7; rewrite H13; subst r.
        intro.
        apply (@valid_not_null _ _ _ _ g4 _ (maGraph _) null); auto; reflexivity.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1 g4 g4' (x, R) (x0, R) x0 r0.
      apply H10; clear H10; auto.

      subst r0.
      f_equal.
      inversion H0.
      rewrite (si_dst1 _ _ _ HH0); auto.
      apply (@right_valid _ _ _ _ _ _ g (binGraph _)); auto.
  + eapply is_guarded_BinMaFin'_labeledgraph_add_edge; [auto | | exact H8].
    rewrite Same_set_spec; intro e; simpl.
    rewrite Intersection_spec.
    assert (e = (x0, R) <-> (x0, R) = e) by (split; intros; congruence).
    tauto.
  + simpl.
    unfold update_elabel; simpl.
    destruct_eq_dec (x, R) (x, R); auto; congruence.
  + subst g5'.
    simpl.
    unfold updateEdgeFunc.
    rewrite if_true; reflexivity.
Qed.

Lemma va_labeledgraph_add_edge_right: forall (g g1 g2 g3 g4: Graph) (g1' g2' g3' g4': LGraph) (x l r x0 r0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  is_guarded_BinMaFin' (fun x => x0 <> x) (fun e => ~ In e ((x0, L) :: nil)) g4' ->
  vertices_at (Intersection _ (vvalid g4') (fun x => x0 <> x)) g4' = vertices_at (Intersection _ (vvalid (labeledgraph_add_edge g4' (x0, R) x0 r0 (null, L))) (fun x => x0 <> x)) (LGraph_SGraph (labeledgraph_add_edge g4' (x0, R) x0 r0 (null, L))).
Proof.
  intros.
  eapply va_labeledgraph_add_edge_eq'; eauto.
  eapply is_BinMaFin_not_evalid; eauto.
  + eapply extended_copy_vvalid_mono in H4; [exact H4 |].
    eapply ecopy1_vvalid_mono in H3; [exact H3 |].
    eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    subst x0; auto.
  + intros ? [? | []].
    subst e; auto.
  + intros [? | []].
    inversion H7.
Qed.

Lemma va_labeledgraph_egen_right: forall (g2: Graph) (x x0: addr),
  reachable_vertices_at x g2 = reachable_vertices_at x (Graph_egen g2 (x, R) (x0, R)).
Proof.
  intros.
  apply va_labeledgraph_egen_eq.
Qed.

Lemma copy_final: forall (g g1 g2 g3 g4 g5: Graph) (g1' g2' g3' g4' g5': LGraph) x l r x0 l0 r0,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  x0 = LocalGraphCopy.vmap g1 x ->
  l = null /\ l0 = null \/ l0 = LocalGraphCopy.vmap g2 l ->
  forall (H999: dst g3' (x0, L) = l0),
  (x0, L) = LocalGraphCopy.emap g3 (x, L) ->
  r = null /\ r0 = null \/ r0 = LocalGraphCopy.vmap g4 r ->
  forall (H998: dst g5' (x0, R) = r0),
  (x0, R) = LocalGraphCopy.emap g5 (x, R) ->
  is_guarded_BinMaFin'
    (fun v => x0 <> v)
    (fun e => ~ In e ((x0, L) :: (x0, R) :: nil)) g5' ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') ->
  ecopy1 (x, R) (g4: LGraph, g4') (g5: LGraph, g5') ->
  @derives pred _
  (vertex_at x0 (null, l0, r0) * vertices_at (Intersection _ (vvalid g5') (fun v => x0 <> v)) g5')
  (EX gg5': Graph',
  !! (copy x g g5 gg5' /\ LocalGraphCopy.vmap g1 x = LocalGraphCopy.vmap g5 x) && reachable_vertices_at x0 gg5').
Proof.
  intros.
  assert (copy x g g5 g5').
  {
    eapply vcopy1_edge_copy_list_copy.
    + assumption.
    + simpl in H0 |- *; unfold Complement, Ensembles.In. congruence.
    + intros; apply (binGraph_out_edges g (binGraph _)); auto.
    + repeat constructor; intro HH; inversion HH; inversion H12.
    + exact H7.
    + hnf.
      exists (g3: LGraph, g3').
      - exists (g1: LGraph, g1'); auto.
        exists (g2: LGraph, g2').
        * exists (g1: LGraph, g1'); auto.
          simpl in H0.
          inversion H0.
          rewrite H14.
          exact H8.
        * exact H9.
      - hnf.
        exists (g4: LGraph, g4').
        * exists (g3: LGraph, g3'); auto.
          simpl in H0.
          inversion H0.
          rewrite H15.
          exact H10.
        * exact H11.
  }
  rewrite (add_andp _ _ (vertex_at_not_null x0 (null, l0, r0))).
  normalize.
  assert (x0 <> null) as LOCAL' by congruence; clear H13.

  assert (LocalGraphCopy.vmap g5 x = x0 /\
          src g5' (x0, L) = x0 /\
          src g5' (x0, R) = x0 /\
          dst g5' (x0, L) = l0 /\
          dst g5' (x0, R) = r0 /\
          evalid g5' (x0, L) /\
          evalid g5' (x0, R) /\
          vvalid g5' x0) as LOCAL.
  {
    pose proof fun H => extended_copy_vmap_root _ _ _ _ _ x H H8 as Hvmap12.
    specialize (Hvmap12 ltac:(simpl in H1 |- *; subst x0; congruence)).
    pose proof ecopy1_vmap_root _ _ _ _ _ x H9 as Hvmap23.
    pose proof fun H => extended_copy_vmap_root _ _ _ _ _ x H H10 as Hvmap34.
    specialize (Hvmap34 ltac:(simpl in H1, Hvmap12, Hvmap23 |- *; subst x0; congruence)).
    pose proof ecopy1_vmap_root _ _ _ _ _ x H11 as Hvmap45.
    split; [congruence |].
    pose proof vcopy1_copied_root_valid _ _ _ _ _ H7 H1 as Hx0_g5'.
    apply (extended_copy_vvalid_mono _ _ _ _ _ _ H8) in Hx0_g5'.
    apply (ecopy1_vvalid_mono _ _ _ _ _ _ H9) in Hx0_g5'.
    apply (extended_copy_vvalid_mono _ _ _ _ _ _ H10) in Hx0_g5'.
    apply (ecopy1_vvalid_mono _ _ _ _ _ _ H11) in Hx0_g5'.
    assert (vvalid g2 x) as Hx_g2.
    {
      rewrite <- (proj1 (proj1 H8)), <- (proj1 (proj1 H7)).
      auto.
    }
    assert (vvalid g3 x) as Hx_g3.
    {
      rewrite <- (proj1 (proj1 H9)).
      auto.
    }
    assert (vvalid g4 x) as Hx_g4.
    {
      rewrite <- (proj1 (proj1 H10)).
      auto.
    }
    assert (vvalid g5 x) as Hx_g5.
    {
      rewrite <- (proj1 (proj1 H11)).
      auto.
    }
    assert (src g3' (x0, L) = x0 /\ dst g3' (x0, L) = l0 /\ evalid g3' (x0, L)) as [Hx0L_src [Hx0L_dst Hx0L_v]].
    {
      destruct H9 as [_ [_ ?]].
      destruct H9 as [? [? [? [? [? ?]]]]].
      destruct H15 as [_ [? _]].
      destruct H15 as [? _].
      rewrite (H15 (x0, L)).
      rewrite left_right_sound in H16 by auto.
      rewrite <- H3 in *.
      rewrite <- H16 by auto.
      simpl in H0; inversion H0.
      split; [congruence | split; tauto].
    }
    pose proof (extended_copy_evalid_mono _ _ _ _ _ _ H10 Hx0L_v) as Hx0L_v'.
    pose proof proj2 (proj2 H10).
    destruct H13 as [_ [_ [_ [? [_ _]]]]].
    destruct H13 as [_ [_ [? ?]]].
    rewrite H13 in Hx0L_src by auto.
    rewrite H14 in Hx0L_dst by auto.
    clear H13 H14 Hx0L_v; rename Hx0L_v' into Hx0L_v.
    pose proof (ecopy1_evalid_mono _ _ _ _ _ _ H11 Hx0L_v) as Hx0L_v'.
    pose proof proj2 (proj2 H11).
    destruct H13 as [_ [_ [_ [? [_ _]]]]].
    destruct H13 as [_ [_ [? ?]]].
    rewrite H13 in Hx0L_src by auto.
    rewrite H14 in Hx0L_dst by auto.
    clear H13 H14 Hx0L_v; rename Hx0L_v' into Hx0L_v.
    assert (src g5' (x0, R) = x0 /\ dst g5' (x0, R) = r0 /\ evalid g5' (x0, R)) as [Hx0R_src [Hx0R_dst Hx0R_v]].
    {
      destruct H11 as [_ [_ ?]].
      destruct H11 as [? [? [? [? [? ?]]]]].
      destruct H15 as [_ [? _]].
      destruct H15 as [? _].
      rewrite (H15 (x0, R)).
      rewrite left_right_sound in H16 by auto.
      rewrite <- H5 in *.
      rewrite <- H16 by auto.
      simpl in H0; inversion H0.
      split; [congruence | split; tauto].
    }
    tauto.
  }
  pose proof H6.
  destruct H13 as [? _].
  assert (BinMaFin' g5').
  {
    constructor.
    + constructor.
      - intros.
        congruence.
      - intros.
        destruct (classic (x0 = x2)).
        * subst x2.
          destruct (classic (e = (x0, L))); [| destruct (classic (e = (x0, R)))].
         ++ subst e; tauto.
         ++ subst e; tauto.
         ++ split; [intros [? ?]; exfalso | tauto].
            pose proof @ma' _ _ x1.
            pose proof @valid_graph' _ _ _ _ _ _ H18 e.
            simpl in H19.
            rewrite !Intersection_spec in H19.
            specialize (H19 ltac:(pose proof @eq_sym _ (x0, L) e; pose proof @eq_sym _ (x0, R) e; tauto)).
            rewrite H16 in H19. tauto.
        * pose proof @bin' _ _ x1.
          pose proof @only_two_edges _ _ _ _ _ _ _ H15 x2 e.
          simpl in H16.
          rewrite !Intersection_spec in H16.
          specialize (H16 ltac:(tauto)).
          rewrite <- H16; split; [| tauto].
          intros [? ?]; repeat split; auto.
          intros [| [| []]]; subst e; rewrite <- H17 in H14; apply H14; symmetry; tauto.
    + constructor.
      - intros.
        destruct (classic ((x0, L) = e)); [| destruct (classic ((x0, R) = e))].
        * unfold is_null_SGBA; simpl.
          subst e.
          replace (src g5' (x0, L)) with x0 by (symmetry; tauto).
          tauto.
        * unfold is_null_SGBA; simpl.
          subst e.
          replace (src g5' (x0, R)) with x0 by (symmetry; tauto).
          tauto.
        * pose proof @ma' _ _ x1.
          pose proof @valid_graph' _ _ _ _ _ _ H16.
          unfold weak_valid in H17.
          simpl in H17.
          specialize (H17 e).
          rewrite !Intersection_spec in H17.
          specialize (H17 ltac:(tauto)).
          tauto.
      - intros.
        pose proof @ma' _ _ x1.
        pose proof @valid_not_null' _ _ _ _ _ _ H15.
        specialize (H16 x2).
        simpl in H16.
        rewrite Intersection_spec in H16.
        destruct (classic (x0 = x2)); [subst x2 |]; tauto.
    + assert (FiniteGraph
           (gpredicate_sub_labeledgraph (fun v : addr => x0 = v)
              (fun e : addr * LR => In e ((x0, L) :: (x0, R) :: nil)) g5')).
      {
        constructor; simpl.
        - exists (x0 :: nil).
          split; [repeat constructor; intros [] |].
          intros.
          rewrite Intersection_spec.
          split; intros.
          * destruct H13 as [|[]].
            subst x2.
            tauto.
          * left.
            tauto.
        - exists ((x0, L) :: (x0, R) :: nil).
          split; [repeat constructor; [intros [| []]; congruence | intros []] |].
          intros.
          rewrite Intersection_spec.
          split; intros.
          * destruct H13 as [| [| []]];
            subst x2; tauto.
          * simpl. tauto.
      }
      apply (@fin' _ _) in x1.
      pose proof fun H H0 => finite_graph_join g5' _ _ (fun _ => True) _ _ (fun _ => True) H H0 x1 X.
      spec X0.
    {
      split.
      + intros; tauto.
      + intros; tauto.
    }
    spec X0.
    {
      split.
      + intros; tauto.
      + intros; tauto.
    }
    pose proof @gpredicate_sub_labeledgraph_equiv _ _ _ _ _ _ _ g5' (fun _ => True) (vvalid g5') (fun _ => True) (evalid g5').
    spec H13.
      { rewrite Same_set_spec; intro; rewrite !Intersection_spec; tauto. }
    spec H13.
      { rewrite Same_set_spec; intro; rewrite !Intersection_spec; tauto. }
    pose proof finite_graph_si _ _ (proj1 H13); clear H13.
    pose proof @gpredicate_sub_labeledgraph_self _ _ _ _ _ _ _ g5'.
    pose proof finite_graph_si _ _ (proj1 H13); clear H13.
    apply X2, X1, X0.
  }
  apply (exp_right (Build_GeneralGraph _ _ _ _ (labeledgraph_vgen g5' x0 null) X)); clear x1.
  apply andp_right.
  + apply prop_right.
    split; auto.
    rewrite <- H1; symmetry; tauto.
  + match goal with
    | |- _ |-- _ ?A => change A with (labeledgraph_vgen g5' x0 null)
    end.
    replace (vertices_at (Intersection addr (vvalid g5') (fun v : addr => x0 <> v)) g5')
      with (vertices_at (Intersection addr (vvalid g5') (fun v : addr => x0 <> v)) (LGraph_SGraph (labeledgraph_vgen g5' x0 null))).
    2: {
       apply vertices_at_vertices_identical.
       rewrite (update_irr _ g5' x0) by (rewrite Intersection_spec; tauto).
       apply (GSG_VGenPreserve (Intersection addr (vvalid g5') (fun v : addr => x0 <> v)) g5').
       + reflexivity.
       + unfold Included, Ensembles.In; intro; rewrite Intersection_spec.
         intros [? _]. apply (vvalid_vguard' (Build_GeneralGraph _ _ _ _ g5' X)), H13.
       + unfold Included, Ensembles.In; intro; rewrite Intersection_spec.
         intros [? _]. apply (vvalid_vguard' (Build_GeneralGraph _ _ _ _ g5' X)), H13.
    }
    change (vvalid g5') with (vvalid (labeledgraph_vgen g5' x0 null)).
    apply derives_refl', vertices_at_sepcon_1x.
    - apply Prop_join_comm.
      rewrite <- copy_vvalid_weak_eq; [apply Ensemble_join_Intersection_Complement | .. | exact H12].
      * unfold Included, Ensembles.In; intros; subst; tauto.
      * intros; tauto.
      * right; symmetry; tauto.
    - change (vgamma (Graph_PointwiseGraph (labeledgraph_vgen g5' x0 null)) x0)
        with (vgamma (LGraph_SGraph (labeledgraph_vgen g5' x0 null)) x0).
      simpl.
      unfold update_vlabel. rewrite if_true by reflexivity.
      repeat f_equal; tauto.
Qed.

End PointwiseGraph_Copy_Bin.


Require Import Fiat.Common Fiat.Computation
        Fiat.ADT.ADTSig Fiat.ADT.Core
        Fiat.ADTRefinement.Core Fiat.ADTRefinement.SetoidMorphisms.

Section SimplifyRep.

  (* If a representation has extraneous information (perhaps intermediate
     data introduced during refinement), simplifying the representation
     is a valid refinement. *)

  Variable oldRep : Type. (* The old representation type. *)
  Variable newRep : Type. (* The new representation type. *)

  Variable simplifyf : oldRep -> newRep. (* The simplification function. *)
  Variable concretize : newRep -> oldRep. (* A map to the enriched representation. *)

  (* The abstraction relation between old and new representations. *)
  Variable AbsR : oldRep -> newRep -> Prop.
  Notation "ro ≃ rn" := (AbsR ro rn) (at level 70).

  (*Definition simplifyMethod
             (Dom : list Type)
             (Cod : Type)
             (oldMeth : methodType oldRep Dom Cod)
             r_n n : Comp (newRep * Cod) :=
    (r_o' <- (oldMeth (concretize r_n) n);
     ret (simplifyf (fst r_o'), snd r_o'))%comp.

  Definition simplifyConstructor
             (Dom : Type)
             (oldConstr : constructorType oldRep Dom)
             n : Comp newRep :=
    (or <- oldConstr n;
     ret (simplifyf or))%comp.

  Variable Sig : ADTSig. (* The signature of the ADT being simplified. *)

  Definition simplifyRep oldConstr oldMeths :
    (forall r_o, r_o ≃ simplifyf r_o) ->
    (forall r_n r_o,
       (r_o ≃ r_n) ->
       forall idx n,
         refineEquiv (r_o'' <- oldMeths idx r_o n;
                      r_n' <- {r_n' | fst r_o'' ≃ r_n'};
                      ret (r_n', snd r_o''))
                     (r_o'' <- oldMeths idx (concretize r_n) n;
                      ret (simplifyf (fst r_o''), snd r_o''))) ->
    refineADT
      (@Build_ADT Sig oldRep oldConstr oldMeths)
      (@Build_ADT Sig newRep
                  (fun idx => simplifyConstructor (oldConstr idx))
                  (fun idx => simplifyMethod (oldMeths idx))).
  Proof.
    econstructor 1 with
    (AbsR := AbsR); simpl; eauto.
    - unfold simplifyConstructor, refine; intros;
      computes_to_inv; repeat computes_to_econstructor; try subst; eauto.
    - unfold simplifyMethod; intros.
      eapply H0; eauto.
  Qed. *)

End SimplifyRep.


From iris.program_logic Require Export language ectx_language ectxi_language.
From iris.program_logic Require Import lifting.
From iris.algebra Require Import auth frac agree gmap list excl.
From F_mu_ref_conc_sub Require Export rules.
From iris.proofmode Require Import tactics.
Import uPred.

Definition specN := nroot .@ "spec".

(** The CMRA for the heap of the specification. *)
Definition tpoolUR : ucmraT := gmapUR nat (exclR (exprO F_mu_ref_conc_lang)).
Definition cfgUR := prodUR tpoolUR (gen_heapUR loc val).

Fixpoint to_tpool_go (i : nat) (tp : list expr) : tpoolUR :=
  match tp with
  | [] => ∅
  | e :: tp => <[i:=Excl e]>(to_tpool_go (S i) tp)
  end.
Definition to_tpool : list expr → tpoolUR := to_tpool_go 0.

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

Section definitionsS.
  Context `{cfgSG Σ, invG Σ}.

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

  Definition tpool_mapsto (j : nat) (e: expr) : iProp Σ :=
    own cfg_name (◯ ({[ j := Excl e ]}, ∅)).

  Definition spec_inv (ρ : cfg F_mu_ref_conc_lang) : iProp Σ :=
    (∃ tp σ, own cfg_name (● (to_tpool tp, to_gen_heap σ))
                 ∗ ⌜rtc erased_step ρ (tp,σ)⌝)%I.
  Definition spec_ctx (ρ : cfg F_mu_ref_conc_lang) : iProp Σ :=
    inv specN (spec_inv ρ).

  Global Instance heapS_mapsto_timeless l q v : Timeless (heapS_mapsto l q v).
  Proof. apply _. Qed.
  Global Instance spec_ctx_persistent ρ : Persistent (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") : bi_scope.
Notation "l ↦ₛ v" := (heapS_mapsto l 1 v) (at level 20) : bi_scope.
Notation "j ⤇ e" := (tpool_mapsto j e) (at level 20) : bi_scope.

Ltac iAsimpl :=
  repeat match goal with
  | |- context [ (_ ⤇ ?e)%I ] => progress (
    let e' := fresh in evar (e':expr);
    assert (e = e') as ->; [asimpl; unfold e'; reflexivity|];
    unfold e'; clear e')
  | |- context [ WP ?e @ _ {{ _ }}%I ] => progress (
    let e' := fresh in evar (e':expr);
    assert (e = e') as ->; [asimpl; unfold e'; reflexivity|];
    unfold e'; clear e')
  end.

Section conversions.
  Context `{cfgSG Σ}.

  (** Conversion to tpools and back *)
  Lemma to_tpool_valid es : ✓ to_tpool es.
  Proof.
    rewrite /to_tpool. move: 0.
    induction es as [|e es]=> n //.
    by apply: insert_valid.
  Qed.

  Lemma tpool_lookup tp j : to_tpool tp !! j = Excl <$> tp !! j.
  Proof.
    cut (∀ i, to_tpool_go i tp !! (i + j) = Excl <$> tp !! j).
    { intros help. apply (help 0). }
    revert j. induction tp as [|e tp IH]=> //= -[|j] i /=.
    - by rewrite Nat.add_0_r lookup_insert.
    - by rewrite -Nat.add_succ_comm lookup_insert_ne; last lia.
  Qed.
  Lemma tpool_lookup_Some tp j e : to_tpool tp !! j = Excl' e → tp !! j = Some e.
  Proof. rewrite tpool_lookup fmap_Some. naive_solver. Qed.
  Hint Resolve tpool_lookup_Some.

  Lemma to_tpool_insert tp j e :
    j < length tp →
    to_tpool (<[j:=e]> tp) = <[j:=Excl e]> (to_tpool tp).
  Proof.
    intros. apply: map_eq=> i. destruct (decide (i = j)) as [->|].
    - by rewrite tpool_lookup lookup_insert list_lookup_insert.
    - rewrite tpool_lookup lookup_insert_ne // list_lookup_insert_ne //.
      by rewrite tpool_lookup.
  Qed.
  Lemma to_tpool_insert' tp j e :
    is_Some (to_tpool tp !! j) →
    to_tpool (<[j:=e]> tp) = <[j:=Excl e]> (to_tpool tp).
  Proof.
    rewrite tpool_lookup fmap_is_Some lookup_lt_is_Some. apply to_tpool_insert.
  Qed.

  Lemma to_tpool_snoc tp e :
    to_tpool (tp ++ [e]) = <[length tp:=Excl e]>(to_tpool tp).
  Proof.
    intros. apply: map_eq=> i.
    destruct (lt_eq_lt_dec i (length tp)) as [[?| ->]|?].
    - rewrite lookup_insert_ne; last lia. by rewrite !tpool_lookup lookup_app_l.
    - by rewrite lookup_insert tpool_lookup lookup_app_r // Nat.sub_diag.
    - rewrite lookup_insert_ne; last lia.
      rewrite !tpool_lookup ?lookup_ge_None_2 ?app_length //=;
         change (ofe_car (exprO F_mu_ref_conc_lang)) with expr; lia.
  Qed.

  Lemma tpool_singleton_included tp j e :
    {[j := Excl e]} ≼ to_tpool tp → tp !! j = Some e.
  Proof.
    move=> /singleton_included [ex [/leibniz_equiv_iff]].
    rewrite tpool_lookup fmap_Some=> [[e' [-> ->]] /Excl_included ?]. by f_equal.
  Qed.
  Lemma tpool_singleton_included' tp j e :
    {[j := Excl e]} ≼ to_tpool tp → to_tpool tp !! j = Excl' e.
  Proof. rewrite tpool_lookup. by move=> /tpool_singleton_included=> ->. Qed.

End conversions.

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

  Local Hint Resolve tpool_lookup.
  Local Hint Resolve tpool_lookup_Some.
  Local Hint Resolve to_tpool_insert.
  Local Hint Resolve to_tpool_insert'.
  Local Hint Resolve tpool_singleton_included.

  Lemma step_insert K tp j e σ κ e' σ' efs :
    tp !! j = Some (fill K e) → head_step e σ κ e' σ' efs →
    erased_step (tp, σ) (<[j:=fill K e']> tp ++ efs, σ').
  Proof.
    intros. rewrite -(take_drop_middle tp j (fill K e)) //.
    rewrite insert_app_r_alt take_length_le ?Nat.sub_diag /=;
      eauto using lookup_lt_Some, Nat.lt_le_incl.
    rewrite -(assoc_L (++)) /=. eexists.
    eapply step_atomic; eauto. by apply: Ectx_step'.
  Qed.

  Lemma step_insert_no_fork K tp j e σ κ e' σ' :
    tp !! j = Some (fill K e) → head_step e σ κ e' σ' [] →
    erased_step (tp, σ) (<[j:=fill K e']> tp, σ').
  Proof. rewrite -(right_id_L [] (++) (<[_:=_]>_)). by apply step_insert. Qed.

  Lemma nsteps_inv_r {A} n (R : A → A → Prop) x y :
    nsteps R (S n) x y → ∃ z, nsteps R n x z ∧ R z y.
  Proof.
    revert x y; induction n; intros x y.
    - inversion 1; subst.
      match goal with H : nsteps _ 0 _ _ |- _ => inversion H end; subst.
      eexists; repeat econstructor; eauto.
    - inversion 1; subst.
      edestruct IHn as [z [? ?]]; eauto.
      exists z; split; eauto using nsteps_l.
  Qed.

  Lemma step_pure' E ρ j K e e' (P : Prop) n :
    P →
    PureExec P n e e' →
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K e ={E}=∗ j ⤇ fill K e'.
  Proof.
    iIntros (HP Hex ?) "[#Hspec Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as (tp σ) ">[Hown Hrtc]" "Hclose".
    iDestruct "Hrtc" as %Hrtc.
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[Htpj%tpool_singleton_included' _]%prod_included ?]%auth_both_valid.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
                                       _ (Excl (fill K e'))). }
    iFrame "Hj". iApply "Hclose". iNext. iExists (<[j:=fill K e']> tp), σ.
    rewrite to_tpool_insert'; last eauto.
    iFrame. iPureIntro.
    apply rtc_nsteps in Hrtc; destruct Hrtc as [m Hrtc].
    specialize (Hex HP). apply (nsteps_rtc (m + n)).
    eapply nsteps_trans; eauto.
    revert e e' Htpj Hex.
    induction n => e e' Htpj Hex.
    - inversion Hex; subst.
      rewrite list_insert_id; eauto. econstructor.
    - apply nsteps_inv_r in Hex.
      destruct Hex as [z [Hex1 Hex2]].
      specialize (IHn _ _ Htpj Hex1).
      eapply nsteps_r; eauto.
      replace (<[j:=fill K e']> tp) with
          (<[j:=fill K e']> (<[j:=fill K z]> tp)); last first.
      { clear. revert tp; induction j; intros tp.
        - destruct tp; trivial.
        - destruct tp; simpl; auto. by rewrite IHj. }
      destruct Hex2 as [Hexs Hexd].
      specialize (Hexs σ). destruct Hexs as [e'' [σ' [efs Hexs]]].
      specialize (Hexd σ [] e'' σ' efs Hexs); destruct Hexd as [? [? [? ?]]];
        subst.
      inversion Hexs; simpl in *; subst.
      rewrite -!fill_app.
      eapply step_insert_no_fork; eauto.
      { apply list_lookup_insert. apply lookup_lt_is_Some; eauto. }
  Qed.

  Lemma do_step_pure E ρ j K e e' `{!PureExec True 1 e e'}:
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K e ={E}=∗ j ⤇ fill K e'.
  Proof. by eapply step_pure'; last eauto. Qed.

  Lemma step_alloc E ρ j K e v:
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Alloc e) ={E}=∗ ∃ l, j ⤇ fill K (Loc l) ∗ l ↦ₛ v.
  Proof.
    iIntros (??) "[#Hinv Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as (tp σ) ">[Hown %]" "Hclose".
    destruct (exist_fresh (dom (gset positive) σ)) as [l Hl%not_elem_of_dom].
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[?%tpool_singleton_included' _]%prod_included ?]%auth_both_valid.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
                                    _ (Excl (fill K (Loc l)))). }
    iMod (own_update with "Hown") as "[Hown Hl]".
    { eapply auth_update_alloc, prod_local_update_2.
      apply (alloc_singleton_local_update (A := (prodR _ (agreeR (valO _))))
                                          _ l (1%Qp, to_agree v)); last done.
      by apply lookup_to_gen_heap_None. }
    iExists l. rewrite /heapS_mapsto. iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (<[j:=fill K (Loc l)]> tp), (<[l:=v]>σ).
    rewrite to_gen_heap_insert to_tpool_insert'; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_load E ρ j K l q v:
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Load (Loc l)) ∗ l ↦ₛ{q} v
    ={E}=∗ j ⤇ fill K (of_val v) ∗ l ↦ₛ{q} v.
  Proof.
    iIntros (?) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as (tp σ) ">[Hown %]" "Hclose".
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[?%tpool_singleton_included' _]%prod_included ?]%auth_both_valid.
    iDestruct (own_valid_2 with "Hown Hl")
      as %[[? ?%gen_heap_singleton_included]%prod_included ?]%auth_both_valid.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
                                    _ (Excl (fill K (of_val v)))). }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (<[j:=fill K (of_val v)]> tp), σ.
    rewrite to_tpool_insert'; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_store E ρ j K l v' e v:
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Store (Loc l) e) ∗ l ↦ₛ v'
    ={E}=∗ j ⤇ fill K Unit ∗ l ↦ₛ v.
  Proof.
    iIntros (??) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as (tp σ) ">[Hown %]" "Hclose".
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[?%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
    iDestruct (own_valid_2 with "Hown Hl")
      as %[[_ Hl%gen_heap_singleton_included]%prod_included _]%auth_both_valid.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
                                       _ (Excl (fill K Unit))). }
    iMod (own_update_2 with "Hown Hl") as "[Hown Hl]".
    { eapply auth_update, prod_local_update_2.
      apply: singleton_local_update.
      { by rewrite /to_gen_heap lookup_fmap Hl. }
        by apply (exclusive_local_update (A := prodR _ (agreeR (valO _)))
                                    _ (1%Qp, to_agree v)). }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (<[j:=fill K Unit]> tp), (<[l:=v]>σ).
    rewrite to_gen_heap_insert to_tpool_insert'; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_cas_fail E ρ j K l q v' e1 v1 e2 v2:
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E → v' ≠ v1 →
    spec_ctx ρ ∗ j ⤇ fill K (CAS (Loc l) e1 e2) ∗ l ↦ₛ{q} v'
    ={E}=∗ j ⤇ fill K (#♭ false) ∗ l ↦ₛ{q} v'.
  Proof.
    iIntros (????) "(#Hinv & Hj & Hl)".
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as (tp σ) ">[Hown %]" "Hclose".
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[?%tpool_singleton_included' _]%prod_included ?]%auth_both_valid.
    iDestruct (own_valid_2 with "Hown Hl")
      as %[[_ ?%gen_heap_singleton_included]%prod_included _]%auth_both_valid.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
                                    _ (Excl (fill K (#♭ false)))). }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (<[j:=fill K (#♭ false)]> tp), σ.
    rewrite to_tpool_insert'; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_cas_suc E ρ j K l e1 v1 v1' e2 v2:
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E → v1 = v1' →
    spec_ctx ρ ∗ j ⤇ fill K (CAS (Loc l) e1 e2) ∗ l ↦ₛ v1'
    ={E}=∗ j ⤇ fill K (#♭ true) ∗ l ↦ₛ v2.
  Proof.
    iIntros (????) "(#Hinv & Hj & Hl)"; subst.
    rewrite /spec_ctx /tpool_mapsto /heapS_mapsto.
    iInv specN as (tp σ) ">[Hown %]" "Hclose".
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[?%tpool_singleton_included' _]%prod_included _]%auth_both_valid.
    iDestruct (own_valid_2 with "Hown Hl")
      as %[[_ Hl%gen_heap_singleton_included]%prod_included _]%auth_both_valid.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
            _ (Excl (fill K (#♭ true)))). }
    iMod (own_update_2 with "Hown Hl") as "[Hown Hl]".
    { eapply auth_update, prod_local_update_2.
      apply: singleton_local_update.
      { by rewrite /to_gen_heap lookup_fmap Hl. }
        by apply (exclusive_local_update (A := prodR _ (agreeR (valO _)))
                                    _ (1%Qp, to_agree v2)). }
    iFrame "Hj Hl". iApply "Hclose". iNext.
    iExists (<[j:=fill K (#♭ true)]> tp), (<[l:=v2]>σ).
    rewrite to_gen_heap_insert to_tpool_insert'; last eauto. iFrame. iPureIntro.
    eapply rtc_r, step_insert_no_fork; eauto. econstructor; eauto.
  Qed.

  Lemma step_rec E ρ j K e1 e2 v :
    to_val e2 = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (App (Rec e1) e2)
    ={E}=∗ j ⤇ fill K (e1.[Rec e1,e2/]).
  Proof. by intros ?; apply: do_step_pure. Qed.

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

  Lemma step_letin E ρ j K e1 e2 v :
    to_val e1 = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (LetIn e1 e2)
    ={E}=∗ j ⤇ fill K (e2.[e1/]).
  Proof. by intros ?; apply: do_step_pure. Qed.

  Lemma step_seq E ρ j K e1 e2 v :
    to_val e1 = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Seq e1 e2)
    ={E}=∗ j ⤇ fill K e2.
  Proof. by intros ?; apply: do_step_pure. Qed.

  Lemma step_tlam E ρ j K e :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (TApp (TLam e)) ={E}=∗ j ⤇ fill K e.
  Proof. by intros ?; apply: do_step_pure. Qed.

  Lemma step_Fold E ρ j K e v :
    to_val e = Some v → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Unfold (Fold e)) ={E}=∗ j ⤇ fill K e.
  Proof. by intros ?; apply: do_step_pure. Qed.

  Lemma step_fst E ρ j K e1 v1 e2 v2 :
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Fst (Pair e1 e2)) ={E}=∗ j ⤇ fill K e1.
  Proof. by intros; apply: do_step_pure. Qed.

  Lemma step_snd E ρ j K e1 v1 e2 v2 :
    to_val e1 = Some v1 → to_val e2 = Some v2 → nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Snd (Pair e1 e2)) ={E}=∗ j ⤇ fill K e2.
  Proof. by intros; apply: do_step_pure. Qed.

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

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

  Lemma step_if_false E ρ j K e1 e2 :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (If (#♭ false) e1 e2) ={E}=∗ j ⤇ fill K e2.
  Proof. by intros; apply: do_step_pure. Qed.

  Lemma step_if_true E ρ j K e1 e2 :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (If (#♭ true) e1 e2) ={E}=∗ j ⤇ fill K e1.
  Proof. by intros; apply: do_step_pure. Qed.

  Lemma step_nat_binop E ρ j K op a b :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (BinOp op (#n a) (#n b))
      ={E}=∗ j ⤇ fill K (of_val (binop_eval op a b)).
  Proof. by intros; apply: do_step_pure. Qed.

  Lemma step_fork E ρ j K e :
    nclose specN ⊆ E →
    spec_ctx ρ ∗ j ⤇ fill K (Fork e) ={E}=∗ ∃ j', j ⤇ fill K Unit ∗ j' ⤇ e.
  Proof.
    iIntros (?) "[#Hspec Hj]". rewrite /spec_ctx /tpool_mapsto.
    iInv specN as (tp σ) ">[Hown %]" "Hclose".
    iDestruct (own_valid_2 with "Hown Hj")
      as %[[?%tpool_singleton_included' _]%prod_included ?]%auth_both_valid.
    assert (j < length tp) by eauto using lookup_lt_Some.
    iMod (own_update_2 with "Hown Hj") as "[Hown Hj]".
    { eapply auth_update, prod_local_update_1.
      apply: singleton_local_update; first done.
      by apply (exclusive_local_update (A := exclR (exprO _))
                                    _ (Excl (fill K Unit))). }
    iMod (own_update with "Hown") as "[Hown Hfork]".
    { eapply auth_update_alloc, prod_local_update_1.
      apply (alloc_singleton_local_update (A := exclR (exprO _))
                                          _ (length tp) (Excl e)); last done.
      rewrite lookup_insert_ne ?tpool_lookup; last lia.
      by rewrite lookup_ge_None_2. }
    iExists (length tp). iFrame "Hj Hfork". iApply "Hclose". iNext.
    iExists (<[j:=fill K Unit]> tp ++ [e]), σ.
    rewrite to_tpool_snoc insert_length to_tpool_insert //. iFrame. iPureIntro.
    eapply rtc_r, step_insert; eauto. econstructor; eauto.
  Qed.
End cfg.


From CE Require Export Aux.

Import ListNotations.

Import Lia.

Definition set_second {A B C : Type} (p : A * B * C) (b : B) : A * B * C :=
match p with
| (a, b0, c) => (a, b, c)
end.

(* I can't import stdlib implementation somehow *)
Definition list_sum l := fold_right plus 0 l.

Fixpoint exp_size (e : Expression) : nat :=
match e with
 | ELit l => 1
 | EVar v => 1
 | EFunId f => 1
 | EFun vl e => 1
(*  | ECons hd tl => 1 + exp_size hd + exp_size tl *)
(*  | ETuple l => 1 + list_sum (map exp_size l) *)
 | ECall f l => 1 + list_sum (map exp_size l)
 | EApp exp l => 1 + list_sum (map exp_size l) + exp_size exp
(*  | ECase e l => 1 + exp_size e + fold_right (fun '(a, b, c) r => r + exp_size b + exp_size c) 0 l *)
 | ELet v e1 e2 => 1 + exp_size e1 + exp_size e2
 | ELetRec f l b e => 1 + exp_size e
 | ETry e1 v1 e2 vl2 e3 => 1 + exp_size e1 + exp_size e2 + exp_size e3
end.

Fixpoint eval_list (f: Environment -> nat -> Expression -> SideEffectList -> nat -> option (nat * (Value + Exception) * SideEffectList)) (env : Environment) (id : nat) (exps : list Expression) (eff : SideEffectList) (clock : nat) : option (nat * ((list Value) + Exception) * SideEffectList) :=
 match exps with
 | []    => Some (id, inl [], eff)
 | x::xs => match f env id x eff clock with
            | Some (id', inl v , eff') =>
              let res := eval_list f env id' xs eff' clock in
                match res with
                | Some (id'', inl xs', eff'') => Some (id'', inl (v::xs'), eff'')
                | r => r
                end
            | Some (id', inr ex, eff') => Some (id', inr ex, eff')
            | None => None
            end
 end
 .

Fixpoint list_eqb {A : Type} (eq : A -> A -> bool) (l1 l2 : list A) : bool :=
match l1, l2 with
| [], [] => true
| x::xs, y::ys => eq x y && list_eqb eq xs ys
| _, _ => false
end.

Definition effect_id_eqb (id1 id2 : SideEffectId) : bool :=
match id1, id2 with
 | Input, Input => true
 | Output, Output => true
 | _, _ => false
end.

Definition effect_eqb (e1 e2 : SideEffectId * list Value) : bool :=
match e1, e2 with
| (id1, vals1), (id2, vals2) => effect_id_eqb id1 id2 && list_eqb Value_eqb vals1 vals2
end.

Inductive ResultType : Type :=
| Result (id : nat) (res : Value + Exception) (eff : SideEffectList)
| Timeout
| Failure.

Inductive ResultListType : Type :=
| LResult (id : nat) (res : list Value + Exception) (eff : SideEffectList)
| LTimeout
| LFailure.

Require Import FunInd.

Fixpoint eval_elems (f : Environment -> nat -> Expression -> SideEffectList -> ResultType) env id exps eff : ResultListType :=
match exps with
| []    => LResult id (inl []) eff
| x::xs =>
  match f env id x eff with
  | Result id' (inl v) eff' =>
    let res := eval_elems f env id' xs eff' in
      match res with
      | LResult id'' (inl xs') eff'' => LResult id'' (inl (v::xs')) eff''
      | r => r
      end
  | Result id' (inr ex) eff' => LResult id' (inr ex) eff'
  | Failure => LFailure
  | Timeout => LTimeout
  end
end.

Fixpoint eval_fbos_expr (clock : nat) (env : Environment) (id : nat) (exp : Expression) (eff : SideEffectList) {struct clock} :
  ResultType :=
match clock with
| 0 => Timeout
| S clock' =>
   match exp with
   | ELit l => Result id (inl (VLit l)) eff
   | EVar v => Result id (get_value env (inl v)) eff
   | EFunId f => Result id (get_value env (inr f)) eff
   | EFun vl e => Result (S id) (inl (VClos env [] id vl e)) eff
   | ECall f l => let res :=
             eval_elems (eval_fbos_expr clock') env id l eff
         in
         match res with
         | LResult id' (inl vl) eff' => Result id' (fst (eval f vl eff')) (snd (eval f vl eff'))
         | LResult id' (inr ex) eff' => Result id' (inr ex) eff'
         | LFailure => Failure
         | LTimeout => Timeout
         end
   | EApp exp l =>
      match eval_fbos_expr clock' env id exp eff with
      | Result id' (inl v) eff' => let res :=
        eval_elems (eval_fbos_expr clock') env id' l eff'
         in
         match res with
         | LResult id'' (inl vl) eff'' =>
           match v with
           | VClos ref ext idcl varl body => if Nat.eqb (length varl) (length vl)
                                             then
                                               eval_fbos_expr clock' (append_vars_to_env varl vl (get_env ref ext)) id'' body eff''
                                             else Result id'' (inr (badarity v)) eff''
           | _                             => Result id'' (inr (badfun v)) eff''
           end
         | LResult id'' (inr ex) eff'' => Result id'' (inr ex) eff''
         | LFailure => Failure
         | LTimeout => Timeout
         end
       | r => r
   end
   | ELet var e1 e2 =>
      match eval_fbos_expr clock' env id e1 eff with
      | Result id' (inl v) eff' => eval_fbos_expr clock' (insert_value env (inl var) v) id' e2 eff'
      | r => r
      end
   | ELetRec f l b e => eval_fbos_expr clock' (append_funs_to_env [(f, (l, b))] env id) (S id) e eff
   | ETry e1 v1 e2 vl2 e3 =>
      match eval_fbos_expr clock' env id e1 eff with
      | Result id' (inr ex) eff' => eval_fbos_expr clock' (append_try_vars_to_env vl2 [exclass_to_value (fst (fst ex)); snd (fst ex); snd ex] env) id' e3 eff'
      | Result id' (inl v) eff' => eval_fbos_expr clock' (insert_value env (inl v1) v) id' e2 eff'
      | r => r
      end
  end
end
.
(*
Functional Scheme div2_ind := Induction for eval_fbos_expr Sort Set.
 TODO: report todo error here
 *)

Example exp1 := ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) ( ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) ( ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) ( ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "Y"%string (ELit (Integer 5)) (EVar "Y"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ELet "X"%string (ELet "X"%string (ELit (Integer 5)) (EVar "X"%string)) (ECall "+"%string [EVar "X"%string; EVar "X"%string])))))))))))))))))))))))))))))))))))).

Compute eval_fbos_expr 10000 [] 0 exp1 [].

Import StringSyntax.

Lemma nil_length {A}: @length A [] = 0.
Proof. auto. Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrint seq.
From CoqUtils Require Import word.
From extructures Require Import fmap.

Require Import Coq.Strings.String.
Require Import Common.Either.
Require Import Intermediate.Machine.

Require Import MicroPolicies.Types.
Require Import MicroPolicies.Instance.
Require Import I2MP.Encode.
Require Import I2MP.Linearize.

Require Import Tests.RSC_DC_MD_Test.
Require Import Tests.IntermediateProgramGeneration.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Import QcNotation. Open Scope qc_scope.

(* TL Questions: *)
(* Do I really need compiler errors? *)

(* ASW: what about unrespected interfaces? *)

(* I do need traces, right? *)
(* YEP!! *)

(* What about execution errors? What's the needed level of details? *)
(* Doesn't NEED to be meaningful *)

(* REMINDER: if a compiled program has +16384 instructions, the alloc syscall
   won't work on the micro-policiy machine, due to address space layout and
   imm word size. *)

Definition mp_program := { fmap mword mt -> matom }.

Definition ExecutionResult := unit.
Definition ExecutionError := unit.

Fixpoint mp_exec (s : state) (fuel : nat)
  : (@Either ExecutionResult ExecutionError) * Log :=
  let list_of_option {A : Type} (o : option A) : list A := match o with
                         | None => nil
                         | Some x => cons x nil
                         end in
  match fuel with
  | O => (Common.Either.Right tt, nil)
  | S n => match stepf s with
           | Some (s', e) => let (r, l) := mp_exec s' n in
                             (r, (list_of_option e ++ l))%list
           | None => (Common.Either.Left "The machine either halted or failed" tt, nil)
           end
  end.

Definition mp_eval (p : mp_program) (fuel : nat)
  : (@Either ExecutionResult ExecutionError) * Log := mp_exec (load p) fuel.

Definition compile_program
           (ip : Intermediate.program)
  : @Either mp_program False := Common.Either.Right (encode (linearize ip)).

Instance show_false : Show False :=
  {| show := (fun f => match (f: False) with end) |}.

Definition mp_rsc_correct (fuel : nat) :=
  let max_components := 15%nat in
  let min_components := 8%nat in
  rsc_correct
    empty_cag
    empty_dag
    min_components
    max_components
    compile_program
    mp_eval
    fuel.

Definition run_rsc_test :=
  show (quickCheck (mp_rsc_correct 500%nat)).