(** Static Intra-method control flow step. We also implement an iterator on it *)
(* Hendra : - Modified to suit DEX program.
            - DEX has different instructions list from JVM.
            - Also trim the system to contain only Arithmetic
            - Only retain the for_all_steps lemma *)
Require Export Annotated.
Import DEX_BigStep.DEX_Dom DEX_Prog.

(* Module Make (Ms:MAP). *)

  Section DEX_S_section.   (** step relation **)
    (*Variable p : DEX_Program.*)
    (* Definition address := Ms.key.
    Variable codes : Ms.t (DEX_Instruction*(option address*list DEX_ClassName)).
    Variable jump_label : address -> DEX_OFFSET.t -> address.

    Definition nextAddress (pc:address): option address :=
    match Ms.get codes pc with
      | Some p => fst (snd p)
      | None => None
    end.

    Definition instructionAtAddress (pc:address) : option DEX_Instruction :=
    match Ms.get codes pc with
      |Some p => Some (fst p)
      |None => None
    end. *)
(*
    Variable subclass_test : DEX_ClassName -> DEX_ClassName -> bool.
*)
    Variable m : DEX_Method.

    (* DEX Definition handler := handler subclass_test m.*)

    Inductive DEX_step : DEX_PC -> DEX_Instruction -> (* DEX_tag ->  *)option DEX_PC -> Prop :=
(*     Inductive DEX_step : address -> DEX_Instruction -> DEX_tag -> option address -> Prop := *)
    | DEX_nop : forall i j,
      next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i DEX_Nop (* None *) (Some j)
    | DEX_move : forall i j (k:DEX_ValKind) (rt:DEX_Reg) (rs:DEX_Reg),

      next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_Move k rt rs) (* None *) (Some j)
(* DEX Method
    | moveResult : forall i j (k:DEX_ValKind) (rt:DEX_Reg),
      next m i = Some j ->
      DEX_step i (MoveResult k rt) None (Some j)
*)
    | DEX_return_s : forall i,
      DEX_step i DEX_Return (* None *) None
    | DEX_vReturn : forall i (k:DEX_ValKind) (rt:DEX_Reg),
      DEX_step i (DEX_VReturn k rt) (* None *) None
    | DEX_const : forall i j (k:DEX_ValKind) (rt:DEX_Reg) (v:Z),
      next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_Const k rt v) (* None *) (Some j)
(* DEX Object
    | instanceOf : forall i j (rt:DEX_Reg) (r:DEX_Reg) (t:DEX_refType),
      next m i = Some j ->
      DEX_step i (InstanceOf rt r t) None (Some j)
    | arrayLength : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
      DEX_step i (ArrayLength rt rs) None (Some j)
    | new : forall i j (rt:DEX_Reg) (t:DEX_refType),
      next m i = Some j ->
      DEX_step i (New rt t) None (Some j)
    | newArray : forall i j (rt:DEX_Reg) (rl:DEX_Reg) (t:DEX_type),
      next m i = Some j ->
      DEX_step i (NewArray rt rl t) None (Some j)
*)
    | DEX_goto : forall i (o:DEX_OFFSET.t),
      DEX_step i (DEX_Goto o) (* None *) (Some (DEX_OFFSET.jump i o))
(*       DEX_step i (DEX_Goto o) None (Some (jump_label i o)) *)
(* still experimental for PackedSwitch in that the next instruction is
   defined as the difference between i and j *)
(*    | packedSwitch : forall i j (rt:DEX_Reg) (firstKey:Z) (size:Z) (l:list OFFSET.t),
      (* next m i = Some j \/ In o ((j - i)::l) -> *)
      next m i = Some j \/ In j (@map _ _ (OFFSET.jump i) l) ->
      step i (PackedSwitch rt firstKey size l) None (Some j)
    | sparseSwitch : forall i j (rt:DEX_Reg) (size:Z) (l:list (Z * OFFSET.t)),
      next m i = Some j \/ In j (@map _ _ (OFFSET.jump i) (@map _ _ (@snd _ _) l)) ->
      step i (SparseSwitch rt size l) None (Some j) *)
    | DEX_ifcmp : forall i j (cmp:DEX_CompInt) (ra:DEX_Reg) (rb:DEX_Reg) (o:DEX_OFFSET.t),
     next m i = Some j \/ j = DEX_OFFSET.jump i o ->
(*       nextAddress i = Some j \/ j = jump_label i o -> *)
      DEX_step i (DEX_Ifcmp cmp ra rb o) (* None *) (Some j)
    | DEX_ifz : forall i j (cmp:DEX_CompInt) (r:DEX_Reg) (o:DEX_OFFSET.t),
      next m i = Some j \/ j = DEX_OFFSET.jump i o ->
(*       nextAddress i = Some j \/ j = jump_label i o -> *)
      DEX_step i (DEX_Ifz cmp r o) (* None *) (Some j)
(* DEX Object
    | aget : forall i j (k:DEX_ArrayKind) (rt:DEX_Reg) (ra:DEX_Reg) (ri:DEX_Reg),
      next m i = Some j ->
      DEX_step i (Aget k rt ra ri) None (Some j)
    | aput : forall i j (k:DEX_ArrayKind) (rs:DEX_Reg) (ra:DEX_Reg) (ri:DEX_Reg),
      next m i = Some j ->
      DEX_step i (Aput k rs ra ri) None (Some j)
    | iget : forall i j (k:DEX_ValKind) (rt:DEX_Reg) (ro:DEX_Reg) (f:DEX_FieldSignature),
      next m i = Some j ->
      DEX_step i (Iget k rt ro f) None (Some j)
    | iput : forall i j (k:DEX_ValKind) (rs:DEX_Reg) (ro:DEX_Reg) (f:DEX_FieldSignature),
      next m i = Some j ->
      DEX_step i (Iput k rs ro f) None (Some j)
*)
(*
    | Sget (k:ValKind) (rt:DEX_Reg) (f:FieldSignature)
    | Sput (k:ValKind) (rs:DEX_Reg) (f:FieldSignature)
*)
(* DEX Method
    | invokevirtual : forall i j (m0:DEX_MethodSignature) (n:Z) (p:list DEX_Reg),
      next m i = Some j ->
      DEX_step i (Invokevirtual m0 n p) None (Some j)
    | invokesuper : forall i j (m0:DEX_MethodSignature) (n:Z) (p:list DEX_Reg),
      next m i = Some j ->
      DEX_step i (Invokesuper m0 n p) None (Some j)
    | invokedirect : forall i j (m0:DEX_MethodSignature) (n:Z) (p:list DEX_Reg),
      next m i = Some j ->
      DEX_step i (Invokedirect m0 n p) None (Some j)
    | invokestatic : forall i j (m0:DEX_MethodSignature) (n:Z) (p:list DEX_Reg),
      next m i = Some j ->
      DEX_step i (Invokestatic m0 n p) None (Some j)
    | invokeinterface : forall i j (m0:DEX_MethodSignature) (n:Z) (p:list DEX_Reg),
      next m i = Some j ->
      DEX_step i (Invokeinterface m0 n p) None (Some j)
*)
    | DEX_ineg : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_Ineg rt rs) (* None *) (Some j)
    | DEX_inot : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_Inot rt rs) (* None *) (Some j)
    | DEX_i2b : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_I2b rt rs) (* None *) (Some j)
    | DEX_i2s : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
       next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_I2s rt rs) (* None *) (Some j)
    | DEX_ibinop : forall i j (op:DEX_BinopInt) (rt:DEX_Reg) (ra:DEX_Reg) (rb:DEX_Reg),
       next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_Ibinop op rt ra rb) (* None *) (Some j)
    | DEX_ibinopConst : forall i j (op:DEX_BinopInt) (rt:DEX_Reg) (r:DEX_Reg) (v:Z),
       next m i = Some j ->
(*       nextAddress i = Some j -> *)
      DEX_step i (DEX_IbinopConst op rt r v) (* None *) (Some j)
(* Hendra 11082016 focus on DEX I
    | DEX_packedSwitch : forall i j (rt:DEX_Reg) (firstKey:Z) (size:nat) (l:list DEX_OFFSET.t),
      (*(next m i = Some d /\ d = DEX_OFFSET.jump i j) \/ In j l ->*)
      (*(nextAddress i = Some d /\ d = jump_label i j) \/ In j l -> *)
      (exists d, nextAddress i = Some d /\ d = jump_label i j) \/ In j l ->
      (*DEX_step i (DEX_PackedSwitch rt firstKey size l) None (Some (DEX_OFFSET.jump i j))*)
      DEX_step i (DEX_PackedSwitch rt firstKey size l) None (Some (jump_label i j))
    | DEX_sparseSwitch : forall i j (rt:DEX_Reg) (size:nat) (l:list (Z * DEX_OFFSET.t)),
      (*(next m i = Some d /\ d = DEX_OFFSET.jump i j) \/ *)
      (exists d, nextAddress i = Some d /\ d = jump_label i j) \/
        In j (@map _ _ (@snd _ _) l) ->
      (*DEX_step i (DEX_SparseSwitch rt size l) None (Some (DEX_OFFSET.jump i j))*)
      DEX_step i (DEX_SparseSwitch rt size l) None (Some (jump_label i j))
*)
.

    Definition get_steps (i:DEX_PC) (ins:DEX_Instruction) (next:option DEX_PC): list ((* DEX_tag *  *)option DEX_PC) :=
(*     Definition get_steps (i:address) (ins:DEX_Instruction) (next:option address): list (DEX_tag * option address) :=  *)
      match ins with
(* Hendra 11082016 focus on DEX I
        | DEX_SparseSwitch r size l =>
          (*(None,next) :: map (fun o => (None,Some (DEX_OFFSET.jump i o))) (@map _ _ (@snd _ _) l)*)
          (None,next) :: map (fun o => ((None:DEX_tag),Some (jump_label i o))) (@map _ _ (@snd _ _) l)
        | DEX_PackedSwitch r firstKey size l =>
          (*(None,next) :: map (fun o => (None,Some (DEX_OFFSET.jump i o))) (l)*)
          (None,next) :: map (fun o => ((None:DEX_tag),(Some (jump_label i o):option address))) (l)
*)
        | DEX_Return => ((* None, *)None)::nil
        | DEX_VReturn k rt => ((* None, *)None)::nil
        | DEX_Goto o => ((* None, *)Some (DEX_OFFSET.jump i o))::nil
        | DEX_Ifcmp cmp ra rb o => ((* None, *)next)::((* None, *)Some (DEX_OFFSET.jump i o))::nil
        | DEX_Ifz cmp r o => ((* None, *)next)::((* None, *)Some (DEX_OFFSET.jump i o))::nil
        | _ => ((* None, *)next)::nil
      end.

(*     (* TODO : needs to be instantiated from outside *)
    Parameter next_as_jump : forall i j,
      nextAddress i = Some j -> exists k,
        jump_label i k = j.
      (*exists k, nextAddress i = Some (jump_label i k).*) *)

    Lemma all_step_in_get_steps : forall i ins (* tau *) oj,
        DEX_step i ins (* tau *) oj ->
        In ((* tau, *)oj) (get_steps i ins (next m i)).
    Proof.
      intros.
      inversion_clear H;
      simpl get_steps; try rewrite H0;
      auto with datatypes;
      (* ifcmp and ifz cases *)
        try (destruct H0 as [H0|H0]; rewrite <- H0; auto with datatypes;
        right; subst; left; reflexivity).
(* Hendra 11082016 focus on DEX I
      (* PackedSwitch case *)
        (* default case : next instruction *)
        destruct H0. left. inversion H. inversion H0. rewrite H1. rewrite <- H2. reflexivity.
        (* other successors case *)
        right. try match goal with
          [ |- In (_,_) (map ?F _) ] =>
          apply in_map with (f:=F); try assumption
        end.
      (* SparseSwitch case *)
        (* default case : next instruction *)
        destruct H0. left. inversion H. inversion H0. rewrite H1. rewrite <- H2. reflexivity.
        (* other successors case *)
        right. try match goal with
          [ |- In (_,_) (map ?F _) ] =>
          apply in_map with (f:=F); try assumption
        end.
*)
    Qed.

(*   Definition needs_next (ins:DEX_Instruction) : Prop :=
    match ins with
      | DEX_Return => False
      | DEX_VReturn _ _ => False
      | _ => True
    end.

  (* For now it is assumed, maybe later on we can define what it means
  for a legal program which satisfies this property. Nevertheless, the
  burden of proving is not in the scope of translation proof *)
  Parameter all_ins_has_next : forall i ins,
    instructionAtAddress i = Some ins ->
    needs_next (ins) ->
    nextAddress i = None -> False. *)

(*   Lemma in_get_steps_all_step : forall i ins tau oj,
        instructionAtAddress i = Some ins ->
        In (tau,oj) (get_steps i ins (nextAddress (*m*) i)) ->
        DEX_step i ins tau oj.
    Proof.
      intros.
      unfold get_steps in H. destruct ins eqn:Hins;
      (* Sequential Instruction *)
      try (inversion H0; try (inversion H1);
      try (inversion H1; destruct oj;
        try (rewrite H4; constructor; auto);
        try (apply all_ins_has_next with (ins:=ins) in H4;
          try (rewrite Hins; unfold needs_next; auto; fail);
          try (inversion H4))); fail);
      (* Goto, Return and VReturn *)
      try (inversion H0; try (inversion H1); constructor; fail);
      (* If and Ifz *)
      try (inversion H0; inversion H1;
        try (destruct oj;
          try (rewrite H4; constructor; left; auto; fail);
          try (apply all_ins_has_next with (ins:=ins) in H4;
            try (rewrite Hins; unfold needs_next; auto; fail);
            try (inversion H4); fail); fail);
        try (inversion H2); constructor; right; auto; fail).
(* Hendra 11082016 focus on DEX I
      (* PackedSwitch *)
      inversion H0. inversion H1.
      (* next successor *)
      destruct oj. rewrite H4.
      apply next_as_jump in H4.
      destruct H4. rewrite <- H2.
      constructor.
      left. exists a; split; try (symmetry; auto); try (inversion H1; auto).
      try (apply all_ins_has_next with (ins:=ins) in H4;
          try (rewrite Hins; unfold needs_next; auto; fail);
          try (inversion H4)).
      (* successor is one of the list *)
      apply in_map_inv in H1.
      inversion H1. inversion H2. inversion H3.
      constructor.
      right; auto.
      (* SparseSwitch *)
      inversion H0. inversion H1.
      (* next successor *)
      destruct oj. rewrite H4.
      apply next_as_jump in H4.
      destruct H4. rewrite <- H2.
      constructor.
      left. exists a; split; try (symmetry; auto); try (inversion H1; auto).
      try (apply all_ins_has_next with (ins:=ins) in H4;
          try (rewrite Hins; unfold needs_next; auto; fail);
          try (inversion H4)).
      (* successor is one of the list *)
      apply in_map_inv in H1.
      inversion H1. inversion H2. inversion H3.
      constructor.
      right; auto.
*)
    Qed. *)

  Section for_all_steps.
    Variable test : DEX_PC -> DEX_Instruction -> (* DEX_tag -> *) option DEX_PC -> bool.
(*     Variable test : address -> DEX_Instruction -> DEX_tag -> option address -> bool. *)

(* This is an attempt to mechanize the proof of translation -
     Definition for_all_steps_codes (codes:Ms.t (DEX_Instruction*(option DEX_PC*list DEX_ClassName))) : bool :=
      Ms.for_all
      (fun i (ins_next:DEX_Instruction*(option (*DEX_PC*)address*list DEX_ClassName)) =>
        let (ins,next) := ins_next in
          for_all _
          (fun (tau_oj:DEX_tag*option (*DEX_PC*)address) =>
              let (tau,oj):=tau_oj in test i ins tau oj)
              (get_steps i ins (fst next)) )
      codes.

    Lemma for_all_steps_codes_true : for_all_steps_codes codes = true ->
      (forall i ins tau oj,
        instructionAtAddress i = Some ins ->
        DEX_step i ins tau oj -> test i ins tau oj = true).
    Proof.
      intros.
      assert (T1:=Ms.for_all_true _ _ codes H).
      assert (T2:=all_step_in_get_steps _ _ _ _ H1).
      unfold instructionAtAddress in H0.
      (*rewrite H in H1.*)
      caseeq (Ms.get codes i).
      intros (ins0,next0) T3.
      rewrite T3 in H0.
      generalize (T1 _ _ T3); clear T1; intros T1.
      apply for_all_true with
        (test:=(fun tau_oj : DEX_tag * option address =>
          let (tau, oj) := tau_oj in test i ins tau oj))
        (2:=T2).
      unfold nextAddress.
      rewrite T3; simpl.
      inversion H0; subst; auto.
      intros T3; rewrite T3 in H0; discriminate.
    Qed.

    Lemma for_all_steps_codes_true2 :
      (forall i ins tau oj,
        instructionAtAddress i = Some ins ->
        DEX_step i ins tau oj ->
        test i ins tau oj = true) ->
        for_all_steps_codes codes = true.
    Proof.
      intros.
      (*assert (T2:=all_step_in_get_steps _ _ _ _ H0).*)
      unfold for_all_steps_codes.
      apply Ms.spec_all_for_true.
      intros.
      destruct a as [ins0 next0].
      apply true_for_all. intros.
      destruct a as [tau oj].
      apply H; auto.
      unfold instructionAtAddress. rewrite H0. auto.
      apply in_get_steps_all_step; auto.
      unfold instructionAtAddress. rewrite H0. auto.
      unfold nextAddress. rewrite H0. simpl. auto.
    Qed.
 *)
(*
  Definition for_all_steps_codes codes : bool :=
    match codes with
      | None => false
      | Some instructions => for_all_steps_codes instructions
    end.
*)
(*
  Definition test_all_steps_m : list (DEX_PC*bool) :=
    match DEX_METHOD.body m with
      | None => nil
      | Some bm =>
      List.map
      (fun (ins_next:DEX_PC*(DEX_Instruction*(option DEX_PC*list DEX_ClassName))) =>
        let (i,ins_next) := ins_next in
        let (ins,next) := ins_next in
          (i,for_all _
            (fun (tau_oj:DEX_tag*option DEX_PC) => let (tau,oj):=tau_oj in test i ins tau oj)
            (get_steps i ins (fst next))))
      (MapN.elements _ bm.(DEX_BYTECODEMETHOD.instr))
    end.

  Lemma for_all_steps_m_true : for_all_steps_m = true ->
      forall i ins tau oj,
        instructionAt m i = Some ins ->
        DEX_step i ins tau oj -> test i ins tau oj = true.
  Proof.
    unfold for_all_steps_m.
    generalize for_all_steps_bm_true.
    destruct (DEX_METHOD.body m) as [bm|]; intro.
    apply H; auto.
    intros; discriminate.
  Qed.
*)

    Definition for_all_steps_bm (bm:DEX_BytecodeMethod) : bool :=
      MapN.for_all _
      (fun i (ins_next:DEX_Instruction*(option DEX_PC *list DEX_ClassName )) =>
        let (ins,next) := ins_next in
          for_all _
          (fun ((* tau_ *)oj:(* DEX_tag* *)option DEX_PC) => (* let (tau,oj):=tau_oj in *) test i ins (* tau *) oj)
          (get_steps i ins ( fst  next)))
      bm.(DEX_BYTECODEMETHOD.instr).

    Lemma for_all_steps_bm_true : forall bm,
      DEX_METHOD.body m = Some bm ->
      for_all_steps_bm bm = true ->
      forall i ins (* tau *) oj,
        instructionAt m i = Some ins ->
        DEX_step i ins (* tau *) oj -> test i ins (* tau *) oj = true.
    Proof.
      intros.
      assert (T1:=MapN.for_all_true _ _ _ H0).
      assert (T2:=all_step_in_get_steps _ _ _ H2).
      unfold instructionAt, DEX_BYTECODEMETHOD.instructionAt in H1.
      rewrite H in H1.
      caseeq (MapN.get (DEX_Instruction * (option DEX_PC*list DEX_ClassName)) (DEX_BYTECODEMETHOD.instr bm) i).
      intros (ins0,next0) T3.
      rewrite T3 in H1.
      generalize (T1 _ _ T3); clear T1; intros T1.
      apply for_all_true with
        (test:=(fun (* tau_ *)oj : (* DEX_tag * *) option DEX_PC =>
          (* let (tau, oj) := tau_oj in *) test i ins (* tau *) oj))
        (2:=T2).
      unfold next, DEX_BYTECODEMETHOD.nextAddress.
      rewrite H; rewrite T3; simpl.
      inversion_mine H1; auto.
      intros T3; rewrite T3 in H1; discriminate.
    Qed.

  Definition for_all_steps_m : bool :=
    match DEX_METHOD.body m with
      | None => false
      | Some bm => for_all_steps_bm bm
    end.

  Definition test_all_steps_m : list (DEX_PC*bool) :=
    match DEX_METHOD.body m with
      | None => nil
      | Some bm =>
      List.map
      (fun (ins_next:DEX_PC*(DEX_Instruction*(option DEX_PC*list DEX_ClassName))) =>
        let (i,ins_next) := ins_next in
        let (ins,next) := ins_next in
          (i,for_all _
            (fun ((* tau_ *)oj:(* DEX_tag* *)option DEX_PC) => (* let (tau,oj):=tau_oj in *) test i ins (* tau *) oj)
            (get_steps i ins (fst next))))
      (MapN.elements _ bm.(DEX_BYTECODEMETHOD.instr))
    end.

  Lemma for_all_steps_m_true : for_all_steps_m = true ->
      forall i ins (* tau *) oj,
        instructionAt m i = Some ins ->
        DEX_step i ins (* tau *) oj -> test i ins (* tau *) oj = true.
  Proof.
    unfold for_all_steps_m.
    generalize for_all_steps_bm_true.
    destruct (DEX_METHOD.body m) as [bm|]; intro.
    apply H; auto.
    intros; discriminate.
  Qed.
  End for_all_steps.

  Section for_all_succs.
    Variable pc:DEX_PC.
    Variable test : (* DEX_tag -> *) option DEX_PC -> bool.

    Definition for_all_succs_bm (bm:DEX_BytecodeMethod) : bool :=
      match MapN.get _ bm.(DEX_BYTECODEMETHOD.instr) pc with
        | None => true
        | Some (ins,(op,l)) =>
          for_all _
          (fun ((* tau_ *)oj:(* DEX_tag* *)option DEX_PC) => (* let (tau,oj):=tau_oj in *) test (* tau *) oj)
          (get_steps pc ins op)
      end.

    Lemma for_all_succs_bm_true : forall bm,
      DEX_METHOD.body m = Some bm ->
      for_all_succs_bm bm = true ->
      forall ins (* tau *) oj,
        instructionAt m pc = Some ins ->
        DEX_step pc ins (* tau *) oj -> test (* tau *) oj = true.
    Proof.
      unfold for_all_succs_bm; intros.
      assert (T2:=all_step_in_get_steps _ _ _ H2).
      unfold instructionAt, DEX_BYTECODEMETHOD.instructionAt in H1.
      rewrite H in H1.
      caseeq (MapN.get (DEX_Instruction * (option DEX_PC*list DEX_ClassName)) (DEX_BYTECODEMETHOD.instr bm) pc).
      intros (ins0,next0) T3.
      rewrite T3 in H1; rewrite T3 in H0.
      destruct next0.
      apply for_all_true with
        (test:=(fun (* tau_ *)oj : (* DEX_tag * *) option DEX_PC =>
          (* let (tau, oj) := tau_oj in *) test (* tau *) oj))
        (2:=T2).
      unfold next, DEX_BYTECODEMETHOD.nextAddress.
      inversion_mine H1.
      rewrite H; rewrite T3; simpl; auto.
      intros.
      rewrite H3 in H1; discriminate.
    Qed.

  Definition for_all_succs_m : bool :=
    match DEX_METHOD.body m with
      | None => false
      | Some bm => for_all_succs_bm bm
    end.

  Lemma for_all_succs_m_true : for_all_succs_m = true ->
      forall ins (* tau *) oj,
        instructionAt m pc = Some ins ->
        DEX_step pc ins (* tau *) oj -> test (* tau *) oj = true.
  Proof.
    unfold for_all_succs_m.
    generalize for_all_succs_bm_true.
    destruct (DEX_METHOD.body m) as [bm|]; intro.
    apply H; auto.
    intros; discriminate.
  Qed.

 End for_all_succs.

  Section for_all_instrs.
    Variable test : DEX_PC -> DEX_Instruction -> bool.

    Definition for_all_instrs_bm (bm:DEX_BytecodeMethod) : bool :=
      MapN.for_all _
      (fun i (ins_next:DEX_Instruction*(option DEX_PC*list DEX_ClassName)) =>
        let (ins,next) := ins_next in test i ins)
      bm.(DEX_BYTECODEMETHOD.instr).

    Lemma for_all_instrs_bm_true : forall bm,
      DEX_METHOD.body m = Some bm ->
      for_all_instrs_bm bm = true ->
      forall i ins,
        instructionAt m i = Some ins -> test i ins = true.
    Proof.
      intros.
      assert (T1:=MapN.for_all_true _ _ _ H0).
      unfold instructionAt, DEX_BYTECODEMETHOD.instructionAt in H1.
      rewrite H in H1.
      caseeq (MapN.get (DEX_Instruction * (option DEX_PC*list DEX_ClassName)) (DEX_BYTECODEMETHOD.instr bm) i).
      intros (ins0,next0) T3.
      rewrite T3 in H1.
      generalize (T1 _ _ T3); clear T1; intros T1.
      inversion_mine H1; auto.
      intros T3; rewrite T3 in H1; discriminate.
    Qed.

    Definition for_all_instrs_m : bool :=
      match DEX_METHOD.body m with
        | None => false
        | Some bm => for_all_instrs_bm bm
      end.

    Lemma for_all_instrs_m_true : for_all_instrs_m = true ->
      forall i ins,
        instructionAt m i = Some ins -> test i ins = true.
    Proof.
      unfold for_all_instrs_m.
      generalize for_all_instrs_bm_true.
      destruct (DEX_METHOD.body m) as [bm|]; intro.
      apply H; auto.
      intros; discriminate.
    Qed.

  End for_all_instrs.

End DEX_S_section.

Module DEX_MapClassTools := MapProjTools DEX_PROG.DEX_MapClass.

Section p.
  Variable p : DEX_Program.

  Definition ValidMethod (m:DEX_Method) : Prop :=
    exists c, DEX_PROG.defined_Class p c /\ DEX_CLASS.defined_Method c m.

  Variable test : DEX_Method -> bool.

  Definition for_all_methods : bool :=
    DEX_MapClassTools.for_all
    (fun cl =>  DEX_MapShortMethSign.for_all _ (fun _ => test) cl.(DEX_CLASS.methods))
    p.(DEX_PROG.classes_map).

  Lemma for_all_methods_true : for_all_methods = true ->
    forall m, ValidMethod m -> test m = true.
  Proof.
    intros.
    destruct H0 as [c [H0 H1]].
    generalize (DEX_MapClassTools.for_all_true _ _ H _ H0); intros.
    unfold DEX_CLASS.defined_Method, DEX_CLASS.method in H1.
    caseeq (DEX_MapShortMethSign.get DEX_Method (DEX_CLASS.methods c) (DEX_METHOD.signature m)); intros.
    rewrite H3 in H1.
    destruct (DEX_METHODSIGNATURE.eq_t (DEX_METHOD.signature m) (DEX_METHOD.signature d)); inversion_mine H1.
    apply (DEX_MapShortMethSign.for_all_true _ _ _ H2 _ _ H3).
    rewrite H3 in H1; discriminate.
  Qed.

End p.


From iris.proofmode Require Import tactics.
From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.algebra Require Import base mem.
From HypVeri.rules Require Import rules_base mov halt run yield.
From HypVeri.examples Require Import instr.
From HypVeri.logrel Require Import logrel logrel_extra logrel_prim_extra fundamental.
From HypVeri Require Import proofmode machine_extra.
Import uPred.
Require Import Setoid.

Program Instance rywu_vmconfig : HypervisorConstants :=
    {vm_count := 3;
     vm_count_pos:= _;
     valid_handles := {[W0]}}.

Program Definition V1 : VMID := (@nat_to_fin 1 _ _).
Program Definition V2 : VMID := (@nat_to_fin 2 _ _).

Section proof.
  Context `{hypparams: !HypervisorParameters}.
  Context (pprog0 pprog1 pprog2 :PID).
  Context (ptx0 prx0 ptx1 prx1 ptx2 prx2 :PID).
  Context (Hps_nd: NoDup [pprog0;pprog1;pprog2;ptx0;ptx1;ptx2;prx0;prx1;prx2]).

  Definition rywu_program0 : list Word :=
    [
    mov_word_I R0 run_I;
    mov_word_I R1 (encode_vmid V2);
    hvc_I;
    mov_word_I R0 run_I;
    mov_word_I R1 (encode_vmid V1);
    hvc_I;
    halt_I
    ].

  Definition rywu_program1 : list Word :=
    [
    mov_word_I R0 yield_I;
    hvc_I
    ].

  Context `{!gen_VMG Σ}.

  Definition rywu_slice_trans trans i j : iProp Σ := slice_transfer_all trans i j.

  Definition rywu_slice_rxs i os (j: VMID) : iProp Σ :=
    (match os with
    | None => True
    | _ => slice_rx_state i os
    end)%I.

  Lemma rywu_machine0 :
    let R2' := (RX_state@V2 := None ∗ RX@V2 := prx2 ∗ ∃ mem_rx, memory_page prx2 mem_rx)%I in
    let R0' := (RX_state@V0 := None ∗ RX@V0 := prx0 ∗ ∃ mem_rx, memory_page prx0 mem_rx)%I in
    let R1' := (RX_state@V1 := None ∗ RX@V1 := prx1 ∗ ∃ mem_rx, memory_page prx1 mem_rx)%I
    in
      seq_in_page (of_pid pprog0) (length rywu_program0) pprog0 ->
      (program (rywu_program0) (of_pid pprog0)) ∗
      V0 -@A> {[pprog0]} ∗
      TX@ V0 := ptx0 ∗
      PC @@ V0 ->r (of_pid pprog0) ∗
      (∃ r0, R0 @@ V0 ->r r0) ∗
      (∃ r1, R1 @@ V0 ->r r1) ∗
      (∃ r2, R2 @@ V0 ->r r2) ∗
      VMProp V0 True%I 1 ∗
      VMProp V1 ((R0 @@ V0 ->r run_I ∗ R1 @@ V0 ->r encode_vmid V1) ∗
                    VMProp V0 ((R0 @@ V0 ->r yield_I ∗ R1 @@ V0 ->r encode_vmid V1) ∗
                                 VMProp V1 False%I (1/2)%Qp) (1/2)%Qp)%I (1/2)%Qp ∗
      VMProp V2 ((vmprop_unknown V2 rywu_slice_trans rywu_slice_rxs ∅ )) (1/2)%Qp ∗
      trans.fresh_handles 1 valid_handles ∗
      R0' ∗ R1' ∗ R2'
      ⊢ WP ExecI @ V0
            {{ (λ m,
                 ⌜m = HaltI⌝ ∗
                 program rywu_program0 (of_pid pprog0) ∗
                 V0 -@A> {[pprog0]} ∗
                 TX@ V0 := ptx0 ∗
                 PC @@ V0 ->r ((of_pid pprog0) ^+ (length rywu_program0))%f ∗
                 R0 @@ V0 ->r yield_I ∗
                 R1 @@ V0 ->r encode_vmid V1
                 )}}%I.
  Proof.
    intros ???.
    iIntros (HIn) "((p_1 & p_2 & p_3 & p_4 & p_5 & p_6 & p_7 & _) & acc & tx & PCz & (%r0 & R0z) & (%r1 & R1z) & (%r2 & R2z)
                            & prop0 & prop1 & prop2 & hp & R0 & R1 & R2)".
    pose proof (seq_in_page_forall2 _ _ _ HIn) as Hforall.
    clear HIn; rename Hforall into HIn.
    assert (pprog0 ≠ ptx0) as Hnottx.
    {
      intro.
      feed pose proof (NoDup_lookup _ 0 3 ptx0 Hps_nd).
      simplify_eq /=. done.
      simplify_eq /=. done.
      lia.
    }
    (* mov_word_I R0 run_I *)
    rewrite wp_sswp.
    iApply ((mov_word (of_pid pprog0) run_I R0) with "[p_1 PCz acc tx R0z]");try rewrite HIn //; iFrameAutoSolve; try set_solver +.
    iModIntro.
    iIntros "(PCz & p_1 & acc & tx & R0z) _".
    (* mov_word_I R1 V2 *)
    rewrite wp_sswp.
    iApply ((mov_word _ (encode_vmid V2) R1) with "[p_2 PCz acc tx R1z]"); try rewrite HIn //; iFrameAutoSolve; try set_solver +.
    iModIntro.
    iIntros "(PCz & p_2 & acc & tx & R1z) _".
    (* hvc_I *)
    rewrite wp_sswp.
    iApply ((run (((pprog0 ^+ 1) ^+ 1))%f V2  True
                (vmprop_zero V2 rywu_slice_trans rywu_slice_rxs ∅ {[V0 := None; V1 := None; V2 := None]})
                (R' := PC @@ V0 ->r (((pprog0 ^+ 1) ^+ 1) ^+ 1)%f
                                 ∗((pprog0 ^+ 1) ^+ 1)%f ->a hvc_I ∗ V0 -@A> {[pprog0]} ∗ TX@ V0 := ptx0)
                ) with "[PCz p_3 acc tx R0z R1z R2z prop0 prop2 hp R0 R1 R2]"); try rewrite HIn //; iFrameAutoSolve.
    { set_solver +. }
    { set_solver +. }
    { set_solver +. }
    { apply decode_encode_hvc_func. }
    { apply decode_encode_vmid. }
    { iSplitL "prop2". iFrame.
      iSplitL "prop0". done.
      iSplitR ""; last done.
      iNext. iIntros "((PC & addr & acc & tx & R0' & R1') & _ & prop0)".
      setoid_rewrite vmprop_unknown_eq.
      iFrame "PC addr acc tx".
      iExists ∅, {[V0 := None; V1 := None; V2 := None]}.
      iSplitR. done.
      iSplitL "hp".
      {
        iExists valid_handles.
        iSplitL "". iPureIntro. rewrite dom_empty_L union_empty_r_L //.
        iFrame.
        rewrite big_sepM_empty //.
      }
      iSplitL "".
      {
        rewrite /rywu_slice_trans /=.
        rewrite transferred_only_equiv.
        rewrite /transaction_pagetable_entries_transferred.
        rewrite /retrievable_transaction_transferred.
        iSplitL. iApply (big_sepFM_empty).
        iSplitL. iSplitL;iApply (big_sepFM_empty).
        rewrite /transferred_memory_pages.
        rewrite map_filter_empty pages_in_trans_empty.
        iExists ∅.
        iApply memory_pages_empty.
        intros. done.
        rewrite /trans_neq. apply map_Forall_empty.
        rewrite /trans_ps_disj /inv_trans_ps_disj'. rewrite /lift_option_gmap fmap_empty. apply map_Forall_empty.
      }
      iSplitL "R0'".
      iExists _. iSplit. iExact "R0'". iPureIntro. apply decode_encode_hvc_func.
      iSplitL "R1'".
      iExists _. iSplit. iExact "R1'". iPureIntro. apply decode_encode_vmid.
      iSplitL "R2z".
      iExists _. iExact "R2z".
      iSplitL "R2".
      {
        iIntros (??).
        simplify_map_eq /=.
        iDestruct "R2" as "($ & R2 & R3)".
        iExists prx2. iFrame "R3 R2".
      }
      iSplitL "R0 R1".
      {
        rewrite /rx_states_global.
        assert (delete V2 {[V0 := None; V1 := None; V2 := None]} = {[V0 := None; V1 := None]}) as ->.
        {
          simpl.
          assert ({[V0 := None; V1 := None; V2 := None]} = {[V2 := None; V0 := None; V1 := None]}) as ->.
          {
            rewrite (map_insert_swap _ V1 V2) //.
            rewrite (map_insert_swap _ V0 V2) //.
          }
          rewrite delete_insert //.
        }
        rewrite big_sepM_insert //.
        rewrite big_sepM_singleton.
        rewrite /rx_state_match.
        iSplitL "R0".
        iDestruct "R0" as "($ & R1 & R2)".
        iExists prx0. iFrame "R2 R1".
        iDestruct "R1" as "($ & R1 & R2)".
        iExists prx1. iFrame "R2 R1".
      }
      iSplitR.
      {
        iPureIntro.
        rewrite /base_extra.is_total_gmap.
        intro. pose proof (in_list_of_vmids k).
        rewrite /list_of_vmids /= in H.
        clear -H.
        repeat destruct H as [<- | H];
          exists None;
          simplify_map_eq;auto. done.
      }
      iExact "prop0".
      }
    iNext.
    iIntros "((PCz & p_3 & acc & tx) & Hprop0) Hholds0".
    iDestruct (VMProp_holds_agree with "[Hholds0 Hprop0]") as "[P prop0]".
    iSplitR "Hprop0".
    2: { iFrame "Hprop0". }
    iSimpl. iSimpl in "Hholds0". done.
    (* getting back resources *)
    iEval(rewrite /vmprop_zero /vmprop_zero_pre) in "P".
    iEval (rewrite later_exist) in "P". iDestruct "P" as (trans' rs') "P".
    iEval (rewrite 8!later_sep) in "P".
    (* rewrite /rywu_slice_trans. *)
    iDestruct "P" as "(_ & _ & >trans_hpool_global & trans & >mem_rx_2 & >rx_2 &>returnreg & prop2)".
    (* mov_word_I R0 run *)
    rewrite wp_sswp.
    rewrite /return_reg_rx.
    iDestruct "returnreg" as "[returnreg | returnreg]".
    {
      iDestruct "returnreg" as "(R0z & rx & R1z & R2z)".
      iDestruct "R0z" as "[R0z | R0z]".
      {
        iApply ((mov_word ((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1)%f run_I R0) with "[p_4 PCz acc tx R0z]");try rewrite HIn //; iFrameAutoSolve; try set_solver +.
        iModIntro.
        iIntros "(PCz & p_4 & acc & tx & R0z) _".
        (* mov_word_I R1 V1 *)
        rewrite wp_sswp.
        iApply ((mov_word (((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1) ^+ 1)%f (encode_vmid V1) R1) with "[p_5 PCz acc tx R1z]"); try rewrite HIn //; iFrameAutoSolve; try set_solver +.
        iModIntro.
        iIntros "(PCz & p_5 & acc & tx & R1z) _".
        (* hvc_I *)
        rewrite wp_sswp.
        iApply ((run ((((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1) ^+ 1) ^+ 1)%f V1 True ((R0 @@ V0 ->r yield_I ∗ R1 @@ V0 ->r encode_vmid V1) ∗ VMProp V1 False (1 / 2)))
                  with "[PCz p_6 acc tx R0z R1z prop0 prop1]"); try rewrite HIn //;iFrameAutoSolve.
        { set_solver +. }
        { set_solver +. }
        { set_solver +. }
        { apply decode_encode_hvc_func. }
        { apply decode_encode_vmid. }
        {
          iSplitR "prop0".
          - iModIntro.
            iFrame "prop1".
          - iSplitL "prop0".
            iFrame "prop0".
            iSplitR "";last done.
            iNext.
            iIntros "((PCz & p_6 & acc & tx & R0z & R1z) & _ & prop)".
            iFrame "R0z R1z prop".
            iCombine "PCz p_6 acc tx" as "R'".
            iExact "R'".
        }
        iModIntro.
        iIntros "[(PC & p_6 & acc & tx) prop0] Hholds".
        iDestruct (VMProp_holds_agree with "[Hholds prop0]") as "[P' prop0]".
        simpl.
        iFrame "Hholds prop0".
        (* getting back resources *)
        iDestruct "P'" as "((>R0z & >R1z) & prop1)".
        (* halt_I *)
        rewrite wp_sswp.
        iApply ((halt (((((((of_pid pprog0) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f) with "[PC p_7 acc tx]");
          try rewrite HIn //; iFrameAutoSolve;try set_solver +.
        iNext.
        iIntros "( PCz & p_7 & acc & tx)".
        iIntros "_".
        iApply wp_terminated'; eauto.
        assert ((((((((pprog0 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f = ((of_pid pprog0) ^+ length rywu_program0)%f) as ->.
        {
          assert ( (Z.of_nat (length rywu_program0)) = 7%Z) as ->. by compute.
          solve_finz.
        }
        iFrame.
        iSplitR; first done.
        done.
      }
      {
        iDestruct "R0z" as "(R0z & ?)".
        iApply ((mov_word ((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1)%f run_I R0) with "[p_4 PCz acc tx R0z]");try rewrite HIn //; iFrameAutoSolve; try set_solver +.
        iModIntro.
        iIntros "(PCz & p_4 & acc & tx & R0z) _".
        (* mov_word_I R1 V1 *)
        rewrite wp_sswp.
        iApply ((mov_word (((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1) ^+ 1)%f (encode_vmid V1) R1) with "[p_5 PCz acc tx R1z]"); try rewrite HIn //; iFrameAutoSolve; try set_solver +.
        iModIntro.
        iIntros "(PCz & p_5 & acc & tx & R1z) _".
        (* hvc_I *)
        rewrite wp_sswp.
        iApply ((run ((((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1) ^+ 1) ^+ 1)%f V1 True ((R0 @@ V0 ->r yield_I ∗ R1 @@ V0 ->r encode_vmid V1) ∗ VMProp V1 False (1 / 2)))
                  with "[PCz p_6 acc tx R0z R1z prop0 prop1]"); try rewrite HIn //;iFrameAutoSolve.
        { set_solver +. }
        { set_solver +. }
        { set_solver +. }
        { apply decode_encode_hvc_func. }
        { apply decode_encode_vmid. }
        {
          iSplitR "prop0".
          - iModIntro.
            iFrame "prop1".
          - iSplitL "prop0".
            iFrame "prop0".
            iSplitR "";last done.
            iNext.
            iIntros "((PCz & p_6 & acc & tx & R0z & R1z) & _ & prop)".
            iFrame "R0z R1z prop".
            iCombine "PCz p_6 acc tx" as "R'".
            iExact "R'".
        }
        iModIntro.
        iIntros "[(PC & p_6 & acc & tx) prop0] Hholds".
        iDestruct (VMProp_holds_agree with "[Hholds prop0]") as "[P' prop0]".
        simpl.
        iFrame "Hholds prop0".
        (* getting back resources *)
        iDestruct "P'" as "((>R0z & >R1z) & prop1)".
        (* halt_I *)
        rewrite wp_sswp.
        iApply ((halt (((((((of_pid pprog0) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f) with "[PC p_7 acc tx]");
          try rewrite HIn //; iFrameAutoSolve;try set_solver +.
        iNext.
        iIntros "( PCz & p_7 & acc & tx)".
        iIntros "_".
        iApply wp_terminated'; eauto.
        assert ((((((((pprog0 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f = ((of_pid pprog0) ^+ length rywu_program0)%f) as ->.
        {
          assert ( (Z.of_nat (length rywu_program0)) = 7%Z) as ->. by compute.
          solve_finz.
        }
        iFrame.
        iSplitR; first done.
        done.
      }
    }
    {
      iDestruct "returnreg" as "[R0z [% [% [rx (? & ? & [% [R1z _ ]] & R2z)]]]]".
      iApply ((mov_word ((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1)%f run_I R0) with "[p_4 PCz acc tx R0z]");try rewrite HIn //; iFrameAutoSolve; try set_solver +.
      iModIntro.
      iIntros "(PCz & p_4 & acc & tx & R0z) _".
      (* mov_word_I R1 V1 *)
      rewrite wp_sswp.
      (* iDestruct "R1z" as "(%j & %p_rx & %l & ? & ? & ? & R1z & R2z & ?)". *)
      (* iDestruct "R1z" as "(%r3 & R1z & ?)". *)
      iApply ((mov_word (((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1) ^+ 1)%f (encode_vmid V1) R1) with "[p_5 PCz acc tx R1z]"); try rewrite HIn //; iFrameAutoSolve; try set_solver +.
      iModIntro.
      iIntros "(PCz & p_5 & acc & tx & R1z) _".
      (* hvc_I *)
      rewrite wp_sswp.
      iApply ((run ((((((of_pid pprog0) ^+ 1) ^+ 1)^+ 1) ^+ 1) ^+ 1)%f V1 True ((R0 @@ V0 ->r yield_I ∗ R1 @@ V0 ->r encode_vmid V1) ∗ VMProp V1 False (1 / 2)))
                with "[PCz p_6 acc tx R0z R1z prop0 prop1]"); try rewrite HIn //;iFrameAutoSolve.
      { set_solver +. }
      { set_solver +. }
      { set_solver +. }
      { apply decode_encode_hvc_func. }
      { apply decode_encode_vmid. }
      {
        iSplitR "prop0".
        - iModIntro.
          iFrame "prop1".
        - iSplitL "prop0".
          iFrame "prop0".
          iSplitR "";last done.
          iNext.
          iIntros "((PCz & p_6 & acc & tx & R0z & R1z) & _ & prop)".
          iFrame "R0z R1z prop".
          iCombine "PCz p_6 acc tx" as "R'".
          iExact "R'".
      }
      iModIntro.
      iIntros "[(PC & p_6 & acc & tx) prop0] Hholds".
      iDestruct (VMProp_holds_agree with "[Hholds prop0]") as "[P' prop0]".
      simpl.
      iFrame "Hholds prop0".
      (* getting back resources *)
      iDestruct "P'" as "((>R0z & >R1z) & prop1)".
      (* halt_I *)
      rewrite wp_sswp.
      iApply ((halt (((((((of_pid pprog0) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f) with "[PC p_7 acc tx]");
        try rewrite HIn //; iFrameAutoSolve;try set_solver +.
      iNext.
      iIntros "( PCz & p_7 & acc & tx)".
      iIntros "_".
      iApply wp_terminated'; eauto.
      assert ((((((((pprog0 ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1) ^+ 1)%f = ((of_pid pprog0) ^+ length rywu_program0)%f) as ->.
      {
        assert ( (Z.of_nat (length rywu_program0)) = 7%Z) as ->. by compute.
        solve_finz.
      }
      iFrame.
      iSplitR; first done.
      done.
    }
  Qed.

  Lemma rywu_machine1:
    seq_in_page (of_pid pprog1) (length rywu_program1) pprog1 ->
    (program rywu_program1 (of_pid pprog1))
    ∗ VMProp V1 ((R0 @@ V0 ->r run_I ∗ R1 @@ V0 ->r encode_vmid V1 )
                 ∗ VMProp V0 ((R0 @@ V0 ->r yield_I ∗ R1 @@ V0 ->r encode_vmid V1 ) ∗ VMProp V1 False%I (1/2)%Qp) (1/2)%Qp)%I (1/2)%Qp
    ∗ PC @@ V1 ->r (of_pid pprog1)
    ∗ (∃ r0, R0 @@ V1 ->r r0)
    ∗ V1 -@A> {[pprog1]}
    ∗ TX@ V1 := ptx1
    ⊢ VMProp_holds V1 (1/2)%Qp -∗
    (WP ExecI @ V1 {{ (λ m, False)}}).
  Proof.
    iIntros (HIn) "((p_1 & p_2 & _) & prop1 & PC1 & [%r0 R01] & acc & tx)".
    iIntros "Hholds".
    iDestruct (VMProp_holds_agree V1 with "[Hholds prop1]") as "[P prop1]".
    iFrame.
    pose proof (seq_in_page_forall2 _ _ _ HIn) as Hforall.
    clear HIn; rename Hforall into HIn.
    assert (ptx1 ≠ pprog1) as Hnottx.
    {
      intro.
      feed pose proof (NoDup_lookup _ 1 4 ptx1 Hps_nd).
      simplify_eq /=. done.
      simplify_eq /=. done.
      lia.
    }
    assert (1 = V1) as HV1.
    by simpl.
    (* mov_word_I R0 yield_I *)
    rewrite wp_sswp.
    iDestruct "P" as "[(R0z & R1z) prop0]".
    iApply ((mov.mov_word (of_pid pprog1) yield_I R0) with "[p_1 PC1 acc tx R01]");try rewrite HIn //;iFrameAutoSolve;try set_solver.
    iModIntro.
    iIntros "(PC1 & p_1 & acc & tx & R01)".
    iSimpl.
    rewrite HV1.
    iIntros "_".
    (* hvc_I *)
    rewrite wp_sswp.
    iApply ((yield ((of_pid pprog1) ^+ 1)%f True False%I)
         with "[PC1 p_2 acc tx R01 R0z R1z prop0 prop1]"); try rewrite HIn //;iFrameAutoSolve.
    { set_solver +. }
    { set_solver +. }
    { set_solver +. }
    { apply decode_encode_hvc_func. }
    { iSplitL "prop0".
      iFrame.
      iSplitL "prop1".
      iFrame.
      iSplitL "";last done.
      iNext.
      iIntros "((H1 & H2 & H3 & H4 & H5 & H6) & _ & H7)".
      iFrame.
      iCombine "H1 H2 H3 H4 H5" as "R'".
      iExact "R'".
    }
    iModIntro.
    iIntros "[? prop1] Hholds".
    simpl.
    iDestruct (VMProp_holds_agree V1 with "[prop1 Hholds]") as "[P prop1]".
    iFrame.
    iMod "P".
    by iExFalso.
  Qed.

  Definition rywu_interp_access := interp_access V2 rywu_slice_trans rywu_slice_rxs ptx2 prx2 {[pprog2;ptx2;prx2]} ∅.

  Lemma rywu_ftlr2 :
   rywu_interp_access ⊢ interp_execute V2.
  Proof. iApply ftlr. Qed.

End proof.


From ITree Require Import ITree.
From Paco Require Import paco.
From compcert Require Import Integers.

Require Import sflib.

Require Import StdlibExt.
Require Import IntegersExt.
Require Import SyncSysModel.

Require Import Executable.
Require Import PALSSystem.

Require Import AcStSystem.
Require Import SpecConsole SpecController SpecDevice.
Require Import AcStRefinement.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlString.

Require Import ZArith List Lia.

Definition exec_sys: ExecutableSpec.t :=
  PALSSys.as_exec active_standby_system.

Definition resize_bytes: bytes -> bytes? :=
  (fun bs => Some (RTSysEnv.resize_bytes 8 bs)).

(* We extract this instead of exec_sys for lighter extraction result. *)
Definition app_system: ExecutableSpec.t :=
  ExecutableSpec.mk _ (list byte)
                    ActiveStandby.period
                    [con_mod; ctrl_mod 1%Z; ctrl_mod 2%Z;
                    dev_mod; dev_mod; dev_mod]
                    [[1; 2]]
                    resize_bytes
.

Local Opaque ActiveStandby.period.
Local Opaque Z.of_nat Z.to_nat.

Lemma exec_sys_equiv: exec_sys = app_system.
Proof.
  unfold exec_sys.
  unfold PALSSys.as_exec.
  unfold RTSysEnv.period. s.
  rewrite Z2Nat.id by ss.
  ss.
Qed.

Definition app_system_itree
  : _ -> _ -> itree _ _ :=
  ExecutableSpec.sys_itree app_system.

Cd "./extr/active_standby_spec".
Extraction "AppSystem.ml" app_system app_system_itree.
Cd "../..".


(** ** Facts about Evaluation of Combinational Concurrent Statement *)

Require Import common.CoqLib.
Require Import common.NatMap.
Require Import common.proofs.NatMapTactics.
Require Import common.InAndNoDup.
Require Import common.NatSet.

Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.HVhdlTypes.
Require Import hvhdl.Environment.
Require Import hvhdl.SemanticalDomains.
Require Import hvhdl.CombinationalEvaluation.
Require Import hvhdl.Place.
Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.HilecopDesignStore.
Require Import hvhdl.SSEvaluation.
Require Import hvhdl.proofs.SSEvaluationFacts.
Require Import hvhdl.PortMapEvaluation.
Require Import hvhdl.proofs.PortMapEvaluationFacts.
Require Import hvhdl.WellDefinedDesign.
Require Import hvhdl.proofs.AbstractSyntaxTactics.
Require Import hvhdl.proofs.WellDefinedDesignFacts.
Require Import hvhdl.proofs.WellDefinedDesignTactics.
Require Import hvhdl.proofs.EnvironmentFacts.
Require Import hvhdl.proofs.EnvironmentTactics.

(** ** Facts about [vcomb] *)

Lemma vcomb_maps_cstore_id :
  forall {D__s Δ σ behavior σ' id__c σ__c},
    vcomb D__s Δ σ behavior σ' ->
    MapsTo id__c σ__c (cstore σ) ->
    exists σ__c', MapsTo id__c σ__c' (cstore σ').
Proof.
  induction 1; try (simpl; exists σ__c; assumption).

  (* CASE process evaluation, no events in sl *)
  - exists σ__c; eapply VSeq_inv_cstore; simpl; eauto.

  (* CASE comp evaluation with events.
       2 subcases, [id__c = compid] or [id__c ≠ compid] *)
  - simpl; destruct (Nat.eq_dec id__c0 id__c).
    + exists σ__c''; rewrite e; apply NatMap.add_1; auto.
    + exists σ__c; apply NatMap.add_2; auto.
      eapply MOP_inv_cstore; eauto.

  (* CASE comp evaluation with no events. *)
  - exists σ__c; eapply MOP_inv_cstore; eauto.

  (* CASE par *)
  - unfold IsMergedDState in H2; apply proj2, proj1 in H2.
    unfold EqualDom in H2; rewrite <- (H2 id__c); exists σ__c; assumption.
Qed.

Lemma vcomb_par_comm :
  forall {D__s Δ σ cstmt cstmt' σ'},
    vcomb D__s Δ σ (cstmt // cstmt') σ' <->
    vcomb D__s Δ σ (cstmt' // cstmt) σ'.
Proof.
  split; inversion_clear 1.
  all :
    eapply @VCombPar; eauto;
    [ transitivity (inter (events σ'0) (events σ'')); auto with set
    | erewrite IsMergedDState_comm; auto ].
Qed.

Lemma vcomb_par_assoc :
  forall {D__s Δ σ cstmt cstmt' cstmt'' σ'},
    vcomb D__s Δ σ (cstmt // cstmt' // cstmt'') σ' <->
    vcomb D__s Δ σ ((cstmt // cstmt') // cstmt'')  σ'.
Proof.
  split.
  (* CASE A *)
  - inversion_clear 1;
      match goal with
      | [ H: vcomb _ _ _ (_ // _) _ |- _ ] => inversion_clear H
      end;
      rename σ'0 into σ0, σ'' into σ1, σ'1 into σ2, σ''0 into σ3.

    assert (Equal (inter (events σ0) (events σ2)) {[]}).
    {
      do 2 decompose_IMDS.
      assert (Equal_empty : Equal (inter (events σ0) (events σ2 U events σ3)) {[]})
        by (match goal with
            | [ H: Equal _ ?u |- Equal (_ _ ?u) _ ] => rewrite <- H
            end; assumption).
      apply empty_is_empty_1.
      rewrite inter_sym, union_inter_1, inter_sym in Equal_empty.
      eapply proj1; eapply @union_empty with (s := (inter (events σ0) (events σ2))); eauto.
    }
    destruct (@IsMergedDState_ex σ σ0 σ2) as (σ4, IsMergedDState_σ4);
      (solve [do 2 decompose_IMDS; auto] || auto).
    eapply @VCombPar with (σ' := σ4) (σ'' := σ3); eauto with hvhdl.

    (* [events σ4 ∩ events σ3 = ∅] *)
    + do 3 decompose_IMDS.
      match goal with
      | [ H: Equal ?ev _ |- Equal (_ ?ev _) _] =>
        rewrite H; rewrite union_inter_1
      end.
      match goal with
      | [ H: Equal ?i {[]} |- Equal (_ U ?i) {[]} ] =>
        rewrite H; apply empty_union_1
      end.
      assert (Equal_empty : Equal (inter (events σ0) ((events σ2) U (events σ3))) {[]})
        by (match goal with
            | [ H: Equal _ ?A  |- Equal (inter _ ?A) _ ] =>
              rewrite <- H
            end; assumption).
      rewrite inter_sym, union_inter_1, union_sym, inter_sym in Equal_empty.
      eapply proj1; eapply union_empty; eauto.

    (* Associativity of IsMErgeddstate relation *)
    + eapply IsMergedDState_assoc_1; eauto.

  (* CASE B *)
  - inversion_clear 1;
      match goal with
      | [ H: vcomb _ _ _ (_ // _) _ |- _ ] => inversion_clear H
      end.
    rename σ'1 into σ0, σ''0 into σ1, σ'' into σ2, σ'0 into σ3.
    assert (Equal (inter (events σ1) (events σ2)) {[]}).
    {
      do 2 decompose_IMDS.
      assert (Equal_empty : Equal (inter (events σ0 U events σ1) (events σ2) ) {[]})
        by (match goal with
            | [ H: Equal _ ?u |- Equal (_ ?u _) _ ] => rewrite <- H
            end; assumption).
      apply empty_is_empty_1.
      rewrite union_inter_1 in Equal_empty.
      eapply proj2; eapply @union_empty; eauto.
    }
    destruct (@IsMergedDState_ex σ σ1 σ2) as (σ4, IsMergedDState_σ4);
      (solve [do 2 decompose_IMDS; auto] || auto).
    eapply @VCombPar with (σ' := σ0) (σ'' := σ4); eauto with hvhdl.

    (* [events σ0 ∩ events σ4 = ∅] *)
    + do 3 decompose_IMDS.
      match goal with
      | [ H: Equal ?ev _ |- Equal (_ _ ?ev) _ ] =>
        rewrite H; rewrite inter_sym; rewrite union_inter_1
      end.
      rewrite inter_sym, union_sym.
      match goal with
      | [ H: Equal ?i {[]} |- Equal (_ U ?i) {[]} ] =>
        rewrite H; apply empty_union_1
      end.
      rewrite inter_sym.
      assert (Equal_empty : Equal (inter (events σ0 U events σ1) (events σ2)) {[]})
        by (match goal with
            | [ H: Equal _ ?A  |- Equal (_ ?A  _) _ ] =>
              rewrite <- H
            end; assumption).
      rewrite union_inter_1 in Equal_empty.
      eapply proj1; eapply union_empty; eauto.

    (* Associativity of IsMErgeddstate relation *)
    + eapply IsMergedDState_assoc_2; eauto.
Qed.

Lemma vcomb_not_in_events_if_not_assigned :
  forall {D__s Δ σ cstmt σ' id},
    vcomb D__s Δ σ cstmt σ' ->
    ~CompOf Δ id ->
    ~AssignedInCs id cstmt ->
    ~NatSet.In id (events σ').
Proof.
  induction 1; (try (solve [simpl; auto with set])).

  (* CASE eventful process *)
  - simpl; intros; eapply VSeq_not_in_events_if_not_assigned; eauto with set.

  (* CASE eventful component *)
  - simpl; intros.
    erewrite add_spec; inversion_clear 1;
      [ subst; match goal with
               | [ H: ~CompOf _ _ |- _ ] =>
                 apply H; exists Δ__c; auto
               end
      | eapply MOP_not_in_events_if_not_assigned; eauto with set].

  (* CASE eventless component *)
  - simpl; intros;
      eapply MOP_not_in_events_if_not_assigned; eauto with set.

  (* CASE || *)
  - simpl; intros.
    decompose_IMDS; match goal with | [ H: Equal _ _ |- _ ] => rewrite H end.
    apply not_in_union; [ apply IHvcomb1; auto | apply IHvcomb2; auto ].
Qed.

Lemma vcomb_inv_cstate :
  forall {D__s Δ σ behavior σ' id__c σ__c},
    vcomb D__s Δ σ behavior σ' ->
    MapsTo id__c σ__c (cstore σ) ->
    ~NatSet.In id__c (events σ') ->
    MapsTo id__c σ__c (cstore σ').
Proof.
  induction 1; auto.

  (* CASE eventful process *)
  - intros; eapply VSeq_inv_cstore; eauto.

  (* CASE eventful component *)
  - simpl; intros.
    erewrite NatMap.add_neq_mapsto_iff; eauto.
    eapply MOP_inv_cstore; eauto.
    intro; subst;
    match goal with
    | [ H: ~NatSet.In _ _ |- _ ] => apply H; auto with set
    end.

  (* CASE eventless component *)
  - intros; eapply MOP_inv_cstore; eauto.

  (* CASE || *)
  - intros;
      decompose_IMDS;
      match goal with
      | [ H: _ -> _ -> ~NatSet.In _ _ -> _ <-> _, H': Equal _ _ |- _ ] =>
        erewrite <- H; auto; (assumption || (rewrite <- H'; assumption))
      end.
Qed.

Lemma vcomb_compid_not_in_events :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    forall {id__c Δ__c compids},
    AreCsCompIds cstmt compids ->
    MapsTo id__c (Component Δ__c) Δ ->
    ~List.In id__c compids ->
    ~NatSet.In id__c (events σ').
Proof.
  induction 1; auto with set.

  (* CASE eventful process *)
  - intros; eapply VSeq_not_in_events_if_not_sig; simpl.
    1, 2: eauto with set.
    1, 2: destruct 1; mapsto_discriminate.

  (* CASE eventful component *)
  - simpl; inversion_clear 1; intros.
    rewrite add_spec; inversion_clear 1.
    match goal with
    | [ H: ~List.In _ _ |- _ ] =>
      apply H; firstorder
    end.
    eapply MOP_not_in_events_if_not_sig; eauto with set;
      destruct 1; mapsto_discriminate.

  (* CASE eventless component *)
  - intros; eapply MOP_not_in_events_if_not_sig; eauto with set;
    destruct 1; mapsto_discriminate.

  (* CASE || *)
  - destruct (AreCsCompIds_ex cstmt) as (compids1, AreCsCompIds_1);
      destruct (AreCsCompIds_ex cstmt') as (compids2, AreCsCompIds_2).
    do 4 intro;
      erewrite (AreCsCompIds_eq_app cstmt cstmt' compids1 compids2)
        with (compids'' := compids); eauto.
    rename H2 into IMDS; erw_IMDS_events_m IMDS; intros; apply not_in_union.
    eapply IHvcomb1; eauto; eapply proj1; eapply not_app_in; eauto.
    eapply IHvcomb2; eauto; eapply proj2; eapply not_app_in; eauto.
Qed.

Lemma vcomb_maps_sstore :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    forall {id v},
      MapsTo id v (sstore σ) ->
      exists v', MapsTo id v' (sstore σ').
Proof.
  induction 1.

  (* CASE active process *)
  - eapply @VSeq_maps_sstore with (σ__w := NoEvDState σ); eauto.

  (* CASE comp evaluation with events. *)
  - cbn; eapply @MOP_maps_sstore with (σ := NoEvDState σ); eauto.

  (* CASE comp evaluation with no events. *)
  - cbn; eapply @MOP_maps_sstore with (σ := NoEvDState σ); eauto.

  (* CASE null *)
  - intros; exists v; assumption.

  (* CASE par *)
  - rename H2 into IMDS; intros.
    apply proj1 in IMDS; unfold EqualDom in IMDS.
    rewrite <- (IMDS id); exists v; assumption.
Qed.

Lemma vcomb_compid_in_events_comp_in_cs :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    forall {id__c},
      CompOf Δ id__c ->
      NatSet.In id__c (events σ') ->
      exists id__e gm ipm opm,
        InCs (cs_comp id__c id__e gm ipm opm) cstmt.
Proof.
  induction 1.

  (* CASE active process *)
  - intros id__c CompOf_; intros; exfalso.
    eapply VSeq_not_in_events_if_not_sig; eauto.
    cbn; eauto with set.
    destruct 1; destruct CompOf_; mapsto_discriminate.
    destruct 1; destruct CompOf_; mapsto_discriminate.

  (* CASE eventful comp *)
  - cbn; intros id__c0 CompOf_.
    rewrite add_iff; inversion 1.
    subst id__c; exists id__e, g, i, o; reflexivity.
    exfalso.
    eapply MOP_not_in_events_if_not_sig; eauto.
    cbn; eauto with set.
    destruct 1; destruct CompOf_; mapsto_discriminate.
    destruct 1; destruct CompOf_; mapsto_discriminate.

  (* CASE eventless comp *)
  - cbn; intros * CompOf_; intros.
    exfalso.
    eapply MOP_not_in_events_if_not_sig; eauto.
    cbn; eauto with set.
    destruct 1; destruct CompOf_; mapsto_discriminate.
    destruct 1; destruct CompOf_; mapsto_discriminate.

  (* CASE cs_null *)
  - cbn; inversion 2.

  (* CASE || *)
  - rename H2 into IMDS; intros id__c CompOf_.
    erw_IMDS_events_m IMDS.
    rewrite union_spec; inversion 1.
    edestruct IHvcomb1 as (id__e, (g, (i, (o, InCs_)))); eauto.
    exists id__e, g, i, o; cbn; left; assumption.
    edestruct IHvcomb2 as (id__e, (g, (i, (o, InCs_)))); eauto.
    exists id__e, g, i, o; cbn; right; assumption.
Qed.

Lemma vcomb_is_compof_if_in_cs :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    forall {id__c id__e gm ipm opm},
      InCs (cs_comp id__c id__e gm ipm opm) cstmt ->
      CompOf Δ id__c.
Proof.
  induction 1; try (solve [inversion 1]).

  (* CASE eventful comp *)
  - inversion 1; subst; unfold CompOf; eauto.

  (* CASE eventless comp *)
  - inversion 1; subst; unfold CompOf; eauto.

  (* CASE || *)
  - inversion 1; eauto.
Qed.

Lemma vcomb_maps_sstore_of_comp :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    forall {id__c id__e gm ipm opm σ__c σ'__c id v},
      InCs (cs_comp id__c id__e gm ipm opm) cstmt ->
      MapsTo id__c σ__c (cstore σ) ->
      MapsTo id v (sstore σ__c) ->
      MapsTo id__c σ'__c (cstore σ') ->
      exists v', MapsTo id v' (sstore σ'__c).
Proof.
  induction 1; try (solve [inversion 1]).
  (* CASE comp evaluation with events.*)
  - inversion_clear 1; cbn; intros.
    erewrite @MapsTo_add_eqv with (e := σ'__c) (e' := σ__c''); eauto.
    edestruct @MIP_maps_sstore with (Δ := Δ); eauto.
    erewrite <- MapsTo_fun with (e := σ__c0) (e' := σ__c); eauto.
    eapply vcomb_maps_sstore; eauto.
  (* CASE comp evaluation with no events.*)
  - inversion_clear 1; cbn; intros.
    exists v.
    assert (MapsTo id__c σ__c (cstore σ'))
      by (eapply MOP_inv_cstore; eauto).
    erewrite <- MapsTo_fun with (e := σ__c) (e' := σ'__c); eauto.
    erewrite <- MapsTo_fun with (e := σ__c0) (e' := σ__c); eauto.
  (* CASE || *)
  - rename H2 into IMDS; intros until σ__c; intros σ__mc.

    (* 2 CASES: [comp ∈ cs] or [comp ∈ cs'] *)
    inversion_clear 1; intros.

    (* CASE [comp ∈ cs] *)
    + (* 2 CASES: [id__c ∈ events σ'] or [id__c ∉ events σ'] *)
      destruct (In_dec id__c (events σ')) as [ In_ev' | nIn_ev' ].
      (* CASE [id__c ∈ events σ'] *)
      -- eapply IHvcomb1; eauto.
         erw_IMDS_cstore_1 IMDS; eauto.

      (* CASE [id__c ∉ events σ'] *)
      -- (* 2 CASES: [id__c ∈ events σ''] or [id__c ∉ events σ''] *)
        destruct (In_dec id__c (events σ'')) as [ In_ev'' | nIn_ev'' ].

        (* CASE [id__c ∈ events σ''] *)
        ++ edestruct @vcomb_compid_in_events_comp_in_cs with (D__s := D__s) (id__c := id__c)
            as (id__e', (g, (i, (o, InCs_)))); eauto.
           eapply @vcomb_is_compof_if_in_cs with (cstmt := cstmt); eauto.
           eapply IHvcomb2; eauto.
           erw_IMDS_cstore_2 IMDS; eauto.

        (* CASE [id__c ∉ events σ''] *)
        ++ assert (eq_cstate: σ__c = σ__mc).
           { eapply MapsTo_fun; eauto.
             erw_IMDS_cstore_m IMDS; eauto.
             eapply not_in_union; eauto. }
           rewrite <- eq_cstate; exists v; assumption.

    (* CASE [comp ∈ cs'] *)
    + (* 2 CASES: [id__c ∈ events σ''] or [id__c ∉ events σ''] *)
      destruct (In_dec id__c (events σ'')) as [ In_ev'' | nIn_ev'' ].
      (* CASE [id__c ∈ events σ''] *)
      -- eapply IHvcomb2; eauto.
         erw_IMDS_cstore_2 IMDS; eauto.

      (* CASE [id__c ∉ events σ''] *)
      -- (* 2 CASES: [id__c ∈ events σ'] or [id__c ∉ events σ'] *)
        destruct (In_dec id__c (events σ')) as [ In_ev' | nIn_ev' ].

        (* CASE [id__c ∈ events σ'] *)
        ++ edestruct @vcomb_compid_in_events_comp_in_cs
          with (D__s := D__s) (id__c := id__c) (cstmt := cstmt)
            as (id__e', (g, (i, (o, InCs_)))); eauto.
           eapply @vcomb_is_compof_if_in_cs with (cstmt := cstmt'); eauto.
           eapply IHvcomb1; eauto.
           erw_IMDS_cstore_1 IMDS; eauto.

        (* CASE [id__c ∉ events σ'] *)
        ++ assert (eq_cstate: σ__c = σ__mc).
           { eapply MapsTo_fun; eauto.
             erw_IMDS_cstore_m IMDS; eauto.
             eapply not_in_union; eauto. }
           rewrite <- eq_cstate; exists v; assumption.
Qed.

Lemma vcomb_inv_well_typed_values_in_sstore :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    (forall {id t v},
        (MapsTo id (Internal t) Δ \/ MapsTo id (Input t) Δ \/ MapsTo id (Output t) Δ) ->
        MapsTo id v (sstore σ) ->
        IsOfType v t) ->
    forall {id t v},
      (MapsTo id (Internal t) Δ \/ MapsTo id (Input t) Δ \/ MapsTo id (Output t) Δ) ->
      MapsTo id v (sstore σ') ->
      IsOfType v t.
Proof.
  induction 1; intros WT; try (solve [trivial]).
  (* CASE process *)
  - eapply @VSeq_inv_well_typed_values_in_sstore with (σ__w := NoEvDState σ); eauto.
  (* CASE eventful component *)
  - cbn; eapply @MOP_inv_well_typed_values_in_sstore with (σ := NoEvDState σ); eauto.
  (* CASE eventless component *)
  - cbn; eapply @MOP_inv_well_typed_values_in_sstore with (σ := NoEvDState σ); eauto.
  (* CASE || *)
  - specialize (IHvcomb1 WT); specialize (IHvcomb2 WT).
    intros *; intros MapsTo_Δ MapsTo_sstore_m.
    rename H2 into IMDS.
    (* 2 CASES: [id ∈ events σ'] or [id ∉ events σ'] *)
    destruct (In_dec id (events σ')) as [ In_ev' | nIn_ev' ].
    (* CASE [id ∈ events σ'] *)
    + eapply IHvcomb1; eauto.
      erw_IMDS_sstore_1 IMDS; eauto.
    (* CASE [id ∉ events σ'] *)
    + (* 2 CASES: [id ∈ events σ''] or [id ∉ events σ''] *)
      destruct (In_dec id (events σ'')) as [ In_ev'' | nIn_ev'' ].
      (* CASE [id ∈ events σ''] *)
      -- eapply IHvcomb2; eauto.
         erw_IMDS_sstore_2 IMDS; eauto.
      (* CASE [id ∉ events σ''] *)
      -- eapply WT; eauto.
         erw_IMDS_sstore_m IMDS; eauto.
         eapply not_in_union; eauto.
Qed.

Lemma vcomb_inv_well_typed_values_in_sstore_of_comp :
  forall {D__s Δ σ cstmt σ'},
    vcomb D__s Δ σ cstmt σ' ->
    (forall {id__c Δ__c σ__c},
        MapsTo id__c (Component Δ__c) Δ ->
        MapsTo id__c σ__c (cstore σ) ->
        forall {id t v},
          (MapsTo id (Internal t) Δ__c \/ MapsTo id (Input t) Δ__c \/ MapsTo id (Output t) Δ__c) ->
          MapsTo id v (sstore σ__c) ->
          IsOfType v t) ->
    forall {id__c Δ__c σ'__c},
      MapsTo id__c (Component Δ__c) Δ ->
      MapsTo id__c σ'__c (cstore σ') ->
      forall {id t v},
        (MapsTo id (Internal t) Δ__c \/ MapsTo id (Input t) Δ__c \/ MapsTo id (Output t) Δ__c) ->
        MapsTo id v (sstore σ'__c) ->
        IsOfType v t.
Proof.
  induction 1; intros WT; trivial.
  (* CASE process *)
  - intros; eapply WT; eauto.
    eapply @VSeq_inv_cstore_2 with (σ__w := NoEvDState σ); eauto.
  (* CASE eventful component *)
  - cbn; do 5 intro.
    (* 2 CASES: [id__c = compid] or [id__c ≠ compid] *)
    destruct (Nat.eq_dec id__c id__c0) as [ eq_ | neq_ ].
    (* CASE [id__c = id__c0] *)
    + rewrite eq_ in *; intros.
      assert (eq_Δ : Component Δ__c0 = Component Δ__c) by (eauto with mapsto).
      inject_left eq_Δ; eauto.
      eapply vcomb_inv_well_typed_values_in_sstore; eauto.
      eapply MIP_inv_well_typed_values_in_sstore; eauto.
      erewrite <- @MapsTo_add_eqv with (e := σ'__c) (e' := σ__c''); eauto.
    (* CASE [id__c ≠ id__c0] *)
    + assert (MapsTo id__c0 σ'__c (cstore σ)) by
        (eapply @MOP_inv_cstore_2 with (σ := NoEvDState σ); eauto with mapsto).
      eapply WT; eauto.
  (* CASE eventless component *)
  - cbn; do 5 intro.
    assert (MapsTo id__c0 σ'__c (cstore σ)) by
        (eapply @MOP_inv_cstore_2 with (σ := NoEvDState σ); eauto with mapsto).
    eapply WT; eauto.
  (* CASE || *)
  - specialize (IHvcomb1 WT); specialize (IHvcomb2 WT).
    intros *; intros MapsTo_Δ__c MapsTo_cstore_m.
    rename H2 into IMDS.
    (* 2 CASES: [id__c ∈ events σ'] or [id__c ∉ events σ'] *)
    destruct (In_dec id__c (events σ')) as [ In_ev' | nIn_ev' ].
    (* CASE [id__c ∈ events σ'] *)
    + eapply IHvcomb1; eauto.
      erw_IMDS_cstore_1 IMDS; eauto.

    (* CASE [id__c ∉ events σ'] *)
    + (* 2 CASES: [id__c ∈ events σ''] or [id__c ∉ events σ''] *)
      destruct (In_dec id__c (events σ'')) as [ In_ev'' | nIn_ev'' ].

      (* CASE [id__c ∈ events σ''] *)
      -- eapply IHvcomb2; eauto.
         erw_IMDS_cstore_2 IMDS; eauto.

      (* CASE [id__c ∉ events σ''] *)
      -- eapply WT; eauto.
         erw_IMDS_cstore_m IMDS; eauto.
         eapply not_in_union; eauto.
Qed.


(** * Definition of a [comp]-based non-computational CFG parser *)
Require Import Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Arith.Compare_dec Coq.Classes.RelationClasses Coq.Strings.String.
Require Import Parsers.ContextFreeGrammar Parsers.Specification Parsers.DependentlyTyped Parsers.MinimalParse.
Require Import Parsers.DependentlyTypedMinimal Parsers.DependentlyTypedSum.
Require Import Parsers.WellFoundedParse Parsers.ContextFreeGrammarProperties.
Require Import Common Common.ilist Common.Wf Common.Le.

Set Implicit Arguments.

Local Open Scope string_like_scope.

Local Coercion is_true : bool >-> Sortclass.

Section recursive_descent_parser.
  Context (CharType : Type)
          (String : string_like CharType)
          (G : grammar CharType).
  Context {predata : parser_computational_predataT}.
  Local Instance types_data : @parser_computational_types_dataT _ String
    := {| predata := predata;
          split_stateT str0 valid g str := True |}.
  Context {methods' : @parser_computational_dataT' _ String types_data}
          {strdata : @parser_computational_strdataT _ String G {| methods' := methods' |}}.

  Local Instance orig_methods : @parser_computational_dataT _ String
    := { methods' := methods' }.

  Context (remove_nonterminal_name_1
           : forall ls ps ps',
               is_valid_nonterminal_name (remove_nonterminal_name ls ps) ps' = true
               -> is_valid_nonterminal_name ls ps' = true)
          (remove_nonterminal_name_2
           : forall ls ps ps',
               is_valid_nonterminal_name (remove_nonterminal_name ls ps) ps' = false
               <-> is_valid_nonterminal_name ls ps' = false \/ ps = ps').

  Definition P (str0 : String) valid : String -> string -> Prop
    := fun str p =>
         sub_names_listT is_valid_nonterminal_name valid initial_nonterminal_names_data
         /\ is_valid_nonterminal_name
              (if lt_dec (Length str) (Length str0)
               then initial_nonterminal_names_data
               else valid)
              p = true.

  Lemma P_remove_impl {str0 valid str name name'}
        (H0 : name <> name')
        (H : P str0 valid str name')
  : P str0 (remove_nonterminal_name valid name) str name'.
  Proof.
    destruct_head_hnf and.
    repeat split; try assumption.
    { apply sub_names_listT_remove_2; assumption. }
    { destruct lt_dec; try assumption.
      match goal with
        | [ |- ?b = true ] => case_eq b; try reflexivity
      end.
      intro H'; exfalso.
      apply remove_nonterminal_name_2 in H'.
      destruct H'; congruence. }
  Qed.

  Definition p_parse_item str0 valid s it
    := { p' : parse_of_item String G s it & Forall_parse_of_item (P str0 valid) p' }.
  Definition p_parse_production str0 valid s p
    := { p' : parse_of_production String G s p & Forall_parse_of_production (P str0 valid) p' }.
  Definition p_parse str0 valid s prods
    := { p' : parse_of String G s prods & Forall_parse_of (P str0 valid) p' }.
  Definition p_parse_nonterminal_name str0 valid s nonterminal_name
    := { p' : parse_of_item String G  s (NonTerminal _ nonterminal_name) & Forall_parse_of_item (P str0 valid) p' }.

  Definition split_parse_of_production {str0 valid str it its}
             (p : p_parse_production str0 valid str (it::its))
  : { s1s2 : String * String & (fst s1s2 ++ snd s1s2 =s str)
                               * p_parse_item str0 valid (fst s1s2) it
                               * p_parse_production str0 valid (snd s1s2) its }%type.
  Proof.
    destruct p as [p H]; revert p H.
    pattern (it :: its).
    match goal with
      | [ |- ?P ?ls ]
        => set (prods := ls);
          change it with (hd it prods);
          change its with (tl prods);
          assert (H' : ls = prods) by reflexivity;
          clearbody prods;
          simpl
    end.
    intro p.
    destruct p.
    { exfalso; clear -H'; abstract inversion H'. }
    { intro H''.
      eexists (_, _); simpl.
      repeat split; try match goal with H : _ |- _ => exists H end.
      { apply bool_eq_correct; reflexivity. }
      { exact (fst H''). }
      { exact (snd H''). } }
  Defined.

  Lemma split_parse_of_production_le1 {str0 valid str it its p}
  : fst (projT1 (@split_parse_of_production str0 valid str it its p)) ≤s str.
  Proof.
    etransitivity; [ eapply str_le1_append | right; apply bool_eq_correct ].
    exact (fst (fst (projT2 (split_parse_of_production p)))).
  Qed.

  Lemma split_parse_of_production_le2 {str0 valid str it its p}
  : snd (projT1 (@split_parse_of_production str0 valid str it its p)) ≤s str.
  Proof.
    etransitivity; [ eapply str_le2_append | right; apply bool_eq_correct ].
    exact (fst (fst (projT2 (split_parse_of_production p)))).
  Qed.

  Local Instance top_types_data : @parser_computational_types_dataT _ String
    := { split_stateT str0 valid g s
         := match g return Type with
              | include_item it => p_parse_item str0 valid s it
              | include_production p => p_parse_production str0 valid s p
              | include_productions prods => p_parse str0 valid s prods
              | include_nonterminal_name nonterminal_name => p_parse_nonterminal_name str0 valid s nonterminal_name
            end }.

  Local Instance top_methods' : @parser_computational_dataT' _ String top_types_data
    := { split_string_for_production str0 valid it its s
         := let st' := split_parse_of_production (state_val s) in
            ({| string_val := fst (projT1 st') ; state_val := snd (fst (projT2 st')) |},
             {| string_val := snd (projT1 st') ; state_val := snd (projT2 st') |})::nil }.
  Proof.
    intros; subst_body; simpl in *.
    abstract (do 2 try constructor; edestruct @split_parse_of_production; simpl; intuition).
  Defined.

  Definition parse_of__of__parse_of_item_lt' {str0 valid str nonterminal_name}
             (pf : Length str < Length str0)
             (p : p_parse_nonterminal_name str0 valid str nonterminal_name)
  : P str0 valid str nonterminal_name * p_parse str initial_nonterminal_names_data str (Lookup G nonterminal_name).
  Proof.
    refine (match projT1 p as p' in parse_of_item _ _ str' it'
                  return match it' with
                           | Terminal _ => True
                           | NonTerminal nonterminal_name' => Length str' < Length str0 -> Forall_parse_of_item (P str0 valid) p' -> P str0 valid str' nonterminal_name' * p_parse str' initial_nonterminal_names_data str' (Lookup G nonterminal_name')
                         end
            with
              | ParseTerminal _ => I
              | ParseNonTerminal _ _ p' => fun pf' H' => (fst H', existT _ p' (expand_forall_parse_of _ _ (snd H')))
            end pf (projT2 p)).
    clear -pf'; unfold P in *; simpl;
    abstract (intros ??; do 2 edestruct lt_dec; intuition).
  Defined.
  Definition parse_of__of__parse_of_item_lt {str0 valid str nonterminal_name} pf p
    := snd (@parse_of__of__parse_of_item_lt' str0 valid str nonterminal_name pf p).

  Definition deloop_right str0 valid str nonterminal_name
    := p_parse str0 (remove_nonterminal_name valid nonterminal_name) str (Lookup G nonterminal_name).

  Definition deloop_onceT
    := forall str0 valid str nonterminal_name prods
              (p : parse_of String G str prods)
              (pf : str = str0 :> String)
              (H : Forall_parse_of (P str0 valid) p),
         p_parse str0 (remove_nonterminal_name valid nonterminal_name) str prods
         + deloop_right str0 valid str nonterminal_name.

  Definition deloop_once_productionT
    := forall str0 valid str nonterminal_name prod
              (p : parse_of_production String G str prod)
              (pf : str = str0 :> String)
              (H : Forall_parse_of_production (P str0 valid) p),
         p_parse_production str0 (remove_nonterminal_name valid nonterminal_name) str prod
         + deloop_right str0 valid str nonterminal_name.

  Definition deloop_once_item'
             (deloop_once : deloop_onceT)
             {str0 valid str nonterminal_name}
             {it}
             (p : parse_of_item String G str it)
             (pf : str = str0 :> String)
             (H : Forall_parse_of_item (P str0 valid) p)
  : p_parse_item str0 (remove_nonterminal_name valid nonterminal_name) str it
    + deloop_right str0 valid str nonterminal_name.
  Proof.
    destruct p as [ | nonterminal_name' str'' p' ].
    { exact (inl (existT _ (ParseTerminal _ _ _) tt)). }
    { refine (if string_dec nonterminal_name nonterminal_name'
              then inr (if @deloop_once _ _ _ nonterminal_name' _ p' pf (snd H)
                        then _
                        else _)
              else match @deloop_once _ _ _ nonterminal_name _ p' pf (snd H) with
                     | inl p''' => inl (existT _ (ParseNonTerminal _ (projT1 p''')) (P_remove_impl _ (fst H), projT2 p'''))
                     | inr ret => inr ret
                   end);
      clear deloop_once;
      solve [ assumption
            | subst; assumption ]. }
  Defined.

  Definition deloop_once'
             (deloop_once : deloop_onceT)
             (deloop_once_production : deloop_once_productionT)
  : deloop_onceT.
  Proof.
    intros str0 valid str nonterminal_name pats p pf H.
    destruct p as [ str' pat' pats' p' | str' pat' pats' p' ].
    { refine match deloop_once_production str0 valid str' nonterminal_name _ p' pf H with
               | inl ret => inl (existT _ (ParseHead pats' (projT1 ret)) (projT2 ret))
               | inr ret => inr ret
             end. }
    { refine match deloop_once str0 valid str' nonterminal_name _ p' pf H with
               | inl ret => inl (existT _ (ParseTail _ (projT1 ret)) (projT2 ret))
               | inr ret => inr ret
             end. }
  Defined.

  Local Ltac deloop_t :=
    repeat match goal with
             | _ => assumption
             | _ => intro
             | [ H : ?x = ?y |- _ ] => subst x
             | [ H : ?x = ?y |- _ ] => subst y
             | [ H : _ ≤s _ |- _ ] => destruct H
             | _ => progress simpl in *
             | [ H : _ |- _ ] => rewrite Length_Empty in H
             | _ => rewrite Length_Empty
             | [ H : _ < 0 |- _ ] => destruct (Lt.lt_n_0 _ H)
             | _ => progress destruct_head and
             | [ |- _ /\ _ ] => split
             | [ H : sub_names_listT _ _ _ |- is_valid_nonterminal_name _ _ = true ]
               => (apply H; eapply sub_names_listT_remove; eassumption)
             | [ H : ~0 < ?n |- _ ]
               => (let H' := fresh in
                   destruct (zerop n) as [ | H' ]; [ clear H | destruct (H H') ])
             | [ H : Length _ = 0 |- _ ] => apply Empty_Length in H
             | [ H : ?x <> ?x |- _ ] => destruct (H eq_refl)
             | [ H : context[Length (_ ++ _)] |- _ ] => rewrite <- Length_correct in H
             | [ H : ~_ < _ + _ |- _ ]
               => unique pose proof (proj1 (not_lt_plus H))
             | [ H : ~_ < _ + _ |- _ ]
               => unique pose proof (proj2 (not_lt_plus H))
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ H : ~ ?a < ?a + _ |- _ ] => apply not_lt_add_r in H
             | [ H : ~ ?a < _ + ?a |- _ ] => apply not_lt_add_l in H
           end.

  Definition deloop_once_production'
             (deloop_once : deloop_onceT)
             (deloop_once_production : deloop_once_productionT)
  : deloop_once_productionT.
  Proof.
    intros str0 valid str nonterminal_name pat p pf H.
    destruct p as [ | str' pat' strs' pats' p' p'' ].
    { refine (inl (existT _ (ParseProductionNil _ _) tt)). }
    { (** We must discriminate based on whether or not [str] has already gotten shorter *)
      destruct (stringlike_dec str' (Empty _)) as [e|e], (stringlike_dec strs' (Empty _)) as [e'|e'];
      try (assert (pf0 : str' = str0)
            by (clear -pf e'; abstract (subst strs'; rewrite ?RightId, ?LeftId in pf; exact pf));
           pose proof (@deloop_once_item' (deloop_once) str0 valid _ nonterminal_name pat' p' pf0 (fst H)) as deloop_once_item;
           clear deloop_once);
      try (assert (pf1 : strs' = str0)
            by (clear -pf e; abstract (subst str'; rewrite ?RightId, ?LeftId in pf; exact pf));
           specialize (deloop_once_production str0 valid _ nonterminal_name pats' p'' pf1 (snd H)));
      try (destruct deloop_once_item as [ret|ret];
           [ | right; repeat first [ subst str' | subst strs' ]; rewrite ?LeftId, ?RightId; assumption ]);
      try (destruct deloop_once_production as [ret'|ret'];
           [ | right; repeat first [ subst str' | subst strs' ]; rewrite ?LeftId, ?RightId; assumption ]);
      left.
      { (** empty, empty *)
        exact (existT _ (ParseProductionCons (projT1 ret) (projT1 ret'))
                      (projT2 ret, projT2 ret')). }
      { (** empty, nonempty *)
        refine (existT _ (ParseProductionCons p' (projT1 ret'))
                       (expand_forall_parse_of_item _ (fst H), projT2 ret')).
        unfold P in *; simpl.
        clear -e e' pf1 remove_nonterminal_name_1 remove_nonterminal_name_2.
        abstract (intros; edestruct lt_dec; deloop_t). }
      { (** nonempty, empty *)
        refine (existT _ (ParseProductionCons (projT1 ret) p'')
                       (projT2 ret, expand_forall_parse_of_production _ _ (snd H))).
        unfold P in *; simpl.
        clear -e e' pf0 remove_nonterminal_name_1 remove_nonterminal_name_2.
        abstract (intros; edestruct lt_dec; deloop_t). }
      { (** nonempty, nonempty *)
        refine (existT _ (ParseProductionCons p' p'')
                       (expand_forall_parse_of_item _ (fst H),
                        expand_forall_parse_of_production _ _ (snd H)));
        unfold P in *; simpl;
        clear -e e' pf remove_nonterminal_name_1 remove_nonterminal_name_2;
        abstract (intros; edestruct lt_dec; deloop_t). } }
  Defined.

  Fixpoint deloop_once {str0 valid str nonterminal_name pats} (p : parse_of String G str pats)
    := @deloop_once' (@deloop_once) (@deloop_once_production) str0 valid str nonterminal_name pats p
  with deloop_once_production {str0 valid str nonterminal_name pat} (p : parse_of_production String G str pat)
       := @deloop_once_production' (@deloop_once) (@deloop_once_production) str0 valid str nonterminal_name pat p.
  Definition deloop_once_item {str0 valid str nonterminal_name it} (p : parse_of_item String G str it)
    := @deloop_once_item' (@deloop_once) str0 valid str nonterminal_name it p.

  Definition parse_of__of__parse_of_item_eq' {str0 valid str nonterminal_name}
             (pf : str = str0 :> String)
             (p : p_parse_nonterminal_name str0 valid str nonterminal_name)
  : P str0 valid str nonterminal_name * p_parse str0 (remove_nonterminal_name valid nonterminal_name) str (Lookup G nonterminal_name).
  Proof.
    refine (match projT1 p as p' in parse_of_item _ _ str' it'
                  return match it' with
                           | Terminal _ => True
                           | NonTerminal nonterminal_name' => str' = str0 -> Forall_parse_of_item (P str0 valid) p' -> P str0 valid str' nonterminal_name' * p_parse str0 (remove_nonterminal_name valid nonterminal_name') str' (Lookup G nonterminal_name')
                         end
            with
              | ParseTerminal _ => I
              | ParseNonTerminal nonterminal_name' _ p'
                => fun pf' H' => (fst H', if @deloop_once str0 valid _ nonterminal_name' _ p' pf' (snd H') then _ else _)
            end pf (projT2 p));
    assumption.
  Defined.
  Definition parse_of__of__parse_of_item_eq {str0 valid str nonterminal_name} pf p
    := snd (@parse_of__of__parse_of_item_eq' str0 valid str nonterminal_name pf p).

  Definition top_methods : @parser_computational_dataT _ String
    := {| DependentlyTyped.methods' := top_methods' |}.

  Local Instance top_prestrdata : @parser_computational_prestrdataT _ String G top_methods option
    := { prelower_nonterminal_name_state str0 valid nonterminal_name str st := Some st;
         prelower_string_head str0 valid prod prods str st
         := match projT1 st as p' in parse_of _ _ str' prods' return Forall_parse_of (P str0 valid) p' -> option (p_parse_production str0 valid str' (hd prod prods')) with
              | ParseHead _ _ _ p' => fun H => Some (existT _ p' H)
              | ParseTail _ _ _ _ => fun _ => None
            end (projT2 st);
         prelower_string_tail str0 valid prod prods str st
         := match projT1 st as p' in parse_of _ _ str' prods' return Forall_parse_of (P str0 valid) p' -> option (p_parse str0 valid str' (tl prods')) with
              | ParseTail _ _ _ p' => fun H => Some (existT _ p' H)
              | ParseHead _ _ _ _ => fun _ => None
            end (projT2 st);
         prelift_lookup_nonterminal_name_state_lt str0 valid nonterminal_name str pf := Some ∘ parse_of__of__parse_of_item_lt pf;
         prelift_lookup_nonterminal_name_state_eq str0 valid nonterminal_name str pf := Some ∘ parse_of__of__parse_of_item_eq pf }.

  Context (split_list_complete : forall str0 valid it its str pf, @split_list_completeT _ String G _ str0 valid it its str pf (split_string_for_production str0 valid it its str)).

  Local Ltac ddestruct H :=
    (* work around 4035 *) let H' := fresh in rename H into H'; dependent destruction H'.

  Local Ltac t' :=
    idtac;
    match goal with
      | _ => intro
      | _ => progress simpl in *
      | _ => discriminate
      | _ => congruence
      | _ => progress destruct_head @StringWithSplitState
      | _ => progress destruct_head_hnf sigT
      | _ => progress destruct_head_hnf prod
      | _ => progress destruct_head_hnf and
      | [ H : ~?T, H' : ?T |- _ ] => destruct (H H')
      | [ H : (?x =s ?x) = false |- _ ] => erewrite (proj2 (bool_eq_correct _ _ _)) in H by reflexivity
      | [ H : parse_of_item _ _ _ (Terminal _) |- _ ] => ddestruct H
      | [ H : parse_of_item _ _ _ (NonTerminal _ _) |- _ ] => ddestruct H
      | [ H : parse_of_production _ _ _ [] |- _ ] => ddestruct H
      | [ H : parse_of _ _ _ (_::_) |- _ ] => ddestruct H
      | [ H : parse_of _ _ _ nil |- _ ] => ddestruct H
      | [ H : appcontext[if lt_dec ?a ?b then _ else _] |- _ ] => destruct (lt_dec a b)
    end.

  Local Ltac t := repeat t'.

  Local Obligation Tactic := t.

  Global Program Instance minimal_of_parse_parser_dependent_types_extra_data'
  : @parser_dependent_types_extra_dataT _ String G
    := @sum_extra_data
         _ String G
         predata
         methods'
         (@minimal_parser_dependent_types_success_data' _ String G _)
         (@minimal_parser_dependent_types_failure_data' _ String G _)
         strdata
         (@minimal_parser_dependent_types_extra_success_data' _ String G _ _)
         (@minimal_parser_dependent_types_extra_failure_data' _ String G _ _ split_list_complete)
         _
         top_methods'
         top_prestrdata
         _ _ _ _ _ _ _ _ _.

  Definition minimal_parse_nonterminal_name__of__parse'
             (nonterminal_name : string)
             (s : String)
             (p : parse_of_item String G s (NonTerminal _ nonterminal_name))
             (H : Forall_parse_of_item
                    (fun _ n => is_valid_nonterminal_name initial_nonterminal_names_data n = true)
                    p)
  : minimal_parse_of_name String G initial_nonterminal_names_data is_valid_nonterminal_name remove_nonterminal_name s initial_nonterminal_names_data s nonterminal_name.
  Proof.
    pose proof (fun H' => @parse_nonterminal_name _ String G minimal_of_parse_parser_dependent_types_extra_data' nonterminal_name s (Some (existT _ p (expand_forall_parse_of_item H' H)))) as H0.
    simpl in *.
    unfold T_nonterminal_name_success, T_nonterminal_name_failure in *.
    simpl in *.
    destruct H0; destruct_head False; try assumption; [ clear ].
    unfold P in *; simpl in *.
    repeat match goal with
             | _ => assumption
             | [ H : _ -> _ |- _ ] => specialize (H (reflexivity _))
             | [ H : False |- _ ] => destruct H
             | _ => intro
             | [ |- _ /\ _ ] => split
             | [ |- appcontext[if lt_dec ?a ?b then _ else _] ]
               => destruct (lt_dec a b)
           end.
    Defined.
End recursive_descent_parser.


Require Import Rel.Definitions.
Require Import Lang.BindingsFacts.
Require Import Wf_natnat.
Set Implicit Arguments.

Implicit Types EV HV V L : Set.

Section section_EV_map_aux.

Hint Extern 1 => match goal with
| [ x : ?V |- ∃ _ : ?V, _ ] => exists x ; crush
end.

Hint Extern 0 => match goal with
| [ |- ?n ⊨ ?X ⇔ ?X ] => apply auto_contr_id
| [ |- ?n ⊨ ?X ≈ᵢ ?X ] => repeat iintro ; apply auto_contr_id
| [ |- Acc lt' (_, _) ] => try lt'_solve
end.

Fixpoint
  EV_map_𝓥_aux
  n EV EV' HV
  (Ξ : XEnv EV HV)
  (f : EV → EV')
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (Hδ₁ : ∀ α : EV, δ₁ α = δ₁' (f α))
  (Hδ₂ : ∀ α : EV, δ₂ α = δ₂' (f α))
  (Hδ : n ⊨ ∀ᵢ α : EV, δ α ≈ᵢ δ' (f α))
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ξ₁ ξ₂ : list var)
  (v₁ v₂ : val0) (T : ty EV HV ∅)
  (W : Acc lt' (n, size_ty T))
  {struct W} :
  (n ⊨
    𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
    𝓥⟦ (EV_map_XEnv f Ξ) ⊢ EV_map_ty f T ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂)
with
  EV_map_𝓾_aux
  n EV EV' HV
  (Ξ : XEnv EV HV)
  (f : EV → EV')
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (Hδ₁ : ∀ α : EV, δ₁ α = δ₁' (f α))
  (Hδ₂ : ∀ α : EV, δ₂ α = δ₂' (f α))
  (Hδ : n ⊨ ∀ᵢ α : EV, δ α ≈ᵢ δ' (f α))
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (ε : ef EV HV ∅)
  (W : Acc lt' (n, 0))
  {struct W} :
  (n ⊨
    𝓾⟦ Ξ ⊢ ε ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓾⟦ (EV_map_XEnv f Ξ) ⊢ EV_map_ef f ε ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)
with
  EV_map_𝓤_aux
  n EV EV' HV
  (Ξ : XEnv EV HV)
  (f : EV → EV')
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (Hδ₁ : ∀ α : EV, δ₁ α = δ₁' (f α))
  (Hδ₂ : ∀ α : EV, δ₂ α = δ₂' (f α))
  (Hδ : n ⊨ ∀ᵢ α : EV, δ α ≈ᵢ δ' (f α))
  (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig)
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (𝓔 : eff EV HV ∅)
  (W : Acc lt' (n, size_eff 𝓔))
  {struct W} :
  (n ⊨
    𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (EV_map_XEnv f Ξ) ⊢ EV_map_eff f 𝓔 ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)
.

Proof.
{
destruct T eqn:HT.
+ crush.
+ simpl 𝓥_Fun ; auto_contr.
  - apply EV_map_𝓥_aux ; auto.
  - apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
+ simpl 𝓥_Fun ; auto_contr.
  replace (EV_shift_XEnv (EV_map_XEnv f Ξ))
    with (EV_map_XEnv (map_inc f) (EV_shift_XEnv Ξ))
    by (repeat erewrite EV_map_map_XEnv ; crush).
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; [ |auto].
  repeat iintro ; apply EV_map_𝓥_aux ; [auto|auto| |auto].
  iintro α ; destruct α ; simpl ; repeat iintro ; [auto|].
  iespecialize Hδ ; apply Hδ.
+ simpl 𝓥_Fun ; auto_contr.
  replace (HV_shift_XEnv (EV_map_XEnv f Ξ))
    with (EV_map_XEnv f (HV_shift_XEnv Ξ))
    by (erewrite EV_HV_map_XEnv ; crush).
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
}

{
destruct ε as [ α | [ p | [ | X ] ] ] ; simpl.
+ iespecialize Hδ ; apply Hδ.
+ auto_contr.
+ auto.
+ auto_contr.
  isplit ; iintro' H.
  - idestruct H as T H ; idestruct H as 𝓔 H ; idestruct H as HX H.
    ielim_prop HX ; eapply binds_EV_map in HX.
    repeat ieexists ; repeat isplit ; [ eauto | ].
    later_shift.
    erewrite <- I_iff_elim_M ; [ apply H | ].
    apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto| ].
    apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
    { erewrite <- 𝓥_roll_unroll_iff ; auto. }
    { erewrite <- 𝓤_roll_unroll_iff ; auto. }
  - idestruct H as T' H ; idestruct H as 𝓔' H ; idestruct H as HX H.
    ielim_prop HX ; apply binds_EV_map_inv in HX.
    destruct HX as [ T [ 𝓔 [ HT [ H𝓔 HX ] ] ] ] ; subst.
    repeat ieexists ; repeat isplit ; [ eauto | ].
    later_shift.
    erewrite I_iff_elim_M ; [ apply H | ].
    apply 𝓗_Fun'_nonexpansive ; repeat iintro ; [auto|].
    apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
    { erewrite <- 𝓥_roll_unroll_iff ; auto. }
    { erewrite <- 𝓤_roll_unroll_iff ; auto. }
}

{
destruct 𝓔 ; simpl.
+ auto.
+ auto_contr ; auto.
}

Qed.

End section_EV_map_aux.

Section section_EV_map.
Context (n : nat).
Context (EV EV' HV : Set).
Context (Ξ : XEnv EV HV).
Context (f : EV → EV').
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig).
Context (Hδ₁ : ∀ α : EV, δ₁ α = δ₁' (f α)).
Context (Hδ₂ : ∀ α : EV, δ₂ α = δ₂' (f α)).
Context (Hδ : n ⊨ ∀ᵢ α : EV, δ α ≈ᵢ δ' (f α)).
Context (ρ₁ ρ₂ : HV → hd0) (ρ : HV → IRel 𝓣_Sig).

Hint Resolve lt'_wf.

Lemma EV_map_𝓥 T ξ₁ ξ₂ v₁ v₂ :
n ⊨
  𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
  𝓥⟦ (EV_map_XEnv f Ξ) ⊢ EV_map_ty f T ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂.
Proof.
apply EV_map_𝓥_aux ; auto.
Qed.

Lemma EV_map_𝓤 𝓔 ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ :
n ⊨
  𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ ⇔
  𝓤⟦ (EV_map_XEnv f Ξ) ⊢ EV_map_eff f 𝓔 ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂.
Proof.
apply EV_map_𝓤_aux ; auto.
Qed.

Hint Resolve EV_map_𝓥 EV_map_𝓤.

Lemma EV_map_𝓣 T 𝓔 ξ₁ ξ₂ t₁ t₂ :
n ⊨
  𝓣⟦ Ξ ⊢ T # 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
  𝓣⟦ (EV_map_XEnv f Ξ) ⊢ (EV_map_ty f T) # (EV_map_eff f 𝓔) ⟧
  δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂.
Proof.
apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
Qed.

End section_EV_map.


Require Import SimTactics SimCompanion IL paco3 OptionR.
Require Export ILStateType.

Set Implicit Arguments.

Lemma sim_let_op X (IST:ILStateType X) X' (IST':ILStateType X')
      i r (L:X) (L':X') V V' x x' e e' s s'
      (EQ:op_eval V e = op_eval V' e')
      (SIM: forall v, op_eval V e = Some v
                 -> Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r i
                                     (L, V [x <- ⎣ v ⎦], s) (L', V' [x' <- ⎣ v ⎦], s'))
  : sim_gen (Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r)
            i (L, V, stmtLet x (Operation e) s) (L', V', stmtLet x' (Operation e') s').
Proof.
  case_eq (op_eval V e); intros.
  * eapply SimSilent; [ eapply plus2O
                      | eapply plus2O
                      | ].
    eapply step_let_op; eauto. eauto.
    eapply step_let_op. rewrite <- EQ. eauto. eauto.
    eapply SIM; eauto.
  * eapply SimTerm; [| eapply star2_refl | eapply star2_refl | | ];
      [ simpl | | ].
    rewrite !result_none; isabsurd; eauto.
    eapply let_op_normal; eauto.
    eapply let_op_normal; rewrite <- EQ; eauto.
Qed.

Lemma sim_let_call X (IST:ILStateType X) X' (IST':ILStateType X')
      i r (L:X) (L':X') V V' x x' f Y Y' s s'
      (EQ: omap (op_eval V) Y = omap (op_eval V') Y')
      (SIM: forall v,  Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r i
                                    (L, V [x <- ⎣ v ⎦], s) (L', V' [x' <- ⎣ v ⎦], s'))
  : sim_gen (Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r) i
            (L, V, stmtLet x (Call f Y) s) (L', V', stmtLet x' (Call f Y') s').
Proof.
  case_eq (omap (op_eval V) Y); intros.
  * pose proof H as H'. rewrite EQ in H'.
    eapply SimExtern;
      [ eapply star2_refl
      | eapply star2_refl
      | step_activated; eauto 20 using step_let_call
      | step_activated; eauto 20 using step_let_call | |].
    eapply step_let_call; eauto.
    intros ? ? ? STEP; subst;
      eapply let_call_inversion in STEP; dcr; subst; eexists; split; try eapply step_let_call; eauto.
    rewrite <- EQ; eauto.
    intros ? ? STEP; eapply let_call_inversion in STEP; dcr; subst; eexists; split; try eapply step_let_call; eauto.
    rewrite EQ; eauto.
  * eapply SimTerm; [| eapply star2_refl | eapply star2_refl | | ];
             [ simpl | | ].
    rewrite !result_none; isabsurd; eauto.
    eapply let_call_normal; eauto.
    eapply let_call_normal; rewrite <- EQ; eauto.
Qed.

Lemma sim_cond X (IST:ILStateType X) X' (IST':ILStateType X')
      i r (L:X) (L':X') V V' e e' s1 s1' s2 s2'
      (EQ: op_eval V e = op_eval V' e')
      (SIM1: forall v, op_eval V e = Some v -> val2bool v = true ->
                  Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r i
                                    (L, V, s1) (L', V', s1'))
      (SIM2: forall v, op_eval V e = Some v -> val2bool v = false ->
                  Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r i
                                    (L, V, s2) (L', V', s2'))
  : sim_gen (Tower3.companion3 (sim_gen (S':=X' * onv val * stmt)) r) i
            (L, V, stmtIf e s1 s2) (L', V', stmtIf e' s1' s2').
Proof.
  case_eq (op_eval V e); intros.
  - case_eq (val2bool v); intros.
    + eapply SimSilent; [ eapply plus2O; [|eapply filter_tau_nil_eq]
                        | eapply plus2O; [|eapply filter_tau_nil_eq]
                        | eapply SIM1; eauto];
      eapply step_cond_true; eauto. rewrite <- EQ; eauto.
    + eapply SimSilent; [ eapply plus2O; [|eapply filter_tau_nil_eq]
                        | eapply plus2O; [|eapply filter_tau_nil_eq]
                        | eapply SIM2; eauto];
      eapply step_cond_false; eauto. rewrite <- EQ; eauto.
  - eapply SimTerm; [| eapply star2_refl | eapply star2_refl | | ];
      [ simpl | | ].
    rewrite !result_none; isabsurd; eauto.
    eapply cond_normal; eauto.
    eapply cond_normal; eauto. rewrite <- EQ; eauto.
Qed.