(*  Title:      HOL/Auth/Guard/Guard.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>Protocol-Independent Confidentiality Theorem on Nonces\<close>

theory Guard imports Analz Extensions begin

(******************************************************************************
messages where all the occurrences of Nonce n are
in a sub-message of the form Crypt (invKey K) X with K:Ks
******************************************************************************)

inductive_set
  guard :: "nat \<Rightarrow> key set \<Rightarrow> msg set"
  for n :: nat and Ks :: "key set"
where
  No_Nonce [intro]: "Nonce n \<notin> parts {X} \<Longrightarrow> X \<in> guard n Ks"
| Guard_Nonce [intro]: "invKey K \<in> Ks \<Longrightarrow> Crypt K X \<in> guard n Ks"
| Crypt [intro]: "X \<in> guard n Ks \<Longrightarrow> Crypt K X \<in> guard n Ks"
| Pair [intro]: "\<lbrakk>X \<in> guard n Ks; Y \<in> guard n Ks\<rbrakk> \<Longrightarrow> \<lbrace>X,Y\<rbrace> \<in> guard n Ks"

subsection\<open>basic facts about \<^term>\<open>guard\<close>\<close>

lemma Key_is_guard [iff]: "Key K \<in> guard n Ks"
by auto

lemma Agent_is_guard [iff]: "Agent A \<in> guard n Ks"
by auto

lemma Number_is_guard [iff]: "Number r \<in> guard n Ks"
by auto

lemma Nonce_notin_guard: "X \<in> guard n Ks \<Longrightarrow> X \<noteq> Nonce n"
by (erule guard.induct, auto)

lemma Nonce_notin_guard_iff [iff]: "Nonce n \<notin> guard n Ks"
by (auto dest: Nonce_notin_guard)

lemma guard_has_Crypt [rule_format]: "X \<in> guard n Ks \<Longrightarrow> Nonce n \<in> parts {X}
\<longrightarrow> (\<exists>K Y. Crypt K Y \<in> kparts {X} \<and> Nonce n \<in> parts {Y})"
by (erule guard.induct, auto)

lemma Nonce_notin_kparts_msg: "X \<in> guard n Ks \<Longrightarrow> Nonce n \<notin> kparts {X}"
by (erule guard.induct, auto)

lemma Nonce_in_kparts_imp_no_guard: "Nonce n \<in> kparts H
\<Longrightarrow> \<exists>X. X \<in> H \<and> X \<notin> guard n Ks"
apply (drule in_kparts, clarify)
apply (rule_tac x=X in exI, clarify)
by (auto dest: Nonce_notin_kparts_msg)

lemma guard_kparts [rule_format]: "X \<in> guard n Ks \<Longrightarrow>
Y \<in> kparts {X} \<longrightarrow> Y \<in> guard n Ks"
by (erule guard.induct, auto)

lemma guard_Crypt: "\<lbrakk>Crypt K Y \<in> guard n Ks; K \<notin> invKey`Ks\<rbrakk> \<Longrightarrow> Y \<in> guard n Ks"
  by (ind_cases "Crypt K Y \<in> guard n Ks") (auto intro!: image_eqI)

lemma guard_MPair [iff]: "(\<lbrace>X,Y\<rbrace> \<in> guard n Ks) = (X \<in> guard n Ks \<and> Y \<in> guard n Ks)"
by (auto, (ind_cases "\<lbrace>X,Y\<rbrace> \<in> guard n Ks", auto)+)

lemma guard_not_guard [rule_format]: "X \<in> guard n Ks \<Longrightarrow>
Crypt K Y \<in> kparts {X} \<longrightarrow> Nonce n \<in> kparts {Y} \<longrightarrow> Y \<notin> guard n Ks"
by (erule guard.induct, auto dest: guard_kparts)

lemma guard_extand: "\<lbrakk>X \<in> guard n Ks; Ks \<subseteq> Ks'\<rbrakk> \<Longrightarrow> X \<in> guard n Ks'"
by (erule guard.induct, auto)

subsection\<open>guarded sets\<close>

definition Guard :: "nat \<Rightarrow> key set \<Rightarrow> msg set \<Rightarrow> bool" where
"Guard n Ks H \<equiv> \<forall>X. X \<in> H \<longrightarrow> X \<in> guard n Ks"

subsection\<open>basic facts about \<^term>\<open>Guard\<close>\<close>

lemma Guard_empty [iff]: "Guard n Ks {}"
by (simp add: Guard_def)

lemma notin_parts_Guard [intro]: "Nonce n \<notin> parts G \<Longrightarrow> Guard n Ks G"
apply (unfold Guard_def, clarify)
apply (subgoal_tac "Nonce n \<notin> parts {X}")
by (auto dest: parts_sub)

lemma Nonce_notin_kparts [simplified]: "Guard n Ks H \<Longrightarrow> Nonce n \<notin> kparts H"
by (auto simp: Guard_def dest: in_kparts Nonce_notin_kparts_msg)

lemma Guard_must_decrypt: "\<lbrakk>Guard n Ks H; Nonce n \<in> analz H\<rbrakk> \<Longrightarrow>
\<exists>K Y. Crypt K Y \<in> kparts H \<and> Key (invKey K) \<in> kparts H"
apply (drule_tac P="\<lambda>G. Nonce n \<in> G" in analz_pparts_kparts_substD, simp)
by (drule must_decrypt, auto dest: Nonce_notin_kparts)

lemma Guard_kparts [intro]: "Guard n Ks H \<Longrightarrow> Guard n Ks (kparts H)"
by (auto simp: Guard_def dest: in_kparts guard_kparts)

lemma Guard_mono: "\<lbrakk>Guard n Ks H; G <= H\<rbrakk> \<Longrightarrow> Guard n Ks G"
by (auto simp: Guard_def)

lemma Guard_insert [iff]: "Guard n Ks (insert X H)
= (Guard n Ks H \<and> X \<in> guard n Ks)"
by (auto simp: Guard_def)

lemma Guard_Un [iff]: "Guard n Ks (G Un H) = (Guard n Ks G & Guard n Ks H)"
by (auto simp: Guard_def)

lemma Guard_synth [intro]: "Guard n Ks G \<Longrightarrow> Guard n Ks (synth G)"
by (auto simp: Guard_def, erule synth.induct, auto)

lemma Guard_analz [intro]: "\<lbrakk>Guard n Ks G; \<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G\<rbrakk>
\<Longrightarrow> Guard n Ks (analz G)"
apply (auto simp: Guard_def)
apply (erule analz.induct, auto)
by (ind_cases "Crypt K Xa \<in> guard n Ks" for K Xa, auto)

lemma in_Guard [dest]: "\<lbrakk>X \<in> G; Guard n Ks G\<rbrakk> \<Longrightarrow> X \<in> guard n Ks"
by (auto simp: Guard_def)

lemma in_synth_Guard: "\<lbrakk>X \<in> synth G; Guard n Ks G\<rbrakk> \<Longrightarrow> X \<in> guard n Ks"
by (drule Guard_synth, auto)

lemma in_analz_Guard: "\<lbrakk>X \<in> analz G; Guard n Ks G;
\<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G\<rbrakk> \<Longrightarrow> X \<in> guard n Ks"
by (drule Guard_analz, auto)

lemma Guard_keyset [simp]: "keyset G \<Longrightarrow> Guard n Ks G"
by (auto simp: Guard_def)

lemma Guard_Un_keyset: "\<lbrakk>Guard n Ks G; keyset H\<rbrakk> \<Longrightarrow> Guard n Ks (G \<union> H)"
by auto

lemma in_Guard_kparts: "\<lbrakk>X \<in> G; Guard n Ks G; Y \<in> kparts {X}\<rbrakk> \<Longrightarrow> Y \<in> guard n Ks"
by blast

lemma in_Guard_kparts_neq: "\<lbrakk>X \<in> G; Guard n Ks G; Nonce n' \<in> kparts {X}\<rbrakk>
\<Longrightarrow> n \<noteq> n'"
by (blast dest: in_Guard_kparts)

lemma in_Guard_kparts_Crypt: "\<lbrakk>X \<in> G; Guard n Ks G; is_MPair X;
Crypt K Y \<in> kparts {X}; Nonce n \<in> kparts {Y}\<rbrakk> \<Longrightarrow> invKey K \<in> Ks"
apply (drule in_Guard, simp)
apply (frule guard_not_guard, simp+)
apply (drule guard_kparts, simp)
by (ind_cases "Crypt K Y \<in> guard n Ks", auto)

lemma Guard_extand: "\<lbrakk>Guard n Ks G; Ks \<subseteq> Ks'\<rbrakk> \<Longrightarrow> Guard n Ks' G"
by (auto simp: Guard_def dest: guard_extand)

lemma guard_invKey [rule_format]: "\<lbrakk>X \<in> guard n Ks; Nonce n \<in> kparts {Y}\<rbrakk> \<Longrightarrow>
Crypt K Y \<in> kparts {X} \<longrightarrow> invKey K \<in> Ks"
by (erule guard.induct, auto)

lemma Crypt_guard_invKey [rule_format]: "\<lbrakk>Crypt K Y \<in> guard n Ks;
Nonce n \<in> kparts {Y}\<rbrakk> \<Longrightarrow> invKey K \<in> Ks"
by (auto dest: guard_invKey)

subsection\<open>set obtained by decrypting a message\<close>

abbreviation (input)
  decrypt :: "msg set => key => msg => msg set" where
  "decrypt H K Y == insert Y (H - {Crypt K Y})"

lemma analz_decrypt: "\<lbrakk>Crypt K Y \<in> H; Key (invKey K) \<in> H; Nonce n \<in> analz H\<rbrakk>
\<Longrightarrow> Nonce n \<in> analz (decrypt H K Y)"
apply (drule_tac P="\<lambda>H. Nonce n \<in> analz H" in ssubst [OF insert_Diff])
apply assumption
apply (simp only: analz_Crypt_if, simp)
done

lemma parts_decrypt: "\<lbrakk>Crypt K Y \<in> H; X \<in> parts (decrypt H K Y)\<rbrakk> \<Longrightarrow> X \<in> parts H"
by (erule parts.induct, auto intro: parts.Fst parts.Snd parts.Body)

subsection\<open>number of Crypt's in a message\<close>

fun crypt_nb :: "msg => nat"
where
  "crypt_nb (Crypt K X) = Suc (crypt_nb X)"
| "crypt_nb \<lbrace>X,Y\<rbrace> = crypt_nb X + crypt_nb Y"
| "crypt_nb X = 0" (* otherwise *)

subsection\<open>basic facts about \<^term>\<open>crypt_nb\<close>\<close>

lemma non_empty_crypt_msg: "Crypt K Y \<in> parts {X} \<Longrightarrow> crypt_nb X \<noteq> 0"
by (induct X, simp_all, safe, simp_all)

subsection\<open>number of Crypt's in a message list\<close>

primrec cnb :: "msg list => nat"
where
  "cnb [] = 0"
| "cnb (X#l) = crypt_nb X + cnb l"

subsection\<open>basic facts about \<^term>\<open>cnb\<close>\<close>

lemma cnb_app [simp]: "cnb (l @ l') = cnb l + cnb l'"
by (induct l, auto)

lemma mem_cnb_minus: "x \<in> set l \<Longrightarrow> cnb l = crypt_nb x + (cnb l - crypt_nb x)"
  by (induct l) auto

lemmas mem_cnb_minus_substI = mem_cnb_minus [THEN ssubst]

lemma cnb_minus [simp]: "x \<in> set l \<Longrightarrow> cnb (remove l x) = cnb l - crypt_nb x"
apply (induct l, auto)
apply (erule_tac l=l and x=x in mem_cnb_minus_substI)
apply simp
done

lemma parts_cnb: "Z \<in> parts (set l) \<Longrightarrow>
cnb l = (cnb l - crypt_nb Z) + crypt_nb Z"
by (erule parts.induct, auto simp: in_set_conv_decomp)

lemma non_empty_crypt: "Crypt K Y \<in> parts (set l) \<Longrightarrow> cnb l \<noteq> 0"
by (induct l, auto dest: non_empty_crypt_msg parts_insert_substD)

subsection\<open>list of kparts\<close>

lemma kparts_msg_set: "\<exists>l. kparts {X} = set l \<and> cnb l = crypt_nb X"
apply (induct X, simp_all)
apply (rename_tac agent, rule_tac x="[Agent agent]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Number nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Nonce nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Key nat]" in exI, simp)
apply (rename_tac X, rule_tac x="[Hash X]" in exI, simp)
apply (clarify, rule_tac x="l@la" in exI, simp)
by (clarify, rename_tac nat X y, rule_tac x="[Crypt nat X]" in exI, simp)

lemma kparts_set: "\<exists>l'. kparts (set l) = set l' \<and> cnb l' = cnb l"
apply (induct l)
apply (rule_tac x="[]" in exI, simp, clarsimp)
apply (rename_tac a b l')
apply (subgoal_tac "\<exists>l''.  kparts {a} = set l'' \<and> cnb l'' = crypt_nb a", clarify)
apply (rule_tac x="l''@l'" in exI, simp)
apply (rule kparts_insert_substI, simp)
by (rule kparts_msg_set)

subsection\<open>list corresponding to "decrypt"\<close>

definition decrypt' :: "msg list => key => msg => msg list" where
"decrypt' l K Y == Y # remove l (Crypt K Y)"

declare decrypt'_def [simp]

subsection\<open>basic facts about \<^term>\<open>decrypt'\<close>\<close>

lemma decrypt_minus: "decrypt (set l) K Y <= set (decrypt' l K Y)"
by (induct l, auto)

subsection\<open>if the analyse of a finite guarded set gives n then it must also gives
one of the keys of Ks\<close>

lemma Guard_invKey_by_list [rule_format]: "\<forall>l. cnb l = p
\<longrightarrow> Guard n Ks (set l) \<longrightarrow> Nonce n \<in> analz (set l)
\<longrightarrow> (\<exists>K. K \<in> Ks \<and> Key K \<in> analz (set l))"
apply (induct p)
(* case p=0 *)
apply (clarify, drule Guard_must_decrypt, simp, clarify)
apply (drule kparts_parts, drule non_empty_crypt, simp)
(* case p>0 *)
apply (clarify, frule Guard_must_decrypt, simp, clarify)
apply (drule_tac P="\<lambda>G. Nonce n \<in> G" in analz_pparts_kparts_substD, simp)
apply (frule analz_decrypt, simp_all)
apply (subgoal_tac "\<exists>l'. kparts (set l) = set l' \<and> cnb l' = cnb l", clarsimp)
apply (drule_tac G="insert Y (set l' - {Crypt K Y})"
and H="set (decrypt' l' K Y)" in analz_sub, rule decrypt_minus)
apply (rule_tac analz_pparts_kparts_substI, simp)
apply (case_tac "K \<in> invKey`Ks")
(* K:invKey`Ks *)
apply (clarsimp, blast)
(* K ~:invKey`Ks *)
apply (subgoal_tac "Guard n Ks (set (decrypt' l' K Y))")
apply (drule_tac x="decrypt' l' K Y" in spec, simp)
apply (subgoal_tac "Crypt K Y \<in> parts (set l)")
apply (drule parts_cnb, rotate_tac -1, simp)
apply (clarify, drule_tac X="Key Ka" and H="insert Y (set l')" in analz_sub)
apply (rule insert_mono, rule set_remove)
apply (simp add: analz_insertD, blast)
(* Crypt K Y:parts (set l) *)
apply (blast dest: kparts_parts)
(* Guard n Ks (set (decrypt' l' K Y)) *)
apply (rule_tac H="insert Y (set l')" in Guard_mono)
apply (subgoal_tac "Guard n Ks (set l')", simp)
apply (rule_tac K=K in guard_Crypt, simp add: Guard_def, simp)
apply (drule_tac t="set l'" in sym, simp)
apply (rule Guard_kparts, simp, simp)
apply (rule_tac B="set l'" in subset_trans, rule set_remove, blast)
by (rule kparts_set)

lemma Guard_invKey_finite: "\<lbrakk>Nonce n \<in> analz G; Guard n Ks G; finite G\<rbrakk>
\<Longrightarrow> \<exists>K. K \<in> Ks \<and> Key K \<in> analz G"
apply (drule finite_list, clarify)
by (rule Guard_invKey_by_list, auto)

lemma Guard_invKey: "\<lbrakk>Nonce n \<in> analz G; Guard n Ks G\<rbrakk>
\<Longrightarrow> \<exists>K. K \<in> Ks \<and> Key K \<in> analz G"
by (auto dest: analz_needs_only_finite Guard_invKey_finite)

subsection\<open>if the analyse of a finite guarded set and a (possibly infinite) set of keys
gives n then it must also gives Ks\<close>

lemma Guard_invKey_keyset: "\<lbrakk>Nonce n \<in> analz (G \<union> H); Guard n Ks G; finite G;
keyset H\<rbrakk> \<Longrightarrow> \<exists>K. K \<in> Ks \<and> Key K \<in> analz (G \<union> H)"
apply (frule_tac P="\<lambda>G. Nonce n \<in> G" and G=G in analz_keyset_substD, simp_all)
apply (drule_tac G="G Un (H Int keysfor G)" in Guard_invKey_finite)
by (auto simp: Guard_def intro: analz_sub)

end


theory Program_Analysis
  imports
    UPPAAL_State_Networks_Impl
    TA_Library.More_Methods
    "HOL-Library.Lattice_Syntax"
begin

(*
fun step_approx :: "instr \<Rightarrow> addr set" where
  "step_approx (JMPZ q) (pc, _) = {pc + 1, q}" |
  "step_approx CALL (pc, q # st, _) = {nat q}
    (if q \<ge> 0 then Some (nat q, int pc # st, m, f, rs) else None)" |
  "step RETURN (pc, q # st, m, f, rs) =
    (if q \<ge> 0 then Some (nat q + 1, st, m, f, rs) else None)" |
  (*
  "step HALT s = Some s" |
  *)
  "step (STOREC c d) (pc, st, m, f, rs) =
    (if d = 0 then Some (pc + 1, st, m, f, c # rs) else None)" |
  "step (SETF b) (pc, st, m, f, rs) = Some (pc + 1, st, m, b, rs)" |
  "step _ _ = None"
*)

fun steps_approx :: "nat \<Rightarrow> 't instrc option list \<Rightarrow> addr \<Rightarrow> addr set" where
  "steps_approx 0 prog pc = (if pc < length prog then {pc} else {})" |
  "steps_approx (Suc n) prog pc =
    (
      if pc \<ge> length prog
      then {}
      else
        case prog ! pc of
          None \<Rightarrow> {pc}
        | Some cmd \<Rightarrow>
          let succs =
            (
              case cmd of
                CEXP ac \<Rightarrow> {pc + 1}
              | INSTR instr \<Rightarrow>
                  case instr of
                    CALL   \<Rightarrow> {..<length prog}
                  | RETURN \<Rightarrow> {..<length prog}
                  | JMPZ pc' \<Rightarrow> {pc + 1, pc'}
                  | HALT \<Rightarrow> {}
                  |    _ \<Rightarrow> {pc + 1}
            )
          in {pc} \<union> \<Union> (steps_approx n prog ` succs)
    )
  "

lemma bounded_less_simp[simp]:
  "\<forall>q\<in>{..<p::nat}. P q \<equiv> \<forall> q < p. P q"
  by (rule eq_reflection) auto

context
  fixes prog :: "int instrc option list"
    and strip :: "real instrc \<Rightarrow> instr"
  assumes instr_id[simp]:
    "strip (INSTR cmd) = cmd"
    "strip (CEXP ac) \<notin> {CALL, RETURN, HALT} \<union> (JMPZ ` UNIV)"
begin

(* XXX This is some idiosyncracy of Isabelle's context management *)
(* We could move this to a different file but rather would like to introduce a private namespace
   on the spot
*)
private definition [simp]:
  "P' \<equiv> map_option strip o (conv_prog (\<lambda> i. if i < length prog then prog ! i else None))"

lemma steps_out_of_range':
  assumes "steps P' n (pc, st, s, f, rs) (pc', st', s', f', rs')" "pc \<ge> length prog"
  shows "pc' = pc"
  using assms by cases (auto simp: striptp_def)

lemmas steps_out_of_range = steps_out_of_range'[unfolded striptp_def P'_def]

lemma steps_steps_approx':
  assumes "steps P' n (pc, st, s, f, rs) (pc', st', s', f', rs')" "pc' < length prog"
  shows "pc' \<in> steps_approx n prog pc"
  using assms
  apply (
      induction P' n "(pc, st, s, f, rs)" "(pc', st', s', f', rs')"
      arbitrary: pc st s f rs rule: steps.induct
      )
   apply (simp split: option.split)
  apply clarsimp
  apply rule
   apply (simp add: striptp_def split: if_split_asm; fail)
  apply (clarsimp split: option.split)
  apply rule
   apply (auto simp add: striptp_def split: if_split_asm; fail)
  apply safe
  apply (case_tac x2)
   apply (simp split: option.split_asm if_split_asm)
   apply (case_tac x1)
                    apply (auto split: if_split_asm; fail)
                   apply (auto split: if_split_asm elim: UPPAAL_Asm.step.elims; fail)
                  apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
                 apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
                apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
               apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
              apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
             apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
            apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
           apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
          apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
         apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
        apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
       apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
       apply (case_tac "q < length prog")
        apply force
       apply (drule steps_out_of_range; simp; fail)
      apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
      apply (case_tac "q + 1 < length prog")
       apply force
      apply (drule steps_out_of_range; simp)
     apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
    apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
   apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm; fail)
  using instr_id by (fastforce split: if_split_asm elim!: UPPAAL_Asm.step.elims)

lemmas steps_steps_approx = steps_steps_approx'[unfolded P'_def]

end (* End of context for fixed program *)

context
  fixes prog :: "int instrc option list"
begin

private abbreviation "P i \<equiv> if i < length prog then prog ! i else None"

lemma stepsc_out_of_range:
  assumes "stepsc (conv_prog P) n u (pc, st, s, f, rs) (pc', st', s', f', rs')" "pc \<ge> length prog"
  shows "pc' = pc"
  using assms by cases auto

lemma stepsc_steps_approx:
  assumes "stepsc (conv_prog P) n u (pc, st, s, f, rs) (pc', st', s', f', rs')" "pc' < length prog"
  shows "pc' \<in> steps_approx n prog pc"
  using assms
  apply (
      induction "conv_prog P" n u "(pc, st, s, f, rs)" "(pc', st', s', f', rs')"
      arbitrary: pc st s f rs rule: stepsc.induct
      )
   apply (simp split: option.split)
  apply clarsimp
  apply rule
   apply (simp split: if_split_asm; fail)
  apply (clarsimp split: option.split)
  apply rule
   apply (simp split: if_split_asm; fail)
  apply (case_tac z)
   apply (simp split: option.split_asm if_split_asm)
   apply (case_tac x1)
                    apply (simp split: if_split_asm)
                   apply (auto elim: UPPAAL_Asm.step.elims)[]
                  apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
                 apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
                apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
               apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
              apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
             apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
            apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
           apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
          apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
         apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
        apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
       apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
       apply (case_tac "q < length prog")
        apply force
       apply (drule stepsc_out_of_range; simp)
      apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
      apply (case_tac "q + 1 < length prog")
       apply force
      apply (drule stepsc_out_of_range; simp)
     apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
    apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
   apply (auto elim!: UPPAAL_Asm.step.elims split: if_split_asm)[]
  by (force split: if_split_asm)

definition
  "time_indep_check pc n \<equiv>
    \<forall> pc' \<in> steps_approx n prog pc. pc' < length prog
    \<longrightarrow> (case prog ! pc' of Some cmd \<Rightarrow> is_instr cmd | _ \<Rightarrow> True)"

lemma time_indep_overapprox:
  assumes
    "time_indep_check pc n"
  shows "time_indep (conv_prog P) n (pc, st, s, f, rs)"
proof -
  { fix pc' st' s' f' rs' cmd u
    assume A:
      "stepsc (conv_prog local.P) n u (pc, st, s, f, rs) (pc', st', s', f', rs')"
      "conv_prog local.P pc' = Some cmd"
    have "is_instr cmd"
    proof (cases "pc' < length prog")
      case True
      with A(2) obtain cmd' where "prog ! pc' = Some cmd'" by auto
      with True stepsc_steps_approx[OF A(1)] A(2) assms show ?thesis
        by (cases cmd') (auto simp: time_indep_check_def)
    next
      case False
      with A(2) show ?thesis by (auto split: option.split_asm)
    qed
  }
  then show ?thesis unfolding time_indep_def by blast
qed

end (* End of context for fixed program *)

context UPPAAL_Reachability_Problem_precompiled_defs
begin

  definition
    "collect_cexp' pc = {ac. Some (CEXP ac) \<in> ((!) prog) ` steps_approx max_steps prog pc}"

  definition "clkp_set'' i l \<equiv>
    collect_clock_pairs (inv ! i ! l) \<union>
    \<Union> ((\<lambda> (g, _). constraint_pair ` collect_cexp' g) ` set (trans ! i ! l))"

  definition
    "collect_cexp = {ac. Some (CEXP ac) \<in> set prog}"

  definition
    "collect_store' pc =
    {(c, x). Some (INSTR (STOREC c x)) \<in> ((!) prog) ` steps_approx max_steps prog pc}"

end

(* XXX Unused *)
(* XXX Move *)
lemma visited_resets_mono:
  "set r \<subseteq> set r'" if "visited P n (pc, st, s, f, r) (pc', st', s', f', r') pcs"
  using that
  apply (
    induction P \<equiv> P n "(pc, st, s, f, r :: nat list)" "(pc', st', s', f', r')" pcs
    arbitrary: pc st s f r  rule: visited.induct
    )
   apply blast
  by (erule step.elims; force split: option.splits if_splits elim!: step.elims)+

(* XXX Unused *)
(* XXX Move *)
lemma visitedc_resets_mono:
  "set r \<subseteq> set r'" if "visitedc P n u (pc, st, s, f, r) (pc', st', s', f', r') pcs"
  using that
  apply (
    induction P \<equiv> P n u "(pc, st, s, f, r :: nat list)" "(pc', st', s', f', r')" pcs
    arbitrary: pc st s f r  rule: visitedc.induct
    )
   apply blast
  by (erule stepc.elims; force split: option.splits if_splits elim!: step.elims)+

(* XXX Move *)
lemma visited_reset:
  "\<exists> x. \<exists> pc \<in> set pcs. Some (STOREC c x) = P pc"
  if "visited P n (pc, st, s, f, r) (pc', st', s', f', r') pcs" "c \<in> set r' - set r"
  using that
  apply (
      induction P \<equiv> P n "(pc, st, s, f, r :: nat list)" "(pc', st', s', f', r')" pcs
      arbitrary: pc st s f r rule: visited.induct
      )
   apply blast
  by (erule step.elims; force split: option.split_asm if_split_asm elim!: step.elims)

(* XXX Move *)
lemma visitedc_reset:
  "\<exists> x. \<exists> pc \<in> set pcs. Some (INSTR (STOREC c x)) = P pc"
  if "visitedc P n u (pc, st, s, f, r) (pc', st', s', f', r') pcs" "c \<in> set r' - set r"
  using that
  apply (
      induction P \<equiv> P n u "(pc, st, s, f, r :: nat list)" "(pc', st', s', f', r')" pcs
      arbitrary: pc st s f r rule: visitedc.induct
      )
   apply blast
  by (erule stepc.elims; force split: option.split_asm if_split_asm elim!: step.elims)

(* TTT Automate *)
lemma visited_fuel_mono:
  "visited P n' s s' pcs" if "visited P n s s' pcs" "n' \<ge> n"
  using that
  apply (induction arbitrary: n')
  subgoal for _ _ _ n'
    by (cases n') (auto intro: visited.intros)
  subgoal for _ _ _ _ _ _ _ _ _ _ _ n'
    by (cases n') (auto intro: visited.intros)
  done

(* TTT Automate *)
lemma visitedc_fuel_mono:
  "visitedc P n' u s s' pcs" if "visitedc P n u s s' pcs" "n' \<ge> n"
  using that
  apply (induction arbitrary: n')
  subgoal for _ _ _ _ n'
    by (cases n') (auto intro: visitedc.intros)
  subgoal for _ _ _ _ _ _ _ _ _ _ _ _ n'
    by (cases n') (auto intro: visitedc.intros)
  done

lemma visted_split:
  assumes "visited P n (pc, st, s, f, r) s'' (pcs' @ pc' # pcs)"
  obtains st' s' f' r' where
    "visited P n (pc, st, s, f, r) (pc', st', s', f', r') pcs"
    "visited P n (pc', st', s', f', r') s'' (pcs' @ [pc'])"
  using assms
    apply atomize_elim
  proof (induction _ _ _ _ "pcs' @ pc' # pcs" arbitrary: pcs rule: visited.induct)
    case (1 prog n u start)
    then show ?case by simp
  next
    case prems: (2 cmd pc st m f rs s prog n s' pcs pcs'')
    show ?case
    proof (cases "pcs'' = []")
      case True
      with prems show ?thesis by (blast intro: visited.intros)
    next
      case False
      with \<open>pcs @ [pc] = _\<close> obtain pcs3 where "pcs'' = pcs3 @ [pc]"
        by (metis append_butlast_last_id last_ConsR last_append last_snoc list.distinct(1))
      with prems obtain st' s'a f' r' where
        "visited prog n s (pc', st', s'a, f', r') pcs3"
        "visited prog n (pc', st', s'a, f', r') s' (pcs' @ [pc'])"
        by (auto 9 2)
      with prems \<open>pcs'' = _\<close> show ?thesis by (auto 4 6 intro: visited.intros visited_fuel_mono)
    qed
  qed

lemma visited_steps':
  assumes "visited P n (pc, st, s, f, r) s'' pcs" "pc' \<in> set pcs"
  obtains st' s' f' r' where "steps P n (pc, st, s, f, r) (pc', st', s', f', r')"
  using assms by (force dest!: split_list dest: visited_steps elim: visted_split)

lemma vistedc_split:
  assumes "visitedc P n u (pc, st, s, f, r) s'' (pcs' @ pc' # pcs)"
  obtains st' s' f' r' where
    "visitedc P n u (pc, st, s, f, r) (pc', st', s', f', r') pcs"
    "visitedc P n u (pc', st', s', f', r') s'' (pcs' @ [pc'])"
  using assms
    apply atomize_elim
  proof (induction _ _ _ _ _ "pcs' @ pc' # pcs" arbitrary: pcs rule: visitedc.induct)
    case (1 prog n u start)
    then show ?case by simp
  next
    case prems: (2 cmd u pc st m f rs s prog n s' pcs pcs'')
    show ?case
    proof (cases "pcs'' = []")
      case True
      with prems show ?thesis by (blast intro: visitedc.intros)
    next
      case False
      with \<open>pcs @ [pc] = _\<close> obtain pcs3 where "pcs'' = pcs3 @ [pc]"
        by (metis append_butlast_last_id last_ConsR last_append last_snoc list.distinct(1))
      with prems obtain st' s'a f' r' where
        "visitedc prog n u s (pc', st', s'a, f', r') pcs3"
        "visitedc prog n u (pc', st', s'a, f', r') s' (pcs' @ [pc'])"
        by (auto 9 2)
      with prems \<open>pcs'' = _\<close> show ?thesis by (auto 4 6 intro: visitedc.intros visitedc_fuel_mono)
    qed
  qed

lemma visitedc_stepsc':
  assumes "visitedc P n u (pc, st, s, f, r) s'' pcs" "pc' \<in> set pcs"
  obtains st' s' f' r' where "stepsc P n u (pc, st, s, f, r) (pc', st', s', f', r')"
  using assms  by (force dest!: split_list dest: visitedc_stepsc elim: vistedc_split)

(* XXX Automate *)
lemma steps_fuel_mono:
  "steps P n' s s'" if "steps P n s s'" "n' \<ge> n"
  using that
  apply (induction arbitrary: n')
  subgoal for _ _ _ n'
    by (cases n') auto
  subgoal for _ _ _ _ _ _ _ _ _ _ n'
    by (cases n') auto
  done

lemma exec_steps':
  assumes "exec prog n s pcs = Some (s', pcs')" "pc' \<in> set pcs' - set pcs"
  obtains st m f rs where "steps prog n s (pc', st, m, f, rs)"
  using assms
    apply atomize_elim
proof (induction P \<equiv> prog n s pcs arbitrary: s' rule: exec.induct)
  case 1
  then show ?case by simp
next
  case (2 n pc st m f rs pcs)
  then obtain instr where "prog pc = Some instr" by (cases "prog pc") auto
  show ?case
  proof (cases "instr = HALT")
    case True
    with "2.prems" \<open>prog pc = _\<close> show ?thesis by (auto; blast)
  next
    case F: False
    show ?thesis
    proof (cases "pc' = pc")
      case True
      with \<open>prog pc = _\<close> show ?thesis by (auto; blast)
    next
      case False
      (* XXX A lot of implicit forward reasoning hides in here *)
      with \<open>prog pc = _\<close> 2(2,3) F show ?thesis
        by - (
          erule exec.elims;
          auto 5 6
            dest!: 2(1)[OF \<open>prog pc = _\<close> F, rotated, OF sym]
            simp: option.split_asm if_split_asm
          )
    qed
  qed
qed

lemma exec_visited:
  assumes "exec prog n s pcs = Some ((pc, st, m, f, rs), pcs')"
  obtains pcs'' where
    "visited prog n s (pc, st, m, f, rs) pcs'' \<and> pcs' = pc # pcs'' @ pcs \<and> prog pc = Some HALT"
  apply atomize_elim
  using assms proof (induction P \<equiv> prog n s pcs arbitrary: pc st m f rs rule: exec.induct)
  case 1
  then show ?case by simp
next
  case (2 n pc' st' m' f' rs' pcs')
  then obtain instr where "prog pc' = Some instr" by (cases "prog pc'") auto
  show ?case
  proof (cases "instr = HALT")
    case True
    with "2.prems" \<open>prog pc' = _\<close> show ?thesis by (auto elim: exec.elims intro: visited.intros)
  next
    case False
    with 2(2) \<open>prog pc' = _\<close> show ?thesis
      by - (
          erule exec.elims;
          auto split: option.split_asm if_split_asm intro: visited.intros
          dest!: 2(1)[OF \<open>prog pc' = _\<close> False, rotated, OF sym]
          )
  qed
qed

lemma exec_reset':
  "\<exists> x. \<exists> pc \<in> set pcs'. Some (STOREC c x) = P pc"
  if "exec P n (pc, st, s, f, r) pcs = Some ((pc', st', s', f', r'), pcs')" "c \<in> set r' - set r"
proof -
  from exec_visited[OF that(1)] obtain pcs'' where *:
    "visited P n (pc, st, s, f, r) (pc', st', s', f', r') pcs''"
    "pcs' = pc' # pcs'' @ pcs \<and> P pc' = Some HALT"
    by auto
  from visited_reset[OF this(1) that(2)] obtain x pc where
    "pc\<in>set pcs''" "Some (STOREC c x) = P pc"
    by auto
  with *(2) show ?thesis by auto
qed

lemma steps_approx_out_of_range:
  "steps_approx n prog pc = {}" if "pc \<ge> length prog"
  using that by (induction n) auto

lemma steps_resets_mono:
  "set r \<subseteq> set r'" if "steps P n (pc, st, s, f, r) (pc', st', s', f', r')"
  using that
  by (induction "(pc, st, s, f, r)" "(pc', st', s', f', r')" arbitrary: pc st s f r;
      fastforce intro: visited.intros elim!: step.elims split: if_split_asm)

lemma resets_start:
  assumes
    "\<forall> pc \<in> {pc..pc'}. \<exists> c x. prog ! pc = Some (INSTR (STOREC c x))"
    "steps
      (map_option stripf o (\<lambda>pc. if pc < size prog then prog ! pc else None))
      n (pc, st, s, f, r) (pc_t, st', s', f', r')"
    "prog ! pc_t = Some (INSTR HALT)"
  shows "{c. \<exists> x. \<exists> pc \<in> {pc .. pc'}. prog ! pc = Some (INSTR (STOREC c x))} \<subseteq> set r'"
    using assms(2,3,1)
  proof (induction
    "(map_option stripf o (\<lambda>pc. if pc < size prog then prog ! pc else None))" n "(pc, st, s, f, r)"
    "(pc_t, st', s', f', r')" arbitrary: pc st s f r
    )
      case prems: 1
      show ?case
      proof (cases "pc' \<ge> pc_t")
        case True (* XXX Automate forward step *)
        with prems obtain c x where "prog ! pc_t = Some (INSTR (STOREC c x))"
          by fastforce
        with prems show ?thesis by simp
      next
        case False
        with prems show ?thesis by auto
      qed
    next
      case prems: (2 cmd pc st m f rs s n)
      show ?case
      proof (cases "pc' \<ge> pc")
        case True (* XXX Automate forward step *)
        with prems(6) obtain c d where "prog ! pc = Some (INSTR (STOREC c d))"
          by fastforce
        moreover obtain pc1 st' s' f' r1 where "s = (pc1, st', s', f', r1)"
          using prod.exhaust by metis
        ultimately have "pc1 = pc + 1"
          using prems(1,2) by (auto elim!: step.elims split: if_split_asm)
        with prems(4)[OF \<open>s = _\<close> prems(5)] prems(6) have
          "{c. \<exists>x. \<exists>pc\<in>{pc1..pc'}. prog ! pc = Some (INSTR (STOREC c x))} \<subseteq> set r'"
          by auto
        moreover have "c \<in> set r1"
          using prems(1,2) \<open>s = _\<close> \<open>prog ! pc = _\<close> by (auto elim!: step.elims split: if_split_asm)
        moreover then have "c \<in> set r'"
          using prems(3) \<open>s = _\<close> by (auto dest: steps_resets_mono)
        ultimately show ?thesis
          using \<open>pc1 = _\<close> \<open>prog ! pc = _\<close> apply clarsimp
          subgoal for _ _ pc''
            by (cases "pc'' = pc"; force)
          done
      next
        case False
        then show ?thesis by auto
      qed
    qed

function find_resets_start where
  "find_resets_start prog pc =
    (
    if pc < length prog
    then
      case prog ! pc of
        Some (INSTR (STOREC c x)) \<Rightarrow> (Some pc \<squnion> find_resets_start prog (pc + 1)) |
        _ \<Rightarrow> None
    else None
    )
  "
  by auto

termination
  by (relation "measure (\<lambda> (prog, pc). length prog - pc)") auto

lemma find_resets_start:
  "\<forall> pc \<in> {pc..pc'}. \<exists> c x. prog ! pc = Some (INSTR (STOREC c x))" if
  "find_resets_start prog pc = Some pc'"
  using that
  proof (induction arbitrary: pc' rule: find_resets_start.induct)
    case prems: (1 prog pc)
    from prems(2) show ?case
      apply (simp split: if_split_asm option.split_asm instrc.split_asm)
      apply (
          auto simp del: find_resets_start.simps simp: le_max_iff_disj sup_nat_def sup_option_def
          split: option.split_asm instr.split_asm dest!: prems(1)
          )
      by (metis atLeastAtMost_iff le_antisym not_less_eq_eq)
  qed

lemmas resets_start' = resets_start[OF find_resets_start]

context UPPAAL_Reachability_Problem_precompiled_defs
begin

  definition
    "collect_store'' pc \<equiv>
    case find_resets_start prog pc of
      None \<Rightarrow> {} |
      Some pc' \<Rightarrow>
        {(c, x). Some (INSTR (STOREC c x)) \<in> ((!) prog) ` {pc .. pc'}}"

end

(* XXX Move to Misc *)
(* XXX Unused *)
lemma bexp_atLeastAtMost_iff:
  "(\<forall> pc \<in> {pc_s..pc_t}. P pc) \<longleftrightarrow> (\<forall> pc. pc_s \<le> pc \<and> pc \<le> pc_t \<longrightarrow> P pc)"
  by auto

(* XXX Move to Misc *)
(* XXX Unused *)
lemma bexp_atLeastLessThan_iff:
  "(\<forall> pc \<in> {pc_s..<pc_t}. P pc) \<longleftrightarrow> (\<forall> pc. pc_s \<le> pc \<and> pc < pc_t \<longrightarrow> P pc)"
  by auto

lemma guaranteed_execution:
  assumes
    "\<forall> pc \<in> {pc..<pc_t}.
      prog ! pc \<noteq> None
      \<and> prog ! pc \<notin> Some ` INSTR `
        {STORE, HALT, POP, CALL, RETURN, instr.AND, instr.NOT, instr.ADD, instr.LT, instr.LE, instr.EQ}
      \<and> (\<forall> c d. prog ! pc = Some (INSTR (STOREC c d)) \<longrightarrow> d = 0)
      "
    "\<forall> pc \<in> {pc..<pc_t}. \<forall> pc'. prog ! pc = Some (INSTR (JMPZ pc')) \<longrightarrow> pc' > pc \<and> pc' \<le> pc_t"
    "prog ! pc_t = Some (INSTR HALT)" "pc_t \<ge> pc" "n > pc_t - pc" "pc_t < length prog"
  shows "\<exists> st' s' f' r'. steps
      (map_option stripf o (\<lambda>pc. if pc < size prog then prog ! pc else None))
      n (pc, st, s, f, r) (pc_t, st', s', f', r')"
  using assms
proof (induction "pc_t - pc" arbitrary: pc st s f r n rule: less_induct)
  case less
  let ?prog = "(map_option stripf \<circ> (\<lambda>pc. if pc < length prog then prog ! pc else None))"
  from \<open>pc_t - pc < n\<close> obtain n' where [simp]: "n = Suc n'" by (cases n) auto
  from less.prems(3-) have [simp]: "pc < length prog" "pc_t < length prog" by auto
  show ?case
  proof (cases "pc_t = pc")
    case True
    then show ?thesis by force
  next
    case False
    with less.prems(1,4) have valid_instr:
      "prog ! pc \<notin> Some ` INSTR `
       {STORE, HALT, POP, CALL, RETURN, instr.AND, instr.NOT, instr.ADD, instr.LT, instr.LE, instr.EQ}"
      "prog ! pc \<noteq> None"
      by auto
    from \<open>pc \<le> _\<close> \<open>pc_t \<noteq> _\<close> less.prems(2) have jumps:
      "pc' > pc \<and> pc' \<le> pc_t" if "prog ! pc = Some (INSTR (JMPZ pc'))" for pc'
      using that by fastforce
    from \<open>pc \<le> _\<close> \<open>pc_t \<noteq> _\<close> less.prems(1) have stores:
      "d = 0" if "prog ! pc = Some (INSTR (STOREC c d))" for c d
      using that by fastforce
    show ?thesis
    proof (cases "prog ! pc")
      case None
      from \<open>pc_t \<noteq> _\<close> less.prems(1,4) have "prog ! pc \<noteq> None"
        by simp
      with None show ?thesis by auto
    next
      case (Some a)
      then show ?thesis
      proof (cases a)
        case (INSTR instr)
        have *:
          "\<exists>st' s' f' r'. steps ?prog n' (pc', st, s, f, r) (pc_t, st', s', f', r')"
          if "pc < pc'" "pc' \<le> pc_t" for pc' st s f r
          apply (rule less.hyps[of pc'])
          subgoal
            using that by simp
          subgoal
            using that less.prems(1) by force
          subgoal
            apply clarsimp
            subgoal premises prems for pc_s pc'
            proof -
              from prems that have "pc_s \<in> {pc..<pc_t}" by simp
              with prems(1) less.prems(2) show ?thesis by blast
            qed
            done
          using \<open>prog ! pc_t = _\<close> \<open>pc_t - pc < n\<close> that by auto
        from \<open>pc_t \<noteq> pc\<close> \<open>pc \<le> _\<close> have "Suc pc \<le> pc_t" by simp
        then obtain pc' st' s' f' r' where
          "step instr (pc, st, s, f, r) = Some (pc', st', s', f', r')" "pc < pc'" "pc' \<le> pc_t"
          apply atomize_elim
          apply (cases instr)
          using valid_instr \<open>a = _\<close> \<open>_ = Some a\<close> by (auto simp: stores jumps)
        with \<open>a = _\<close> \<open>_ = Some a\<close> show ?thesis by (force dest!: *)
      next
        case (CEXP x2)
        have *:
          "\<exists>st' s' f' r'. steps ?prog n' (Suc pc, st, s, f, r) (pc_t, st', s', f', r')"
          if "Suc pc \<le> pc_t" for st s f r
          apply (rule less.hyps[of "Suc pc"])
          subgoal
            using \<open>pc \<le> _\<close> \<open>pc_t \<noteq> pc\<close> by simp
          subgoal
            using less.prems(1) by force
          subgoal
            apply clarsimp
            subgoal premises prems for pc_s pc'
            proof -
              from prems have "pc_s \<in> {pc..<pc_t}" by simp
              with prems(1) less.prems(2) show ?thesis by blast
            qed
            done
          using \<open>prog ! pc_t = _\<close> \<open>pc_t - pc < n\<close> that by auto
        from \<open>pc_t \<noteq> pc\<close> \<open>pc \<le> _\<close> have "Suc pc \<le> pc_t" by simp
        with \<open>a = _\<close> \<open>_ = Some a\<close> show ?thesis by (force dest!: *)
      qed
    qed
  qed
qed

function find_next_halt where
  "find_next_halt prog pc =
    (
    if pc < length prog
    then
      case prog ! pc of
        Some (INSTR HALT) \<Rightarrow> Some pc |
        _ \<Rightarrow> find_next_halt prog (pc + 1)
    else None
    )
  "
  by auto

termination
  by (relation "measure (\<lambda> (prog, pc). length prog - pc)") auto

lemma find_next_halt_finds_halt:
  "prog ! pc' = Some (INSTR HALT) \<and> pc \<le> pc' \<and> pc' < length prog"
  if "find_next_halt prog pc = Some pc'"
using that proof (induction prog pc rule: find_next_halt.induct)
  case prems: (1 prog pc)
  from prems(20) show ?case
    by (
        simp,
        simp
        split: if_split_asm option.split_asm instrc.split_asm instr.split_asm
        del: find_next_halt.simps;
        fastforce dest: prems(1-19) simp del: find_next_halt.simps)
qed

definition
  "guaranteed_execution_cond prog pc_s n \<equiv>
    case find_next_halt prog pc_s of
      None \<Rightarrow> False |
      Some pc_t \<Rightarrow>
       (
       \<forall> pc \<in> {pc_s..<pc_t}.
          prog ! pc \<noteq> None
          \<and> prog ! pc \<notin> Some ` INSTR `
            {STORE, HALT, POP, CALL, RETURN, instr.AND, instr.NOT, instr.ADD, instr.LT, instr.LE, instr.EQ}
          \<and> (\<forall> c d. prog ! pc = Some (INSTR (STOREC c d)) \<longrightarrow> d = 0)
        ) \<and>
        (\<forall> pc \<in> {pc_s..<pc_t}. \<forall> pc'. prog ! pc = Some (INSTR (JMPZ pc')) \<longrightarrow> pc' > pc \<and> pc' \<le> pc_t)
       \<and> n > pc_t - pc_s
  "

lemma guaranteed_execution_cond_alt_def[code]:
  "guaranteed_execution_cond prog pc_s n \<equiv>
    case find_next_halt prog pc_s of
      None \<Rightarrow> False |
      Some pc_t \<Rightarrow>
       (
       \<forall> pc \<in> {pc_s..<pc_t}.
          prog ! pc \<noteq> None
          \<and> prog ! pc \<notin> Some ` INSTR `
            {STORE, HALT, POP, CALL, RETURN, instr.AND, instr.NOT, instr.ADD, instr.LT, instr.LE, instr.EQ}
          \<and> (case prog ! pc of Some (INSTR (STOREC c d)) \<Rightarrow> d = 0 | _ \<Rightarrow> True)
        ) \<and>
        (\<forall> pc \<in> {pc_s..<pc_t}.
          case prog ! pc of Some (INSTR (JMPZ pc')) \<Rightarrow> pc' > pc \<and> pc' \<le> pc_t | _ \<Rightarrow> True)
       \<and> n > pc_t - pc_s
  "
proof (rule eq_reflection, goal_cases)
  case 1
  have *:
    "(\<forall> c d. prog ! pc = Some (INSTR (STOREC c d)) \<longrightarrow> d = 0) \<longleftrightarrow>
     (case prog ! pc of Some (INSTR (STOREC c d)) \<Rightarrow> d = 0 | _ \<Rightarrow> True)" for pc
    by (auto split: option.split instrc.split instr.split)
  have **:
    "(\<forall> pc'. prog ! pc = Some (INSTR (JMPZ pc')) \<longrightarrow> pc' > pc \<and> pc' \<le> pc_t) \<longleftrightarrow>
     (case prog ! pc of Some (INSTR (JMPZ pc')) \<Rightarrow> pc' > pc \<and> pc' \<le> pc_t | _ \<Rightarrow> True)" for pc pc_t
    by (auto split: option.split instrc.split instr.split)
  show ?case unfolding guaranteed_execution_cond_def * ** ..
qed

lemma guaranteed_execution':
  "\<exists> pc_t st' s' f' r' pcs'. exec
      (map_option stripf o (\<lambda>pc. if pc < size prog then prog ! pc else None))
      n (pc, st, s, f, r) pcs = Some ((pc_t, st', s', f', r'), pcs')"
  if "guaranteed_execution_cond prog pc n"
proof -
  from that obtain pc_t where "find_next_halt prog pc = Some pc_t"
    unfolding guaranteed_execution_cond_def bexp_atLeastAtMost_iff
    by (auto split: option.split_asm)
  then have "prog ! pc_t = Some (INSTR HALT) \<and> pc \<le> pc_t \<and> pc_t < length prog"
    by (rule find_next_halt_finds_halt)
  moreover then have "\<exists> st' s' f' r'. steps
      (map_option stripf o (\<lambda>pc. if pc < size prog then prog ! pc else None))
      n (pc, st, s, f, r) (pc_t, st', s', f', r')"
    using \<open>_ = Some pc_t\<close> that
    unfolding guaranteed_execution_cond_def bexp_atLeastAtMost_iff
    by - (rule guaranteed_execution, auto)
  ultimately show ?thesis by (force dest: steps_exec)
  qed

context UPPAAL_Reachability_Problem_precompiled_defs
begin

  lemma collect_cexp_alt_def:
    "collect_cexp =
      set (List.map_filter
        (\<lambda> x. case x of Some (CEXP ac) \<Rightarrow> Some ac | _ \<Rightarrow> None)
         prog)"
    unfolding collect_cexp_def set_map_filter by (auto split: option.split_asm instrc.split_asm)

  lemma clkp_set'_alt_def:
    "clkp_set' =
      \<Union> (collect_clock_pairs ` set (concat inv)) \<union> (constraint_pair ` collect_cexp)"
    unfolding clkp_set'_def collect_cexp_def by auto

  definition
    "collect_store = {(c, x). Some (INSTR (STOREC c x)) \<in> set prog}"

  lemma collect_store_alt_def:
    "collect_store =
      set (List.map_filter
        (\<lambda> x. case x of Some (INSTR (STOREC c x)) \<Rightarrow> Some (c, x) | _ \<Rightarrow> None)
         prog)"
    unfolding collect_store_def set_map_filter
    by (auto split: option.split_asm instrc.split_asm instr.split_asm)

  lemma clk_set'_alt_def: "clk_set' = (fst ` clkp_set' \<union> fst ` collect_store)"
    unfolding clk_set'_def collect_store_def by auto

end

fun conj_instr :: "'t instrc \<Rightarrow> addr \<Rightarrow> bool" where
  "conj_instr (CEXP _) _ = True" |
  "conj_instr (INSTR COPY) _ = True" |
  "conj_instr (INSTR (JMPZ pc)) pc_t = (pc = pc_t)" |
  "conj_instr (INSTR instr.AND) _ = True" |
  "conj_instr _ _ = False"

(*
inductive is_conj_block :: "'t instrc option list \<Rightarrow> addr \<Rightarrow> addr \<Rightarrow> bool" where
  (* "is_conj_block prog pc pc" if "prog ! pc = Some (INSTR HALT)" | *)
  "is_conj_block prog pc (pc' + 1)" if
  "prog ! (pc' + 1) = Some (INSTR HALT)" "is_conj_block prog pc pc'" |
  "is_conj_block prog pc pc" if "prog ! pc = Some (CEXP ac)" |
  "is_conj_block prog pc (pc' + 3)" if
  "prog ! (pc' + 1) = Some (INSTR COPY)" "prog ! (pc' + 2) = Some (CEXP ac)"
  "prog ! (pc' + 3) = Some (INSTR instr.AND)"
  "is_conj_block prog pc pc'" |
  "is_conj_block prog pc (pc' + 4)" if
  "prog ! (pc' + 1) = Some (INSTR COPY)"
  "prog ! (pc' + 2) = Some (INSTR (JMPZ pc_t))" "prog ! pc_t = Some (INSTR HALT)"
  "prog ! (pc' + 3) = Some (CEXP ac)" "prog ! (pc' + 4) = Some (INSTR instr.AND)"
  "is_conj_block prog pc pc'"
*)

inductive is_conj_block' :: "'t instrc option list \<Rightarrow> addr \<Rightarrow> addr \<Rightarrow> bool" where
  "is_conj_block' prog pc pc" if
  "pc < length prog"
  "prog ! pc = Some (INSTR HALT)" |
  (*
  "is_conj_block' prog pc (pc + 2)" if
  "pc + 2 < length prog"
  "prog ! (pc) = Some (INSTR COPY)" "prog ! (pc + 1) = Some (CEXP ac)"
  "prog ! (pc + 2) = Some (INSTR instr.AND)" |
  *)
  (*
  "is_conj_block' prog pc (pc' + 2)" if
  "pc' + 2 < length prog"
  "prog ! (pc') = Some (INSTR COPY)" "prog ! (pc' + 1) = Some (CEXP ac)"
  "prog ! (pc' + 2) = Some (INSTR instr.AND)"
  "is_conj_block' prog pc pc'"
  *)
  "is_conj_block' prog pc pc'" if
  "pc' < length prog"
  "prog ! pc = Some (INSTR COPY)" "prog ! (pc + 1) = Some (CEXP ac)"
  "prog ! (pc + 2) = Some (INSTR instr.AND)"
  "is_conj_block' prog (pc + 3) pc'" |
  "is_conj_block' prog pc pc'" if
  "pc' < length prog"
  "prog ! pc = Some (INSTR COPY)"
  "prog ! (pc + 1) = Some (INSTR (JMPZ pc'))" (* "prog ! pc_t = Some (INSTR HALT)" *)
  "prog ! (pc + 2) = Some (CEXP ac)"
  "prog ! (pc + 3) = Some (INSTR instr.AND)"
  "is_conj_block' prog (pc + 4) pc'"

inductive_cases stepscE: "stepsc prog n u (pc, st, m, f, rs) (pc', st', m', f', rs')"

function check_conj_block' :: "'t instrc option list \<Rightarrow> addr \<Rightarrow> addr option" where
  "check_conj_block' prog pc = (
    if pc \<ge> length prog then None
    else if prog ! pc = Some (INSTR HALT) then Some pc
    else if
      prog ! pc = Some (INSTR COPY) \<and> (case prog ! (pc + 1) of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False)
      \<and> prog ! (pc + 2) = Some (INSTR instr.AND)
    then check_conj_block' prog (pc + 3)
    else if
      prog ! pc = Some (INSTR COPY) \<and> (case prog ! (pc + 2) of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False)
      \<and> prog ! (pc + 3) = Some (INSTR instr.AND)
      \<and> (case prog ! (pc + 1) of Some (INSTR (JMPZ pc')) \<Rightarrow> True | _ \<Rightarrow> False)
    then
      (case (prog ! (pc + 1), check_conj_block' prog (pc + 4)) of (Some (INSTR (JMPZ pc')), Some pc'')
        \<Rightarrow> if pc' = pc'' then Some pc' else None | _ \<Rightarrow> None)
    else None
    )
  "
  by pat_completeness auto

termination
  by (relation "measure (\<lambda> (prog, pc). length prog - pc)") auto

lemma is_conj_block'_len_prog:
  "pc' < length prog" if "is_conj_block' prog pc pc'"
  using that by induction auto

lemma check_conj_block':
  "check_conj_block' prog pc = Some pc' \<Longrightarrow> is_conj_block' prog pc pc'"
  apply (induction prog pc rule: check_conj_block'.induct)
    apply (erule check_conj_block'.elims)
  by (auto
        split: if_split_asm option.split_asm instrc.split_asm instr.split_asm
        simp del: check_conj_block'.simps
        intro: is_conj_block'.intros is_conj_block'_len_prog)

lemma stepsc_reverseE':
  assumes "stepsc prog (Suc n) u s s''" "s'' \<noteq> s"
  obtains pc' st' m' f' rs' cmd where
    "stepc cmd u (pc', st', m', f', rs') = Some s''"
    "prog pc' = Some cmd"
    "stepsc prog n u s (pc', st', m', f', rs')"
  apply atomize_elim
  using assms
proof (induction prog "Suc n" u s s'' arbitrary: n rule: stepsc.induct) thm stepsc.induct
  case (1 prog n u start)
  then show ?case by simp
next
  case prems: (2 cmd u pc st m f rs s prog n s')
  then show ?case
  proof (cases "s' = s")
    case True
    with prems show ?thesis
      apply simp
      apply solve_ex_triv+
      by (auto elim: stepsc.cases)
  next
    case False
    with prems(3) have "n > 0" by (auto elim!: stepsc.cases)
    then obtain n' where "n = Suc n'" by (cases n) auto
    from prems(4)[OF this False] obtain cmd pc' st' m' f' rs' where
      "stepc cmd u (pc', st', m', f', rs') = Some s'" "prog pc' = Some cmd"
      "stepsc prog n' u s (pc', st', m', f', rs')"
      by atomize_elim
    with prems show ?thesis unfolding \<open>n = _\<close> by blast
  qed
qed

lemma stepsc_reverseE:
  assumes "stepsc prog n u s s''" "s'' \<noteq> s"
  obtains n' pc' st' m' f' rs' cmd where
    "n = Suc n'"
    "stepc cmd u (pc', st', m', f', rs') = Some s''"
    "prog pc' = Some cmd"
    "stepsc prog n' u s (pc', st', m', f', rs')"
proof -
  from assms have "n > 0" by (auto elim!: stepsc.cases)
  then obtain n' where "n = Suc n'" by (cases n) auto
  with assms show ?thesis by (auto elim!: stepsc_reverseE' intro!: that)
qed

lemma
  "pc = pc' - 1" if
  "stepc (CEXP cc) u (pc, st, m, f, rs) = Some (pc', st', m', f', rs')"
  using that by auto

lemma
  "pc = pc' - 1" if
  "stepc (INSTR instr) u (pc, st, m, f, rs) = Some (pc', st', m', f', rs')"
  "\<not> (\<exists> x. instr = JMPZ pc')" "instr \<noteq> RETURN" "instr \<noteq> CALL"
  using that by (auto split: option.split_asm if_split_asm elim!: step.elims)

lemma stepc_pc_no_jump:
  "pc = pc' - 1" if
  "stepc cmd u (pc, st, m, f, rs) = Some (pc', st', m', f', rs')"
  "cmd \<noteq> INSTR (JMPZ pc')" "cmd \<noteq> INSTR RETURN" "cmd \<noteq> INSTR CALL"
  using that by (cases cmd) (auto split: option.split_asm if_split_asm elim!: step.elims)

inductive stepsn :: "'t programc \<Rightarrow> nat \<Rightarrow> (nat, 't :: time) cval \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool"
  for prog where
  "stepsn prog 0 u start start" | (*
  "stepsc prog (Suc n) u s s'" if
    "stepc cmd u (pc, st, m, f, rs) = Some s'"
    "stepsc prog n u s (pc, st, m, f, rs)"
    "prog pc = Some cmd" *)
  "stepsn prog (Suc n) u (pc, st, m, f, rs) s'" if
    "stepc cmd u (pc, st, m, f, rs) = Some s"
    "prog pc = Some cmd"
    "stepsn prog n u s s'"

declare stepsn.intros[intro]

lemma stepsc_stepsn:
  assumes "stepsc P n u s s'"
  obtains n' where "stepsn P n' u s s'" "n' < n"
  using assms by induction auto

lemma stepsn_stepsc:
  assumes "stepsn P n' u s s'" "n' < n"
  shows "stepsc P n u s s'"
  using assms
  proof (induction arbitrary: n)
    case (1 u start)
    then obtain n' where "n = Suc n'" by (cases n) auto
    then show ?case by auto
  next
    case (2 cmd u pc st m f rs s n s' n')
    from \<open>_ < n'\<close> have "n < n' - 1" by simp
    from 2(4)[OF this] 2(1,2,3,5) show ?case
    proof -
      have "(\<exists>fa n fb p. P = fa \<and> n' = Suc n \<and> u = fb \<and> (pc, st, m, f, rs) = p \<and> s' = p) \<or> (\<exists>i fa n is isa b ns p fb na pa. P = fb \<and> n' = Suc na \<and> u = fa \<and> (pc, st, m, f, rs) = (n, is, isa, b, ns) \<and> s' = pa \<and> stepc i fa (n, is, isa, b, ns) = Some p \<and> fb n = Some i \<and> stepsc fb na fa p pa)"
        using "2.prems" Suc_pred' \<open>P pc = Some cmd\<close> \<open>stepc cmd u (pc, st, m, f, rs) = Some s\<close> \<open>stepsc P (n' - 1) u s s'\<close> gr_implies_not_zero by blast
      then show ?thesis
        by blast
    qed
  qed

lemma stepsn_extend:
  assumes "stepsn P n1 u s s1" "stepsn P n2 u s s2" "n1 \<le> n2"
  shows "stepsn P (n2 - n1) u s1 s2"
using assms
proof (induction arbitrary: n2 s2)
  case (1 u start)
  then show ?case by simp
next
  case (2 cmd u pc st m f rs s n s')
  from 2(1,2,5-) have "stepsn P (n2 - 1) u s s2" by (auto elim: stepsn.cases)
  from 2(4)[OF this] \<open>Suc n <= _\<close> show ?case by simp
qed

(* XXX Move *)
lemma stepsc_halt:
  "s' = (pc, s)" if "stepsc P n u (pc, s) s'" "P pc = Some (INSTR HALT)"
  using that by (induction P n u "(pc, s)" s') auto

lemma stepsn_halt:
  "s' = (pc, s)" if "stepsn P n u (pc, s) s'" "P pc = Some (INSTR HALT)"
  apply (rule stepsc_halt[OF stepsn_stepsc[where n = "Suc n"]])
  using that by simp+

lemma is_conj_block'_pc_mono:
  "pc \<le> pc'" if "is_conj_block' prog pc pc'"
  using that by induction auto

lemma is_conj_block'_halt:
  "prog ! pc' = Some (INSTR HALT)" if "is_conj_block' prog pc pc'"
  using that by induction auto

lemma numeral_4_eq_4:
  "4 = Suc (Suc (Suc (Suc 0)))"
  by simp

lemma is_conj_block'_is_conj:
  assumes "is_conj_block' P pc pc'"
    and "stepsn (\<lambda> i. if i < length P then P ! i else None) n u (pc, st, s, f, rs) (pc_t, st_t, s_t, True, rs_t)"
    and "P ! pc_t = Some (INSTR HALT)"
    (* and "pc < pc_t" (* "pc_t \<le> pc'" *) *)
  shows "f \<and> pc_t = pc'"
  using assms
proof (induction arbitrary: n st s f rs)
  case (1 pc prog)
  with stepsn_halt[OF this(3)] show ?case by simp
next
  case prems: (2 pc' prog pc ac)
  let ?P = "(\<lambda>i. if i < length prog then prog ! i else None)"
  consider (0) "n = 0" | (1) "n = 1" | (2) "n = 2" | (3) "n \<ge> 3" by force
  then show ?case
  proof cases
    case 0
    with prems show ?thesis by (auto elim!: stepsn.cases)
  next
    case 1
    with prems show ?thesis by (auto elim!: stepsn.cases simp: int_of_def split: if_split_asm)
  next
    case 2
    with prems show ?thesis by (auto elim!: stepsn.cases simp: int_of_def numeral_2_eq_2 split: if_split_asm)
  next
    case 3
    from prems have "pc + 2 < length prog" by (auto dest: is_conj_block'_pc_mono)
    with prems(2-4) obtain st1 s1 rs1 where
      "stepsn ?P 3 u (pc, st, s, f, rs) (pc + 3, st1, s1, f \<and> (u \<turnstile>\<^sub>a ac), rs1)"
      by (force simp: int_of_def numeral_3_eq_3)
    from stepsn_extend[OF this prems(7) 3] have
      "stepsn ?P (n - 3) u (pc + 3, st1, s1, f \<and> (u \<turnstile>\<^sub>a ac), rs1) (pc_t, st_t, s_t, True, rs_t)" .
    from prems(6)[OF this \<open>prog ! pc_t = _\<close>] have "pc_t = pc'" "u \<turnstile>\<^sub>a ac" f by auto
    then show ?thesis by simp
  qed
next
  case prems: (3 pc' prog pc ac)
  let ?P = "(\<lambda>i. if i < length prog then prog ! i else None)"
  consider (0) "n = 0" | (1) "n = 1" | (2) "n = 2" | (3) "n = 3" | (4) "n \<ge> 4" by force
  then show ?case
  proof cases
    case 0
    with prems show ?thesis by (auto elim!: stepsn.cases)
  next
    case 1
    with prems show ?thesis by (auto elim!: stepsn.cases simp: int_of_def split: if_split_asm)
  next
    case 2
    with prems show ?thesis by (auto elim!: stepsn.cases simp: int_of_def numeral_2_eq_2 split: if_split_asm)
  next
    case 3
    with prems show ?thesis
      by (auto elim!: stepsn.cases simp: int_of_def numeral_3_eq_3 split: if_split_asm dest!: is_conj_block'_halt)
  next
    case 4
    from prems have "pc + 3 < length prog" by (auto dest: is_conj_block'_pc_mono)
    show ?thesis
    proof (cases f)
      case True
      with \<open>pc + 3 < _\<close> prems(2-6) obtain st1 s1 rs1 where
        "stepsn ?P 4 u (pc, st, s, f, rs) (pc + 4, st1, s1, f \<and> (u \<turnstile>\<^sub>a ac), rs1)"
      by (force simp: int_of_def numeral_3_eq_3 numeral_4_eq_4)
      from stepsn_extend[OF this prems(8) 4] have
        "stepsn ?P (n - 4) u (pc + 4, st1, s1, f \<and> (u \<turnstile>\<^sub>a ac), rs1) (pc_t, st_t, s_t, True, rs_t)" .
      from prems(7)[OF this \<open>prog ! pc_t = _\<close>] have "pc_t = pc'" "u \<turnstile>\<^sub>a ac" f by auto
      then show ?thesis by simp
    next
      case False
      with \<open>pc + 3 < _\<close> prems(1-6) obtain st1 s1 rs1 where
        "stepsn ?P 2 u (pc, st, s, f, rs) (pc', st1, s1, False, rs1)"
        by (force simp: int_of_def numeral_2_eq_2)
      from stepsn_extend[OF this prems(8)] 4 have
        "stepsn ?P (n - 2) u (pc', st1, s1, False, rs1) (pc_t, st_t, s_t, True, rs_t)" by simp
      from stepsn_halt[OF this] prems(1,6) show ?thesis by (auto dest: is_conj_block'_halt)
    qed
  qed
qed

lemma is_conj_block'_is_conj':
  assumes "is_conj_block' P pc pc'"
    and "stepst (\<lambda> i. if i < length P then P ! i else None) n u (pc, st, s, f, rs) (pc_t, st_t, s_t, True, rs_t)"
    (* and "pc < pc_t" (* "pc_t \<le> pc'" *) *)
  shows "f \<and> pc_t = pc'"
  using assms
  unfolding stepst_def by (auto split: if_split_asm elim!: is_conj_block'_is_conj stepsc_stepsn)

lemma is_conj_block'_is_conj2:
  assumes "is_conj_block' P (pc + 1) pc'" "P ! pc = Some (CEXP ac)"
    and "stepst (\<lambda> i. if i < length P then P ! i else None) n u (pc, st, s, f, rs) (pc_t, st_t, s_t, True, rs_t)"
  shows "(u \<turnstile>\<^sub>a ac) \<and> pc_t = pc'"
proof -
  let ?P = "(\<lambda> i. if i < length P then P ! i else None)"
  from assms(1) have "pc < pc'" "pc' < length P"
    by (auto dest: is_conj_block'_pc_mono is_conj_block'_len_prog)
  with assms(2,3) obtain st' s' rs' where
    "stepst ?P (n - 1) u (pc + 1, st', s', u \<turnstile>\<^sub>a ac, rs') (pc_t, st_t, s_t, True, rs_t)"
    unfolding stepst_def
    apply (clarsimp split: if_split_asm)
    apply (erule stepsc.cases)
    by auto
  from is_conj_block'_is_conj'[OF assms(1) this] show ?thesis .
qed

lemma is_conj_block'_is_conj3:
  assumes "is_conj_block' P (pc + 2) pc'" "P ! pc = Some (CEXP ac)" "P ! (pc + 1) = Some (INSTR instr.AND)"
    and "stepst (\<lambda> i. if i < length P then P ! i else None) n u (pc, st, s, f, rs) (pc_t, st_t, s_t, True, rs_t)"
  shows "(u \<turnstile>\<^sub>a ac) \<and> pc_t = pc'"
proof -
  let ?P = "(\<lambda> i. if i < length P then P ! i else None)"
  from assms(1) have "pc < pc'" "pc' < length P"
    by (auto dest: is_conj_block'_pc_mono is_conj_block'_len_prog)
  with assms(2,3,4) obtain st' s' rs' f where
    "stepst ?P (n - 2) u (pc + 2, st', s', f \<and> (u \<turnstile>\<^sub>a ac), rs') (pc_t, st_t, s_t, True, rs_t)"
    unfolding stepst_def
    apply (clarsimp split: if_split_asm)
    apply (erule stepsc.cases)
     apply force
    apply (erule stepsc.cases)
    by (auto split: if_split_asm option.split_asm elim!: UPPAAL_Asm.step.elims)
  from is_conj_block'_is_conj'[OF assms(1) this] show ?thesis by simp
qed

definition
  "is_conj_block P pc pc' \<equiv>
   (\<exists> ac. P ! pc = Some (CEXP ac)) \<and> is_conj_block' P (pc + 1) pc'
   \<or> (\<exists> ac.
      P ! pc = Some (CEXP ac)) \<and> P ! (pc + 1) = Some (INSTR instr.AND)
      \<and> is_conj_block' P (pc + 2) pc'"

lemma is_conj_block_alt_def[code]:
"is_conj_block P pc pc' \<equiv>
   (case P ! pc of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False) \<and> is_conj_block' P (pc + 1) pc'
   \<or> (case P ! pc of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False) \<and> P ! (pc + 1) = Some (INSTR instr.AND)
      \<and> is_conj_block' P (pc + 2) pc'"
  unfolding is_conj_block_def
  by (rule eq_reflection) (auto split: option.split_asm instrc.split_asm)

lemma is_conj_block_is_conj:
  assumes "is_conj_block P pc pc'" "P ! pc = Some (CEXP ac)"
    and
      "stepst
        (\<lambda> i. if i < length P then P ! i else None) n u
        (pc, st, s, f, rs)
        (pc_t, st_t, s_t, True, rs_t)"
  shows "(u \<turnstile>\<^sub>a ac) \<and> pc_t = pc'"
  using assms
  unfolding is_conj_block_def
  apply safe
  by ((drule is_conj_block'_is_conj2 is_conj_block'_is_conj3; simp), simp)+

lemma is_conj_block'_decomp:
  "is_conj_block P pc' pc''" if
  "is_conj_block' P pc pc''" "P ! pc' = Some (CEXP ac)" "pc \<le> pc'" "pc' \<le> pc''"
  using that
proof (induction arbitrary: pc')
  case (1 pc prog)
  then show ?case by (simp add: is_conj_block_def)
next
  case prems: (2 pc'' prog pc ac)
  with \<open>pc \<le> _\<close> consider "pc' = pc" | "pc' = Suc pc" | "pc' = Suc (Suc pc)" | "pc + 3 \<le> pc'"
    by force
  then show ?case using prems by cases (auto simp add: numeral_3_eq_3 is_conj_block_def)
next
  case prems: (3 pc'' prog pc ac)
  with \<open>pc \<le> _\<close> consider
    "pc' = pc" | "pc' = Suc pc" | "pc' = Suc (Suc pc)" | "pc' = Suc (Suc (Suc pc))" | "pc + 4 \<le> pc'"
    by force
  then show ?case using prems by cases (auto simp add: numeral_3_eq_3 numeral_4_eq_4 is_conj_block_def)+
qed

lemma is_conj_block_decomp:
  "is_conj_block P pc' pc''" if
  "is_conj_block P pc pc''" "P ! pc' = Some (CEXP ac)" "pc \<le> pc'" "pc' \<le> pc''"
  using that
  apply (subst (asm) is_conj_block_def)
  apply safe
  (* XXX Should work without metis *)
  apply (metis
    One_nat_def add_Suc_right diff_diff_cancel diff_is_0_eq diff_le_self gr_zeroI
    is_conj_block'_decomp le_simps(3) mpl_lem pl_pl_mm that(1))
  by (metis
    One_nat_def Suc_1 add.right_neutral add_Suc_right instrc.simps(4) is_conj_block'_decomp
    le_antisym not_less_eq_eq option.inject that(1))

lemma steps_approx_finite[intro,simp]:
  "finite (steps_approx n P pc_s)"
  by (induction rule: steps_approx.induct; clarsimp split: option.split instrc.split instr.split)

abbreviation "conv_P \<equiv> map (map_option (map_instrc real_of_int))"

lemma stepst_stepc_extend:
  "stepst P n u (pc', s') (pc'', s'')"
  if "stepst P n u (pc, s) (pc'', s'')" "stepsc P n u (pc, s) (pc', s')"
proof -
  from that have "P pc'' = Some (INSTR HALT)" unfolding stepst_def by auto
  from that obtain n1 n2 where *:
    "stepsn P n1 u (pc, s) (pc'', s'')" "stepsn P n2 u (pc, s) (pc', s')" "n1 < n" "n2 < n"
    unfolding stepst_def by (auto elim!: stepsc_stepsn)
  show ?thesis
  proof (cases "n1 \<ge> n2")
    case True
    from stepsn_extend[OF *(2,1) this] \<open>n1 < _\<close> \<open>n2 < _\<close> \<open>P pc'' = _\<close> show ?thesis
      unfolding stepst_def by (auto intro: stepsn_stepsc)
  next
    case False
    with stepsn_extend[OF *(1,2)] \<open>n1 < _\<close> \<open>n2 < _\<close> \<open>P pc'' = _\<close> show ?thesis
      unfolding stepst_def by (auto intro: stepsn_stepsc dest!: stepsn_halt)
  qed
qed

lemma conv_P_conj_block'[intro]:
  "is_conj_block' (conv_P P) pc pc'" if "is_conj_block' P pc pc'"
  using that
  apply induction
    apply (rule is_conj_block'.intros(1))
     apply (simp; fail)
    apply (simp; fail)
   apply (rule is_conj_block'.intros(2))
       apply (simp; fail)
      apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
     apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
    apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
   apply (simp; fail)
  apply (rule is_conj_block'.intros(3))
       apply (simp; fail)
      apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
     apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
    apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
   apply (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog)
  apply (simp; fail)
  done

lemma conv_P_conj_block[intro]:
  "is_conj_block (conv_P P) pc pc'" if "is_conj_block P pc pc'"
  using that[unfolded is_conj_block_def]
  apply safe
  by (frule is_conj_block'_pc_mono; force dest: is_conj_block'_len_prog simp: is_conj_block_def)+

context
  fixes P :: "int instrc option list"
    and pc_s :: addr
    and n :: nat
begin

private abbreviation "prog i \<equiv> if i < length P then P ! i else None"

lemma stepst_conv_P:
  "stepst (\<lambda> i. if i < length (conv_P P) then conv_P P ! i else None) n u s s'" if
  "stepst (conv_prog prog) n u s s'" using that unfolding stepst_def
  apply safe
  subgoal for pc a aa ab b z
    apply rotate_tac
    by (induction "conv_prog prog" n u s "(pc, a, aa, ab, b)" rule: stepsc.induct)
      (auto split: if_split_asm)
  by (auto split: if_split_asm)

lemma is_conj:
  fixes u :: "nat \<Rightarrow> real"
  defines "S \<equiv> steps_approx n P pc_s"
  defines "pc_c \<equiv> Min {pc. \<exists> ac. pc \<in> S \<and> P ! pc = Some (CEXP ac)}"
  assumes "is_conj_block P pc_c (Max S)"
    and "stepst (conv_prog prog) n u (pc_s, st, s, f, rs) (pc_t, st_t, s_t, True, rs_t)"
    and "stepsc (conv_prog prog) n u (pc_s, st, s, f, rs) (pc', st', s', f', rs')"
    and "P ! pc' = Some (CEXP ac)" "pc' < length P"
  shows "(u \<turnstile>\<^sub>a conv_ac ac) \<and> pc_t = Max S"
proof -
  from stepst_stepc_extend[OF assms(4,5)] have *:
    "stepst (conv_prog prog) n u (pc', st', s', f', rs') (pc_t, st_t, s_t, True, rs_t)" .
  from \<open>stepsc _ _ _ _ _\<close> \<open>P ! pc' = _\<close> \<open>pc' < _\<close> have "pc_c \<le> pc'" "pc' \<le> Max S"
    unfolding pc_c_def S_def by (auto intro: stepsc_steps_approx Min_le Max_ge)
  from is_conj_block_decomp[OF assms(3) \<open>P ! pc' = _\<close> this] have
    "is_conj_block P pc' (Max S)" .
  then have "is_conj_block (conv_P P) pc' (Max S)" by auto
  from is_conj_block_is_conj[OF this _ stepst_conv_P[OF *]] \<open>P ! pc' = _\<close> \<open>pc' < _\<close>
    show ?thesis
    by auto
qed

lemma is_conj':
  fixes u :: "nat \<Rightarrow> real"
  defines "S \<equiv> steps_approx n P pc_s"
  assumes "{pc. \<exists> ac. pc \<in> S \<and> P ! pc = Some (CEXP ac)} = {}"
    and "stepsc (conv_prog prog) n u (pc_s, st, s, f, rs) (pc', st', s', f', rs')"
    and "P ! pc' = Some (CEXP ac)" "pc' < length P"
  shows False
  using stepsc_steps_approx[OF assms(3,5)] assms(4) assms(2) unfolding S_def by auto

term is_conj_block

definition
"check_conj_block pc pc' \<equiv>
   (case P ! pc of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False) \<and> check_conj_block' P (pc + 1) = Some pc'
   \<or> (case P ! pc of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False) \<and> P ! (pc + 1) = Some (INSTR instr.AND)
      \<and> check_conj_block' P (pc + 2) = Some pc'"

lemma check_conj_block:
  "check_conj_block pc pc' \<Longrightarrow> is_conj_block P pc pc'"
  unfolding is_conj_block_alt_def check_conj_block_def
  by (auto dest!: check_conj_block' simp del: check_conj_block'.simps)

definition
  "conjunction_check \<equiv>
    let S = steps_approx n P pc_s; S' = {pc. \<exists> ac. pc \<in> S \<and> P ! pc = Some (CEXP ac)} in
      S' = {} \<or> check_conj_block (Min S') (Max S)
  "

lemma conjunction_check_alt_def[code]:
  "conjunction_check =
    (
     let
        S = steps_approx n P pc_s;
        S' = {pc. pc \<in> S \<and> (case P ! pc of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False)}
      in
        S' = {} \<or> check_conj_block (Min S') (Max S)
    )
  "
proof -
  let ?S = "steps_approx n P pc_s"
  have "
    {pc. pc \<in> ?S \<and> (case P ! pc of Some (CEXP ac) \<Rightarrow> True | _ \<Rightarrow> False)}
  = {pc. \<exists> ac. pc \<in> ?S \<and> P ! pc = Some (CEXP ac)}
  " by safe (auto split: option.splits instrc.splits)
  show ?thesis unfolding conjunction_check_def Let_def \<open>_ = _\<close> ..
qed

lemma conjunction_check:
  fixes u :: "nat \<Rightarrow> real"
  assumes "conjunction_check"
    and "stepst (conv_prog prog) n u (pc_s, st, s, f, rs) (pc_t, st_t, s_t, True, rs_t)"
    and "stepsc (conv_prog prog) n u (pc_s, st, s, f, rs) (pc', st', s', f', rs')"
    and "P ! pc' = Some (CEXP ac)" "pc' < length P"
  shows "u \<turnstile>\<^sub>a conv_ac ac"
  using assms
  unfolding conjunction_check_def Let_def
  apply -
  apply (erule disjE)
   apply (drule is_conj'; simp)
    apply (drule check_conj_block)
  apply (subst is_conj; simp)
  done

end (* End of context for fixed program *)

end (* Theory *)


theory SumRandom_Value
  imports SumRandom_Abstractions

begin

context SumRandom begin

section random_with_seed

definition rand_with_seed_v :: "(funtyp, vtyp) vval \<Rightarrow> (funtyp, vtyp) vval \<Rightarrow> bool"
  where
  "rand_with_seed_v x y =
      (\<exists>s s'. x = VAbstract (VSeed s) \<and>
              y = VAbstract (VSeed s'))"

lemma rand_with_seed_v_rename_monoexpr_correct:
  "\<lbrakk>rand_with_seed_v (val.rename_val rename' (val.monoval v)) v';
    val.proc_env_matches \<xi>\<^sub>v \<Xi>';
    proc_ctx_wellformed \<Xi>'\<rbrakk> \<Longrightarrow>
     v' = val.rename_val rename' (val.monoval v') \<and>
    rand_with_seed_v v v'"
  by (clarsimp simp: rand_with_seed_v_def)
     (case_tac v; clarsimp)

lemma rand_with_seed_v_preservation:
  "\<lbrakk>val.vval_typing \<Xi>' v t; rand_with_seed_v v v'\<rbrakk>
    \<Longrightarrow> val.vval_typing \<Xi>' v' t"
  by (fastforce elim: val.vval_typing.cases
                intro: val.v_t_abstract
                simp: rand_with_seed_v_def seed_abs_typing_v_def)

end (* of context *)

end


(*  Title:      HOL/Auth/n_moesi_lemma_inv__2_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_moesi Protocol Case Study*}

theory n_moesi_lemma_inv__2_on_rules imports n_moesi_lemma_on_inv__2
begin
section{*All lemmas on causal relation between inv__2*}
lemma lemma_inv__2_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__2  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_rule_t1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rule_t2 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t3 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t4 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_rul_t5 N i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rule_t1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rule_t1Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rule_t2 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rule_t2Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t3 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t3Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t4 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t4Vsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_rul_t5 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_rul_t5Vsinv__2) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


section \<open>Semantics of SM\<close>
theory SM_Semantics
imports SM_State SM_Cfg Gen_Scheduler
begin

  section \<open>Evaluation of Expressions\<close>
  subsection \<open>Basic operations\<close>
  text \<open>Attention: Silently overflows, using 2's complement.
    This should match Java-semantics. In C, signed overflow is undefined!\<close>
  primrec eval_bin_op :: "bin_op \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val" where
    "eval_bin_op bo_plus v1 v2 = v1+v2"
  | "eval_bin_op bo_minus v1 v2 = v1-v2"
  | "eval_bin_op bo_mul v1 v2 = v1*v2"
  | "eval_bin_op bo_div v1 v2 = v1 sdiv v2"
  | "eval_bin_op bo_mod v1 v2 = v1 smod v2"
  | "eval_bin_op bo_less v1 v2 = val_of_bool (v1 < v2)"
  | "eval_bin_op bo_less_eq v1 v2 = val_of_bool (v1 \<le> v2)"
  | "eval_bin_op bo_eq v1 v2 = val_of_bool (v1 = v2)"
  | "eval_bin_op bo_and v1 v2 = v1 AND v2"
  | "eval_bin_op bo_or v1 v2 = v1 OR v2"
  | "eval_bin_op bo_xor v1 v2 = v1 XOR v2"

  primrec eval_un_op :: "un_op \<Rightarrow> val \<Rightarrow> val" where
    "eval_un_op uo_minus v = -v"  \<comment> \<open>Attention: Silently overflows. @{term "-min_int = min_int"}!\<close>
  | "eval_un_op uo_not v = NOT v"

  subsection \<open>Expressions\<close>
  abbreviation exists_var :: "valuation \<Rightarrow> ident \<Rightarrow> bool" where
    "exists_var s x \<equiv> x \<in> dom s"

  abbreviation update_var :: "ident \<Rightarrow> val \<Rightarrow> valuation \<Rightarrow> valuation" where
    "update_var x v s \<equiv> s(x\<mapsto>v)"

  fun eval_exp :: "exp \<Rightarrow> focused_state \<rightharpoonup> val" where
    "eval_exp (e_var x) (ls,gs) = do {
      let lv = local_state.variables ls; let gv = global_state.variables gs;
      case lv x of
        Some v \<Rightarrow> Some v
      | None \<Rightarrow> (case gv x of
          Some v \<Rightarrow> Some v
        | None \<Rightarrow> None)
    }"
  | "eval_exp (e_localvar x) (ls,gs) = local_state.variables ls x"
  | "eval_exp (e_globalvar x) (ls,gs) = global_state.variables gs x"
  | "eval_exp (e_const n) fs = do {
      assert_option (n\<ge>min_signed \<and> n\<le>max_signed);
      Some (signed_of_int n)
    }"
  | "eval_exp (e_bin bop e1 e2) fs = do {
      v1\<leftarrow>eval_exp e1 fs;
      v2\<leftarrow>eval_exp e2 fs;
      Some (eval_bin_op bop v1 v2)
      }"
  | "eval_exp (e_un uop e) fs = do {
      v\<leftarrow>eval_exp e fs;
      Some (eval_un_op uop v)
      }"

  subsection \<open>Local Actions\<close>

  text \<open>Enabledness and effects of actions\<close>
  primrec la_en :: "focused_state \<Rightarrow> action \<rightharpoonup> bool" where
    "la_en fs (AAssign c _ _) = do { v \<leftarrow> eval_exp c fs; Some (bool_of_val v)}"
  | "la_en fs (AAssign_local c _ _) = do { v \<leftarrow> eval_exp c fs; Some (bool_of_val v)}"
  | "la_en fs (AAssign_global c _ _) = do { v \<leftarrow> eval_exp c fs; Some (bool_of_val v)}"
  | "la_en fs (ATest e) = do {
      v \<leftarrow> eval_exp e fs;
      Some (bool_of_val v)}"
  | "la_en _ (ASkip) = Some True"

  text \<open>Extension (for run, handshake): Let action have scheduler effect\<close>
  fun la_ex :: "focused_state \<Rightarrow> action \<rightharpoonup> focused_state" where
    "la_ex (ls,gs) (AAssign c x e) = do {
      u \<leftarrow> eval_exp c (ls,gs);
      assert_option (bool_of_val u);
      v \<leftarrow> eval_exp e (ls,gs);
      if exists_var (local_state.variables ls) x then do {
        let ls = local_state.variables_update (update_var x v) ls;
        Some (ls,gs)
      } else do {
        assert_option (exists_var (global_state.variables gs) x);
        let gs = global_state.variables_update (update_var x v) gs;
        Some (ls,gs)
      }
    }"
  | "la_ex (ls,gs) (AAssign_local c x e) = do {
      u \<leftarrow> eval_exp c (ls,gs);
      assert_option (bool_of_val u);
      v \<leftarrow> eval_exp e (ls,gs);
      assert_option (exists_var (local_state.variables ls) x);
      let ls = local_state.variables_update (update_var x v) ls;
      Some (ls,gs)
    }"
  | "la_ex (ls,gs) (AAssign_global c x e) = do {
      u \<leftarrow> eval_exp c (ls,gs);
      assert_option (bool_of_val u);
      v \<leftarrow> eval_exp e (ls,gs);
      assert_option (exists_var (global_state.variables gs) x);
      let gs = global_state.variables_update (update_var x v) gs;
      Some (ls,gs)
    }"
  | "la_ex fs (ATest e) = do {
      v \<leftarrow> eval_exp e fs;
      assert_option (bool_of_val v);
      Some fs
    }"
  | "la_ex fs ASkip = Some fs"

  subsection "Scheduling"
  type_synonym local_config = "(cmd,local_state) local_config"
  type_synonym global_config = "(cmd,local_state,global_state) global_config"

  interpretation li: Gen_Scheduler cfg la_en la_ex .

  subsection \<open>Initial State\<close>
  definition init_valuation :: "var_decl list \<Rightarrow> valuation" where
    "init_valuation vd x \<equiv> if x \<in> set vd then Some 0 else None"

  lemma init_valuation_eq_Some[simp]: "init_valuation vd x = Some v \<longleftrightarrow> x\<in>set vd \<and> v=0"
    unfolding init_valuation_def by auto

  lemma init_valuation_eq_None[simp]: "init_valuation vd x = None \<longleftrightarrow> x\<notin>set vd"
    unfolding init_valuation_def by auto

  definition init_pc :: "proc_decl \<Rightarrow> local_config" where
    "init_pc pd \<equiv> \<lparr>
      local_config.command = proc_decl.body pd,
      local_config.state = \<lparr>
        local_state.variables = init_valuation (proc_decl.local_vars pd)
      \<rparr>
    \<rparr>"

  definition init_gc :: "program \<Rightarrow> global_config" where
    "init_gc prog \<equiv> \<lparr>
      global_config.processes = mset (map init_pc (program.processes prog)),
      global_config.state = \<lparr>
        global_state.variables = init_valuation (program.global_vars prog)
      \<rparr>
    \<rparr>"

  subsection "Semantics Reference Point"

  interpretation li: Gen_Scheduler_linit cfg la_en la_ex "{init_gc prog}" global_config.state
    for prog .

  abbreviation "ref_is_run \<equiv> li.sa.is_run"
  abbreviation "ref_accept \<equiv> li.sa.accept"

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                    May 2005               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_rep_par
imports CSP_T_law_alpha_par CSP_T_op_rep_par
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*****************************************************************

         1. associativity of [||]:I
         2. commutativity of [||]:I
         3.
         4.

 *****************************************************************)

(*****************************************************
   replace an index set with another equal index set
 *****************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Rep_parallel_index_eq:
   "[| finite I1 ;
       EX f. I2 = f ` I1 & inj_on f I1 &
             (ALL i:I1. PXf2 (f i) = PXf1 i) |]
    ==> [||]:I1 PXf1 =T[M,M] [||]:I2 PXf2"
apply (simp add: cspT_semantics)

apply (case_tac "I1 = {}")
apply (simp)
apply (rule order_antisym)

 (* <= *)
 apply (rule)
 apply (elim conjE exE)
   apply (simp add: in_traces_par)
(* not necessary for Isabelle 2017
 apply (subgoal_tac "Union (snd ` PXf2 ` f ` I1) = Union (snd ` PXf1 ` I1)")
 apply (simp)
 apply (simp add: Union_index_fun)
*)

 (* => *)
 apply (rule)
 apply (elim conjE exE)
  apply (simp add: in_traces_par)
(* not necessary for Isabelle 2017
 apply (subgoal_tac "Union (snd ` PXf2 ` f ` I1) = Union (snd ` PXf1 ` I1)")
 apply (simp)
 apply (simp add: Union_index_fun)
*)
done

(*********************************************************
                [||]:I PXf ==> [||] PXs
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Index_to_Inductive_parallel:
  "[| finite I ; Is isListOf I |] ==>
   [||]:I PXf =T[M,M] [||] (map PXf Is)"
apply (simp add: cspT_semantics)

apply (case_tac "I = {}")
apply (simp)

apply (case_tac "map PXf Is = []")
apply (simp)
apply (rule order_antisym)

 (* <= *)
 apply (rule)
 apply (simp add: in_traces_Rep_parallel)
 apply (simp add: in_traces_Inductive_parallel_nth)
 apply (simp add: isListOf_set_eq)
 apply (intro allI impI)
 apply (elim conjE exE)
 apply (drule_tac x="Is!i" in bspec)
 apply (simp add: isListOf_nth_in_index)
 apply (simp)

 (* => *)
 apply (rule)
 apply (simp add: in_traces_Rep_parallel)
 apply (simp add: in_traces_Inductive_parallel_nth)
 apply (simp add: isListOf_set_eq)
 apply (intro ballI)
 apply (elim conjE)
 apply (erule isListOf_index_to_nthE)
 apply (drule_tac x="i" in bspec, simp)
 apply (elim exE conjE)
 apply (drule_tac x="n" in spec, simp)
done

(************************************
 |       [||]:I PXf and SKIP        |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_SKIP_Rep_parallel_right:
  "finite I ==>
   (([||]:I PXf) |[Union (snd `  PXf ` I), {}]| SKIP) =T[M,M]
   ([||]:I PXf)"
apply (case_tac "I={}")
apply (simp add: cspT_SKIP_Alpha_parallel)

apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces_par)

 apply (intro ballI)
 apply (elim conjE)
 apply (drule_tac x="i" in bspec, simp)
 apply (subgoal_tac "snd (PXf i) <= Union (snd ` PXf ` I)")
 apply (simp add: rest_tr_of_rest_tr_subset)
 apply (force)

(* <= *)
 apply (rule)
 apply (simp add: in_traces_par in_traces)
 apply (simp add: rest_tr_empty)

 apply (intro ballI)
 apply (elim conjE)
 apply (drule_tac x="i" in bspec, simp)
 apply (subgoal_tac "snd (PXf i) <= Union (snd ` PXf ` I)")
 apply (simp add: rest_tr_of_rest_tr_subset)
 apply (force)
done

(************************************
 |        SKIP and [||]:I PXf       |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_SKIP_Rep_parallel_left:
  "finite I ==>
   (SKIP |[{}, Union (snd ` PXf ` I)]| ([||]:I PXf)) =T[M,M]
   ([||]:I PXf)"
  apply (subgoal_tac
    "(SKIP |[{}, Union (snd ` PXf ` I)]| ([||]:I PXf)) =T[M,M]
     (([||]:I PXf) |[Union (snd ` PXf ` I), {}]| SKIP)")
apply (rule cspT_trans)
(* modified for Isabelle 2017 *)
  apply (simp del: UN_simps SUP_image)
  apply (simp del: UN_simps SUP_image add: cspT_SKIP_Rep_parallel_right)
apply (simp add: cspT_Alpha_parallel_commut)
done

(*** left and right ***)

lemmas cspT_SKIP_Rep_parallel = cspT_SKIP_Rep_parallel_left
                                  cspT_SKIP_Rep_parallel_right

(************************************
 |          associativity           |
 ************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspT_Rep_parallel_assoc:
 "[| I1 Int I2 = {} ; finite I1 ; finite I2 |] ==>
  [||]:(I1 Un I2) PXf =T[M,M]
  [||]:I1 PXf |[Union (snd ` PXf ` I1), Union (snd ` PXf ` I2)]| [||]:I2 PXf"

  apply (case_tac "I1 = {}")
   apply (case_tac "I2 = {}")
    apply (rule cspT_sym)
    apply (simp add: cspT_SKIP_Alpha_parallel)

   apply (rule cspT_sym)
(* for Isabelle 2017 *)
   apply (simp del: UN_simps SUP_image add: cspT_SKIP_Rep_parallel)

  apply (case_tac "I2 = {}")
   apply (rule cspT_sym)
(* for Isabelle 2017 *)
   apply (simp del: UN_simps SUP_image add: cspT_SKIP_Rep_parallel)
  apply (simp add: cspT_semantics)
apply (rule order_antisym)

 (* => *)
 apply (rule)
(* for Isabelle 2017 *)
 apply (simp del: UN_simps SUP_image add: in_traces_par)
 apply (simp add: Union_snd_Un)
 apply (elim conjE)
 apply (rule conjI)

  apply (intro ballI)
  apply (drule_tac x="i" in bspec, simp)
  apply (subgoal_tac "snd (PXf i) <= Union (snd ` PXf ` I1)")
  apply (simp add: rest_tr_of_rest_tr_subset)
  apply (force)

  apply (intro ballI)
  apply (drule_tac x="i" in bspec, simp)
  apply (subgoal_tac "snd (PXf i) <= Union (snd ` PXf ` I2)")
  apply (simp add: rest_tr_of_rest_tr_subset)
  apply (force)

 (* <= *)
 apply (rule)
(* for Isabelle 2017 *)
 apply (simp del: UN_simps SUP_image add: in_traces_par)
 apply (simp add: Union_snd_Un)
 apply (elim conjE)

 apply (intro ballI)
 apply (simp)
 apply (erule disjE)

  apply (drule_tac x="i" in bspec, simp)
  apply (subgoal_tac "snd (PXf i) <= Union (snd ` PXf ` I1)")
  apply (simp add: rest_tr_of_rest_tr_subset)
  apply (force)

  apply (drule_tac x="i" in bspec, simp)
  apply (subgoal_tac "snd (PXf i) <= Union (snd ` PXf ` I2)")
  apply (simp add: rest_tr_of_rest_tr_subset)
  apply (force)
done

(************************************
 |             induct               |
 ************************************)

(*------------------*
 |     csp law      |
 |   (derivable)    |
 *------------------*)

lemma cspT_Rep_parallel_induct:
 "[| finite I ; i ~: I |] ==>
  [||]:(insert i I) PXf =T[M,M]
  fst (PXf i) |[snd (PXf i), Union (snd ` PXf ` I)]| [||]:I PXf"
apply (insert cspT_Rep_parallel_assoc[of "{i}" I PXf M])
apply (simp add: Rep_parallel_one)
apply (rule cspT_trans)
apply (simp)

apply (insert cspT_Alpha_parallel_assoc
  [of "fst (PXf i)" "snd (PXf i)" "{}" "SKIP" "Union (snd ` PXf ` I)" "[||]:I PXf" M])
apply (rule cspT_trans)
apply (simp)

  apply (rule cspT_decompo_Alpha_parallel)
(* for Isabelle 2017 *)
apply (simp_all)
apply (simp add: cspT_SKIP_Rep_parallel[simplified])
done

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


(*  Title:      ZF/Induct/Datatypes.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Sample datatype definitions\<close>

theory Datatypes imports ZF begin

subsection \<open>A type with four constructors\<close>

text \<open>
  It has four contructors, of arities 0--3, and two parameters \<open>A\<close> and \<open>B\<close>.
\<close>

consts
  data :: "[i, i] => i"

datatype "data(A, B)" =
    Con0
  | Con1 ("a \<in> A")
  | Con2 ("a \<in> A", "b \<in> B")
  | Con3 ("a \<in> A", "b \<in> B", "d \<in> data(A, B)")

lemma data_unfold: "data(A, B) = ({0} + A) + (A \<times> B + A \<times> B \<times> data(A, B))"
  by (fast intro!: data.intros [unfolded data.con_defs]
    elim: data.cases [unfolded data.con_defs])

text \<open>
  \medskip Lemmas to justify using @{term data} in other recursive
  type definitions.
\<close>

lemma data_mono: "[| A \<subseteq> C; B \<subseteq> D |] ==> data(A, B) \<subseteq> data(C, D)"
  apply (unfold data.defs)
  apply (rule lfp_mono)
   apply (rule data.bnd_mono)+
  apply (rule univ_mono Un_mono basic_monos | assumption)+
  done

lemma data_univ: "data(univ(A), univ(A)) \<subseteq> univ(A)"
  apply (unfold data.defs data.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] subset_trans [OF A_subset_univ Un_upper1, THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma data_subset_univ:
    "[| A \<subseteq> univ(C); B \<subseteq> univ(C) |] ==> data(A, B) \<subseteq> univ(C)"
  by (rule subset_trans [OF data_mono data_univ])

subsection \<open>Example of a big enumeration type\<close>

text \<open>
  Can go up to at least 100 constructors, but it takes nearly 7
  minutes \dots\ (back in 1994 that is).
\<close>

consts
  enum :: i

datatype enum =
    C00 | C01 | C02 | C03 | C04 | C05 | C06 | C07 | C08 | C09
  | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 | C19
  | C20 | C21 | C22 | C23 | C24 | C25 | C26 | C27 | C28 | C29
  | C30 | C31 | C32 | C33 | C34 | C35 | C36 | C37 | C38 | C39
  | C40 | C41 | C42 | C43 | C44 | C45 | C46 | C47 | C48 | C49
  | C50 | C51 | C52 | C53 | C54 | C55 | C56 | C57 | C58 | C59

end


section \<open> Separation Logic \<close>

theory utp_mem_seplog
  imports utp_mem_aseplog utp_mem_prog
begin

definition heaplet :: "(addr, 's) uexpr \<Rightarrow> ('a::{countable,infinite}, 's) uexpr \<Rightarrow> 's mpred" (infix "\<^bold>\<mapsto>" 70) where
[upred_defs]: "v \<^bold>\<mapsto> e = (dom\<^sub>u(&hp) =\<^sub>u {v \<oplus>\<^sub>p str}\<^sub>u \<and> &hp(v \<oplus>\<^sub>p str)\<^sub>a =\<^sub>u uop to_nat_bij (e \<oplus>\<^sub>p str))"

abbreviation heaplet_min :: "(addr, 's) uexpr \<Rightarrow> ('a::{countable,infinite}, 's) uexpr \<Rightarrow> 's mpred" (infix "\<^bold>\<hookrightarrow>" 70) where
"v \<^bold>\<hookrightarrow> e \<equiv> v \<^bold>\<mapsto> e \<^bold>* true"

abbreviation heaplet_ex :: "(addr, 's) uexpr \<Rightarrow> 's mpred" ("_ \<^bold>\<mapsto> -" [69] 70) where
"e \<^bold>\<mapsto> - \<equiv> (\<^bold>\<exists> v::nat \<bullet> e \<^bold>\<mapsto> \<guillemotleft>v\<guillemotright>)"

lemma local_wrt_heap_lookup:
  "\<lbrakk> vwb_lens x; x \<sharp> e; str:x \<sharp> p \<rbrakk> \<Longrightarrow> local_wrt p (x := *e)"
  apply (rel_simp)
  apply (rename_tac q st hp0 hp1)
  apply (rule_tac x="hp0" in exI)
  apply (auto)
  done

subsection \<open> Separation Logic Laws \<close>

lemma allocation_noninterfering_local:
  "{emp}v := alloc(e){&v \<^bold>\<mapsto> e}\<^sub>D"
  by (rel_auto)

lemma allocation_noninterfering_global:
  "\<lbrakk> vwb_lens x; str:x \<sharp> p \<rbrakk> \<Longrightarrow> {p}x := alloc(e){p \<^bold>* &x \<^bold>\<mapsto> e}\<^sub>D"
  apply (rel_simp)
  apply (rename_tac ok hp st ok' l)
  apply (rule_tac x="hp" in exI)
  apply (rule_tac x="bot(l \<mapsto> to_nat_bij (\<lbrakk>e\<rbrakk>\<^sub>e (put\<^bsub>x\<^esub> st l)))\<^sub>f" in exI)
  apply (simp add: ffun_indep_compat)
  done

lemma mutation_local: "{e \<^bold>\<mapsto> -} *e := v {e \<^bold>\<mapsto> v}\<^sub>D"
  by (rel_auto)

lemma mutation_global: "{p \<^bold>* e \<^bold>\<mapsto> -} *e := v {p \<^bold>* e \<^bold>\<mapsto> v}\<^sub>D"
  apply (rel_simp)
  apply (rename_tac st ok' a b x)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="b(\<lbrakk>e\<rbrakk>\<^sub>e st \<mapsto> to_nat_bij (\<lbrakk>v\<rbrakk>\<^sub>e st))\<^sub>f" in exI)
  apply (auto simp add: compatible_ffun_def compatible_pfun_def)
  oops

lemma deallocation_local:
  "{e \<^bold>\<mapsto> -} dealloc(e) {emp}\<^sub>D"
  by (rel_auto)

lemma deallocation_global:
  "{r \<^bold>* e \<^bold>\<mapsto> -} dealloc(e) {r}\<^sub>D"
  apply (rel_simp)
  apply (rename_tac ok st ok' a b x)
  apply (subgoal_tac "fdom(a) \<lhd>\<^sub>f b = fdom(a) \<lhd>\<^sub>f (fdom(b) \<lhd>\<^sub>f b)")
   apply (simp add: compatible_ffun_def)
  oops

lemma lookup_global:
  "\<lbrakk> vwb_lens x; x \<sharp> e; x \<sharp> v; str:x \<sharp> r \<rbrakk> \<Longrightarrow>
    {r \<^bold>* e \<^bold>\<mapsto> v} x := *e {r \<^bold>* (&str:x =\<^sub>u (v \<oplus>\<^sub>p str) \<and> e \<^bold>\<mapsto> v)}\<^sub>D"
  by (rel_auto)

end


theory Repetition
  imports BigStepSimple
begin

subsection \<open>Alternative rule for repetition\<close>

theorem Valid_frame:
  assumes "\<Turnstile> {\<lambda>s tr. P s \<and> tr = []} c {\<lambda>s tr. Q s \<and> R tr}"
  shows "\<Turnstile> {\<lambda>s tr. P s \<and> R' tr} c {\<lambda>s tr. Q s \<and> (R' @\<^sub>t R) tr}"
  using assms unfolding Valid_def
  by (auto simp add: join_assn_def)

theorem Valid_loop2:
  assumes "\<And>a tr1 tr2. Q a tr1 \<Longrightarrow> P (f a) tr2 \<Longrightarrow> P a (tr1 @ tr2)"
    and "\<And>a. \<Turnstile> {\<lambda>s tr. R a s \<and> tr = []} c {\<lambda>s tr. R (f a) s \<and> Q a tr}"
  shows "\<Turnstile> {\<lambda>s tr. \<exists>b. R b s \<and> (P b @- P a) tr} c {\<lambda>s tr. \<exists>b. R b s \<and> (P b @- P a) tr}"
  apply (rule Valid_ex_pre)
  subgoal for b
    apply (rule Valid_ex_post) apply (rule exI[where x="f b"])
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_frame[OF assms(2)])
    apply (auto simp add: entails_def)
    using assms(1) by (auto simp add: join_assn_def magic_wand_assn_def)
  done

theorem Valid_loop3:
  assumes "\<And>a. P a []"
  assumes "\<And>a tr1 tr2. Q a tr1 \<Longrightarrow> P (f a) tr2 \<Longrightarrow> P a (tr1 @ tr2)"
    and "\<And>a. \<Turnstile> {\<lambda>s tr. R a s \<and> tr = []} c {\<lambda>s tr. R (f a) s \<and> Q a tr}"
  shows "\<Turnstile> {\<lambda>s tr. R a s \<and> tr = []} Rep c {\<lambda>s tr. \<exists>b. R b s \<and> P a tr}"
  apply (rule Valid_weaken_pre)
  prefer 2 apply (rule Valid_strengthen_post)
    prefer 2 apply (rule Valid_rep[where P="\<lambda>s tr. \<exists>b. R b s \<and> (P b @- P a) tr"])
    apply (rule Valid_loop2[of Q P f])
  using assms apply auto
  using assms(1) apply (auto simp add: entails_def magic_wand_assn_def)
  by fastforce

end