(*  Title:      HOL/UNITY/Rename.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2000  University of Cambridge
*)

section\<open>Renaming of State Sets\<close>

theory Rename imports Extend begin

definition rename :: "['a => 'b, 'a program] => 'b program" where
    "rename h == extend (%(x,u::unit). h x)"

declare image_inv_f_f [simp] image_f_inv_f [simp]

declare Extend.intro [simp,intro]

lemma good_map_bij [simp,intro]: "bij h ==> good_map (%(x,u). h x)"
apply (rule good_mapI)
apply (unfold bij_def inj_on_def surj_def, auto)
done

lemma fst_o_inv_eq_inv: "bij h ==> fst (inv (%(x,u). h x) s) = inv h s"
apply (unfold bij_def split_def, clarify)
apply (subgoal_tac "surj (%p. h (fst p))")
 prefer 2 apply (simp add: surj_def)
apply (erule injD)
apply (simp (no_asm_simp) add: surj_f_inv_f)
apply (erule surj_f_inv_f)
done

lemma mem_rename_set_iff: "bij h ==> z \<in> h`A = (inv h z \<in> A)"
by (force simp add: bij_is_inj bij_is_surj [THEN surj_f_inv_f])

lemma extend_set_eq_image [simp]: "extend_set (%(x,u). h x) A = h`A"
by (force simp add: extend_set_def)

lemma Init_rename [simp]: "Init (rename h F) = h`(Init F)"
by (simp add: rename_def)

subsection\<open>inverse properties\<close>

lemma extend_set_inv:
     "bij h
      ==> extend_set (%(x,u::'c). inv h x) = project_set (%(x,u::'c). h x)"
apply (unfold bij_def)
apply (rule ext)
apply (force simp add: extend_set_def project_set_def surj_f_inv_f)
done

(** for "rename" (programs) **)

lemma bij_extend_act_eq_project_act: "bij h
      ==> extend_act (%(x,u::'c). h x) = project_act (%(x,u::'c). inv h x)"
apply (rule ext)
apply (force simp add: extend_act_def project_act_def bij_def surj_f_inv_f)
done

lemma bij_extend_act: "bij h ==> bij (extend_act (%(x,u::'c). h x))"
apply (rule bijI)
apply (rule Extend.inj_extend_act)
apply simp
apply (simp add: bij_extend_act_eq_project_act)
apply (rule surjI)
apply (rule Extend.extend_act_inverse)
apply (blast intro: bij_imp_bij_inv)
done

lemma bij_project_act: "bij h ==> bij (project_act (%(x,u::'c). h x))"
apply (frule bij_imp_bij_inv [THEN bij_extend_act])
apply (simp add: bij_extend_act_eq_project_act bij_imp_bij_inv inv_inv_eq)
done

lemma bij_inv_project_act_eq: "bij h ==> inv (project_act (%(x,u::'c). inv h x)) =
                project_act (%(x,u::'c). h x)"
apply (simp (no_asm_simp) add: bij_extend_act_eq_project_act [symmetric])
apply (rule surj_imp_inv_eq)
apply (blast intro!: bij_extend_act bij_is_surj)
apply (simp (no_asm_simp) add: Extend.extend_act_inverse)
done

lemma extend_inv: "bij h
      ==> extend (%(x,u::'c). inv h x) = project (%(x,u::'c). h x) UNIV"
apply (frule bij_imp_bij_inv)
apply (rule ext)
apply (rule program_equalityI)
  apply (simp (no_asm_simp) add: extend_set_inv)
 apply (simp add: Extend.project_act_Id Extend.Acts_extend
          insert_Id_image_Acts bij_extend_act_eq_project_act inv_inv_eq)
apply (simp add: Extend.AllowedActs_extend Extend.AllowedActs_project
             bij_project_act bij_vimage_eq_inv_image bij_inv_project_act_eq)
done

lemma rename_inv_rename [simp]: "bij h ==> rename (inv h) (rename h F) = F"
by (simp add: rename_def extend_inv Extend.extend_inverse)

lemma rename_rename_inv [simp]: "bij h ==> rename h (rename (inv h) F) = F"
apply (frule bij_imp_bij_inv)
apply (erule inv_inv_eq [THEN subst], erule rename_inv_rename)
done

lemma rename_inv_eq: "bij h ==> rename (inv h) = inv (rename h)"
by (rule inv_equality [symmetric], auto)

(** (rename h) is bijective <=> h is bijective **)

lemma bij_extend: "bij h ==> bij (extend (%(x,u::'c). h x))"
apply (rule bijI)
apply (blast intro: Extend.inj_extend)
apply (rule_tac f = "extend (% (x,u) . inv h x)" in surjI)
apply (subst (1 2) inv_inv_eq [of h, symmetric], assumption+)
apply (simp add: bij_imp_bij_inv extend_inv [of "inv h"])
apply (simp add: inv_inv_eq)
apply (rule Extend.extend_inverse)
apply (simp add: bij_imp_bij_inv)
done

lemma bij_project: "bij h ==> bij (project (%(x,u::'c). h x) UNIV)"
apply (subst extend_inv [symmetric])
apply (auto simp add: bij_imp_bij_inv bij_extend)
done

lemma inv_project_eq:
     "bij h
      ==> inv (project (%(x,u::'c). h x) UNIV) = extend (%(x,u::'c). h x)"
apply (rule inj_imp_inv_eq)
apply (erule bij_project [THEN bij_is_inj])
apply (simp (no_asm_simp) add: Extend.extend_inverse)
done

lemma Allowed_rename [simp]:
     "bij h ==> Allowed (rename h F) = rename h ` Allowed F"
apply (simp (no_asm_simp) add: rename_def Extend.Allowed_extend)
apply (subst bij_vimage_eq_inv_image)
apply (rule bij_project, blast)
apply (simp (no_asm_simp) add: inv_project_eq)
done

lemma bij_rename: "bij h ==> bij (rename h)"
apply (simp (no_asm_simp) add: rename_def bij_extend)
done
lemmas surj_rename = bij_rename [THEN bij_is_surj]

lemma inj_rename_imp_inj: "inj (rename h) ==> inj h"
apply (unfold inj_on_def, auto)
apply (drule_tac x = "mk_program ({x}, {}, {})" in spec)
apply (drule_tac x = "mk_program ({y}, {}, {})" in spec)
apply (auto simp add: program_equality_iff rename_def extend_def)
done

lemma surj_rename_imp_surj: "surj (rename h) ==> surj h"
apply (unfold surj_def, auto)
apply (drule_tac x = "mk_program ({y}, {}, {})" in spec)
apply (auto simp add: program_equality_iff rename_def extend_def)
done

lemma bij_rename_imp_bij: "bij (rename h) ==> bij h"
apply (unfold bij_def)
apply (simp (no_asm_simp) add: inj_rename_imp_inj surj_rename_imp_surj)
done

lemma bij_rename_iff [simp]: "bij (rename h) = bij h"
by (blast intro: bij_rename bij_rename_imp_bij)

subsection\<open>the lattice operations\<close>

lemma rename_SKIP [simp]: "bij h ==> rename h SKIP = SKIP"
by (simp add: rename_def Extend.extend_SKIP)

lemma rename_Join [simp]:
     "bij h ==> rename h (F \<squnion> G) = rename h F \<squnion> rename h G"
by (simp add: rename_def Extend.extend_Join)

lemma rename_JN [simp]:
     "bij h ==> rename h (JOIN I F) = (\<Squnion>i \<in> I. rename h (F i))"
by (simp add: rename_def Extend.extend_JN)

subsection\<open>Strong Safety: co, stable\<close>

lemma rename_constrains:
     "bij h ==> (rename h F \<in> (h`A) co (h`B)) = (F \<in> A co B)"
apply (unfold rename_def)
apply (subst extend_set_eq_image [symmetric])+
apply (erule good_map_bij [THEN Extend.intro, THEN Extend.extend_constrains])
done

lemma rename_stable:
     "bij h ==> (rename h F \<in> stable (h`A)) = (F \<in> stable A)"
apply (simp add: stable_def rename_constrains)
done

lemma rename_invariant:
     "bij h ==> (rename h F \<in> invariant (h`A)) = (F \<in> invariant A)"
apply (simp add: invariant_def rename_stable bij_is_inj [THEN inj_image_subset_iff])
done

lemma rename_increasing:
     "bij h ==> (rename h F \<in> increasing func) = (F \<in> increasing (func o h))"
apply (simp add: increasing_def rename_stable [symmetric] bij_image_Collect_eq bij_is_surj [THEN surj_f_inv_f])
done

subsection\<open>Weak Safety: Co, Stable\<close>

lemma reachable_rename_eq:
     "bij h ==> reachable (rename h F) = h ` (reachable F)"
apply (simp add: rename_def Extend.reachable_extend_eq)
done

lemma rename_Constrains:
     "bij h ==> (rename h F \<in> (h`A) Co (h`B)) = (F \<in> A Co B)"
by (simp add: Constrains_def reachable_rename_eq rename_constrains
               bij_is_inj image_Int [symmetric])

lemma rename_Stable:
     "bij h ==> (rename h F \<in> Stable (h`A)) = (F \<in> Stable A)"
by (simp add: Stable_def rename_Constrains)

lemma rename_Always: "bij h ==> (rename h F \<in> Always (h`A)) = (F \<in> Always A)"
by (simp add: Always_def rename_Stable bij_is_inj [THEN inj_image_subset_iff])

lemma rename_Increasing:
     "bij h ==> (rename h F \<in> Increasing func) = (F \<in> Increasing (func o h))"
by (simp add: Increasing_def rename_Stable [symmetric] bij_image_Collect_eq
              bij_is_surj [THEN surj_f_inv_f])

subsection\<open>Progress: transient, ensures\<close>

lemma rename_transient:
     "bij h ==> (rename h F \<in> transient (h`A)) = (F \<in> transient A)"
apply (unfold rename_def)
apply (subst extend_set_eq_image [symmetric])
apply (erule good_map_bij [THEN Extend.intro, THEN Extend.extend_transient])
done

lemma rename_ensures:
     "bij h ==> (rename h F \<in> (h`A) ensures (h`B)) = (F \<in> A ensures B)"
apply (unfold rename_def)
apply (subst extend_set_eq_image [symmetric])+
apply (erule good_map_bij [THEN Extend.intro, THEN Extend.extend_ensures])
done

lemma rename_leadsTo:
     "bij h ==> (rename h F \<in> (h`A) leadsTo (h`B)) = (F \<in> A leadsTo B)"
apply (unfold rename_def)
apply (subst extend_set_eq_image [symmetric])+
apply (erule good_map_bij [THEN Extend.intro, THEN Extend.extend_leadsTo])
done

lemma rename_LeadsTo:
     "bij h ==> (rename h F \<in> (h`A) LeadsTo (h`B)) = (F \<in> A LeadsTo B)"
apply (unfold rename_def)
apply (subst extend_set_eq_image [symmetric])+
apply (erule good_map_bij [THEN Extend.intro, THEN Extend.extend_LeadsTo])
done

lemma rename_rename_guarantees_eq:
     "bij h ==> (rename h F \<in> (rename h ` X) guarantees
                              (rename h ` Y)) =
                (F \<in> X guarantees Y)"
apply (unfold rename_def)
apply (subst good_map_bij [THEN Extend.intro, THEN Extend.extend_guarantees_eq [symmetric]], assumption)
apply (simp (no_asm_simp) add: fst_o_inv_eq_inv o_def)
done

lemma rename_guarantees_eq_rename_inv:
     "bij h ==> (rename h F \<in> X guarantees Y) =
                (F \<in> (rename (inv h) ` X) guarantees
                     (rename (inv h) ` Y))"
apply (subst rename_rename_guarantees_eq [symmetric], assumption)
apply (simp add: o_def bij_is_surj [THEN surj_f_inv_f] image_comp)
done

lemma rename_preserves:
     "bij h ==> (rename h G \<in> preserves v) = (G \<in> preserves (v o h))"
apply (subst good_map_bij [THEN Extend.intro, THEN Extend.extend_preserves [symmetric]], assumption)
apply (simp add: o_def fst_o_inv_eq_inv rename_def bij_is_surj [THEN surj_f_inv_f])
done

lemma ok_rename_iff [simp]: "bij h ==> (rename h F ok rename h G) = (F ok G)"
by (simp add: Extend.ok_extend_iff rename_def)

lemma OK_rename_iff [simp]: "bij h ==> OK I (%i. rename h (F i)) = (OK I F)"
by (simp add: Extend.OK_extend_iff rename_def)

subsection\<open>"image" versions of the rules, for lifting "guarantees" properties\<close>

(*All the proofs are similar.  Better would have been to prove one
  meta-theorem, but how can we handle the polymorphism?  E.g. in
  rename_constrains the two appearances of "co" have different types!*)
lemmas bij_eq_rename = surj_rename [THEN surj_f_inv_f, symmetric]

lemma rename_image_constrains:
     "bij h ==> rename h ` (A co B) = (h ` A) co (h`B)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_constrains)
done

lemma rename_image_stable: "bij h ==> rename h ` stable A = stable (h ` A)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_stable)
done

lemma rename_image_increasing:
     "bij h ==> rename h ` increasing func = increasing (func o inv h)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_increasing o_def bij_is_inj)
done

lemma rename_image_invariant:
     "bij h ==> rename h ` invariant A = invariant (h ` A)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_invariant)
done

lemma rename_image_Constrains:
     "bij h ==> rename h ` (A Co B) = (h ` A) Co (h`B)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_Constrains)
done

lemma rename_image_preserves:
     "bij h ==> rename h ` preserves v = preserves (v o inv h)"
by (simp add: o_def rename_image_stable preserves_def bij_image_INT
              bij_image_Collect_eq)

lemma rename_image_Stable:
     "bij h ==> rename h ` Stable A = Stable (h ` A)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_Stable)
done

lemma rename_image_Increasing:
     "bij h ==> rename h ` Increasing func = Increasing (func o inv h)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_Increasing o_def bij_is_inj)
done

lemma rename_image_Always: "bij h ==> rename h ` Always A = Always (h ` A)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_Always)
done

lemma rename_image_leadsTo:
     "bij h ==> rename h ` (A leadsTo B) = (h ` A) leadsTo (h`B)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_leadsTo)
done

lemma rename_image_LeadsTo:
     "bij h ==> rename h ` (A LeadsTo B) = (h ` A) LeadsTo (h`B)"
apply auto
 defer 1
 apply (rename_tac F)
 apply (subgoal_tac "\<exists>G. F = rename h G")
 apply (auto intro!: bij_eq_rename simp add: rename_LeadsTo)
done

end


theory Abstract_Rules_To_Incredible
imports
  Main
  "~~/src/HOL/Library/FSet"
  "~~/src/HOL/Library/Stream"
  Incredible_Deduction
  Abstract_Rules
begin

text \<open>In this theory, the abstract rules given in @{theory Abstract_Rules} are used to
create a proper signature.\<close>

text \<open>Besides the rules given there, we have nodes for assumptions, conclusions, and the helper
block.\<close>

datatype ('form, 'rule) graph_node = Assumption 'form | Conclusion 'form | Rule 'rule | Helper

type_synonym ('form, 'var) in_port = "('form, 'var) antecedent"
type_synonym 'form reg_out_port = "'form"
type_synonym 'form hyp = "'form"
datatype ('form, 'var) out_port = Reg "'form reg_out_port" | Hyp "'form hyp" "('form, 'var) in_port"
type_synonym ('v, 'form, 'var) edge' = "(('v \<times> ('form, 'var) out_port) \<times> ('v \<times> ('form, 'var) in_port))"

context Abstract_Task
begin
  definition nodes :: "('form, 'rule) graph_node stream" where
    "nodes = Helper ## shift (map Assumption assumptions) (shift (map Conclusion conclusions) (smap Rule rules))"

  lemma Helper_in_nodes[simp]:
    "Helper \<in> sset nodes" by (simp add: nodes_def)
  lemma Assumption_in_nodes[simp]:
    "Assumption a \<in> sset nodes \<longleftrightarrow> a \<in> set assumptions" by (auto simp add: nodes_def stream.set_map)
  lemma Conclusion_in_nodes[simp]:
    "Conclusion c \<in> sset nodes \<longleftrightarrow> c \<in> set conclusions" by (auto simp add: nodes_def stream.set_map)
  lemma Rule_in_nodes[simp]:
    "Rule r \<in> sset nodes \<longleftrightarrow> r \<in> sset rules" by (auto simp add: nodes_def stream.set_map)

  fun inPorts' :: "('form, 'rule) graph_node \<Rightarrow> ('form, 'var) in_port list"  where
    "inPorts' (Rule r) = antecedent r"
   |"inPorts' (Assumption r) = []"
   |"inPorts' (Conclusion r) = [ plain_ant r ]"
   |"inPorts' Helper  = [ plain_ant anyP ]"

  fun inPorts :: "('form, 'rule) graph_node \<Rightarrow> ('form, 'var) in_port fset"  where
    "inPorts (Rule r) = f_antecedent r"
   |"inPorts (Assumption r) = {||}"
   |"inPorts (Conclusion r) = {| plain_ant r |}"
   |"inPorts Helper  = {| plain_ant anyP |}"

  lemma inPorts_fset_of:
    "inPorts n = fset_from_list (inPorts' n)"
    by (cases n rule: inPorts.cases) (auto simp: fmember.rep_eq f_antecedent_def)

  definition outPortsRule where
    "outPortsRule r = ffUnion ((\<lambda> a. (\<lambda> h. Hyp h a) |`| a_hyps a) |`| f_antecedent r) |\<union>| Reg |`| f_consequent r"

  lemma Reg_in_outPortsRule[simp]:  "Reg c |\<in>| outPortsRule r \<longleftrightarrow> c |\<in>| f_consequent r"
    by (auto simp add: outPortsRule_def fmember.rep_eq ffUnion.rep_eq)
  lemma Hyp_in_outPortsRule[simp]:  "Hyp h c |\<in>| outPortsRule r \<longleftrightarrow> c |\<in>| f_antecedent r \<and> h |\<in>| a_hyps c"
    by (auto simp add: outPortsRule_def fmember.rep_eq ffUnion.rep_eq)

  fun outPorts where
    "outPorts (Rule r) = outPortsRule r"
   |"outPorts (Assumption r) = {|Reg r|}"
   |"outPorts (Conclusion r) = {||}"
   |"outPorts Helper  = {| Reg anyP |}"

  fun labelsIn where
    "labelsIn _ p = a_conc p"

  fun labelsOut where
    "labelsOut _ (Reg p) = p"
   | "labelsOut _ (Hyp h c) = h"

  fun hyps where
     "hyps (Rule r) (Hyp h a) = (if a |\<in>| f_antecedent r \<and> h |\<in>| a_hyps a then Some a else None)"
   | "hyps _ _ = None"

  fun local_vars :: "('form, 'rule) graph_node \<Rightarrow> ('form, 'var) in_port \<Rightarrow> 'var set"  where
     "local_vars _ a = a_fresh a"

  sublocale Labeled_Signature nodes inPorts outPorts hyps labelsIn labelsOut
  proof(standard,goal_cases)
    case (1 n p1 p2)
    thus ?case by(induction n p1 rule: hyps.induct) (auto  split: if_splits)
  qed

  lemma hyps_for_conclusion[simp]: "hyps_for (Conclusion n) p = {||}"
    using hyps_for_subset by auto
  lemma hyps_for_Helper[simp]: "hyps_for Helper p = {||}"
    using hyps_for_subset by auto
  lemma hyps_for_Rule[simp]: "ip |\<in>| f_antecedent r \<Longrightarrow> hyps_for (Rule r) ip = (\<lambda> h. Hyp h ip) |`| a_hyps ip"
    by (auto elim!: hyps.elims split: if_splits)
end

text \<open>Finally, a given proof graph solves the task at hand if all the given conclusions are present
as conclusion blocks in the graph.\<close>

locale Tasked_Proof_Graph =
  Abstract_Task freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP  antecedent consequent rules assumptions conclusions  +
  Scoped_Proof_Graph freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP  inPorts outPorts nodeOf hyps nodes vertices labelsIn labelsOut vidx inst edges local_vars
   for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form"

    and antecedent :: "'rule \<Rightarrow> ('form, 'var) antecedent list"
    and consequent :: "'rule \<Rightarrow> 'form list"
    and rules :: "'rule stream"

    and assumptions :: "'form list"
    and conclusions :: "'form list"

    and vertices :: "'vertex fset"
    and nodeOf :: "'vertex \<Rightarrow> ('form, 'rule) graph_node"
    and edges :: "('vertex, 'form, 'var) edge' set"
    and vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"  +
  assumes conclusions_present: "set (map Conclusion conclusions) \<subseteq> nodeOf ` fset vertices"

end


(* Title:  Containers/Equal.thy
   Author: Andreas Lochbihler, KIT *)

theory Equal imports Main begin

section {* Locales to abstract over HOL equality *}

locale equal_base = fixes equal :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

locale equal = equal_base +
  assumes equal_eq: "equal = op ="
begin

lemma equal_conv_eq: "equal x y \<longleftrightarrow> x = y"
by(simp add: equal_eq)

end

end


section\<open>Routing and IP Assignments\<close>
theory Routing_IpAssmt
imports Ipassmt
        "../../Routing/Routing_Table"
begin
context
begin

subsection\<open>Routing IP Assignment\<close>
text\<open>Up to now, the definitions were all still on word intervals because those are much more convenient to work with.\<close>

definition routing_ipassmt :: "'i::len routing_rule list \<Rightarrow> (iface \<times> ('i word \<times> nat) list) list"
  where
  "routing_ipassmt rt \<equiv> map (apfst Iface \<circ> apsnd cidr_split) (routing_ipassmt_wi rt)"

private lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split x)) = wordinterval_to_set x"
  apply(subst cidr_split_prefix[symmetric])
  apply(fact ipcidr_union_set_uncurry)
done

private lemma map_of_map_Iface: "map_of (map (\<lambda>x. (Iface (fst x), f (snd x))) xs) (Iface ifce) =
        map_option f ((map_of xs) ifce)"
  by (induct xs) (auto)

lemma "routing_ipassmt_wi ([]::32 prefix_routing) = [(output_iface (routing_action (undefined :: 32 routing_rule)), WordInterval 0 0xFFFFFFFF)]"
  by code_simp

lemma routing_ipassmt: "
    valid_prefixes rt \<Longrightarrow>
    output_iface (routing_table_semantics rt (p_dst p)) = p_oiface p \<Longrightarrow>
    \<exists>p_ips. map_of (routing_ipassmt rt) (Iface (p_oiface p)) = Some p_ips \<and> p_dst p \<in> ipcidr_union_set (set p_ips)"
  apply(simp add: routing_ipassmt_def)
  apply(drule routing_ipassmt_wi[where output_port="p_oiface p" and k="p_dst p"])
  apply(simp)
  apply(elim exE, rename_tac ip_range)
  apply(rule_tac x="cidr_split ip_range" in exI)
  apply(simp)
  apply(simp add: comp_def)
  apply(simp add: map_of_map_Iface)
  apply(rule_tac x="ip_range" in exI)
  apply(simp)
  by (simp add: routing_ipassmt_wi_distinct)

lemma routing_ipassmt_ipassmt_sanity_disjoint: "valid_prefixes (rt::('i::len) prefix_routing) \<Longrightarrow>
    ipassmt_sanity_disjoint (map_of (routing_ipassmt rt))"
unfolding ipassmt_sanity_disjoint_def routing_ipassmt_def comp_def
  apply(clarsimp)
  apply(drule map_of_SomeD)+
  apply(clarsimp split: iface.splits)
using routing_ipassmt_wi_disjoint[where 'i = 'i] by meson

lemma routing_ipassmt_distinct: "distinct (map fst (routing_ipassmt rtbl))"
  using routing_ipassmt_wi_distinct[of rtbl]
  unfolding routing_ipassmt_def
  apply(simp add: comp_def)
  apply(subst distinct_map[where f = Iface and xs = "map fst (routing_ipassmt_wi rtbl)", simplified, unfolded comp_def])
  apply(auto intro: inj_onI)
done

end

end


(* Author: Andreas Lochbihler, ETH Zürich
   Author: Florian Haftmann, TU Muenchen  *)

section \<open>Less common functions on lists\<close>

theory More_List
imports "MainRLT"
begin

definition strip_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "strip_while P = rev \<circ> dropWhile P \<circ> rev"

lemma strip_while_rev [simp]:
  "strip_while P (rev xs) = rev (dropWhile P xs)"
  by (simp add: strip_while_def)

lemma strip_while_Nil [simp]:
  "strip_while P [] = []"
  by (simp add: strip_while_def)

lemma strip_while_append [simp]:
  "\<not> P x \<Longrightarrow> strip_while P (xs @ [x]) = xs @ [x]"
  by (simp add: strip_while_def)

lemma strip_while_append_rec [simp]:
  "P x \<Longrightarrow> strip_while P (xs @ [x]) = strip_while P xs"
  by (simp add: strip_while_def)

lemma strip_while_Cons [simp]:
  "\<not> P x \<Longrightarrow> strip_while P (x # xs) = x # strip_while P xs"
  by (induct xs rule: rev_induct) (simp_all add: strip_while_def)

lemma strip_while_eq_Nil [simp]:
  "strip_while P xs = [] \<longleftrightarrow> (\<forall>x\<in>set xs. P x)"
  by (simp add: strip_while_def)

lemma strip_while_eq_Cons_rec:
  "strip_while P (x # xs) = x # strip_while P xs \<longleftrightarrow> \<not> (P x \<and> (\<forall>x\<in>set xs. P x))"
  by (induct xs rule: rev_induct) (simp_all add: strip_while_def)

lemma split_strip_while_append:
  fixes xs :: "'a list"
  obtains ys zs :: "'a list"
  where "strip_while P xs = ys" and "\<forall>x\<in>set zs. P x" and "xs = ys @ zs"
proof (rule that)
  show "strip_while P xs = strip_while P xs" ..
  show "\<forall>x\<in>set (rev (takeWhile P (rev xs))). P x" by (simp add: takeWhile_eq_all_conv [symmetric])
  have "rev xs = rev (strip_while P xs @ rev (takeWhile P (rev xs)))"
    by (simp add: strip_while_def)
  then show "xs = strip_while P xs @ rev (takeWhile P (rev xs))"
    by (simp only: rev_is_rev_conv)
qed

lemma strip_while_snoc [simp]:
  "strip_while P (xs @ [x]) = (if P x then strip_while P xs else xs @ [x])"
  by (simp add: strip_while_def)

lemma strip_while_map:
  "strip_while P (map f xs) = map f (strip_while (P \<circ> f) xs)"
  by (simp add: strip_while_def rev_map dropWhile_map)

lemma strip_while_dropWhile_commute:
  "strip_while P (dropWhile Q xs) = dropWhile Q (strip_while P xs)"
proof (induct xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  show ?case
  proof (cases "\<forall>y\<in>set xs. P y")
    case True
    with dropWhile_append2 [of "rev xs"] show ?thesis
      by (auto simp add: strip_while_def dest: set_dropWhileD)
  next
    case False
    then obtain y where "y \<in> set xs" and "\<not> P y"
      by blast
    with Cons dropWhile_append3 [of P y "rev xs"] show ?thesis
      by (simp add: strip_while_def)
  qed
qed

lemma dropWhile_strip_while_commute:
  "dropWhile P (strip_while Q xs) = strip_while Q (dropWhile P xs)"
  by (simp add: strip_while_dropWhile_commute)

definition no_leading :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "no_leading P xs \<longleftrightarrow> (xs \<noteq> [] \<longrightarrow> \<not> P (hd xs))"

lemma no_leading_Nil [simp, intro!]:
  "no_leading P []"
  by (simp add: no_leading_def)

lemma no_leading_Cons [simp, intro!]:
  "no_leading P (x # xs) \<longleftrightarrow> \<not> P x"
  by (simp add: no_leading_def)

lemma no_leading_append [simp]:
  "no_leading P (xs @ ys) \<longleftrightarrow> no_leading P xs \<and> (xs = [] \<longrightarrow> no_leading P ys)"
  by (induct xs) simp_all

lemma no_leading_dropWhile [simp]:
  "no_leading P (dropWhile P xs)"
  by (induct xs) simp_all

lemma dropWhile_eq_obtain_leading:
  assumes "dropWhile P xs = ys"
  obtains zs where "xs = zs @ ys" and "\<And>z. z \<in> set zs \<Longrightarrow> P z" and "no_leading P ys"
proof -
  from assms have "\<exists>zs. xs = zs @ ys \<and> (\<forall>z \<in> set zs. P z) \<and> no_leading P ys"
  proof (induct xs arbitrary: ys)
    case Nil then show ?case by simp
  next
    case (Cons x xs ys)
    show ?case proof (cases "P x")
      case True with Cons.hyps [of ys] Cons.prems
      have "\<exists>zs. xs = zs @ ys \<and> (\<forall>a\<in>set zs. P a) \<and> no_leading P ys"
        by simp
      then obtain zs where "xs = zs @ ys" and "\<And>z. z \<in> set zs \<Longrightarrow> P z"
        and *: "no_leading P ys"
        by blast
      with True have "x # xs = (x # zs) @ ys" and "\<And>z. z \<in> set (x # zs) \<Longrightarrow> P z"
        by auto
      with * show ?thesis
        by blast    next
      case False
      with Cons show ?thesis by (cases ys) simp_all
    qed
  qed
  with that show thesis
    by blast
qed

lemma dropWhile_idem_iff:
  "dropWhile P xs = xs \<longleftrightarrow> no_leading P xs"
  by (cases xs) (auto elim: dropWhile_eq_obtain_leading)

abbreviation no_trailing :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "no_trailing P xs \<equiv> no_leading P (rev xs)"

lemma no_trailing_unfold:
  "no_trailing P xs \<longleftrightarrow> (xs \<noteq> [] \<longrightarrow> \<not> P (last xs))"
  by (induct xs) simp_all

lemma no_trailing_Nil [simp, intro!]:
  "no_trailing P []"
  by simp

lemma no_trailing_Cons [simp]:
  "no_trailing P (x # xs) \<longleftrightarrow> no_trailing P xs \<and> (xs = [] \<longrightarrow> \<not> P x)"
  by simp

lemma no_trailing_append:
  "no_trailing P (xs @ ys) \<longleftrightarrow> no_trailing P ys \<and> (ys = [] \<longrightarrow> no_trailing P xs)"
  by (induct xs) simp_all

lemma no_trailing_append_Cons [simp]:
  "no_trailing P (xs @ y # ys) \<longleftrightarrow> no_trailing P (y # ys)"
  by simp

lemma no_trailing_strip_while [simp]:
  "no_trailing P (strip_while P xs)"
  by (induct xs rule: rev_induct) simp_all

lemma strip_while_idem [simp]:
  "no_trailing P xs \<Longrightarrow> strip_while P xs = xs"
  by (cases xs rule: rev_cases) simp_all

lemma strip_while_eq_obtain_trailing:
  assumes "strip_while P xs = ys"
  obtains zs where "xs = ys @ zs" and "\<And>z. z \<in> set zs \<Longrightarrow> P z" and "no_trailing P ys"
proof -
  from assms have "rev (rev (dropWhile P (rev xs))) = rev ys"
    by (simp add: strip_while_def)
  then have "dropWhile P (rev xs) = rev ys"
    by simp
  then obtain zs where A: "rev xs = zs @ rev ys" and B: "\<And>z. z \<in> set zs \<Longrightarrow> P z"
    and C: "no_trailing P ys"
    using dropWhile_eq_obtain_leading by blast
  from A have "rev (rev xs) = rev (zs @ rev ys)"
    by simp
  then have "xs = ys @ rev zs"
    by simp
  moreover from B have "\<And>z. z \<in> set (rev zs) \<Longrightarrow> P z"
    by simp
  ultimately show thesis using that C by blast
qed

lemma strip_while_idem_iff:
  "strip_while P xs = xs \<longleftrightarrow> no_trailing P xs"
proof -
  define ys where "ys = rev xs"
  moreover have "strip_while P (rev ys) = rev ys \<longleftrightarrow> no_trailing P (rev ys)"
    by (simp add: dropWhile_idem_iff)
  ultimately show ?thesis by simp
qed

lemma no_trailing_map:
  "no_trailing P (map f xs) \<longleftrightarrow> no_trailing (P \<circ> f) xs"
  by (simp add: last_map no_trailing_unfold)

lemma no_trailing_drop [simp]:
  "no_trailing P (drop n xs)" if "no_trailing P xs"
proof -
  from that have "no_trailing P (take n xs @ drop n xs)"
    by simp
  then show ?thesis
    by (simp only: no_trailing_append)
qed

lemma no_trailing_upt [simp]:
  "no_trailing P [n..<m] \<longleftrightarrow> (n < m \<longrightarrow> \<not> P (m - 1))"
  by (auto simp add: no_trailing_unfold)

definition nth_default :: "'a \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a"
where
  "nth_default dflt xs n = (if n < length xs then xs ! n else dflt)"

lemma nth_default_nth:
  "n < length xs \<Longrightarrow> nth_default dflt xs n = xs ! n"
  by (simp add: nth_default_def)

lemma nth_default_beyond:
  "length xs \<le> n \<Longrightarrow> nth_default dflt xs n = dflt"
  by (simp add: nth_default_def)

lemma nth_default_Nil [simp]:
  "nth_default dflt [] n = dflt"
  by (simp add: nth_default_def)

lemma nth_default_Cons:
  "nth_default dflt (x # xs) n = (case n of 0 \<Rightarrow> x | Suc n' \<Rightarrow> nth_default dflt xs n')"
  by (simp add: nth_default_def split: nat.split)

lemma nth_default_Cons_0 [simp]:
  "nth_default dflt (x # xs) 0 = x"
  by (simp add: nth_default_Cons)

lemma nth_default_Cons_Suc [simp]:
  "nth_default dflt (x # xs) (Suc n) = nth_default dflt xs n"
  by (simp add: nth_default_Cons)

lemma nth_default_replicate_dflt [simp]:
  "nth_default dflt (replicate n dflt) m = dflt"
  by (simp add: nth_default_def)

lemma nth_default_append:
  "nth_default dflt (xs @ ys) n =
    (if n < length xs then nth xs n else nth_default dflt ys (n - length xs))"
  by (auto simp add: nth_default_def nth_append)

lemma nth_default_append_trailing [simp]:
  "nth_default dflt (xs @ replicate n dflt) = nth_default dflt xs"
  by (simp add: fun_eq_iff nth_default_append) (simp add: nth_default_def)

lemma nth_default_snoc_default [simp]:
  "nth_default dflt (xs @ [dflt]) = nth_default dflt xs"
  by (auto simp add: nth_default_def fun_eq_iff nth_append)

lemma nth_default_eq_dflt_iff:
  "nth_default dflt xs k = dflt \<longleftrightarrow> (k < length xs \<longrightarrow> xs ! k = dflt)"
  by (simp add: nth_default_def)

lemma nth_default_take_eq:
  "nth_default dflt (take m xs) n =
    (if n < m then nth_default dflt xs n else dflt)"
  by (simp add: nth_default_def)

lemma in_enumerate_iff_nth_default_eq:
  "x \<noteq> dflt \<Longrightarrow> (n, x) \<in> set (enumerate 0 xs) \<longleftrightarrow> nth_default dflt xs n = x"
  by (auto simp add: nth_default_def in_set_conv_nth enumerate_eq_zip)

lemma last_conv_nth_default:
  assumes "xs \<noteq> []"
  shows "last xs = nth_default dflt xs (length xs - 1)"
  using assms by (simp add: nth_default_def last_conv_nth)

lemma nth_default_map_eq:
  "f dflt' = dflt \<Longrightarrow> nth_default dflt (map f xs) n = f (nth_default dflt' xs n)"
  by (simp add: nth_default_def)

lemma finite_nth_default_neq_default [simp]:
  "finite {k. nth_default dflt xs k \<noteq> dflt}"
  by (simp add: nth_default_def)

lemma sorted_list_of_set_nth_default:
  "sorted_list_of_set {k. nth_default dflt xs k \<noteq> dflt} = map fst (filter (\<lambda>(_, x). x \<noteq> dflt) (enumerate 0 xs))"
  by (rule sorted_distinct_set_unique) (auto simp add: nth_default_def in_set_conv_nth
    sorted_filter distinct_map_filter enumerate_eq_zip intro: rev_image_eqI)

lemma map_nth_default:
  "map (nth_default x xs) [0..<length xs] = xs"
proof -
  have *: "map (nth_default x xs) [0..<length xs] = map (List.nth xs) [0..<length xs]"
    by (rule map_cong) (simp_all add: nth_default_nth)
  show ?thesis by (simp add: * map_nth)
qed

lemma range_nth_default [simp]:
  "range (nth_default dflt xs) = insert dflt (set xs)"
  by (auto simp add: nth_default_def [abs_def] in_set_conv_nth)

lemma nth_strip_while:
  assumes "n < length (strip_while P xs)"
  shows "strip_while P xs ! n = xs ! n"
proof -
  have "length (dropWhile P (rev xs)) + length (takeWhile P (rev xs)) = length xs"
    by (subst add.commute)
      (simp add: arg_cong [where f=length, OF takeWhile_dropWhile_id, unfolded length_append])
  then show ?thesis using assms
    by (simp add: strip_while_def rev_nth dropWhile_nth)
qed

lemma length_strip_while_le:
  "length (strip_while P xs) \<le> length xs"
  unfolding strip_while_def o_def length_rev
  by (subst (2) length_rev[symmetric])
    (simp add: strip_while_def length_dropWhile_le del: length_rev)

lemma nth_default_strip_while_dflt [simp]:
  "nth_default dflt (strip_while ((=) dflt) xs) = nth_default dflt xs"
  by (induct xs rule: rev_induct) auto

lemma nth_default_eq_iff:
  "nth_default dflt xs = nth_default dflt ys
     \<longleftrightarrow> strip_while (HOL.eq dflt) xs = strip_while (HOL.eq dflt) ys" (is "?P \<longleftrightarrow> ?Q")
proof
  let ?xs = "strip_while (HOL.eq dflt) xs" and ?ys = "strip_while (HOL.eq dflt) ys"
  assume ?P
  then have eq: "nth_default dflt ?xs = nth_default dflt ?ys"
    by simp
  have len: "length ?xs = length ?ys"
  proof (rule ccontr)
    assume len: "length ?xs \<noteq> length ?ys"
    { fix xs ys :: "'a list"
      let ?xs = "strip_while (HOL.eq dflt) xs" and ?ys = "strip_while (HOL.eq dflt) ys"
      assume eq: "nth_default dflt ?xs = nth_default dflt ?ys"
      assume len: "length ?xs < length ?ys"
      then have "length ?ys > 0" by arith
      then have "?ys \<noteq> []" by simp
      with last_conv_nth_default [of ?ys dflt]
      have "last ?ys = nth_default dflt ?ys (length ?ys - 1)"
        by auto
      moreover from \<open>?ys \<noteq> []\<close> no_trailing_strip_while [of "HOL.eq dflt" ys]
        have "last ?ys \<noteq> dflt" by (simp add: no_trailing_unfold)
      ultimately have "nth_default dflt ?xs (length ?ys - 1) \<noteq> dflt"
        using eq by simp
      moreover from len have "length ?ys - 1 \<ge> length ?xs" by simp
      ultimately have False by (simp only: nth_default_beyond) simp
    }
    from this [of xs ys] this [of ys xs] len eq show False
      by (auto simp only: linorder_class.neq_iff)
  qed
  then show ?Q
  proof (rule nth_equalityI [rule_format])
    fix n
    assume n: "n < length ?xs"
    with len have "n < length ?ys"
      by simp
    with n have xs: "nth_default dflt ?xs n = ?xs ! n"
      and ys: "nth_default dflt ?ys n = ?ys ! n"
      by (simp_all only: nth_default_nth)
    with eq show "?xs ! n = ?ys ! n"
      by simp
  qed
next
  assume ?Q
  then have "nth_default dflt (strip_while (HOL.eq dflt) xs) = nth_default dflt (strip_while (HOL.eq dflt) ys)"
    by simp
  then show ?P
    by simp
qed

lemma nth_default_map2:
  \<open>nth_default d (map2 f xs ys) n = f (nth_default d1 xs n) (nth_default d2 ys n)\<close>
    if \<open>length xs = length ys\<close> and \<open>f d1 d2 = d\<close> for bs cs
using that proof (induction xs ys arbitrary: n rule: list_induct2)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs y ys)
  then show ?case
    by (cases n) simp_all
qed

end


(*  Title:      HOL/TLA/Memory/MemoryParameters.thy
    Author:     Stephan Merz, University of Munich
*)

section \<open>RPC-Memory example: Memory parameters\<close>

theory MemoryParameters
imports RPCMemoryParams
begin

(* the memory operations *)
datatype memOp = read Locs | "write" Locs Vals

consts
  (* memory locations and contents *)
  MemLoc         :: "Locs set"
  MemVal         :: "Vals set"

  (* some particular values *)
  OK             :: "Vals"
  BadArg         :: "Vals"
  MemFailure     :: "Vals"
  NotAResult     :: "Vals"  (* defined here for simplicity *)

  (* the initial value stored in each memory cell *)
  InitVal        :: "Vals"

axiomatization where
  (* basic assumptions about the above constants and predicates *)
  BadArgNoMemVal:    "BadArg \<notin> MemVal" and
  MemFailNoMemVal:   "MemFailure \<notin> MemVal" and
  InitValMemVal:     "InitVal : MemVal" and
  NotAResultNotVal:  "NotAResult \<notin> MemVal" and
  NotAResultNotOK:   "NotAResult \<noteq> OK" and
  NotAResultNotBA:   "NotAResult \<noteq> BadArg" and
  NotAResultNotMF:   "NotAResult \<noteq> MemFailure"

lemmas [simp] =
  BadArgNoMemVal MemFailNoMemVal InitValMemVal NotAResultNotVal
  NotAResultNotOK NotAResultNotBA NotAResultNotMF
  NotAResultNotOK [symmetric] NotAResultNotBA [symmetric] NotAResultNotMF [symmetric]

lemma MemValNotAResultE: "\<lbrakk> x \<in> MemVal; (x \<noteq> NotAResult \<Longrightarrow> P) \<rbrakk> \<Longrightarrow> P"
  using NotAResultNotVal by blast

end


(* Title: Resampling.thy
   Author: Andreas Lochbihler, ETH Zurich *)

theory Resampling imports
  While_SPMF
begin

lemma ord_spmf_lossless:
  assumes "ord_spmf (=) p q" "lossless_spmf p"
  shows "p = q"
  unfolding pmf.rel_eq[symmetric] using assms(1)
  by(rule pmf.rel_mono_strong)(use assms(2) in \<open>auto elim!: ord_option.cases simp add: lossless_iff_set_pmf_None\<close>)

context notes [[function_internals]] begin

partial_function (spmf) resample :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a spmf" where
  "resample A B = bind_spmf (spmf_of_set A) (\<lambda>x. if x \<in> B then return_spmf x else resample A B)"

end

lemmas resample_fixp_induct[case_names adm bottom step] = resample.fixp_induct

context
  fixes A :: "'a set"
  and B :: "'a set"
begin

interpretation loop_spmf "\<lambda>x. x \<notin> B" "\<lambda>_. spmf_of_set A" .

lemma resample_conv_while: "resample A B = bind_spmf (spmf_of_set A) while"
proof(induction rule: parallel_fixp_induct_2_1[OF partial_function_definitions_spmf partial_function_definitions_spmf resample.mono while.mono resample_def while_def, case_names adm bottom step])
  case adm show ?case by simp
  case bottom show ?case by simp
  case (step resample' while') then show ?case by(simp add: z3_rule(33) cong del: if_cong)
qed

context
  assumes A: "finite A"
    and B: "B \<subseteq> A" "B \<noteq> {}"
begin

private lemma A_nonempty: "A \<noteq> {}"
  using B by blast

private lemma B_finite: "finite B"
  using A B by(blast intro: finite_subset)

lemma lossless_resample: "lossless_spmf (resample A B)"
proof -
  from B have [simp]: "A \<inter> B \<noteq> {}" by auto
  have "lossless_spmf (while x)" for x
    by(rule termination_0_1_immediate[where p="card (A \<inter> B) / card A"])
      (simp_all add: spmf_map vimage_def measure_spmf_of_set field_simps A_nonempty A not_le card_gt_0_iff B)
  then show ?thesis by(clarsimp simp add: resample_conv_while A A_nonempty)
qed

lemma resample_le_sample:
  "ord_spmf (=) (resample A B) (spmf_of_set B)"
proof(induction rule: resample_fixp_induct)
  case adm show ?case by simp
  case bottom show ?case by simp
  case (step resample')
  note [simp] = B_finite A
  show ?case
  proof(rule ord_pmf_increaseI)
    fix x
    let ?f = "\<lambda>x. if x \<in> B then return_spmf x else resample' A B"
    have "spmf (bind_spmf (spmf_of_set A) ?f) x =
      (\<Sum>n\<in>B \<union> (A - B). if n \<in> B then (if n = x then 1 else 0) / card A else spmf (resample' A B) x / card A)"
      using B
      by(auto simp add: spmf_bind integral_spmf_of_set sum_divide_distrib if_distrib[where f="\<lambda>p. spmf p _ / _"] cong: if_cong intro!: sum.cong split: split_indicator_asm)
    also have "\<dots> = (\<Sum>n\<in>B. (if n = x then 1 else 0) / card A) + (\<Sum>n\<in>A - B. spmf (resample' A B) x / card A)"
      by(subst sum.union_disjoint)(auto)
    also have "\<dots> = (if x \<in> B then 1 / card A else 0) + card (A - B) / card A * spmf (resample' A B) x"
      by(simp cong: sum.cong add: if_distrib[where f="\<lambda>x. x / _"] cong: if_cong)
    also have "\<dots> \<le> (if x \<in> B then 1 / card A else 0) + card (A - B) / card A * spmf (spmf_of_set B) x"
      by(intro add_left_mono mult_left_mono step.IH[THEN ord_spmf_eq_leD]) simp
    also have "\<dots> = spmf (spmf_of_set B) x" using B
      by(simp add: spmf_of_set field_simps A_nonempty card_Diff_subset card_mono of_nat_diff)
    finally show "spmf (bind_spmf (spmf_of_set A) ?f) x \<le> \<dots>" .
  qed simp
qed

lemma resample_eq_sample: "resample A B = spmf_of_set B"
  using resample_le_sample lossless_resample by(rule ord_spmf_lossless)

end

end

end


(*  Title:      HOL/Imperative_HOL/ex/Subarray.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section {* Theorems about sub arrays *}

theory Subarray
imports "~~/src/HOL/Imperative_HOL/Array" Sublist
begin

definition subarray :: "nat \<Rightarrow> nat \<Rightarrow> ('a::heap) array \<Rightarrow> heap \<Rightarrow> 'a list" where
  "subarray n m a h \<equiv> sublist' n m (Array.get h a)"

lemma subarray_upd: "i \<ge> m \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h"
apply (simp add: subarray_def Array.update_def)
apply (simp add: sublist'_update1)
done

lemma subarray_upd2: " i < n  \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h"
apply (simp add: subarray_def Array.update_def)
apply (subst sublist'_update2)
apply fastforce
apply simp
done

lemma subarray_upd3: "\<lbrakk> n \<le> i; i < m\<rbrakk> \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h[i - n := v]"
unfolding subarray_def Array.update_def
by (simp add: sublist'_update3)

lemma subarray_Nil: "n \<ge> m \<Longrightarrow> subarray n m a h = []"
by (simp add: subarray_def sublist'_Nil')

lemma subarray_single: "\<lbrakk> n < Array.length h a \<rbrakk> \<Longrightarrow> subarray n (Suc n) a h = [Array.get h a ! n]"
by (simp add: subarray_def length_def sublist'_single)

lemma length_subarray: "m \<le> Array.length h a \<Longrightarrow> List.length (subarray n m a h) = m - n"
by (simp add: subarray_def length_def length_sublist')

lemma length_subarray_0: "m \<le> Array.length h a \<Longrightarrow> List.length (subarray 0 m a h) = m"
by (simp add: length_subarray)

lemma subarray_nth_array_Cons: "\<lbrakk> i < Array.length h a; i < j \<rbrakk> \<Longrightarrow> (Array.get h a ! i) # subarray (Suc i) j a h = subarray i j a h"
unfolding Array.length_def subarray_def
by (simp add: sublist'_front)

lemma subarray_nth_array_back: "\<lbrakk> i < j; j \<le> Array.length h a\<rbrakk> \<Longrightarrow> subarray i j a h = subarray i (j - 1) a h @ [Array.get h a ! (j - 1)]"
unfolding Array.length_def subarray_def
by (simp add: sublist'_back)

lemma subarray_append: "\<lbrakk> i < j; j < k \<rbrakk> \<Longrightarrow> subarray i j a h @ subarray j k a h = subarray i k a h"
unfolding subarray_def
by (simp add: sublist'_append)

lemma subarray_all: "subarray 0 (Array.length h a) a h = Array.get h a"
unfolding Array.length_def subarray_def
by (simp add: sublist'_all)

lemma nth_subarray: "\<lbrakk> k < j - i; j \<le> Array.length h a \<rbrakk> \<Longrightarrow> subarray i j a h ! k = Array.get h a ! (i + k)"
unfolding Array.length_def subarray_def
by (simp add: nth_sublist')

lemma subarray_eq_samelength_iff: "Array.length h a = Array.length h' a \<Longrightarrow> (subarray i j a h = subarray i j a h') = (\<forall>i'. i \<le> i' \<and> i' < j \<longrightarrow> Array.get h a ! i' = Array.get h' a ! i')"
unfolding Array.length_def subarray_def by (rule sublist'_eq_samelength_iff)

lemma all_in_set_subarray_conv: "(\<forall>j. j \<in> set (subarray l r a h) \<longrightarrow> P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < Array.length h a \<longrightarrow> P (Array.get h a ! k))"
unfolding subarray_def Array.length_def by (rule all_in_set_sublist'_conv)

lemma ball_in_set_subarray_conv: "(\<forall>j \<in> set (subarray l r a h). P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < Array.length h a \<longrightarrow> P (Array.get h a ! k))"
unfolding subarray_def Array.length_def by (rule ball_in_set_sublist'_conv)

end


theory PseudoCodeEquiv
imports "../HOModel" GenSynchMod
begin

definition nextState :: "nat => locState => (Proc => locState message) => locState" where
"nextState k s msgs ==
    let synch_a = (ALL p. msgs p ~= Void --> (EX m. msgs p = Content m & conc m & x m mod k = x s mod k)) in
    let ready_a = (ALL p m. msgs p = Content m --> ready m) in
    let force_a = (Max (k_mod.forceMsgs ` range msgs)) in
    let x_a = Suc (LEAST v. EX m p. msgs p = Content m & forc m = force_a & x m = v) in
    if x_a mod k = 0 then
        if level s = 0 & synch_a then
            if force_a <= 2 then
                (| x = 0, conc = True, ready = True, forc = 2, level = 1 |)
            else
                (| x = x_a, conc = True, ready = True, forc = force_a, level = 1 |)
        else
            if level s = 1 & synch_a & ready_a then
                (| x = 0, conc = True, ready = True, forc = 3, level = 2 |)
            else
                (| x = x_a, conc = True, ready = level s > 0, forc = force_a, level = level s |)
    else
        (| x = x_a, conc = synch_a, ready = ready_a, forc = force_a, level = level s |)"

lemma minMsgs_eq:
assumes "msgs p = Content s"
shows "(ALL p :: Proc. msgs p ~= Void --> (EX m. msgs p = Content m & conc m & x m mod k = x s mod k)) = k_mod.isSynch k msgs"
proof
    assume asm:"ALL p. msgs p ~= Void --> (EX m. msgs p = Content m & conc m & x m mod k = x s mod k)"
    show "k_mod.isSynch k msgs" unfolding k_mod.isSynch_def
    proof (rule allI impI)+
        fix p
        assume "msgs p ~= Void"
        from this obtain m where "msgs p = Content m" and "conc m" and "x m mod k = x s mod k" using asm by auto
        moreover from this obtain q sq where "msgs q = Content sq" and "forc sq = k_mod.maxForce msgs"
            using Max_in[of "k_mod.forceMsgs ` range msgs"] finite_UNIV unfolding k_mod.maxForce_def
            by (smt (verit, ccfv_SIG) Max_ge asm empty_iff finite finite_imageI imageE imageI k_mod.forceMsgs.simps(1)
            k_mod.forceMsgs.simps(3) k_mod.maxForce_def le_neq_implies_less less_nat_zero_code neq0_conv rangeI)
        from this obtain qq sqq where "msgs qq = Content sqq" and "forc sqq = k_mod.maxForce msgs" and "x sqq = k_mod.minMsgs msgs"
            using LeastI_ex unfolding k_mod.minMsgs_def by (smt (verit, del_insts))
        hence "k_mod.minMsgs msgs mod k = x s mod k" using asm by (metis message.inject message.simps(5))
        ultimately show "EX m. msgs p = Content m & conc m & x m mod k = k_mod.minMsgs msgs mod k" by auto
    qed
next
    assume asm:"k_mod.isSynch k msgs"
    show "ALL p. msgs p ~= Void --> (EX m. msgs p = Content m & conc m & x m mod k = x s mod k)"
    proof (rule allI impI)+
        fix p
        assume "msgs p ~= Void"
        from this obtain m where "msgs p = Content m" and "conc m" and "x m mod k = k_mod.minMsgs msgs mod k"
            using asm unfolding k_mod.isSynch_def by auto
        moreover have "x s mod k = k_mod.minMsgs msgs mod k" using asm assms unfolding k_mod.isSynch_def by (metis message.inject message.simps(5))
        ultimately show "EX m. msgs p = Content m & conc m & x m mod k = x s mod k" by auto
    qed
qed

lemma equiv_pseudocode:
assumes "msgs p = Content s"
and k2:"k > 2"
and "k_mod.maxForce msgs <= 3"
shows "k_mod.gen_nextState k p s msgs (nextState k s msgs)"
proof -
    have nxt:"nextState k s msgs =
        (let synch_a = k_mod.isSynch k msgs in
        let ready_a = k_mod.isReady msgs in
        let force_a = k_mod.maxForce msgs in
        let x_a = Suc (k_mod.minMsgs msgs) in
        if x_a mod k = 0 then
            if level s = 0 & synch_a then
                if force_a <= 2 then
                    (| x = 0, conc = True, ready = True, forc = 2, level = 1 |)
                else
                    (| x = x_a, conc = True, ready = True, forc = force_a, level = 1 |)
            else
                if level s = 1 & synch_a & ready_a then
                    (| x = 0, conc = True, ready = True, forc = 3, level = 2 |)
                else
                    (| x = x_a, conc = True, ready = level s > 0, forc = force_a, level = level s |)
        else
            (| x = x_a, conc = synch_a, ready = ready_a, forc = force_a, level = level s |))"
        using minMsgs_eq[of msgs p s k] assms
        unfolding k_mod.minMsgs_def k_mod.maxForce_def k_mod.isReady_def nextState_def
        by presburger
    thus ?thesis
    proof (cases "k_mod.goto_level1 k msgs s | k_mod.goto_level2 k msgs s")
        case goto:True
        hence mod0:"Suc (k_mod.minMsgs msgs) mod k = 0" using k2
            unfolding k_mod.goto_level1_def k_mod.goto_level2_def by (metis Suc_diff_1 dual_order.strict_trans less_2_cases_iff mod_Suc)
        thus ?thesis
        proof (cases "level s = 0 & k_mod.maxForce msgs > 2")
            case True
            hence "nextState k s msgs = (| x = Suc (k_mod.minMsgs msgs), conc = True, ready = True, forc = k_mod.maxForce msgs, level = 1 |)"
                using nxt mod0 goto
                unfolding k_mod.goto_level1_def k_mod.goto_level2_def by auto
            thus ?thesis unfolding k_mod.gen_nextState_def by (smt (z3) Suc_1 True diff_Suc_1 k_mod.goto_level1_def less_Suc_eq_0_disj
                less_numeral_extra(1) less_numeral_extra(3) locState.select_convs(1) locState.select_convs(2)
                locState.select_convs(3) locState.select_convs(4) locState.select_convs(5) mod_Suc nxt)
        next
            case False
            hence "nextState k s msgs = (| x = 0, conc = True, ready = True, forc = Suc (Suc (level s)), level = Suc (level s) |)"
                using nxt mod0 goto
                unfolding k_mod.goto_level1_def k_mod.goto_level2_def by auto
            moreover have "k_mod.maxForce msgs <= Suc (if k_mod.goto_level1 k msgs s then 1 else 2)"
                using goto False assms(3)
                unfolding k_mod.goto_level1_def k_mod.goto_level2_def by fastforce
            ultimately show ?thesis unfolding k_mod.gen_nextState_def
                using goto False
                by (smt (z3) One_nat_def Suc_1 k_mod.goto_level1_def k_mod.goto_level2_def less_2_cases_iff
                less_le locState.select_convs(1) locState.select_convs(2) locState.select_convs(3) locState.select_convs(4)
                locState.select_convs(5) not_le zero_less_one)
        qed
    next
        case False
        moreover from this have "nextState k s msgs = (let x_a = Suc (k_mod.minMsgs msgs) in
             (| x = x_a, conc = x_a mod k = 0 | k_mod.isSynch k msgs,
            ready = if x_a mod k = 0 then level s > 0 else k_mod.isReady msgs, forc = k_mod.maxForce msgs, level = level s |))"
            using nxt unfolding k_mod.goto_level1_def k_mod.goto_level2_def
            by (smt (z3) One_nat_def diff_Suc_1 diff_is_0_eq' mod_Suc one_neq_zero zero_le_one)
        ultimately show ?thesis unfolding k_mod.gen_nextState_def by simp
    qed
qed