section Parser
theory IpRoute_Parser
imports Routing_Table
  "../IP_Addresses/IP_Address_Parser"
keywords "parse_ip_route" "parse_ip_6_route" :: thy_decl
begin
text\<open>This helps to read the output of the \texttt{ip route} command into a @{typ "32 routing_rule list"}.\<close>

definition empty_rr_hlp :: "('a::len) prefix_match \<Rightarrow> 'a routing_rule" where
  "empty_rr_hlp pm = routing_rule.make pm default_metric (routing_action.make '''' None)"

lemma empty_rr_hlp_alt:
  "empty_rr_hlp pm = \<lparr> routing_match = pm, metric = 0, routing_action = \<lparr>output_iface = [], next_hop = None\<rparr>\<rparr>"
  unfolding empty_rr_hlp_def routing_rule.defs default_metric_def routing_action.defs ..

definition routing_action_next_hop_update :: "'a word \<Rightarrow> 'a routing_rule \<Rightarrow> ('a::len) routing_rule"
  where
  "routing_action_next_hop_update h pk = pk\<lparr> routing_action := (routing_action pk)\<lparr> next_hop := Some h\<rparr> \<rparr>"
lemma "routing_action_next_hop_update h pk = routing_action_update (next_hop_update (\<lambda>_. (Some h))) (pk::32 routing_rule)"
  by(simp add: routing_action_next_hop_update_def)

definition routing_action_oiface_update :: "string \<Rightarrow> 'a routing_rule \<Rightarrow> ('a::len) routing_rule"
  where
  "routing_action_oiface_update h pk = routing_action_update (output_iface_update (\<lambda>_. h)) (pk::'a routing_rule)"
lemma "routing_action_oiface_update h pk = pk\<lparr> routing_action := (routing_action pk)\<lparr> output_iface :=  h\<rparr> \<rparr>"
  by(simp add: routing_action_oiface_update_def)

(* Could be moved to Bitmagic *)
definition "default_prefix = PrefixMatch 0 0"
lemma default_prefix_matchall: "prefix_match_semantics default_prefix ip"
  unfolding default_prefix_def by (simp add: valid_prefix_00 zero_prefix_match_all)

definition "sanity_ip_route (r::('a::len) prefix_routing) \<equiv> correct_routing r \<and> unambiguous_routing r \<and> list_all (op \<noteq> '''' \<circ> routing_oiface) r"
text\<open>The parser ensures that @{const sanity_ip_route} holds for any ruleset that is imported.\<close>

(* Hide all the ugly ml in a file with the right extension *)
(*Depends on the function parser_ipv4 from IP_Address_Parser*)
ML_file "IpRoute_Parser.ml"

ML\<open>
  Outer_Syntax.local_theory @{command_keyword parse_ip_route}
  "Load a file generated by ip route and make the routing table definition available as isabelle term"
  (Parse.binding --| @{keyword "="} -- Parse.string >> register_ip_route 32)
\<close>

ML\<open>
  Outer_Syntax.local_theory @{command_keyword parse_ip_6_route}
  "Load a file generated by ip -6 route and make the routing table definition available as isabelle term"
  (Parse.binding --| @{keyword "="} -- Parse.string >> register_ip_route 128)
\<close>

parse_ip_route "rtbl_parser_test1" = "ip-route-ex"
lemma  "sanity_ip_route rtbl_parser_test1" by eval (* checked by parse_ip_route alread *)

lemma "rtbl_parser_test1 =
  [\<lparr>routing_match = PrefixMatch 0xFFFFFF00 32, metric = 0, routing_action = \<lparr>output_iface = ''tun0'', next_hop = None\<rparr>\<rparr>,
  \<lparr>routing_match = PrefixMatch 0xA0D2AA0 28, metric = 303, routing_action = \<lparr>output_iface = ''ewlan'', next_hop = None\<rparr>\<rparr>,
  \<lparr>routing_match = PrefixMatch 0xA0D2500 24, metric = 0, routing_action = \<lparr>output_iface = ''tun0'', next_hop = Some 0xFFFFFF00\<rparr>\<rparr>,
  \<lparr>routing_match = PrefixMatch 0xA0D2C00 24, metric = 0, routing_action = \<lparr>output_iface = ''tun0'', next_hop = Some 0xFFFFFF00\<rparr>\<rparr>,
  \<lparr>routing_match = PrefixMatch 0 0, metric = 303, routing_action = \<lparr>output_iface = ''ewlan'', next_hop = Some 0xA0D2AA1\<rparr>\<rparr>]"
by eval

parse_ip_6_route "rtbl_parser_test2" = "ip-6-route-ex"
value[code] rtbl_parser_test2
lemma  "sanity_ip_route rtbl_parser_test2" by eval

end


theory ReynoldsList
  imports Refinement
begin

no_notation pmult (infixl "*" 80)
  and times (infixl "*" 70)
  and Set.image (infixr "`" 90)
  and sup (infixl "+" 65)
  and pmult_one ("1")
  and bot ("\<bottom>")
  and sep_impl (infix "-*" 55)

no_notation Set.image (infixr "`" 90)
  and times (infixl "*" 70)

(* List *)
primrec list' :: "nat \<Rightarrow> nat list \<Rightarrow> 'a pred" where
  "list' i [] = \<lbrace>i = 0\<rbrace> \<sqinter> emp"
| "list' i (y#ys) = \<lbrace>i \<noteq> 0\<rbrace> \<sqinter> (EXS j. \<lbrace>i [\<mapsto>] [y,j]\<rbrace> * list' j ys)"

syntax
  "_list" :: "nat \<Rightarrow> nat list \<Rightarrow> bool" ("list _ _")

translations
  "list x xs" == "|(`(CONST curry (CONST list' x xs)))|"

lemma list_cong: "list' x xs (a, h) \<Longrightarrow> x' = x \<Longrightarrow> xs' = xs \<Longrightarrow> h' = h \<Longrightarrow> list' x' xs' (a, h')"
  by force

lemma list_cong_ex: "list' x xs (a, h) \<Longrightarrow> x' = x \<Longrightarrow> h' = h \<Longrightarrow> \<exists>xs. list' x' xs (a, h')"
  by force

lemma empty_list: "list' i a (s, h) \<Longrightarrow> i = 0 \<Longrightarrow> a = []"
  by (metis (mono_tags, lifting) PairE inf1E list'.simps(2) list.exhaust old.prod.case)

lemma list_i_null: "list' 0 a (s, h) \<Longrightarrow> a = [] \<and> h = Map.empty"
  by (induct a, simp_all add: emp_def)

lemma list_i_not_null: "list' i a (s, h) \<Longrightarrow> i \<noteq> 0 \<Longrightarrow> a \<noteq> []"
  by (induct a, simp_all add: emp_def)

lemma list_i_not_null_var: "list' i x (s, h) \<Longrightarrow> i \<noteq> 0 \<Longrightarrow> (\<exists>y ys. x = y#ys)"
  apply (auto dest!: list_i_not_null)
  by (metis list.exhaust)

lemma sep_conj_s_preserving:
  assumes "(\<And>h. P (s, h) \<Longrightarrow> P (s', h))" and  "(\<And>h. Q (s, h) \<Longrightarrow> Q (s', h))"
  shows "((P * Q) (s, h) \<Longrightarrow> (P * Q) (s', h))"
  using assms by (auto simp add: sep_conj_def ortho_def split: option.splits)

lemma list_s_preserving: "list' n as (s :: 'a, h) \<Longrightarrow> list' n as (s' :: 'a, h)"
  apply (induct as arbitrary: n h)
  by (auto simp add: emp_def intro: sep_conj_s_preserving [of _ s])

record list_state =
  i :: nat
  j :: nat
  k :: nat

lemma [simp]: "list' n as (j_update m s, h) = list' n as (s, h)"
  by (auto intro: list_s_preserving)

lemma [simp]: "list' n as (k_update m s, h) = list' n as (s, h)"
  by (auto intro: list_s_preserving)

lemma heap_div: "h1 \<bottom> h2 \<Longrightarrow> h1 a = Some b \<Longrightarrow> (h1 ++ h2) a = Some b"
  apply (auto simp: ortho_def)
  by (auto simp: map_add_def split: option.splits)

lemma heap_div_var: "h1 \<bottom> h2 \<Longrightarrow> h2 a = Some b \<Longrightarrow> (h1 ++ h2) a = Some b"
  by (auto simp: ortho_def)

lemma heap_ortho_div2: "[x \<mapsto> y, z \<mapsto> w] \<bottom> h \<Longrightarrow> [x \<mapsto> y] \<bottom> [z \<mapsto> w] \<Longrightarrow>([x \<mapsto> y, z \<mapsto> w] ++ h)(x := None, z := None) = h"
apply (simp add: fun_upd_def ortho_def map_add_def)
apply (rule ext)
apply (case_tac "xa = z")
apply auto
apply force
apply force
by (metis option.exhaust option.simps(4) option.simps(5))

lemma heap_div_the: "h1 \<bottom> h2 \<Longrightarrow> h1 a = Some b \<Longrightarrow> the ((h1 ++ h2) a) = b"
  apply (auto simp: ortho_def)
  by (auto simp: map_add_def split: option.splits)

lemma [iff]: "x \<sqinter> emp = (\<lambda>(s, h). x (s, h) \<and> emp (s, h))"
  by auto

lemma "q s \<Longrightarrow> (p \<sqinter> q) s = p s \<and> q s"
  by auto

lemma pred_infI: "p s \<and> q s \<Longrightarrow> (p \<sqinter> q) s"
  by auto

lemma pred_infD: "(p \<sqinter> q) s \<Longrightarrow> p s \<and> q s"
  by auto

lemma listI: "p \<noteq> 0 \<Longrightarrow>  h1 \<bottom> h2 \<Longrightarrow> is_heap_list p [q, r] (s, h1) \<Longrightarrow> list' r ns (s, h2) \<Longrightarrow> list' p (q#ns) (s, h1 ++ h2)"
  by (force simp: sep_conj_eq)

declare sep_conj_eq [simp] emp_def[simp]
notation
  pred_ex (binder "\<exists> " 10)
  and inf (infixl "\<and>" 75)

lemma "\<lbrakk>\<lbrace>list `i Ao\<rbrace> , \<lbrace> list `j (rev Ao)\<rbrace>\<rbrakk> \<sqsubseteq>
    `j := 0;
    while `i \<noteq> 0
    do
      `k := @(`i + 1);
      @(`i + 1) := `j;
      `j := `i;
      `i := `k
    od"
proof -
  have "\<lbrakk> \<lbrace>list `i Ao\<rbrace>, \<lbrace>list `j (rev Ao)\<rbrace> \<rbrakk> \<sqsubseteq>
      `j := 0;
      \<lbrakk>\<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>,
        \<lbrace> list `j (rev Ao) \<rbrace> \<rbrakk>"
      (is "... \<sqsubseteq> ?p")
    by refinement force
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          \<lbrakk>(\<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    by refinement (auto dest!: list_i_null)
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          \<lbrakk>(\<exists>a A B k. (\<lbrace>`i [\<mapsto>] [a,k]\<rbrace> * \<lbrace> list k A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev (a#A)) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    by refinement (frule list_i_not_null_var, fastforce+)
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          \<lbrakk>(\<exists> a A B. (\<lbrace>`i [\<mapsto>] [a,`k]\<rbrace> * \<lbrace> list `k A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev (a#A)) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists> A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    apply refinement
    apply (rule_tac x=x in exI, rule_tac x=xa in exI, rule_tac x=xb in exI)
    apply (subgoal_tac "the ((h1a ++ h2a ++ h2) (Suc (i a))) = xc")
    by (auto simp add: is_singleton_def intro!: heap_div_the heap_divider)
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          @(`i + 1) := `j;
          \<lbrakk>(\<exists> a A B. (\<lbrace>`i [\<mapsto>] [a,`j]\<rbrace> * \<lbrace> list `k A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev (a#A)) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists> A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
        by refinement (force simp: spec_def ht_def mono_def)
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          @(`i + 1) := `j;
          \<lbrakk>(\<exists>a A B. (\<lbrace> list `k A \<rbrace> * \<lbrace>`i [\<mapsto>] [a,`j]\<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev (a#A)) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    by refinement (subst mult_commute, force)
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          @(`i + 1) := `j;
          \<lbrakk>(\<exists>a A B. (\<lbrace> list `k A \<rbrace> * \<lbrace> list `i (a#B) \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ (a#B) \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    apply refinement
    apply (rule_tac x=x in exI, rule_tac x=xa in exI, rule_tac x=xb in exI)
    apply (auto simp only: sep_conj_eq)
    apply (rule_tac x=h1a in exI, rule_tac x="h2a ++ h2" in exI)
    apply (auto simp del: list'.simps is_heap_list.simps intro!: listI)
    apply (force simp add: is_singleton_def ortho_def)
    by (force simp add: is_singleton_def ortho_def intro: listI)
  also have "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          @(`i + 1) := `j;
          \<lbrakk>(\<exists>A B. (\<lbrace> list `k A \<rbrace> * \<lbrace> list `i B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    by refinement (force simp only: sep_conj_eq)
  also have nine: "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          @(`i + 1) := `j;
          `j := `i;
          \<lbrakk>(\<exists>A B. (\<lbrace> list `k A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>) \<and> \<lbrace>`i \<noteq> 0\<rbrace>,
            \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>\<rbrakk>
        od" (is "... \<sqsubseteq> ?p")
    by refinement auto
  also have ten: "?p \<sqsubseteq>
        `j := 0;
        while `i \<noteq> 0 do
          `k := @(`i + 1);
          @(`i + 1) := `j;
          `j := `i;
          `i := `k
        od"
        by refinement auto
  finally show ?thesis .
qed

lemma "\<turnstile> \<lbrace>list `i Ao\<rbrace>
      `j := 0;
      while `i \<noteq> 0
      inv \<exists>A B. (\<lbrace> list `i A \<rbrace> * \<lbrace> list `j B \<rbrace>) \<and> \<lbrace>(rev Ao) = (rev A) @ B \<rbrace>
      do
        `k := @(`i + 1);
        @(`i + 1) := `j;
        `j := `i;
        `i := `k
      od
   \<lbrace> list `j (rev Ao)\<rbrace>"
apply hoare
apply force
apply (clarsimp dest!: list_i_null)
apply clarsimp
apply (frule list_i_not_null_var, simp)
apply (clarsimp simp add: is_singleton_def)
apply (rule_tac x=ys in exI, rule_tac x="y # xa" in exI)
apply (subgoal_tac "the (([i a \<mapsto> y, Suc (i a) \<mapsto> x] ++ h2a ++ h2) (Suc (i a))) = x")
apply auto
prefer 2
apply (force intro!: heap_div_the heap_divider)
apply (rule_tac x=h2a in exI, rule_tac x="[i a \<mapsto> y, Suc (i a) \<mapsto> j a] ++ h2" in exI)
apply (auto simp add: is_singleton_def ortho_def intro!: listI)
by (metis domIff empty_map_add fun_upd_upd map_add_upd_left)

hide_const i j k

record list_dealloc_state =
  x :: nat
  y :: nat

lemma [simp]: "list' n as (x_update m s, h) = list' n as (s, h)"
  by (auto intro: list_s_preserving)

lemma [simp]: "list' n as (y_update m s, h) = list' n as (s, h)"
  by (auto intro: list_s_preserving)

lemma list_dealloc: " \<turnstile> \<lbrace> list `x xs \<rbrace>
  while `x \<noteq> 0
  inv \<lbrace> \<exists>xs. list `x xs \<rbrace>
  do
    `y := `x;
    `x := @(`x + 1);
    dispose `y;
    dispose (`y + 1)
  od
  ( emp )"
apply hoare
apply (auto simp: mono_def dispose_comm_def list_i_null, frule list_i_not_null_var)
by (auto simp: is_singleton_def, auto intro!: list_cong_ex heap_div_the heap_ortho_div2)

hide_const x y

lemma "\<turnstile> ( \<lbrace> x [\<mapsto>] [b, j] \<rbrace> * \<lbrace> list i as \<rbrace> ) @x := a ( \<lbrace> x [\<mapsto>] [a, j] \<rbrace> * \<lbrace> list i as \<rbrace> )"
  by (simp only: is_heap_list.simps(2) curry_conv split_eta) hoare

end


section \<open>Transition Systems\<close>

theory Transition_System_Extensions
imports
  "Basics/Word_Prefixes"
  "Extensions/Set_Extensions"
  "Extensions/Relation_Extensions"
  Transition_Systems_and_Automata.Transition_System
  Transition_Systems_and_Automata.Transition_System_Extra
  Transition_Systems_and_Automata.Transition_System_Construction
begin

  context transition_system_initial
  begin

    definition cycles :: "'state \<Rightarrow> 'transition list set"
      where "cycles p \<equiv> {w. path w p \<and> target w p = p}"

    lemma cyclesI[intro!]:
      assumes "path w p" "target w p = p"
      shows "w \<in> cycles p"
      using assms unfolding cycles_def by auto
    lemma cyclesE[elim!]:
      assumes "w \<in> cycles p"
      obtains "path w p" "target w p = p"
      using assms unfolding cycles_def by auto

    inductive_set executable :: "'transition set"
      where executable: "p \<in> nodes \<Longrightarrow> enabled a p \<Longrightarrow> a \<in> executable"

    lemma executableI_step[intro!]:
      assumes "p \<in> nodes" "enabled a p"
      shows "a \<in> executable"
      using executable assms by this
    lemma executableI_words_fin[intro!]:
      assumes "p \<in> nodes" "path w p"
      shows "set w \<subseteq> executable"
      using assms by (induct w arbitrary: p, auto del: subsetI)
    lemma executableE[elim?]:
      assumes "a \<in> executable"
      obtains p
      where "p \<in> nodes" "enabled a p"
      using assms by induct auto

  end

  locale transition_system_interpreted =
    transition_system ex en
    for ex :: "'action \<Rightarrow> 'state \<Rightarrow> 'state"
    and en :: "'action \<Rightarrow> 'state \<Rightarrow> bool"
    and int :: "'state \<Rightarrow> 'interpretation"
  begin

    definition visible :: "'action set"
      where "visible \<equiv> {a. \<exists> q. en a q \<and> int q \<noteq> int (ex a q)}"

    lemma visibleI[intro]:
      assumes "en a q" "int q \<noteq> int (ex a q)"
      shows "a \<in> visible"
      using assms unfolding visible_def by auto
    lemma visibleE[elim]:
      assumes "a \<in> visible"
      obtains q
      where "en a q" "int q \<noteq> int (ex a q)"
      using assms unfolding visible_def by auto

    abbreviation "invisible \<equiv> - visible"

    lemma execute_fin_word_invisible:
      assumes "path w p" "set w \<subseteq> invisible"
      shows "int (target w p) = int p"
      using assms by (induct w arbitrary: p rule: list.induct, auto)
    lemma execute_inf_word_invisible:
      assumes "run w p" "k \<le> l" "\<And> i. k \<le> i \<Longrightarrow> i < l \<Longrightarrow> w !! i \<notin> visible"
      shows "int ((p ## trace w p) !! k) = int ((p ## trace w p) !! l)"
    proof -
      have "(p ## trace w p) !! l = target (stake l w) p" by simp
      also have "stake l w = stake k w @ stake (l - k) (sdrop k w)" using assms(2) by simp
      also have "target \<dots> p = target (stake (l - k) (sdrop k w)) (target (stake k w) p)"
        unfolding fold_append comp_apply by rule
      also have "int \<dots> = int (target (stake k w) p)"
      proof (rule execute_fin_word_invisible)
        have "w = stake l w @- sdrop l w" by simp
        also have "stake l w = stake k w @ stake (l - k) (sdrop k w)" using assms(2) by simp
        finally have 1: "run (stake k w @- stake (l - k) (sdrop k w) @- sdrop l w) p"
          unfolding shift_append using assms(1) by simp
        show "path (stake (l - k) (sdrop k w)) (target (stake k w) p)" using 1 by auto
        show "set (stake (l - k) (sdrop k w)) \<subseteq> invisible" using assms(3) by (auto simp: set_stake_snth)
      qed
      also have "\<dots> = int ((p ## trace w p) !! k)" by simp
      finally show ?thesis by rule
    qed

  end

  locale transition_system_complete =
    transition_system_initial ex en init +
    transition_system_interpreted ex en int
    for ex :: "'action \<Rightarrow> 'state \<Rightarrow> 'state"
    and en :: "'action \<Rightarrow> 'state \<Rightarrow> bool"
    and init :: "'state \<Rightarrow> bool"
    and int :: "'state \<Rightarrow> 'interpretation"
  begin

    definition language :: "'interpretation stream set"
      where "language \<equiv> {smap int (p ## trace w p) |p w. init p \<and> run w p}"

    lemma languageI[intro!]:
      assumes "w = smap int (p ## trace v p)" "init p" "run v p"
      shows "w \<in> language"
      using assms unfolding language_def by auto
    lemma languageE[elim!]:
      assumes "w \<in> language"
      obtains p v
      where "w = smap int (p ## trace v p)" "init p" "run v p"
      using assms unfolding language_def by auto

  end

  locale transition_system_finite_nodes =
    transition_system_initial ex en init
    for ex :: "'action \<Rightarrow> 'state \<Rightarrow> 'state"
    and en :: "'action \<Rightarrow> 'state \<Rightarrow> bool"
    and init :: "'state \<Rightarrow> bool"
    +
    assumes reachable_finite: "finite nodes"

  locale transition_system_cut =
    transition_system_finite_nodes ex en init
    for ex :: "'action \<Rightarrow> 'state \<Rightarrow> 'state"
    and en :: "'action \<Rightarrow> 'state \<Rightarrow> bool"
    and init :: "'state \<Rightarrow> bool"
    +
    fixes cuts :: "'action set"
    assumes cycles_cut: "p \<in> nodes \<Longrightarrow> w \<in> cycles p \<Longrightarrow> w \<noteq> [] \<Longrightarrow> set w \<inter> cuts \<noteq> {}"
  begin

    inductive scut :: "'state \<Rightarrow> 'state \<Rightarrow> bool"
      where scut: "p \<in> nodes \<Longrightarrow> en a p \<Longrightarrow> a \<notin> cuts \<Longrightarrow> scut p (ex a p)"

    declare scut.intros[intro!]
    declare scut.cases[elim!]

    lemma scut_reachable:
      assumes "scut p q"
      shows "p \<in> nodes" "q \<in> nodes"
      using assms by auto
    lemma scut_trancl:
      assumes "scut\<^sup>+\<^sup>+ p q"
      obtains w
      where "path w p" "target w p = q" "set w \<inter> cuts = {}" "w \<noteq> []"
    using assms
    proof (induct arbitrary: thesis)
      case (base q)
      show ?case using base by force
    next
      case (step q r)
      obtain w where 1: "path w p" "target w p = q" "set w \<inter> cuts = {}" "w \<noteq> []"
        using step(3) by this
      obtain a where 2: "en a q" "a \<notin> cuts" "ex a q = r" using step(2) by auto
      show ?case
      proof (rule step(4))
        show "path (w @ [a]) p" using 1 2 by auto
        show "target (w @ [a]) p = r" using 1 2 by auto
        show "set (w @ [a]) \<inter> cuts = {}" using 1 2 by auto
        show "w @ [a] \<noteq> []" by auto
      qed
    qed

    sublocale wellfounded_relation "scut\<inverse>\<inverse>"
    proof (unfold_locales, intro finite_acyclic_wf_converse[to_pred] acyclicI[to_pred], safe)
      have 1: "{(p, q). scut p q} \<subseteq> nodes \<times> nodes" using scut_reachable by blast
      have 2: "finite (nodes \<times> nodes)"
        using finite_cartesian_product reachable_finite by blast
      show "finite {(p, q). scut p q}" using 1 2 by blast
    next
      fix p
      assume 1: "scut\<^sup>+\<^sup>+ p p"
      have 2: "p \<in> nodes" using 1 tranclE[to_pred] scut_reachable by metis
      obtain w where 3: "path w p" "target w p = p" "set w \<inter> cuts = {}" "w \<noteq> []"
        using scut_trancl 1 by this
      have 4: "w \<in> cycles p" using 3(1, 2) by auto
      have 5: "set w \<inter> cuts \<noteq> {}" using cycles_cut 2 4 3(4) by this
      show "False" using 3(3) 5 by simp
    qed

    lemma no_cut_scut:
      assumes "p \<in> nodes" "en a p" "a \<notin> cuts"
      shows "scut\<inverse>\<inverse> (ex a p) p"
      using assms by auto

  end

  locale transition_system_sticky =
    transition_system_complete ex en init int +
    transition_system_cut ex en init sticky
    for ex :: "'action \<Rightarrow> 'state \<Rightarrow> 'state"
    and en :: "'action \<Rightarrow> 'state \<Rightarrow> bool"
    and init :: "'state \<Rightarrow> bool"
    and int :: "'state \<Rightarrow> 'interpretation"
    and sticky :: "'action set"
    +
    assumes executable_visible_sticky: "executable \<inter> visible \<subseteq> sticky"

end


(*  Title:       BDD

    Author:      Veronika Ortner and Norbert Schirmer, 2004
    Maintainer:  Norbert Schirmer,  norbert.schirmer at web de
    License:     LGPL
*)

(*
RepointProof.thy

Copyright (C) 2004-2008 Veronika Ortner and Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* Proof of Procedure Repoint *}
theory RepointProof imports ProcedureSpecs begin

hide_const (open) DistinctTreeProver.set_of tree.Node tree.Tip

lemma (in Repoint_impl) Repoint_modifies:
  shows "\<forall>\<sigma>. \<Gamma>\<turnstile>{\<sigma>} \<acute>p :==  PROC Repoint (\<acute>p)
        {t. t may_only_modify_globals \<sigma> in [low,high]}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma low_high_exchange_dag:
assumes pt_same: "\<forall>pt. pt \<notin> set_of lt \<longrightarrow> low pt = lowa pt \<and> high pt = higha pt"
assumes pt_changed: "\<forall>pt \<in> set_of lt. lowa pt = (rep \<propto> low) pt \<and>
                            higha pt = (rep \<propto> high) pt"
assumes rep_pt: "\<forall>pt \<in> set_of rt. rep pt = pt"
shows "\<And>q.  Dag q (rep \<propto> low) (rep \<propto> high) rt \<Longrightarrow>
            Dag q (rep \<propto> lowa) (rep \<propto> higha) rt"
using rep_pt
proof (induct rt)
  case Tip thus ?case by simp
next
  case (Node lrt q' rrt)
  have "Dag q (rep \<propto> low) (rep \<propto> high) (Node lrt q' rrt)" by fact
  then obtain
    q': "q = q'"  and
    q_notNull: "q \<noteq> Null" and
    lrt: "Dag ((rep \<propto> low) q) (rep \<propto> low) (rep \<propto> high) lrt" and
    rrt: "Dag ((rep \<propto> high) q) (rep \<propto> low) (rep \<propto> high) rrt"
    by auto
  have rlowa_rlow: "((rep \<propto> lowa) q) = ((rep \<propto> low) q)"
  proof (cases "q \<in> set_of lt")
    case True
    note q_in_lt=this
    with pt_changed have lowa_q: "lowa q = (rep \<propto> low) q"
      by simp
    thus "(rep \<propto> lowa) q = (rep \<propto> low) q"
    proof (cases "low q = Null")
      case True
      with lowa_q have "lowa q = Null"
        by (simp add: null_comp_def)
      with True show ?thesis
        by (simp add: null_comp_def)
    next
      assume lq_nNull: "low q \<noteq> Null"
      show ?thesis
      proof (cases "(rep \<propto> low) q = Null")
        case True
        with lowa_q have "lowa q = Null"
          by simp
        with True show ?thesis
          by (simp add: null_comp_def)
      next
        assume rlq_nNull: "(rep \<propto> low) q \<noteq> Null"
        with lrt lowa_q have "lowa q \<in> set_of lrt"
          by auto
        with Node.prems Node have "lowa q \<in> set_of (Node lrt q' rrt)"
          by simp
        with Node.prems have "rep (lowa q) = lowa q"
          by auto
        with lowa_q rlq_nNull show ?thesis
          by (simp add: null_comp_def)
      qed
    qed
  next
    assume q_notin_lt: " q \<notin> set_of lt"
    with pt_same have "low q = lowa q"
      by auto
    thus ?thesis
      by (simp add: null_comp_def)
  qed
  have rhigha_rhigh: "((rep \<propto> higha) q) = ((rep \<propto> high) q)"
  proof (cases "q \<in> set_of lt")
    case True
    note q_in_lt=this
    with pt_changed have higha_q: "higha q = (rep \<propto> high) q"
      by simp
    thus ?thesis
    proof (cases "high q = Null")
      case True
      with higha_q have "higha q = Null"
        by (simp add: null_comp_def)
      with True show ?thesis
        by (simp add: null_comp_def)
    next
      assume hq_nNull: "high q \<noteq> Null"
      show ?thesis
      proof (cases "(rep \<propto> high) q = Null")
        case True
        with higha_q have "higha q = Null"
          by simp
        with True show ?thesis
          by (simp add: null_comp_def)
      next
        assume rhq_nNull: "(rep \<propto> high) q \<noteq> Null"
        with rrt higha_q have "higha q \<in> set_of rrt"
          by auto
        with Node.prems Node have "higha q \<in> set_of (Node lrt q' rrt)"
          by simp
        with Node.prems have "rep (higha q) = higha q"
          by auto
        with higha_q rhq_nNull show ?thesis
          by (simp add: null_comp_def)
      qed
    qed
  next
    assume q_notin_lt: " q \<notin> set_of lt"
    with pt_same have "high q = higha q"
      by auto
    thus ?thesis
      by (simp add: null_comp_def)
  qed
  with rrt have rhigha_mixed_dag:
    "Dag ((rep \<propto> higha) q) (rep \<propto> low) (rep \<propto> high) rrt"
    by simp
  from lrt rlowa_rlow have rlowa_mixed_dag:
    " Dag ((rep \<propto> lowa) q) (rep \<propto> low) (rep \<propto> high) lrt"
    by simp
  from Node.prems have lrt_rep_eq: " \<forall>pt\<in>set_of lrt. rep pt = pt"
    by simp
  from Node.prems have rrt_rep_eq: "\<forall>pt\<in>set_of rrt. rep pt = pt"
    by simp
  from rlowa_mixed_dag lrt_rep_eq have lowa_lrt:
    " Dag ((rep \<propto> lowa) q) (rep \<propto> lowa) (rep \<propto> higha) lrt"
    apply -
    apply (rule Node.hyps)
    apply auto
    done
  from rhigha_mixed_dag rrt_rep_eq have higha_rrt:
    " Dag ((rep \<propto> higha) q) (rep \<propto> lowa) (rep \<propto> higha) rrt"
    apply -
    apply (rule Node.hyps)
    apply auto
    done
  with lowa_lrt q' q_notNull
  show " Dag q (rep \<propto> lowa) (rep \<propto> higha) (Node lrt q' rrt)"
    by simp
qed

(*lemma Repoint_spec :
includes Repoint_impl
shows
  "\<forall>\<sigma> rept. \<Gamma>\<turnstile> \<lbrace>\<sigma>. (Dag ((\<^bsup>\<sigma>\<^esup>rep \<propto> id) \<^bsup>\<sigma>\<^esup>p) (\<^bsup>\<sigma>\<^esup>rep \<propto> \<^bsup>\<sigma>\<^esup>low) (\<^bsup>\<sigma>\<^esup>rep \<propto> \<^bsup>\<sigma>\<^esup>high) rept)
  \<and> (\<forall> no \<in> set_of rept. \<^bsup>\<sigma>\<^esup>rep no = no) \<rbrace>
  \<acute>p :== CALL Repoint (\<acute>p)
  \<lbrace>Dag \<acute>p \<acute>low \<acute>high rept \<and>
  (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> \<^bsup>\<sigma>\<^esup>low pt = \<acute>low pt \<and> \<^bsup>\<sigma>\<^esup>high pt = \<acute>high pt)\<rbrace>"
apply (hoare_rule CallRec1_SamePost)
apply (vcg)
apply  (rule conjI)
apply  clarify
prefer 2
apply (intro impI allI )
apply (simp add: null_comp_def)
apply (rule conjI)
prefer 2
apply (clarsimp)
apply clarify
*)

lemma (in Repoint_impl) Repoint_spec':
shows
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>}
  \<acute>p :== PROC Repoint (\<acute>p)
  \<lbrace>\<forall> rept. ((Dag ((\<^bsup>\<sigma>\<^esup>rep \<propto> id) \<^bsup>\<sigma>\<^esup>p) (\<^bsup>\<sigma>\<^esup>rep \<propto> \<^bsup>\<sigma>\<^esup>low) (\<^bsup>\<sigma>\<^esup>rep \<propto> \<^bsup>\<sigma>\<^esup>high) rept)
  \<and> (\<forall> no \<in> set_of rept. \<^bsup>\<sigma>\<^esup>rep no = no))
  \<longrightarrow> Dag \<acute>p \<acute>low \<acute>high rept \<and>
  (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> \<^bsup>\<sigma>\<^esup>low pt = \<acute>low pt \<and> \<^bsup>\<sigma>\<^esup>high pt = \<acute>high pt)\<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply vcg
apply  (rule conjI)
apply  clarify
prefer 2
apply (intro impI allI )
apply (simp add: null_comp_def)
apply (rule conjI)
prefer 2
apply (clarsimp)
apply clarify
proof -
  fix low high p rep lowa higha pa lowb highb pb rept
  assume p_nNull: "p \<noteq> Null"
  assume rp_nNull: " rep p \<noteq> Null"
  assume rec_spec_lrept:
    "\<forall>rept. Dag ((rep \<propto> id) (low (rep p))) (rep \<propto> low) (rep \<propto> high) rept
    \<and> (\<forall>no\<in>set_of rept. rep no = no)
    \<longrightarrow> Dag pa lowa higha rept \<and>
        (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> low pt = lowa pt \<and> high pt = higha pt)"
  assume rec_spec_rrept:
    "\<forall>rept. Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rept
    \<and> (\<forall>no\<in>set_of rept. rep no = no)
    \<longrightarrow> Dag pb lowb highb rept \<and>
        (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> (lowa(rep p := pa)) pt = lowb pt \<and> higha pt = highb pt)"
  assume rept_dag: "Dag ((rep \<propto> id) p) (rep \<propto> low) (rep \<propto> high) rept"
  assume rno_rept: "\<forall>no\<in>set_of rept. rep no = no"
  show " Dag (rep p) lowb (highb(rep p := pb)) rept \<and>
    (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> low pt = lowb pt \<and> high pt = (highb(rep p := pb)) pt)"
  proof -
    from rp_nNull rept_dag p_nNull obtain lrept rrept where
      rept_def: "rept = Node lrept (rep p) rrept"
      by auto
    with rept_dag p_nNull have lrept_dag:
      "Dag ((rep \<propto> low) (rep p)) (rep \<propto> low) (rep \<propto> high) lrept"
      by simp
    from rept_def rept_dag p_nNull have rrept_dag:
      "Dag ((rep \<propto> high) (rep p)) (rep \<propto> low) (rep \<propto> high) rrept"
      by simp
    from rno_rept rept_def have rno_lrept: "\<forall> no \<in> set_of lrept. rep no = no"
      by auto
    from rno_rept rept_def have rno_rrept: "\<forall> no \<in> set_of rrept. rep no = no"
      by auto
    have repoint_post_low:
      " Dag pa lowa higha lrept \<and>
      (\<forall>pt. pt \<notin> set_of lrept \<longrightarrow> low pt = lowa pt \<and> high pt = higha pt)"
    proof -
      from lrept_dag have " Dag ((rep \<propto> id) (low (rep p))) (rep \<propto> low) (rep \<propto> high) lrept"
        by (simp add: id_trans)
      with  rec_spec_lrept rno_lrept show ?thesis
        apply -
        apply (erule_tac x=lrept in allE)
        apply (erule impE)
        apply simp
        apply assumption
        done
    qed
    hence low_lowa_nc: "(\<forall>pt. pt \<notin> set_of lrept \<longrightarrow> low pt = lowa pt \<and> high pt = higha pt)"
      by simp
    from lrept_dag  repoint_post_low obtain
      pa_def: "pa = (rep \<propto> low) (rep p)" and
      lowa_higha_def: "(\<forall> no \<in> set_of lrept. lowa no = (rep \<propto> low) no \<and> higha no = (rep \<propto> high) no)"
      apply -
      apply (drule Dags_eq_hp_eq)
      apply auto
      done
    from rept_dag have rept_DAG: "DAG rept"
      by (rule Dag_is_DAG)
    with rept_def have rp_notin_lrept: "rep p \<notin> set_of lrept"
      by simp
    from rept_DAG rept_def have rp_notin_rrept: "rep p \<notin> set_of rrept"
      by simp
    have "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rrept"
    proof -
      from low_lowa_nc rp_notin_lrept have "(rep \<propto> high) (rep p) = (rep \<propto> higha) (rep p)"
        by (auto simp add: null_comp_def)
      with rrept_dag have higha_mixed_rrept:
        "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> low) (rep \<propto> high) rrept"
        by (simp add: id_trans)
      thm low_high_exchange_dag
      with low_lowa_nc lowa_higha_def rno_rrept have lowa_higha_rrept:
        "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa) (rep \<propto> higha) rrept"
        apply -
        apply (rule low_high_exchange_dag)
        apply auto
        done
      have "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa) (rep \<propto> higha) rrept =
        Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rrept"
      proof -
        have "\<forall> no \<in> set_of rrept. (rep \<propto> lowa) no = (rep \<propto> lowa(rep p := pa)) no \<and>
          (rep \<propto> higha) no = (rep \<propto> higha) no"
        proof
          fix no
          assume no_in_rrept: "no \<in> set_of rrept"
          with rp_notin_rrept have "no \<noteq> rep p"
            by blast
          thus "(rep \<propto> lowa) no = (rep \<propto> lowa(rep p := pa)) no \<and>
            (rep \<propto> higha) no = (rep \<propto> higha) no"
            by (simp add: null_comp_def)
        qed
        thus ?thesis
          by (rule heaps_eq_Dag_eq)
      qed
      with lowa_higha_rrept show ?thesis
        by simp
    qed
    with rec_spec_rrept rno_rrept have repoint_rrept: "Dag pb lowb highb rrept \<and>
      (\<forall>pt. pt \<notin> set_of rrept \<longrightarrow>
      (lowa(rep p := pa)) pt = lowb pt \<and> higha pt = highb pt)"
      apply -
      apply (erule_tac x=rrept in allE)
      apply (erule impE)
      apply simp
      apply assumption
      done
    then have ab_nc: "(\<forall>pt. pt \<notin> set_of rrept \<longrightarrow>
      (lowa(rep p := pa)) pt = lowb pt \<and> higha pt = highb pt)"
      by simp
    from repoint_rrept rrept_dag obtain
      pb_def: "pb = ((rep \<propto> high) (rep p))" and
      lowb_highb_def: "(\<forall> no \<in> set_of rrept. lowb no = (rep \<propto> low) no \<and> highb no = (rep \<propto> high) no)"
      apply -
      apply (drule Dags_eq_hp_eq)
      apply auto
      done
    have rept_end_dag: " Dag (rep p) lowb (highb(rep p := pb)) rept"
    proof -
      have "\<forall> no \<in> set_of rept. lowb no = (rep \<propto> low) no \<and> (highb(rep p := pb)) no = (rep \<propto> high) no"
      proof
        fix no
        assume no_in_rept: " no \<in> set_of rept"
        show "lowb no = (rep \<propto> low) no \<and> (highb(rep p := pb)) no = (rep \<propto> high) no"
        proof (cases "no \<in> set_of rrept")
          case True
          with lowb_highb_def pb_def show ?thesis
            by simp
        next
          assume no_notin_rrept: " no \<notin> set_of rrept"
          show ?thesis
          proof (cases "no \<in> set_of lrept")
            case True
            with no_notin_rrept rp_notin_lrept ab_nc
            have ab_nc_no: "lowa no = lowb no \<and> higha no = highb no"
              apply -
              apply (erule_tac x=no in allE)
              apply (erule impE)
              apply simp
              apply (subgoal_tac "no \<noteq> rep p")
              apply simp
              apply blast
              done
            from lowa_higha_def True have
              "lowa no = (rep \<propto> low) no \<and> higha no = (rep \<propto> high) no"
              by auto
            with ab_nc_no have "lowb no = (rep \<propto> low) no \<and> highb no =(rep \<propto> high) no"
              by simp
            with rp_notin_lrept True show ?thesis
              apply (subgoal_tac "no \<noteq> rep p")
              apply simp
              apply blast
              done
          next
            assume no_notin_lrept: " no \<notin> set_of lrept"
            with no_in_rept rept_def no_notin_rrept have no_rp: "no = rep p"
              by simp
            with rp_notin_lrept low_lowa_nc have a_nc:
              "low no = lowa no \<and> high no = higha no"
              by auto
            from rp_notin_rrept no_rp ab_nc have
              "(lowa(rep p := pa)) no = lowb no \<and> higha no = highb no"
              by auto
            with a_nc pa_def no_rp have "(rep \<propto> low) no = lowb no \<and> high no = highb no"
              by auto
            with pb_def no_rp show ?thesis
              by simp
          qed
        qed
      qed
      with rept_dag have " Dag (rep p) lowb (highb(rep p := pb)) rept =
        Dag (rep p) (rep \<propto> low) (rep \<propto> high) rept"
        apply -
        thm heaps_eq_Dag_eq
        apply (rule heaps_eq_Dag_eq)
        apply auto
        done
      with rept_dag p_nNull show ?thesis
        by simp
    qed
    have "(\<forall>pt. pt \<notin> set_of rept \<longrightarrow> low pt = lowb pt \<and> high pt = (highb(rep p := pb)) pt)"
    proof (intro allI impI)
      fix pt
      assume pt_notin_rept: "pt \<notin> set_of rept"
      with rept_def obtain
        pt_notin_lrept: "pt \<notin> set_of lrept" and
        pt_notin_rrept: "pt \<notin> set_of rrept" and
        pt_neq_rp: "pt \<noteq> rep p"
        by simp
      with low_lowa_nc ab_nc show "low pt = lowb pt \<and> high pt = (highb(rep p := pb)) pt"
        by auto
    qed
    with rept_end_dag show ?thesis
      by simp
  qed
qed

lemma (in Repoint_impl) Repoint_spec:
shows
  "\<forall>\<sigma> rept. \<Gamma>\<turnstile> \<lbrace>\<sigma>. Dag ((\<acute>rep \<propto> id) \<acute>p) (\<acute>rep \<propto> \<acute>low) (\<acute>rep \<propto> \<acute>high) rept
  \<and> (\<forall> no \<in> set_of rept. \<acute>rep no = no) \<rbrace>
  \<acute>p :== PROC Repoint (\<acute>p)
  \<lbrace>Dag \<acute>p \<acute>low \<acute>high rept \<and>
  (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> \<^bsup>\<sigma>\<^esup>low pt = \<acute>low pt \<and> \<^bsup>\<sigma>\<^esup>high pt = \<acute>high pt)\<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply vcg
apply (rule conjI)
prefer 2
apply  (clarsimp simp add: null_comp_def)
apply clarify
apply (rule conjI)
prefer 2
apply  clarsimp
apply clarify
proof -
  fix rept low high rep p
  assume rept_dag: "Dag ((rep \<propto> id) p) (rep \<propto> low) (rep \<propto> high) rept"
  assume rno_rept: "\<forall>no\<in>set_of rept. rep no = no"
  assume p_nNull: "p \<noteq> Null"
  assume rp_nNull: " rep p \<noteq> Null"
  show "\<exists>lrept.
             Dag ((rep \<propto> id) (low (rep p))) (rep \<propto> low) (rep \<propto> high) lrept \<and>
             (\<forall>no\<in>set_of lrept. rep no = no) \<and>
             (\<forall>lowa higha pa.
                 Dag pa lowa higha lrept \<and>
                 (\<forall>pt. pt \<notin> set_of lrept \<longrightarrow>
                       low pt = lowa pt \<and> high pt = higha pt) \<longrightarrow>
                 (\<exists>rrept.
                     Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa(rep p := pa))
                      (rep \<propto> higha) rrept \<and>
                     (\<forall>no\<in>set_of rrept. rep no = no) \<and>
                     (\<forall>lowb highb pb.
                         Dag pb lowb highb rrept \<and>
                         (\<forall>pt. pt \<notin> set_of rrept \<longrightarrow>
                               (lowa(rep p := pa)) pt = lowb pt \<and>
                               higha pt = highb pt) \<longrightarrow>
                         Dag (rep p) lowb (highb(rep p := pb)) rept \<and>
                         (\<forall>pt. pt \<notin> set_of rept \<longrightarrow>
                               low pt = lowb pt \<and>
                               high pt = (highb(rep p := pb)) pt))))"
  proof -
    from rp_nNull rept_dag p_nNull obtain lrept rrept where
      rept_def: "rept = Node lrept (rep p) rrept"
      by auto
    with rept_dag p_nNull have lrept_dag:
      "Dag ((rep \<propto> low) (rep p)) (rep \<propto> low) (rep \<propto> high) lrept"
      by simp
    from rept_def rept_dag p_nNull have rrept_dag:
      "Dag ((rep \<propto> high) (rep p)) (rep \<propto> low) (rep \<propto> high) rrept"
      by simp
    from rno_rept rept_def have rno_lrept: "\<forall> no \<in> set_of lrept. rep no = no"
      by auto
    from rno_rept rept_def have rno_rrept: "\<forall> no \<in> set_of rrept. rep no = no"
      by auto
    show ?thesis
      apply (rule_tac x=lrept in exI)
      apply (rule conjI)
      apply  (simp add: id_trans lrept_dag)
      apply (rule conjI)
      apply (rule rno_lrept)
      apply clarify
    proof -
      case (goal1 lowa higha pa)
      have lrepta: "Dag pa lowa higha lrept" by fact
      have low_lowa_nc:
        "\<forall>pt. pt \<notin> set_of lrept \<longrightarrow> low pt = lowa pt \<and> high pt = higha pt" by fact
      from lrept_dag lrepta  obtain
        pa_def: "pa = (rep \<propto> low) (rep p)" and
        lowa_higha_def: "\<forall>no \<in> set_of lrept.
        lowa no = (rep \<propto> low) no \<and> higha no = (rep \<propto> high) no"
        apply -
        apply (drule Dags_eq_hp_eq)
        apply auto
        done
      from rept_dag have rept_DAG: "DAG rept"
        by (rule Dag_is_DAG)
      with rept_def have rp_notin_lrept: "rep p \<notin> set_of lrept"
        by simp
      from rept_DAG rept_def have rp_notin_rrept: "rep p \<notin> set_of rrept"
        by simp
      have rrepta: "Dag ((rep \<propto> id) (higha (rep p)))
                       (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rrept"
      proof -
        from low_lowa_nc rp_notin_lrept
        have "(rep \<propto> high) (rep p) = (rep \<propto> higha) (rep p)"
          by (auto simp add: null_comp_def)
        with rrept_dag have higha_mixed_rrept:
          "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> low) (rep \<propto> high) rrept"
          by (simp add: id_trans)
        thm low_high_exchange_dag
        with low_lowa_nc lowa_higha_def rno_rrept
        have lowa_higha_rrept:
            "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa) (rep \<propto> higha) rrept"
          apply -
          apply (rule low_high_exchange_dag)
          apply auto
          done
        have "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa) (rep \<propto> higha) rrept =
              Dag ((rep \<propto> id) (higha (rep p)))
                      (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rrept"
        proof -
          have "\<forall>no \<in> set_of rrept.
                    (rep \<propto> lowa) no = (rep \<propto> lowa(rep p := pa)) no \<and>
                    (rep \<propto> higha) no = (rep \<propto> higha) no"
          proof
            fix no
            assume no_in_rrept: "no \<in> set_of rrept"
            with rp_notin_rrept have "no \<noteq> rep p"
              by blast
            thus "(rep \<propto> lowa) no = (rep \<propto> lowa(rep p := pa)) no \<and>
              (rep \<propto> higha) no = (rep \<propto> higha) no"
              by (simp add: null_comp_def)
          qed
          thus ?thesis
            by (rule heaps_eq_Dag_eq)
        qed
        with lowa_higha_rrept show ?thesis
          by simp
      qed
      show ?case
        apply (rule_tac x=rrept in exI)
        apply (rule conjI)
        apply  (rule rrepta)
        apply (rule conjI)
        apply  (rule rno_rrept)
        apply clarify
      proof -
        case (goal1 lowb highb pb)
        have rreptb: "Dag pb lowb highb rrept" by fact
        have ab_nc: "\<forall>pt. pt \<notin> set_of rrept \<longrightarrow>
                        (lowa(rep p := pa)) pt = lowb pt \<and> higha pt = highb pt" by fact
        from rreptb rrept_dag obtain
          pb_def: "pb = ((rep \<propto> high) (rep p))" and
          lowb_highb_def: "\<forall>no \<in> set_of rrept.
                              lowb no = (rep \<propto> low) no \<and> highb no = (rep \<propto> high) no"
          apply -
          apply (drule Dags_eq_hp_eq)
          apply auto
          done
        have rept_end_dag: " Dag (rep p) lowb (highb(rep p := pb)) rept"
        proof -
          have "\<forall>no \<in> set_of rept.
                lowb no = (rep \<propto> low) no \<and> (highb(rep p := pb)) no = (rep \<propto> high) no"
          proof
            fix no
            assume no_in_rept: " no \<in> set_of rept"
            show "lowb no = (rep \<propto> low) no \<and>
                  (highb(rep p := pb)) no = (rep \<propto> high) no"
            proof (cases "no \<in> set_of rrept")
              case True
              with lowb_highb_def pb_def show ?thesis
                by simp
            next
              assume no_notin_rrept: " no \<notin> set_of rrept"
              show ?thesis
              proof (cases "no \<in> set_of lrept")
                case True
                with no_notin_rrept rp_notin_lrept ab_nc
                have ab_nc_no: "lowa no = lowb no \<and> higha no = highb no"
                  apply -
                  apply (erule_tac x=no in allE)
                  apply (erule impE)
                  apply simp
                  apply (subgoal_tac "no \<noteq> rep p")
                  apply simp
                  apply blast
                  done
                from lowa_higha_def True have
                  "lowa no = (rep \<propto> low) no \<and> higha no = (rep \<propto> high) no"
                  by auto
                with ab_nc_no
                have "lowb no = (rep \<propto> low) no \<and> highb no =(rep \<propto> high) no"
                  by simp
                with rp_notin_lrept True show ?thesis
                  apply (subgoal_tac "no \<noteq> rep p")
                  apply simp
                  apply blast
                  done
              next
                assume no_notin_lrept: " no \<notin> set_of lrept"
                with no_in_rept rept_def no_notin_rrept have no_rp: "no = rep p"
                  by simp
                with rp_notin_lrept low_lowa_nc
                have a_nc: "low no = lowa no \<and> high no = higha no"
                  by auto
                from rp_notin_rrept no_rp ab_nc
                have "(lowa(rep p := pa)) no = lowb no \<and> higha no = highb no"
                  by auto
                with a_nc pa_def no_rp
                have "(rep \<propto> low) no = lowb no \<and> high no = highb no"
                  by auto
                with pb_def no_rp show ?thesis
                  by simp
              qed
            qed
          qed
          with rept_dag
          have "Dag (rep p) lowb (highb(rep p := pb)) rept =
                Dag (rep p) (rep \<propto> low) (rep \<propto> high) rept"
            apply -
            apply (rule heaps_eq_Dag_eq)
            apply auto
            done
          with rept_dag p_nNull show ?thesis
            by simp
        qed
        have "(\<forall>pt. pt \<notin> set_of rept \<longrightarrow> low pt = lowb pt \<and>
                    high pt = (highb(rep p := pb)) pt)"
        proof (intro allI impI)
          fix pt
          assume pt_notin_rept: "pt \<notin> set_of rept"
          with rept_def obtain
            pt_notin_lrept: "pt \<notin> set_of lrept" and
            pt_notin_rrept: "pt \<notin> set_of rrept" and
            pt_neq_rp: "pt \<noteq> rep p"
            by simp
          with low_lowa_nc ab_nc
          show "low pt = lowb pt \<and> high pt = (highb(rep p := pb)) pt"
            by auto
        qed
        with rept_end_dag show ?case
          by simp
      qed
    qed
  qed
qed

lemma (in Repoint_impl) Repoint_spec_total:
shows
  "\<forall>\<sigma> rept. \<Gamma>\<turnstile>\<^sub>t \<lbrace>\<sigma>. Dag ((\<acute>rep \<propto> id) \<acute>p) (\<acute>rep \<propto> \<acute>low) (\<acute>rep \<propto> \<acute>high) rept
  \<and> (\<forall> no \<in> set_of rept. \<acute>rep no = no) \<rbrace>
  \<acute>p :== PROC Repoint (\<acute>p)
  \<lbrace>Dag \<acute>p \<acute>low \<acute>high rept \<and>
  (\<forall>pt. pt \<notin> set_of rept \<longrightarrow> \<^bsup>\<sigma>\<^esup>low pt = \<acute>low pt \<and> \<^bsup>\<sigma>\<^esup>high pt = \<acute>high pt)\<rbrace>"

apply (hoare_rule HoareTotal.ProcRec1
          [where r="measure (\<lambda>(s,p). size
                       (dag ((\<^bsup>s\<^esup>rep \<propto> id) \<^bsup>s\<^esup>p) (\<^bsup>s\<^esup>rep \<propto> \<^bsup>s\<^esup>low) (\<^bsup>s\<^esup>rep \<propto> \<^bsup>s\<^esup>high)))"])
apply vcg
apply (rule conjI)
prefer 2
apply  (clarsimp simp add: null_comp_def)
apply clarify
apply (rule conjI)
prefer 2
apply  clarsimp
apply clarify
proof -
  fix rept low high rep p
  assume rept_dag: "Dag ((rep \<propto> id) p) (rep \<propto> low) (rep \<propto> high) rept"
  assume rno_rept: "\<forall>no\<in>set_of rept. rep no = no"
  assume p_nNull: "p \<noteq> Null"
  assume rp_nNull: " rep p \<noteq> Null"
  show "\<exists>lrept.
             Dag ((rep \<propto> id) (low (rep p))) (rep \<propto> low) (rep \<propto> high) lrept \<and>
             (\<forall>no\<in>set_of lrept. rep no = no) \<and>
             size (dag ((rep \<propto> id) (low (rep p))) (rep \<propto> low) (rep \<propto> high))
             < size (dag ((rep \<propto> id) p) (rep \<propto> low) (rep \<propto> high)) \<and>
             (\<forall>lowa higha pa.
                 Dag pa lowa higha lrept \<and>
                 (\<forall>pt. pt \<notin> set_of lrept \<longrightarrow>
                       low pt = lowa pt \<and> high pt = higha pt) \<longrightarrow>
                 (\<exists>rrept.
                     Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa(rep p := pa))
                      (rep \<propto> higha) rrept \<and>
                     (\<forall>no\<in>set_of rrept. rep no = no) \<and>
                     size (dag ((rep \<propto> id) (higha (rep p)))
                            (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha))
                     < size (dag ((rep \<propto> id) p) (rep \<propto> low) (rep \<propto> high)) \<and>
                     (\<forall>lowb highb pb.
                         Dag pb lowb highb rrept \<and>
                         (\<forall>pt. pt \<notin> set_of rrept \<longrightarrow>
                               (lowa(rep p := pa)) pt = lowb pt \<and>
                               higha pt = highb pt) \<longrightarrow>
                         Dag (rep p) lowb (highb(rep p := pb)) rept \<and>
                         (\<forall>pt. pt \<notin> set_of rept \<longrightarrow>
                               low pt = lowb pt \<and>
                               high pt = (highb(rep p := pb)) pt))))"
  proof -
    from rp_nNull rept_dag p_nNull obtain lrept rrept where
      rept_def: "rept = Node lrept (rep p) rrept"
      by auto
    with rept_dag p_nNull have lrept_dag:
      "Dag ((rep \<propto> low) (rep p)) (rep \<propto> low) (rep \<propto> high) lrept"
      by simp
    from rept_def rept_dag p_nNull have rrept_dag:
      "Dag ((rep \<propto> high) (rep p)) (rep \<propto> low) (rep \<propto> high) rrept"
      by simp
    from rno_rept rept_def have rno_lrept: "\<forall> no \<in> set_of lrept. rep no = no"
      by auto
    from rno_rept rept_def have rno_rrept: "\<forall> no \<in> set_of rrept. rep no = no"
      by auto
    show ?thesis
      apply (rule_tac x=lrept in exI)
      apply (rule conjI)
      apply  (simp add: id_trans lrept_dag)
      apply (rule conjI)
      apply (rule rno_lrept)
      apply (rule conjI)
      using rept_dag rept_def
      apply  (simp only: Dag_dag)
      apply  (clarsimp simp add: id_trans Dag_dag)
      apply clarify
    proof -
      case (goal1 lowa higha pa)
      have lrepta: "Dag pa lowa higha lrept" by fact
      have low_lowa_nc:
        "\<forall>pt. pt \<notin> set_of lrept \<longrightarrow> low pt = lowa pt \<and> high pt = higha pt" by fact
      from lrept_dag lrepta  obtain
        pa_def: "pa = (rep \<propto> low) (rep p)" and
        lowa_higha_def: "\<forall>no \<in> set_of lrept.
        lowa no = (rep \<propto> low) no \<and> higha no = (rep \<propto> high) no"
        apply -
        apply (drule Dags_eq_hp_eq)
        apply auto
        done
      from rept_dag have rept_DAG: "DAG rept"
        by (rule Dag_is_DAG)
      with rept_def have rp_notin_lrept: "rep p \<notin> set_of lrept"
        by simp
      from rept_DAG rept_def have rp_notin_rrept: "rep p \<notin> set_of rrept"
        by simp
      have rrepta: "Dag ((rep \<propto> id) (higha (rep p)))
                       (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rrept"
      proof -
        from low_lowa_nc rp_notin_lrept
        have "(rep \<propto> high) (rep p) = (rep \<propto> higha) (rep p)"
          by (auto simp add: null_comp_def)
        with rrept_dag have higha_mixed_rrept:
          "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> low) (rep \<propto> high) rrept"
          by (simp add: id_trans)
        thm low_high_exchange_dag
        with low_lowa_nc lowa_higha_def rno_rrept
        have lowa_higha_rrept:
            "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa) (rep \<propto> higha) rrept"
          apply -
          apply (rule low_high_exchange_dag)
          apply auto
          done
        have "Dag ((rep \<propto> id) (higha (rep p))) (rep \<propto> lowa) (rep \<propto> higha) rrept =
              Dag ((rep \<propto> id) (higha (rep p)))
                      (rep \<propto> lowa(rep p := pa)) (rep \<propto> higha) rrept"
        proof -
          have "\<forall>no \<in> set_of rrept.
                    (rep \<propto> lowa) no = (rep \<propto> lowa(rep p := pa)) no \<and>
                    (rep \<propto> higha) no = (rep \<propto> higha) no"
          proof
            fix no
            assume no_in_rrept: "no \<in> set_of rrept"
            with rp_notin_rrept have "no \<noteq> rep p"
              by blast
            thus "(rep \<propto> lowa) no = (rep \<propto> lowa(rep p := pa)) no \<and>
              (rep \<propto> higha) no = (rep \<propto> higha) no"
              by (simp add: null_comp_def)
          qed
          thus ?thesis
            by (rule heaps_eq_Dag_eq)
        qed
        with lowa_higha_rrept show ?thesis
          by simp
      qed
      show ?case
        apply (rule_tac x=rrept in exI)
        apply (rule conjI)
        apply  (rule rrepta)
        apply (rule conjI)
        apply  (rule rno_rrept)
        apply (rule conjI)
        using rept_dag rept_def rrepta
        apply  (simp only: Dag_dag)
        apply  (clarsimp simp add: id_trans Dag_dag)
        apply clarify
      proof -
        case (goal1 lowb highb pb)
        have rreptb: "Dag pb lowb highb rrept" by fact
        have ab_nc: "\<forall>pt. pt \<notin> set_of rrept \<longrightarrow>
                        (lowa(rep p := pa)) pt = lowb pt \<and> higha pt = highb pt" by fact
        from rreptb rrept_dag obtain
          pb_def: "pb = ((rep \<propto> high) (rep p))" and
          lowb_highb_def: "\<forall>no \<in> set_of rrept.
                              lowb no = (rep \<propto> low) no \<and> highb no = (rep \<propto> high) no"
          apply -
          apply (drule Dags_eq_hp_eq)
          apply auto
          done
        have rept_end_dag: " Dag (rep p) lowb (highb(rep p := pb)) rept"
        proof -
          have "\<forall>no \<in> set_of rept.
                lowb no = (rep \<propto> low) no \<and> (highb(rep p := pb)) no = (rep \<propto> high) no"
          proof
            fix no
            assume no_in_rept: " no \<in> set_of rept"
            show "lowb no = (rep \<propto> low) no \<and>
                  (highb(rep p := pb)) no = (rep \<propto> high) no"
            proof (cases "no \<in> set_of rrept")
              case True
              with lowb_highb_def pb_def show ?thesis
                by simp
            next
              assume no_notin_rrept: " no \<notin> set_of rrept"
              show ?thesis
              proof (cases "no \<in> set_of lrept")
                case True
                with no_notin_rrept rp_notin_lrept ab_nc
                have ab_nc_no: "lowa no = lowb no \<and> higha no = highb no"
                  apply -
                  apply (erule_tac x=no in allE)
                  apply (erule impE)
                  apply simp
                  apply (subgoal_tac "no \<noteq> rep p")
                  apply simp
                  apply blast
                  done
                from lowa_higha_def True have
                  "lowa no = (rep \<propto> low) no \<and> higha no = (rep \<propto> high) no"
                  by auto
                with ab_nc_no
                have "lowb no = (rep \<propto> low) no \<and> highb no =(rep \<propto> high) no"
                  by simp
                with rp_notin_lrept True show ?thesis
                  apply (subgoal_tac "no \<noteq> rep p")
                  apply simp
                  apply blast
                  done
              next
                assume no_notin_lrept: " no \<notin> set_of lrept"
                with no_in_rept rept_def no_notin_rrept have no_rp: "no = rep p"
                  by simp
                with rp_notin_lrept low_lowa_nc
                have a_nc: "low no = lowa no \<and> high no = higha no"
                  by auto
                from rp_notin_rrept no_rp ab_nc
                have "(lowa(rep p := pa)) no = lowb no \<and> higha no = highb no"
                  by auto
                with a_nc pa_def no_rp
                have "(rep \<propto> low) no = lowb no \<and> high no = highb no"
                  by auto
                with pb_def no_rp show ?thesis
                  by simp
              qed
            qed
          qed
          with rept_dag
          have "Dag (rep p) lowb (highb(rep p := pb)) rept =
                Dag (rep p) (rep \<propto> low) (rep \<propto> high) rept"
            apply -
            apply (rule heaps_eq_Dag_eq)
            apply auto
            done
          with rept_dag p_nNull show ?thesis
            by simp
        qed
        have "(\<forall>pt. pt \<notin> set_of rept \<longrightarrow> low pt = lowb pt \<and>
                    high pt = (highb(rep p := pb)) pt)"
        proof (intro allI impI)
          fix pt
          assume pt_notin_rept: "pt \<notin> set_of rept"
          with rept_def obtain
            pt_notin_lrept: "pt \<notin> set_of lrept" and
            pt_notin_rrept: "pt \<notin> set_of rrept" and
            pt_neq_rp: "pt \<noteq> rep p"
            by simp
          with low_lowa_nc ab_nc
          show "low pt = lowb pt \<and> high pt = (highb(rep p := pb)) pt"
            by auto
        qed
        with rept_end_dag show ?case
          by simp
      qed
    qed
  qed
qed

end


(*  Title:    HOL/Library/Conditional_Parametricity.thy
    Author:   Jan Gilcher, Andreas Lochbihler, Dmitriy Traytel, ETH Zürich

A conditional parametricity prover
*)

theory Conditional_Parametricity
imports "MainRLT"
keywords "parametric_constant" :: thy_decl
begin

context includes lifting_syntax begin

qualified definition Rel_match :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "Rel_match R x y = R x y"

named_theorems parametricity_preprocess

lemma bi_unique_Rel_match [parametricity_preprocess]:
  "bi_unique A = Rel_match (A ===> A ===> (=)) (=) (=)"
  unfolding bi_unique_alt_def2 Rel_match_def ..

lemma bi_total_Rel_match [parametricity_preprocess]:
  "bi_total A = Rel_match ((A ===> (=)) ===> (=)) All All"
  unfolding bi_total_alt_def2 Rel_match_def ..

lemma is_equality_Rel: "is_equality A \<Longrightarrow> Transfer.Rel A t t"
  by (fact transfer_raw)

lemma Rel_Rel_match: "Transfer.Rel R x y \<Longrightarrow> Rel_match R x y"
  unfolding Rel_match_def Rel_def .

lemma Rel_match_Rel: "Rel_match R x y \<Longrightarrow> Transfer.Rel R x y"
  unfolding Rel_match_def Rel_def .

lemma Rel_Rel_match_eq: "Transfer.Rel R x y = Rel_match R x y"
  using Rel_Rel_match Rel_match_Rel by fast

lemma Rel_match_app:
  assumes "Rel_match (A ===> B) f g" and "Transfer.Rel A x y"
  shows "Rel_match B (f x) (g y)"
  using assms Rel_match_Rel Rel_app Rel_Rel_match by fast

end

ML_file \<open>conditional_parametricity.ML\<close>

end


(*  Title:      JinjaDCI/Common/WellForm.thy

    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   2003 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory J/WellForm.thy by Tobias Nipkow
*)

section \<open> Generic Well-formedness of programs \<close>

theory WellForm imports TypeRel SystemClasses begin

text \<open>\noindent This theory defines global well-formedness conditions
for programs but does not look inside method bodies.  Hence it works
for both Jinja and JVM programs. Well-typing of expressions is defined
elsewhere (in theory @{text WellType}).

Because Jinja does not have method overloading, its policy for method
overriding is the classical one: \emph{covariant in the result type
but contravariant in the argument types.} This means the result type
of the overriding method becomes more specific, the argument types
become more general.
\<close>

type_synonym 'm wf_mdecl_test = "'m prog \<Rightarrow> cname \<Rightarrow> 'm mdecl \<Rightarrow> bool"

definition wf_fdecl :: "'m prog \<Rightarrow> fdecl \<Rightarrow> bool"
where
  "wf_fdecl P \<equiv> \<lambda>(F,b,T). is_type P T"

definition wf_mdecl :: "'m wf_mdecl_test \<Rightarrow> 'm wf_mdecl_test"
where
  "wf_mdecl wf_md P C \<equiv> \<lambda>(M,b,Ts,T,m).
  (\<forall>T\<in>set Ts. is_type P T) \<and> is_type P T \<and> wf_md P C (M,b,Ts,T,m)"

definition wf_clinit :: "'m mdecl list \<Rightarrow> bool" where
"wf_clinit ms = (\<exists>m. (clinit,Static,[],Void,m)\<in>set ms)"

definition wf_cdecl :: "'m wf_mdecl_test \<Rightarrow> 'm prog \<Rightarrow> 'm cdecl \<Rightarrow> bool"
where
  "wf_cdecl wf_md P  \<equiv>  \<lambda>(C,(D,fs,ms)).
  (\<forall>f\<in>set fs. wf_fdecl P f) \<and>  distinct_fst fs \<and>
  (\<forall>m\<in>set ms. wf_mdecl wf_md P C m) \<and>  distinct_fst ms \<and>
  (C \<noteq> Object \<longrightarrow>
   is_class P D \<and> \<not> P \<turnstile> D \<preceq>\<^sup>* C \<and>
   (\<forall>(M,b,Ts,T,m)\<in>set ms.
      \<forall>D' b' Ts' T' m'. P \<turnstile> D sees M,b':Ts' \<rightarrow> T' = m' in D' \<longrightarrow>
                       b = b' \<and> P \<turnstile> Ts' [\<le>] Ts \<and> P \<turnstile> T \<le> T')) \<and>
  wf_clinit ms"

definition wf_syscls :: "'m prog \<Rightarrow> bool"
where
  "wf_syscls P  \<equiv>  {Object} \<union> sys_xcpts \<subseteq> set(map fst P)"

definition wf_prog :: "'m wf_mdecl_test \<Rightarrow> 'm prog \<Rightarrow> bool"
where
  "wf_prog wf_md P  \<equiv>  wf_syscls P \<and> (\<forall>c \<in> set P. wf_cdecl wf_md P c) \<and> distinct_fst P"

subsection\<open> Well-formedness lemmas \<close>

lemma class_wf:
  "\<lbrakk>class P C = Some c; wf_prog wf_md P\<rbrakk> \<Longrightarrow> wf_cdecl wf_md P (C,c)"
(*<*)by (unfold wf_prog_def class_def) (fast dest: map_of_SomeD)(*>*)

lemma class_Object [simp]:
  "wf_prog wf_md P \<Longrightarrow> \<exists>C fs ms. class P Object = Some (C,fs,ms)"
(*<*)by (unfold wf_prog_def wf_syscls_def class_def)
        (auto simp: map_of_SomeI)
(*>*)

lemma is_class_Object [simp]:
  "wf_prog wf_md P \<Longrightarrow> is_class P Object"
(*<*)by (simp add: is_class_def)(*>*)

lemma is_class_supclass:
assumes wf: "wf_prog wf_md P" and sub: "P \<turnstile> C \<preceq>\<^sup>* D"
shows "is_class P C \<Longrightarrow> is_class P D"
(*<*)
using sub proof(induct)
  case step then show ?case
    by(auto simp:wf_cdecl_def is_class_def dest!:class_wf[OF _ wf] subcls1D)
qed simp
(*>*)

lemma is_class_xcpt:
  "\<lbrakk> C \<in> sys_xcpts; wf_prog wf_md P \<rbrakk> \<Longrightarrow> is_class P C"
(*<*)
by (fastforce intro!: map_of_SomeI
              simp add: wf_prog_def wf_syscls_def is_class_def class_def)
(*>*)

lemma subcls1_wfD:
assumes sub1: "P \<turnstile> C \<prec>\<^sup>1 D" and wf: "wf_prog wf_md P"
shows "D \<noteq> C \<and> (D,C) \<notin> (subcls1 P)\<^sup>+"
(*<*)
proof -
  obtain fs ms where "C \<noteq> Object" and cls: "class P C = \<lfloor>(D, fs, ms)\<rfloor>"
    using subcls1D[OF sub1] by clarify
  then show ?thesis using wf class_wf[OF cls wf] r_into_trancl[OF sub1]
    by(force simp add: wf_cdecl_def reflcl_trancl [THEN sym]
             simp del: reflcl_trancl)
qed
(*>*)

lemma wf_cdecl_supD:
  "\<lbrakk>wf_cdecl wf_md P (C,D,r); C \<noteq> Object\<rbrakk> \<Longrightarrow> is_class P D"
(*<*)by (auto simp: wf_cdecl_def)(*>*)

lemma subcls_asym:
  "\<lbrakk> wf_prog wf_md P; (C,D) \<in> (subcls1 P)\<^sup>+ \<rbrakk> \<Longrightarrow> (D,C) \<notin> (subcls1 P)\<^sup>+"
(*<*)by(erule tranclE; fast dest!: subcls1_wfD intro: trancl_trans)(*>*)

lemma subcls_irrefl:
  "\<lbrakk> wf_prog wf_md P; (C,D) \<in> (subcls1 P)\<^sup>+ \<rbrakk> \<Longrightarrow> C \<noteq> D"
(*<*)by (erule trancl_trans_induct) (auto dest: subcls1_wfD subcls_asym)(*>*)

lemma acyclic_subcls1:
  "wf_prog wf_md P \<Longrightarrow> acyclic (subcls1 P)"
(*<*)by (unfold acyclic_def) (fast dest: subcls_irrefl)(*>*)

lemma wf_subcls1:
  "wf_prog wf_md P \<Longrightarrow> wf ((subcls1 P)\<inverse>)"
(*<*)
proof -
  assume wf: "wf_prog wf_md P"
  have "finite (subcls1 P)" by(rule finite_subcls1)
  then have fin': "finite ((subcls1 P)\<inverse>)" by(subst finite_converse)

  from wf have "acyclic (subcls1 P)" by(rule acyclic_subcls1)
  then have acyc': "acyclic ((subcls1 P)\<inverse>)" by (subst acyclic_converse)

  from fin' acyc' show ?thesis by (rule finite_acyclic_wf)
qed
(*>*)

lemma single_valued_subcls1:
  "wf_prog wf_md G \<Longrightarrow> single_valued (subcls1 G)"
(*<*)
by(auto simp:wf_prog_def distinct_fst_def single_valued_def dest!:subcls1D)
(*>*)

lemma subcls_induct:
  "\<lbrakk> wf_prog wf_md P; \<And>C. \<forall>D. (C,D) \<in> (subcls1 P)\<^sup>+ \<longrightarrow> Q D \<Longrightarrow> Q C \<rbrakk> \<Longrightarrow> Q C"
(*<*)
  (is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
proof -
  assume p: "PROP ?P"
  assume ?A then have wf: "wf_prog wf_md P" by assumption
  have wf':"wf (((subcls1 P)\<^sup>+)\<inverse>)" using wf_trancl[OF wf_subcls1[OF wf]]
    by(simp only: trancl_converse)
  show ?thesis using wf_induct[where a = C and P = Q, OF wf' p] by simp
qed
(*>*)

lemma subcls1_induct_aux:
assumes "is_class P C" and wf: "wf_prog wf_md P" and QObj: "Q Object"
shows
 "\<lbrakk> \<And>C D fs ms.
    \<lbrakk> C \<noteq> Object; is_class P C; class P C = Some (D,fs,ms) \<and>
      wf_cdecl wf_md P (C,D,fs,ms) \<and> P \<turnstile> C \<prec>\<^sup>1 D \<and> is_class P D \<and> Q D\<rbrakk> \<Longrightarrow> Q C \<rbrakk>
  \<Longrightarrow> Q C"
(*<*)
  (is "PROP ?P \<Longrightarrow> _")
proof -
  assume p: "PROP ?P"
  have "class P C \<noteq> None \<longrightarrow> Q C"
  proof(induct rule: subcls_induct[OF wf])
    case (1 C)
    have "class P C \<noteq> None \<Longrightarrow> Q C"
    proof(cases "C = Object")
      case True
      then show ?thesis using QObj by fast
    next
      case False
      assume nNone: "class P C \<noteq> None"
      then have is_cls: "is_class P C" by(simp add: is_class_def)
      obtain D fs ms where cls: "class P C = \<lfloor>(D, fs, ms)\<rfloor>" using nNone by safe
      also have wfC: "wf_cdecl wf_md P (C, D, fs, ms)" by(rule class_wf[OF cls wf])
      moreover have D: "is_class P D" by(rule wf_cdecl_supD[OF wfC False])
      moreover have "P \<turnstile> C \<prec>\<^sup>1 D" by(rule subcls1I[OF cls False])
      moreover have "class P D \<noteq> None" using D by(simp add: is_class_def)
      ultimately show ?thesis using 1 by (auto intro: p[OF False is_cls])
    qed
  then show "class P C \<noteq> None \<longrightarrow> Q C" by simp
  qed
  thus ?thesis using assms by(unfold is_class_def) simp
qed
(*>*)

(* FIXME can't we prove this one directly?? *)
lemma subcls1_induct [consumes 2, case_names Object Subcls]:
  "\<lbrakk> wf_prog wf_md P; is_class P C; Q Object;
    \<And>C D. \<lbrakk>C \<noteq> Object; P \<turnstile> C \<prec>\<^sup>1 D; is_class P D; Q D\<rbrakk> \<Longrightarrow> Q C \<rbrakk>
  \<Longrightarrow> Q C"
(*<*)by (erule (2) subcls1_induct_aux) blast(*>*)

lemma subcls_C_Object:
assumes "class": "is_class P C" and wf: "wf_prog wf_md P"
shows "P \<turnstile> C \<preceq>\<^sup>* Object"
(*<*)
using wf "class"
proof(induct rule: subcls1_induct)
  case Subcls
  then show ?case by(simp add: converse_rtrancl_into_rtrancl)
qed fast
(*>*)

lemma is_type_pTs:
assumes "wf_prog wf_md P" and "(C,S,fs,ms) \<in> set P" and "(M,b,Ts,T,m) \<in> set ms"
shows "set Ts \<subseteq> types P"
(*<*)
proof
  from assms have "wf_mdecl wf_md P C (M,b,Ts,T,m)"
    by (unfold wf_prog_def wf_cdecl_def) auto
  hence "\<forall>t \<in> set Ts. is_type P t" by (unfold wf_mdecl_def) auto
  moreover fix t assume "t \<in> set Ts"
  ultimately have "is_type P t" by blast
  thus "t \<in> types P" ..
qed
(*>*)

lemma wf_supercls_distinct_app:
assumes wf:"wf_prog wf_md P"
  and nObj: "C \<noteq> Object" and cls: "class P C = \<lfloor>(D, fs, ms)\<rfloor>"
  and super: "supercls_lst P (C#Cs)" and dist: "distinct (C#Cs)"
shows "distinct (D#C#Cs)"
proof -
  have "\<not> P \<turnstile> D \<preceq>\<^sup>* C" using subcls1_wfD[OF subcls1I[OF cls nObj] wf]
    by (simp add: rtrancl_eq_or_trancl)
  then show ?thesis using assms by auto
qed

subsection\<open> Well-formedness and method lookup \<close>

lemma sees_wf_mdecl:
assumes wf: "wf_prog wf_md P" and sees: "P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D"
shows "wf_mdecl wf_md P D (M,b,Ts,T,m)"
(*<*)
using wf visible_method_exists[OF sees] proof(cases b)
qed (fastforce simp:wf_cdecl_def dest!:class_wf dest:map_of_SomeD)+
(*>*)

lemma sees_method_mono [rule_format (no_asm)]:
assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C" and wf: "wf_prog wf_md P"
shows "\<forall>D b Ts T m. P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D \<longrightarrow>
     (\<exists>D' Ts' T' m'. P \<turnstile> C' sees M,b:Ts'\<rightarrow>T' = m' in D' \<and> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T)"
(*<*)
  (is "\<forall>D b Ts T m. ?P C D b Ts T m \<longrightarrow> ?Q C' D b Ts T m")
proof(rule disjE[OF rtranclD[OF sub]])
  assume "C' = C"
  then show ?thesis using assms by fastforce
next
  assume "C' \<noteq> C \<and> (C', C) \<in> (subcls1 P)\<^sup>+"
  then have neq: "C' \<noteq> C" and subcls1: "(C', C) \<in> (subcls1 P)\<^sup>+" by simp+
  show ?thesis proof(induct rule: trancl_trans_induct[OF subcls1])
    case (2 x y z)
    then have zy: "\<And>D b Ts T m. ?P z D b Ts T m \<Longrightarrow> ?Q y D b Ts T m" by blast
    have "\<And>D b Ts T m. ?P z D b Ts T m \<Longrightarrow> ?Q x D b Ts T m"
    proof -
      fix D b Ts T m assume P: "?P z D b Ts T m"
      then show "?Q x D b Ts T m" using zy[OF P] 2(2)
        by(fast elim: widen_trans widens_trans)
    qed
    then show ?case by blast
  next
    case (1 x y)
    have "\<And>D b Ts T m. ?P y D b Ts T m \<Longrightarrow> ?Q x D b Ts T m"
    proof -
      fix D b Ts T m assume P: "?P y D b Ts T m"
      then obtain Mm where sees: "P \<turnstile> y sees_methods Mm" and
                           M: "Mm M = \<lfloor>((b, Ts, T, m), D)\<rfloor>"
        by(clarsimp simp:Method_def)
      obtain fs ms where nObj: "x \<noteq> Object" and
                         cls: "class P x = \<lfloor>(y, fs, ms)\<rfloor>"
        using subcls1D[OF 1] by clarsimp
      have x_meth: "P \<turnstile> x sees_methods Mm ++ (map_option (\<lambda>m. (m, x)) \<circ> map_of ms)"
        using sees_methods_rec[OF cls nObj sees] by simp
      show "?Q x D b Ts T m" proof(cases "map_of ms M")
        case None
        then have "\<exists>m'. P \<turnstile> x sees M, b :  Ts\<rightarrow>T = m' in D" using M x_meth
          by(fastforce simp add:Method_def map_add_def split:option.split)
        then show ?thesis by auto
      next
        case (Some a)
        then obtain b' Ts' T' m' where a: "a = (b',Ts',T',m')" by(cases a)
        then have "(\<exists>m' Mm. P \<turnstile> y sees_methods Mm \<and> Mm M = \<lfloor>((b, Ts, T, m'), D)\<rfloor>)
              \<longrightarrow> b' = b \<and> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T"
          using nObj class_wf[OF cls wf] map_of_SomeD[OF Some]
          by(clarsimp simp: wf_cdecl_def Method_def) fast
        then show ?thesis using Some a sees M x_meth
          by(fastforce simp:Method_def map_add_def split:option.split)
      qed
    qed
    then show ?case by simp
  qed
qed
(*>*)

lemma sees_method_mono2:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; wf_prog wf_md P;
     P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D; P \<turnstile> C' sees M,b':Ts'\<rightarrow>T' = m' in D' \<rbrakk>
  \<Longrightarrow> b = b' \<and> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T"
(*<*)by(blast dest:sees_method_mono sees_method_fun)(*>*)

lemma mdecls_visible:
assumes wf: "wf_prog wf_md P" and "class": "is_class P C"
shows "\<And>D fs ms. class P C = Some(D,fs,ms)
         \<Longrightarrow> \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> (\<forall>(M,b,Ts,T,m) \<in> set ms. Mm M = Some((b,Ts,T,m),C))"
(*<*)
using wf "class"
proof (induct rule:subcls1_induct)
  case Object
  with wf have dfst:"distinct_fst ms"
    by (unfold class_def wf_prog_def wf_cdecl_def) (fastforce dest:map_of_SomeD)
  with dfst have "distinct_fst ms"
    by(blast dest: distinct_fst_appendD)
  with Object show ?case by(fastforce intro!: sees_methods_Object map_of_SomeI)
next
  case Subcls
  with wf have dfst:"distinct_fst ms"
    by (unfold class_def wf_prog_def wf_cdecl_def) (fastforce dest:map_of_SomeD)
  with dfst have "distinct_fst ms"
    by(blast dest: distinct_fst_appendD)
  with Subcls show ?case
    by(fastforce elim:sees_methods_rec dest:subcls1D map_of_SomeI
                simp:is_class_def)
qed
(*>*)

lemma mdecl_visible:
assumes wf: "wf_prog wf_md P" and C: "(C,S,fs,ms) \<in> set P" and  m: "(M,b,Ts,T,m) \<in> set ms"
shows "P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in C"
(*<*)
proof -
  from wf C have "class": "class P C = Some (S,fs,ms)"
    by (auto simp add: wf_prog_def class_def is_class_def intro: map_of_SomeI)
  from "class" have "is_class P C" by(auto simp:is_class_def)
  with assms "class" show ?thesis
    by(bestsimp simp:Method_def dest:mdecls_visible)
qed
(*>*)

lemma Call_lemma:
assumes sees: "P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in D" and sub: "P \<turnstile> C' \<preceq>\<^sup>* C" and wf: "wf_prog wf_md P"
shows "\<exists>D' Ts' T' m'.
       P \<turnstile> C' sees M,b:Ts'\<rightarrow>T' = m' in D' \<and> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T \<and> P \<turnstile> C' \<preceq>\<^sup>* D'
       \<and> is_type P T' \<and> (\<forall>T\<in>set Ts'. is_type P T) \<and> wf_md P D' (M,b,Ts',T',m')"
(*<*)
using assms sees_method_mono[OF sub wf sees]
by(fastforce intro:sees_method_decl_above dest:sees_wf_mdecl
             simp: wf_mdecl_def)
(*>*)

lemma wf_prog_lift:
  assumes wf: "wf_prog (\<lambda>P C bd. A P C bd) P"
  and rule:
  "\<And>wf_md C M b Ts C T m bd.
   wf_prog wf_md P \<Longrightarrow>
   P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in C \<Longrightarrow>
   set Ts \<subseteq>  types P \<Longrightarrow>
   bd = (M,b,Ts,T,m) \<Longrightarrow>
   A P C bd \<Longrightarrow>
   B P C bd"
  shows "wf_prog (\<lambda>P C bd. B P C bd) P"
(*<*)
proof -
  have "\<And>c. c\<in>set P \<Longrightarrow> wf_cdecl A P c \<Longrightarrow> wf_cdecl B P c"
  proof -
    fix c assume "c\<in>set P" and "wf_cdecl A P c"
    then show "wf_cdecl B P c"
     using rule[OF wf mdecl_visible[OF wf] is_type_pTs[OF wf]]
     by (auto simp: wf_cdecl_def wf_mdecl_def)
  qed
  then show ?thesis using wf by (clarsimp simp: wf_prog_def)
qed
(*>*)

lemma wf_sees_clinit:
assumes wf:"wf_prog wf_md P" and ex: "class P C = Some a"
shows "\<exists>m. P \<turnstile> C sees clinit,Static:[] \<rightarrow> Void = m in C"
proof -
  from ex obtain D fs ms where "a = (D,fs,ms)" by(cases a)
  then have sP: "(C, D, fs, ms) \<in> set P" using ex map_of_SomeD[of P C a] by(simp add: class_def)
  then have "wf_clinit ms" using assms by(unfold wf_prog_def wf_cdecl_def, auto)
  then obtain m where sm: "(clinit, Static, [], Void, m) \<in> set ms" by (meson wf_clinit_def)
  then have "P \<turnstile> C sees clinit,Static:[] \<rightarrow> Void = m in C"
    using mdecl_visible[OF wf sP sm] by simp
  then show ?thesis by(rule exI)
qed
(*>*)

lemma wf_sees_clinit1:
assumes wf:"wf_prog wf_md P" and ex: "class P C = Some a"
and "P \<turnstile> C sees clinit,b:Ts \<rightarrow> T = m in D"
shows "b = Static \<and> Ts = [] \<and> T = Void \<and> D = C"
proof -
  obtain m' where sees: "P \<turnstile> C sees clinit,Static:[] \<rightarrow> Void = m' in C"
    using wf_sees_clinit[OF wf ex] by clarify
  then show ?thesis using sees wf by (meson assms(3) sees_method_fun)
qed

lemma wf_NonStatic_nclinit:
assumes wf: "wf_prog wf_md P" and meth: "P \<turnstile> C sees M,NonStatic:Ts\<rightarrow>T=(mxs,mxl,ins,xt) in D"
shows "M \<noteq> clinit"
proof -
  from sees_method_is_class[OF meth] obtain a where cls: "class P C = Some a"
    by(clarsimp simp: is_class_def)
  with wf wf_sees_clinit[OF wf cls]
   obtain m where "P \<turnstile> C sees clinit,Static:[]\<rightarrow>Void=m in C" by clarsimp
  with meth show ?thesis by(auto dest: sees_method_fun)
qed

subsection\<open> Well-formedness and field lookup \<close>

lemma wf_Fields_Ex:
assumes wf: "wf_prog wf_md P" and "is_class P C"
shows "\<exists>FDTs. P \<turnstile> C has_fields FDTs"
(*<*)
using assms proof(induct rule:subcls1_induct)
  case Object
  then show ?case using class_Object[OF wf]
    by(blast intro:has_fields_Object)
next
  case Subcls
  then show ?case by(blast intro:has_fields_rec dest:subcls1D)
qed
(*>*)

lemma has_fields_types:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; (FD,b,T) \<in> set FDTs; wf_prog wf_md P \<rbrakk> \<Longrightarrow> is_type P T"
(*<*)
proof(induct rule:Fields.induct)
qed(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)+
(*>*)

lemma sees_field_is_type:
  "\<lbrakk> P \<turnstile> C sees F,b:T in D; wf_prog wf_md P \<rbrakk> \<Longrightarrow> is_type P T"
(*<*)
  by (meson has_field_def has_fields_types has_visible_field map_of_SomeD)
(*>*)

lemma wf_syscls:
  "set SystemClasses \<subseteq> set P \<Longrightarrow> wf_syscls P"
(*<*)
by (force simp: image_def SystemClasses_def wf_syscls_def sys_xcpts_def
                ObjectC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def
                NoClassDefFoundC_def
                IncompatibleClassChangeC_def NoSuchFieldC_def NoSuchMethodC_def)
(*>*)

subsection\<open> Well-formedness and subclassing \<close>

lemma wf_subcls_nCls:
assumes wf: "wf_prog wf_md P" and ns: "\<not> is_class P C"
shows "\<lbrakk> P \<turnstile> D \<preceq>\<^sup>* D'; D \<noteq> C \<rbrakk> \<Longrightarrow> D' \<noteq> C"
proof(induct rule: rtrancl.induct)
  case (rtrancl_into_rtrancl a b c)
  with ns show ?case by(clarsimp dest!: subcls1D wf_cdecl_supD[OF class_wf[OF _ wf]])
qed(simp)

lemma wf_subcls_nCls':
assumes wf: "wf_prog wf_md P" and ns: "\<not>is_class P C\<^sub>0"
shows "\<And>cd D'. cd \<in> set P \<Longrightarrow> \<not>P \<turnstile> fst cd \<preceq>\<^sup>* C\<^sub>0"
proof -
  fix cd D' assume cd: "cd \<in> set P"
  then have cls: "is_class P (fst cd)" using class_exists_equiv is_class_def by blast
  with wf_subcls_nCls[OF wf ns] ns show "\<not>P \<turnstile> fst cd \<preceq>\<^sup>* C\<^sub>0" by(cases "fst cd = D'", auto)
qed

lemma wf_nclass_nsub:
 "\<lbrakk> wf_prog wf_md P; is_class P C; \<not>is_class P C' \<rbrakk> \<Longrightarrow> \<not>P \<turnstile> C \<preceq>\<^sup>* C'"
 by(rule notI, auto dest: wf_subcls_nCls[where C=C' and D=C])

lemma wf_sys_xcpt_nsub_Start:
assumes wf: "wf_prog wf_md P" and ns: "\<not>is_class P Start" and sx: "C \<in> sys_xcpts"
shows "\<not>P \<turnstile> C \<preceq>\<^sup>* Start"
proof -
  have Cns: "C \<noteq> Start" using Start_nsys_xcpts sx by clarsimp
  show ?thesis using wf_subcls_nCls[OF wf ns _ Cns] by auto
qed

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      ClosureEx.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory ClosureEx
imports "../Vcg" "../Simpl_Heap" Closure
begin

record globals =
 cnt_' :: "ref \<Rightarrow> nat"
 alloc_' :: "ref list"
 free_' :: "nat"
record 'g vars = "'g state" +
 p_':: ref
 r_':: nat
 n_':: nat
 m_':: nat
 c_':: "(string \<times> ref) list \<times> string"
 d_':: "(string \<times> ref) list \<times> string"
 e_':: "(string \<times> nat) list \<times> string"

definition "var\<^sub>n = [''n''\<mapsto> (\<lambda>x. n_'_update (\<lambda>_. x)),
                    ''m''\<mapsto> (\<lambda>x. m_'_update (\<lambda>_. x))]"
definition "upd\<^sub>n = gen_upd var\<^sub>n"

lemma upd\<^sub>n_ap: "upd\<^sub>n (fst (ap es (es',p))) = upd\<^sub>n es' \<circ> upd\<^sub>n es"
  by (simp add: upd\<^sub>n_def gen_upd_ap)

lemma
"\<Gamma>\<turnstile>\<lbrace>\<acute>n=n\<^sub>0 \<and> (\<forall>i j. \<Gamma>\<turnstile> \<lbrace>\<acute>n=i \<and> \<acute>m=j\<rbrace> callClosure upd\<^sub>n \<acute>e \<lbrace>\<acute>r=i + j\<rbrace>)\<rbrace>
      \<acute>e :== (ap [(''n'',\<acute>n)] \<acute>e)
   \<lbrace>\<forall>j. \<Gamma>\<turnstile> \<lbrace>\<acute>m=j\<rbrace> callClosure upd\<^sub>n \<acute>e \<lbrace>\<acute>r=n\<^sub>0 + j\<rbrace>\<rbrace>"
apply vcg_step
apply clarify
apply (rule ap_closure [where var=var\<^sub>n, folded upd\<^sub>n_def])
apply clarsimp
apply (rename_tac s s')
apply (erule_tac x="n_' s" in allE)
apply (erule_tac x="m_' s'" in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply (assumption)
apply (simp add: upd\<^sub>n_def gen_upd_def var\<^sub>n_def)
done

definition "var = [''p''\<mapsto> (\<lambda>x. p_'_update (\<lambda>_. x))]"
definition "upd = gen_upd var"

procedures Inc(p|r) =
 "\<acute>p\<rightarrow>\<acute>cnt :== \<acute>p\<rightarrow>\<acute>cnt + 1;;
  \<acute>r :== \<acute>p\<rightarrow>\<acute>cnt"

lemma (in Inc_impl)
 "\<forall>i p. \<Gamma>\<turnstile> \<lbrace>\<acute>p\<rightarrow>\<acute>cnt = i\<rbrace> \<acute>r :== PROC Inc(\<acute>p) \<lbrace>\<acute>r=i+1 \<and> \<acute>p\<rightarrow>\<acute>cnt = i+1\<rbrace>"
  apply vcg
  apply simp
  done

procedures (imports Inc_signature) NewCounter(|c) =
"\<acute>p :== NEW 1 [\<acute>cnt :== 0];;
 \<acute>c :== ([(''p'',\<acute>p)],Inc_'proc)"

locale NewCounter_impl' = NewCounter_impl + Inc_impl
lemma (in NewCounter_impl')
shows
  "\<forall>alloc. \<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace> \<acute>c :== PROC NewCounter()
          \<lbrace>\<exists>p. p\<rightarrow>\<acute>cnt = 0 \<and>
               (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>"
apply vcg
apply simp
apply (rule_tac x="new (set alloc)" in exI)
apply simp
apply (simp add: callClosure_def)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply (simp add: upd_def var_def gen_upd_def)
done

lemma (in NewCounter_impl')

shows
  "\<forall>alloc. \<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace> \<acute>c :== PROC NewCounter()
          \<lbrace>\<exists>p. p\<rightarrow>\<acute>cnt = 0 \<and>
               (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>"
apply vcg
apply simp
apply (rule_tac x="new (set alloc)" in exI)
apply simp
apply (simp add: callClosure_def)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply (simp add: upd_def var_def gen_upd_def)
done

lemma (in NewCounter_impl')
shows NewCounter_spec:
  "\<forall>alloc. \<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free \<and> \<acute>alloc=alloc\<rbrace> \<acute>c :== PROC NewCounter()
          \<lbrace>\<exists>p. p \<notin> set alloc \<and> p \<in> set \<acute>alloc \<and> p \<noteq> Null \<and> p\<rightarrow>\<acute>cnt = 0 \<and>
               (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>"
apply vcg
apply clarsimp
apply (rule_tac x="new (set alloc)" in exI)
apply simp
apply (simp add: callClosure_def)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply (simp add: upd_def var_def gen_upd_def)
done

lemma "\<Gamma>\<turnstile>\<lbrace>\<exists>p. p \<noteq> Null \<and> p\<rightarrow>\<acute>cnt = i \<and>
              (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>
           dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>))
           \<lbrace>\<acute>r=i+1\<rbrace>"
apply (rule conseq_extract_pre)
apply clarify
apply (rule dynCallClosureFix)
apply (simp only: Ball_def)
prefer 3
apply (assumption)
prefer 2
apply vcg_step
apply vcg_step
apply (simp only: simp_thms)
apply clarsimp
done

lemma (in NewCounter_impl')
 shows "\<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace>
             \<acute>c :== CALL NewCounter ();;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>))
           \<lbrace>\<acute>r=1\<rbrace>"
apply vcg_step
apply (rule dynCallClosure)
prefer 2
apply vcg_step
apply vcg_step
apply vcg_step
apply clarsimp
apply (erule_tac x=0 in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply (assumption)
apply simp
done

lemma (in NewCounter_impl')
 shows "\<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace>
             \<acute>c :== CALL NewCounter ();;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>));;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>))
           \<lbrace>\<acute>r=2\<rbrace>"
apply vcg_step
apply (rule dynCallClosure)
prefer 2
apply vcg_step
apply vcg_step
apply vcg_step
apply (rule dynCallClosure)
apply vcg_step
apply vcg_step
apply vcg_step

apply clarsimp
apply (subgoal_tac "\<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = 0\<rbrace> callClosure upd (c_' t) \<lbrace>\<acute>r = Suc 0 \<and> p\<rightarrow>\<acute>cnt = Suc 0\<rbrace>")
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule_tac x=1 in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule allE)
apply assumption
done

lemma (in NewCounter_impl')
 shows "\<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace>
             \<acute>c :== CALL NewCounter ();;
             \<acute>d :== \<acute>c;;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>n_' := r_' t\<rparr>));;
             dynCallClosure (\<lambda>s. s) upd d_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>m_' := r_' t\<rparr>));;
             \<acute>r :== \<acute>n + \<acute>m
           \<lbrace>\<acute>r=3\<rbrace>"

apply vcg_step
apply vcg_step
apply (rule dynCallClosure)
prefer 2
apply vcg_step
apply vcg_step
apply vcg_step
apply (rule dynCallClosure)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply clarsimp
apply (subgoal_tac "\<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = 0\<rbrace> callClosure upd (c_' t) \<lbrace>\<acute>r = Suc 0 \<and> p\<rightarrow>\<acute>cnt = Suc 0\<rbrace>")
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule_tac x=1 in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule allE)
apply assumption
done

end