(* Title:  Shortest_Path.thy
   Author: Lars Noschinski, TU München
*)

theory Shortest_Path imports
  Arc_Walk
  Weighted_Graph
  "~~/src/HOL/Library/Extended_Real"
begin

section {* Shortest Paths *}

context wf_digraph begin

(*Rename, as we are outside of any local context?*)
definition \<mu> where
  "\<mu> f u v \<equiv> INF p: {p. awalk u p v}. ereal (awalk_cost f p)"

lemma shortest_path_inf:
  assumes "\<not>(u \<rightarrow>\<^sup>* v)"
  shows "\<mu> f u v = \<infinity>"
proof -
  have *: "{p. awalk u p v} = {}"
    using assms by (auto simp: reachable_awalk)
  show "\<mu> f u v = \<infinity>" unfolding \<mu>_def *
    by (simp add: INF_def top_ereal_def)
qed

lemma min_cost_le_walk_cost:
  assumes "awalk u p v"
  shows "\<mu> c u v \<le> awalk_cost c p"
  using assms unfolding \<mu>_def by (auto intro: INF_lower2)

lemma pos_cost_pos_awalk_cost:
  assumes "awalk u p v"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> c e \<ge> 0"
  shows "awalk_cost c p \<ge> 0"
using assms by (induct p arbitrary: u) (auto simp: awalk_Cons_iff)

fun mk_cycles_path :: "nat
  \<Rightarrow> 'b awalk \<Rightarrow> 'b awalk" where
    "mk_cycles_path 0 c = []"
  | "mk_cycles_path (Suc n) c = c @ (mk_cycles_path n c)"

lemma mk_cycles_path_awalk:
  assumes "awalk u c u"
  shows "awalk u (mk_cycles_path n c) u"
using assms by (induct n) (auto simp: awalk_Nil_iff)

lemma mk_cycles_awalk_cost:
  assumes "awalk u p u"
  shows "awalk_cost c (mk_cycles_path n p) = n * awalk_cost c p"
using assms proof (induct rule: mk_cycles_path.induct)
  case 1 show ?case by simp
next
  case (2 n p)
  have "awalk_cost c (mk_cycles_path (Suc n) p)
      = awalk_cost c (p @ (mk_cycles_path n p))"
    by simp
  also have "\<dots> = awalk_cost c p + real n * awalk_cost c p"
  proof (cases n)
    case 0 then show ?thesis by simp
  next
    case (Suc n') then show ?thesis
      using 2 by simp
  qed
  also have "\<dots> = real (Suc n) * awalk_cost c p"
    by (simp add: algebra_simps real_of_nat_Suc)
  finally show ?case .
qed

lemma inf_over_nats:
  fixes a c :: real
  assumes "c < 0"
  shows "(INF (i :: nat). ereal (a + i * c)) = - \<infinity>"
proof (rule INF_eqI)
  fix i :: nat show "- \<infinity> \<le> a + real i * c" by simp
next
  fix y :: ereal
  assume "\<And>(i :: nat). i \<in> UNIV \<Longrightarrow> y \<le> a + real i * c"
  then have l_assm: "\<And>i::nat. y \<le> a + real i * c" by simp

  show "y \<le> - \<infinity>"
  proof (subst ereal_infty_less_eq, rule ereal_bot)
    fix B :: real
    obtain real_x where "a + real_x * c \<le> B" using `c < 0`
      by atomize_elim
         (rule exI[where x="(- abs B -a)/c"], auto simp: field_simps)
    obtain x :: nat where "a + x * c \<le> B"
    proof (atomize_elim, intro exI[where x="natceiling real_x"] conjI)
      have "real (natceiling real_x) * c \<le> real_x * c"
        using `c < 0` by (simp add: real_natceiling_ge)
      then show "a + natceiling real_x * c \<le> B"
        using `a + real_x * c \<le> B` by simp
    qed
    then show "y \<le> ereal B"
    proof -
      have "ereal (a + x * c) \<le> ereal B"
        using `a + x * c \<le> B` by simp
      with l_assm show ?thesis by (rule order_trans)
    qed
  qed
qed

lemma neg_cycle_imp_inf_\<mu>:
  assumes walk_p: "awalk u p v"
  assumes walk_c: "awalk w c w"
  assumes w_in_p: "w \<in> set (awalk_verts u p)"
  assumes "awalk_cost f c < 0"
  shows "\<mu> f u v = -\<infinity>"
proof -
  from w_in_p obtain xs ys where pv_decomp: "awalk_verts u p = xs @ w # ys"
    by (auto simp: in_set_conv_decomp)

  def q \<equiv> "take (length xs) p" and r \<equiv> "drop (length xs) p"
  def ext_p \<equiv> "\<lambda>n. q @ mk_cycles_path n c @ r"

  have ext_p_cost: "\<And>n. awalk_cost f (ext_p n)
      = (awalk_cost f q + awalk_cost f r) + n * awalk_cost f c"
    using `awalk w c w`
    by (auto simp: ext_p_def intro: mk_cycles_awalk_cost)

  from q_def r_def have "awlast u q = w"
    using pv_decomp walk_p by (auto simp: awalk_verts_take_conv elim!: awalkE)
  moreover
  from q_def r_def have "awalk u (q @ r) v"
    using walk_p by simp
  ultimately
  have "awalk u q w" "awalk w r v" "\<And>n. awalk w (mk_cycles_path n c) w"
    using walk_c
    by (auto simp: intro: mk_cycles_path_awalk)
  then have "\<And>n. awalk u (ext_p n) v"
    unfolding ext_p_def by (blast intro: awalk_appendI)
  then have "{ext_p i|i. i \<in> UNIV} \<subseteq> {p. awalk u p v}"
    by auto
  then have "(INF p:{p. awalk u p v}. ereal (awalk_cost f p))
      \<le> (INF p: {ext_p i|i. i \<in> UNIV}. ereal (awalk_cost f p))"
    by (auto intro: INF_superset_mono)
  also have "\<dots> = (INF i: UNIV. ereal (awalk_cost f (ext_p i)))"
    unfolding INF_def by (rule arg_cong[where f=Inf], auto)
  also have "\<dots> = - \<infinity>" unfolding ext_p_cost
    by (rule inf_over_nats[OF `awalk_cost f c < 0`])
  finally show ?thesis unfolding \<mu>_def by simp
qed

lemma walk_cheaper_path_imp_neg_cyc:
  assumes p_props: "awalk u p v"
  assumes less_path_\<mu>: "awalk_cost f p < (INF p: {p. apath u p v}. ereal (awalk_cost f p))"
  shows "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0"
proof -
  def path_\<mu>  \<equiv> "(INF p: {p. apath u p v}. ereal (awalk_cost f p))"
  then have "awalk u p v" and "awalk_cost f p < path_\<mu>"
    using p_props less_path_\<mu> by simp_all
  then show ?thesis
  proof (induct rule: awalk_to_apath_induct)
    case (path p) then have "apath u p v" by (auto simp: apath_def)
    then show ?case using path.prems by (auto simp: path_\<mu>_def dest: not_mem_less_INF)
  next
    case (decomp p q r s)
    then obtain w where p_props: "p = q @ r @ s" "awalk u q w" "awalk w r w" "awalk w s v"
      by (auto elim: awalk_cyc_decompE)
    then have "awalk u (q @ s) v"
      using `awalk u p v` by (auto simp: awalk_appendI)
    then have verts_ss: "set (awalk_verts u (q @ s)) \<subseteq> set (awalk_verts u p)"
      using `awalk u p v` `p = q @ r @ s` by (auto simp: set_awalk_verts)

    show ?case
    proof (cases "ereal (awalk_cost f (q @ s)) < path_\<mu>")
      case True then have "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u (q @ s)) \<and> awalk_cost f c < 0"
        by (rule decomp)
      then show ?thesis using verts_ss by auto
    next
      case False
      note `awalk_cost f p < path_\<mu>`
      also have "path_\<mu> \<le> awalk_cost f (q @ s)"
        using False by simp
      finally have "awalk_cost f r < 0" using `p = q @ r @ s` by simp
      moreover
      have "w \<in> set (awalk_verts u q)" using `awalk u q w` by auto
      then have "w \<in> set (awalk_verts u p)"
        using `awalk u p v` `awalk u q w` `p = q @ r @ s`
        by (auto simp: set_awalk_verts)
      ultimately
      show ?thesis using `awalk w r w` by auto
    qed
  qed
qed

lemma (in fin_digraph) neg_inf_imp_neg_cyc:
  assumes inf_mu: "\<mu> f u v = - \<infinity>"
  shows "\<exists>p. awalk u p v \<and> (\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
proof -
  def path_\<mu> \<equiv> "INF s:{p. apath u p v}. ereal (awalk_cost f s)"

  have awalks_ne: "{p. awalk u p v} \<noteq> {}"
    using inf_mu unfolding \<mu>_def INF_def by safe (simp add: top_ereal_def)
  then have paths_ne: "{p. apath u p v} ~= {}"
    by (auto intro: apath_awalk_to_apath)

  obtain p where "apath u p v" "awalk_cost f p = path_\<mu>"
  proof -
    obtain p where "p \<in> {p. apath u p v}" "awalk_cost f p = path_\<mu>"
    using finite_INF_in[OF apaths_finite paths_ne, of "awalk_cost f"]
      by (auto simp: path_\<mu>_def)
    then show ?thesis using that by auto
  qed
  then have "path_\<mu> \<noteq> -\<infinity>" by auto
  then have "\<mu> f u v < path_\<mu>" using inf_mu by simp
  then obtain pw where p_def: "awalk u pw v" "awalk_cost f pw < path_\<mu>"
    by atomize_elim (auto simp: \<mu>_def INF_less_iff)
  then have "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u pw) \<and> awalk_cost f c < 0"
    by (intro walk_cheaper_path_imp_neg_cyc) (auto simp: path_\<mu>_def)
  with `awalk u pw v` show ?thesis by auto
qed

lemma (in fin_digraph) no_neg_cyc_imp_no_neg_inf:
  assumes no_neg_cyc: "\<And>p. awalk u p v
    \<Longrightarrow> \<not>(\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
  shows "- \<infinity> < \<mu> f u v"
proof (intro ereal_MInfty_lessI notI)
  assume "\<mu> f u v = - \<infinity>"
  then obtain p where p_props: "awalk u p v"
    and ex_cyc: "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0"
    by atomize_elim (rule neg_inf_imp_neg_cyc)
  then show False using no_neg_cyc by blast
qed

lemma \<mu>_reach_conv:
  "\<mu> f u v < \<infinity> \<longleftrightarrow> u \<rightarrow>\<^sup>* v"
proof
  assume "\<mu> f u v < \<infinity>"
  then have "{p. awalk u p v} \<noteq> {}"
    unfolding \<mu>_def INF_def by safe (simp add: top_ereal_def)
  then show "u \<rightarrow>\<^sup>* v" by (simp add: reachable_awalk)
next
  assume "u \<rightarrow>\<^sup>* v"
  then obtain p where p_props: "apath u p v"
    by (metis reachable_awalk apath_awalk_to_apath)
  then have "{p} \<subseteq> {p. apath u p v}" by simp
  then have "\<mu> f u v \<le> (INF p: {p}. ereal (awalk_cost f p))"
    unfolding \<mu>_def by (intro INF_superset_mono) (auto simp: apath_def)
  also have "\<dots> < \<infinity>" unfolding INF_def by (simp add: min_def)
  finally show "\<mu> f u v < \<infinity>" .
qed

lemma awalk_to_path_no_neg_cyc_cost:
  assumes p_props:"awalk u p v"
  assumes no_neg_cyc: "\<not> (\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
  shows "awalk_cost f (awalk_to_apath p) \<le> awalk_cost f p"
using assms
proof (induct rule: awalk_to_apath_induct)
  case path then show ?case by (auto simp: awalk_to_apath.simps)
next
  case (decomp p q r s)
  from decomp(2,3) have "is_awalk_cyc_decomp p (q,r,s)"
    using awalk_cyc_decomp_has_prop[OF decomp(1)] by auto
  then have decomp_props: "p = q @ r @ s" "\<exists>w. awalk w r w" by auto

  have "awalk_cost f (awalk_to_apath p) = awalk_cost f (awalk_to_apath (q @ s))"
    using decomp by (auto simp: step_awalk_to_apath[of _ p _ q r s])
  also have "\<dots> \<le> awalk_cost f (q @ s)"
  proof -
    have "awalk u (q @ s) v"
      using `awalk u p v` decomp_props by (auto dest!: awalk_ends_eqD)
    then have "set (awalk_verts u (q @ s)) \<subseteq> set (awalk_verts u p)"
      using `awalk u p v` `p = q @ r @ s`
      by (auto simp add: set_awalk_verts)
    then show ?thesis using decomp.prems by (intro decomp.hyps) auto
  qed
  also have "\<dots> \<le> awalk_cost f p"
  proof -
    obtain w where "awalk u q w" "awalk w r w" "awalk w s v"
      using decomp by (auto elim: awalk_cyc_decompE)
    then have "w \<in> set (awalk_verts u q)" by auto
    then have "w \<in> set (awalk_verts u p)"
      using `p = q @ r @ s` `awalk u p v` `awalk u q w`
      by (auto simp add: set_awalk_verts)
    then have "0 \<le> awalk_cost f r" using `awalk w r w`
      using decomp.prems by (auto simp: not_less)
    then show ?thesis using `p = q @ r @ s` by simp
  qed
  finally show ?case .
qed

lemma (in fin_digraph) no_neg_cyc_reach_imp_path:
  assumes reach: "u \<rightarrow>\<^sup>* v"
  assumes no_neg_cyc: "\<And>p. awalk u p v
    \<Longrightarrow> \<not>(\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
  shows "\<exists>p. apath u p v \<and> \<mu> f u v = awalk_cost f p"
proof -
  def set_walks \<equiv> "{p. awalk u p v}"
  def set_paths \<equiv> "{p. apath u p v}"

  have "set_paths \<noteq> {}"
  proof -
    obtain p where "apath u p v"
      using reach by (metis apath_awalk_to_apath reachable_awalk)
    then show ?thesis unfolding set_paths_def by blast
  qed

  have "\<mu> f u v = (INF p: set_walks. ereal (awalk_cost f p))"
    unfolding \<mu>_def set_walks_def by simp
  also have "\<dots> = (INF p: set_paths. ereal (awalk_cost f p))"
  proof (rule antisym)
    have "awalk_to_apath ` set_walks \<subseteq> set_paths"
      unfolding set_walks_def set_paths_def
      by (intro subsetI) (auto elim: apath_awalk_to_apath)
    then have "(INF p: set_paths. ereal (awalk_cost f p))
      \<le> (INF p: awalk_to_apath ` set_walks. ereal (awalk_cost f p))"
      by (rule INF_superset_mono) simp
    also have "\<dots> = (INF p: set_walks. ereal (awalk_cost f (awalk_to_apath p)))"
      by (auto simp add: comp_def)
    also have "\<dots> \<le> (INF p: set_walks. ereal (awalk_cost f p))"
    proof -
      { fix p assume "p \<in> set_walks"
        then have "awalk u p v" by (auto simp: set_walks_def)
        then have "awalk_cost f (awalk_to_apath p) \<le> awalk_cost f p"
          using no_neg_cyc
          using no_neg_cyc and awalk_to_path_no_neg_cyc_cost
          by auto }
      then show ?thesis by (intro INF_mono) auto
    qed
    finally show
      "(INF p: set_paths. ereal (awalk_cost f p))
      \<le> (INF p: set_walks. ereal (awalk_cost f p))" by simp

    have "set_paths \<subseteq> set_walks"
      unfolding set_paths_def set_walks_def by (auto simp: apath_def)
    then show "(INF p: set_walks. ereal (awalk_cost f p))
      \<le> (INF p: set_paths. ereal (awalk_cost f p))"
      by (rule INF_superset_mono) simp
  qed
  also have "\<dots> \<in> (\<lambda>p. ereal (awalk_cost f p)) ` set_paths"
    using apaths_finite `set_paths \<noteq> {}`
    by (intro finite_INF_in) (auto simp: set_paths_def)
  finally show ?thesis
    by (simp add: set_paths_def image_def)
qed

lemma (in fin_digraph) min_cost_awalk:
  assumes reach: "u \<rightarrow>\<^sup>* v"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> c e \<ge> 0"
  shows "\<exists>p. apath u p v \<and> \<mu> c u v = awalk_cost c p"
proof -
  have pc: "\<And>u p v. awalk u p v \<Longrightarrow> 0 \<le> awalk_cost c p"
    using pos_cost_pos_awalk_cost pos_cost by auto

  from reach show ?thesis
    by (rule no_neg_cyc_reach_imp_path) (auto simp: not_less intro: pc)
qed

lemma (in fin_digraph) pos_cost_mu_triangle:
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> c e \<ge> 0" (* introduce predicate? *)
  assumes e_props: "arc_to_ends G e = (u,v)" "e \<in> arcs G"
  shows "\<mu> c s v \<le> \<mu> c s u + c e"
proof cases
  assume "\<mu> c s u = \<infinity>" then show ?thesis by simp
next
  assume "\<mu> c s u \<noteq> \<infinity>"
  then have "{p. awalk s p u} \<noteq> {}"
    unfolding \<mu>_def INF_def by safe (simp add: top_ereal_def)
  then have "s \<rightarrow>\<^sup>* u" by (simp add: reachable_awalk)
  with pos_cost
  obtain p where p_props: "apath s p u"
      and p_cost: "\<mu> c s u = awalk_cost c p"
    by (metis min_cost_awalk)

  have "awalk u [e] v"
    using e_props by (auto simp: arc_to_ends_def awalk_simps)
  with `apath s p u`
  have "awalk s (p @ [e]) v"
    by (auto simp: apath_def awalk_appendI)
  then have "\<mu> c s v \<le> awalk_cost c (p @ [e])"
    by (rule min_cost_le_walk_cost)
  also have "\<dots> \<le> awalk_cost c p + c e" by simp
  also have "\<dots> \<le> \<mu> c s u + c e" using p_cost by simp
  finally show ?thesis .
qed

lemma (in fin_digraph) mu_exact_triangle:
  assumes "v \<noteq> s"
  assumes "s \<rightarrow>\<^sup>* v"
  assumes nonneg_arcs: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"
  obtains u e where "\<mu> c s v = \<mu> c s u + c e" and "arc e (u,v)"
proof -
  obtain p where p_path: "apath s p v"
    and p_cost: "\<mu> c s v = awalk_cost c p"
    using assms by (metis min_cost_awalk)
  then obtain e p' where p'_props: "p = p' @ [e]" using `v \<noteq> s`
    by (cases p rule: rev_cases) (auto simp: apath_def)
  then obtain u where "awalk s p' u" "awalk u [e] v"
    using `apath s p v` by (auto simp: apath_def)
  then have mu_le: "\<mu> c s v \<le> \<mu> c s u + c e" and arc: "arc e (u,v)"
    using nonneg_arcs by (auto intro!: pos_cost_mu_triangle simp: arc_to_ends_def arc_def)

  have "\<mu> c s u + c e \<le> ereal (awalk_cost c p') + ereal (c e)"
    using `awalk s p' u`
    by (fast intro: add_right_mono min_cost_le_walk_cost)
  also have "\<dots> = awalk_cost c p" using p'_props by simp
  also have "\<dots> = \<mu> c s v" using p_cost by simp
  finally
  have "\<mu> c s v = \<mu> c s u + c e" using mu_le by auto
  then show ?thesis using arc ..
qed

lemma (in fin_digraph) mu_exact_triangle_Ex:
  assumes "v \<noteq> s"
  assumes "s \<rightarrow>\<^sup>* v"
  assumes "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"
  shows "\<exists>u e. \<mu> c s v = \<mu> c s u + c e \<and> arc e (u,v)"
using assms by (metis mu_exact_triangle)

lemma (in fin_digraph) mu_Inf_triangle:
  assumes "v \<noteq> s"
  assumes "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"
  shows "\<mu> c s v = Inf {\<mu> c s u + c e | u e. arc e (u, v)}" (is "_ = Inf ?S")
proof cases
  assume "s \<rightarrow>\<^sup>* v"
  then obtain u e where "\<mu> c s v = \<mu> c s u + c e" "arc e (u,v)"
    using assms by (metis mu_exact_triangle)
  then have "Inf ?S \<le> \<mu> c s v" by (auto intro: Complete_Lattices.Inf_lower)
  also have "\<dots> \<le> Inf ?S" using assms(2)
    by (auto intro!: Complete_Lattices.Inf_greatest pos_cost_mu_triangle
      simp: arc_def arc_to_ends_def)
  finally show ?thesis by simp
next
  assume "\<not>s \<rightarrow>\<^sup>* v"
  then have "\<mu> c s v = \<infinity>" by (metis shortest_path_inf)
  def S \<equiv> "?S"
  show "\<mu> c s v = Inf S"
  proof cases
    assume "S = {}" then show ?thesis unfolding `\<mu> c s v = \<infinity>`
      by (simp add: top_ereal_def)
  next
    assume "S \<noteq> {}"
    { fix x assume "x \<in> S"
      then obtain u e where "arc e (u,v)" and x_val: "x = \<mu> c s u + c e"
        unfolding S_def by auto
      then have "\<not>s \<rightarrow>\<^sup>* u" using `\<not> s \<rightarrow>\<^sup>* v` by (metis reachable_arc_trans)
      then have "\<mu> c s u + c e= \<infinity>" by (simp add: shortest_path_inf)
      then have "x = \<infinity>" using x_val by simp }
    then have "S = {\<infinity>}" using `S \<noteq> {}` by auto
    then show ?thesis using `\<mu> c s v = \<infinity>` by (simp add: min_def)
  qed
qed

end

end


(* Author: Tobias Nipkow *)

section "Live Variable Analysis"

theory Live imports Vars Big_Step
begin

subsection "Liveness Analysis"

fun L :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"L SKIP X = X" |
"L (x ::= a) X = vars a \<union> (X - {x})" |
"L (c\<^sub>1;; c\<^sub>2) X = L c\<^sub>1 (L c\<^sub>2 X)" |
"L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> L c\<^sub>1 X \<union> L c\<^sub>2 X" |
"L (WHILE b DO c) X = vars b \<union> X \<union> L c X"

value "show (L (''y'' ::= V ''z'';; ''x'' ::= Plus (V ''y'') (V ''z'')) {''x''})"

value "show (L (WHILE Less (V ''x'') (V ''x'') DO ''y'' ::= V ''z'') {''x''})"

fun "kill" :: "com \<Rightarrow> vname set" where
"kill SKIP = {}" |
"kill (x ::= a) = {x}" |
"kill (c\<^sub>1;; c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
"kill (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = kill c\<^sub>1 \<inter> kill c\<^sub>2" |
"kill (WHILE b DO c) = {}"

fun gen :: "com \<Rightarrow> vname set" where
"gen SKIP = {}" |
"gen (x ::= a) = vars a" |
"gen (c\<^sub>1;; c\<^sub>2) = gen c\<^sub>1 \<union> (gen c\<^sub>2 - kill c\<^sub>1)" |
"gen (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = vars b \<union> gen c\<^sub>1 \<union> gen c\<^sub>2" |
"gen (WHILE b DO c) = vars b \<union> gen c"

lemma L_gen_kill: "L c X = gen c \<union> (X - kill c)"
by(induct c arbitrary:X) auto

lemma L_While_pfp: "L c (L (WHILE b DO c) X) \<subseteq> L (WHILE b DO c) X"
by(auto simp add:L_gen_kill)

lemma L_While_lpfp:
  "vars b \<union> X \<union> L c P \<subseteq> P \<Longrightarrow> L (WHILE b DO c) X \<subseteq> P"
by(simp add: L_gen_kill)

lemma L_While_vars: "vars b \<subseteq> L (WHILE b DO c) X"
by auto

lemma L_While_X: "X \<subseteq> L (WHILE b DO c) X"
by auto

text\<open>Disable L WHILE equation and reason only with L WHILE constraints\<close>
declare L.simps(5)[simp del]

subsection "Correctness"

theorem L_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq c1 s1 s2 c2 s3 X t1)
  from Seq.IH(1) Seq.prems obtain t2 where
    t12: "(c1, t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X"
    by simp blast
  from Seq.IH(2)[OF s2t2] obtain t3 where
    t23: "(c2, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using t12 t23 s3t3 by auto
next
  case (IfTrue b s c1 s' c2)
  hence "s = t on vars b" "s = t on L c1 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  from IfTrue.IH[OF \<open>s = t on L c1 X\<close>] obtain t' where
    "(c1, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using \<open>bval b t\<close> by auto
next
  case (IfFalse b s c2 s' c1)
  hence "s = t on vars b" "s = t on L c2 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  from IfFalse.IH[OF \<open>s = t on L c2 X\<close>] obtain t' where
    "(c2, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using \<open>~bval b t\<close> by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  thus ?case by(metis WhileFalse.prems L_While_X big_step.WhileFalse subsetD)
next
  case (WhileTrue b s1 c s2 s3 X t1)
  let ?w = "WHILE b DO c"
  from \<open>bval b s1\<close> WhileTrue.prems have "bval b t1"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  have "s1 = t1 on L c (L ?w X)" using L_While_pfp WhileTrue.prems
    by (blast)
  from WhileTrue.IH(1)[OF this] obtain t2 where
    "(c, t1) \<Rightarrow> t2" "s2 = t2 on L ?w X" by auto
  from WhileTrue.IH(2)[OF this(2)] obtain t3 where "(?w,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with \<open>bval b t1\<close> \<open>(c, t1) \<Rightarrow> t2\<close> show ?case by auto
qed

subsection "Program Optimization"

text\<open>Burying assignments to dead variables:\<close>
fun bury :: "com \<Rightarrow> vname set \<Rightarrow> com" where
"bury SKIP X = SKIP" |
"bury (x ::= a) X = (if x \<in> X then x ::= a else SKIP)" |
"bury (c\<^sub>1;; c\<^sub>2) X = (bury c\<^sub>1 (L c\<^sub>2 X);; bury c\<^sub>2 X)" |
"bury (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = IF b THEN bury c\<^sub>1 X ELSE bury c\<^sub>2 X" |
"bury (WHILE b DO c) X = WHILE b DO bury c (L (WHILE b DO c) X)"

text\<open>We could prove the analogous lemma to @{thm[source]L_correct}, and the
proof would be very similar. However, we phrase it as a semantics
preservation property:\<close>

theorem bury_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (bury c X,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq c1 s1 s2 c2 s3 X t1)
  from Seq.IH(1) Seq.prems obtain t2 where
    t12: "(bury c1 (L c2 X), t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X"
    by simp blast
  from Seq.IH(2)[OF s2t2] obtain t3 where
    t23: "(bury c2 X, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using t12 t23 s3t3 by auto
next
  case (IfTrue b s c1 s' c2)
  hence "s = t on vars b" "s = t on L c1 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  from IfTrue.IH[OF \<open>s = t on L c1 X\<close>] obtain t' where
    "(bury c1 X, t) \<Rightarrow> t'" "s' =t' on X" by auto
  thus ?case using \<open>bval b t\<close> by auto
next
  case (IfFalse b s c2 s' c1)
  hence "s = t on vars b" "s = t on L c2 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  from IfFalse.IH[OF \<open>s = t on L c2 X\<close>] obtain t' where
    "(bury c2 X, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using \<open>~bval b t\<close> by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t" by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  thus ?case
    by simp (metis L_While_X WhileFalse.prems big_step.WhileFalse subsetD)
next
  case (WhileTrue b s1 c s2 s3 X t1)
  let ?w = "WHILE b DO c"
  from \<open>bval b s1\<close> WhileTrue.prems have "bval b t1"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  have "s1 = t1 on L c (L ?w X)"
    using L_While_pfp WhileTrue.prems by blast
  from WhileTrue.IH(1)[OF this] obtain t2 where
    "(bury c (L ?w X), t1) \<Rightarrow> t2" "s2 = t2 on L ?w X" by auto
  from WhileTrue.IH(2)[OF this(2)] obtain t3
    where "(bury ?w X,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with \<open>bval b t1\<close> \<open>(bury c (L ?w X), t1) \<Rightarrow> t2\<close> show ?case by auto
qed

corollary final_bury_correct: "(c,s) \<Rightarrow> s' \<Longrightarrow> (bury c UNIV,s) \<Rightarrow> s'"
using bury_correct[of c s s' UNIV]
by (auto simp: fun_eq_iff[symmetric])

text\<open>Now the opposite direction.\<close>

lemma SKIP_bury[simp]:
  "SKIP = bury c X \<longleftrightarrow> c = SKIP | (\<exists>x a. c = x::=a & x \<notin> X)"
by (cases c) auto

lemma Assign_bury[simp]: "x::=a = bury c X \<longleftrightarrow> c = x::=a \<and> x \<in> X"
by (cases c) auto

lemma Seq_bury[simp]: "bc\<^sub>1;;bc\<^sub>2 = bury c X \<longleftrightarrow>
  (\<exists>c\<^sub>1 c\<^sub>2. c = c\<^sub>1;;c\<^sub>2 & bc\<^sub>2 = bury c\<^sub>2 X & bc\<^sub>1 = bury c\<^sub>1 (L c\<^sub>2 X))"
by (cases c) auto

lemma If_bury[simp]: "IF b THEN bc1 ELSE bc2 = bury c X \<longleftrightarrow>
  (\<exists>c1 c2. c = IF b THEN c1 ELSE c2 &
     bc1 = bury c1 X & bc2 = bury c2 X)"
by (cases c) auto

lemma While_bury[simp]: "WHILE b DO bc' = bury c X \<longleftrightarrow>
  (\<exists>c'. c = WHILE b DO c' & bc' = bury c' (L (WHILE b DO c') X))"
by (cases c) auto

theorem bury_correct2:
  "(bury c X,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction "bury c X" s s' arbitrary: c X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq bc1 s1 s2 bc2 s3 c X t1)
  then obtain c1 c2 where c: "c = c1;;c2"
    and bc2: "bc2 = bury c2 X" and bc1: "bc1 = bury c1 (L c2 X)" by auto
  note IH = Seq.hyps(2,4)
  from IH(1)[OF bc1, of t1] Seq.prems c obtain t2 where
    t12: "(c1, t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X" by auto
  from IH(2)[OF bc2 s2t2] obtain t3 where
    t23: "(c2, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using c t12 t23 s3t3 by auto
next
  case (IfTrue b s bc1 s' bc2)
  then obtain c1 c2 where c: "c = IF b THEN c1 ELSE c2"
    and bc1: "bc1 = bury c1 X" and bc2: "bc2 = bury c2 X" by auto
  have "s = t on vars b" "s = t on L c1 X" using IfTrue.prems c by auto
  from bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  note IH = IfTrue.hyps(3)
  from IH[OF bc1 \<open>s = t on L c1 X\<close>] obtain t' where
    "(c1, t) \<Rightarrow> t'" "s' =t' on X" by auto
  thus ?case using c \<open>bval b t\<close> by auto
next
  case (IfFalse b s bc2 s' bc1)
  then obtain c1 c2 where c: "c = IF b THEN c1 ELSE c2"
    and bc1: "bc1 = bury c1 X" and bc2: "bc2 = bury c2 X" by auto
  have "s = t on vars b" "s = t on L c2 X" using IfFalse.prems c by auto
  from bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  note IH = IfFalse.hyps(3)
  from IH[OF bc2 \<open>s = t on L c2 X\<close>] obtain t' where
    "(c2, t) \<Rightarrow> t'" "s' =t' on X" by auto
  thus ?case using c \<open>~bval b t\<close> by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t"
    by auto (metis L_While_vars bval_eq_if_eq_on_vars rev_subsetD)
  thus ?case using WhileFalse
    by auto (metis L_While_X big_step.WhileFalse subsetD)
next
  case (WhileTrue b s1 bc' s2 s3 w X t1)
  then obtain c' where w: "w = WHILE b DO c'"
    and bc': "bc' = bury c' (L (WHILE b DO c') X)" by auto
  from \<open>bval b s1\<close> WhileTrue.prems w have "bval b t1"
    by auto (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  note IH = WhileTrue.hyps(3,5)
  have "s1 = t1 on L c' (L w X)"
    using L_While_pfp WhileTrue.prems w by blast
  with IH(1)[OF bc', of t1] w obtain t2 where
    "(c', t1) \<Rightarrow> t2" "s2 = t2 on L w X" by auto
  from IH(2)[OF WhileTrue.hyps(6), of t2] w this(2) obtain t3
    where "(w,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with \<open>bval b t1\<close> \<open>(c', t1) \<Rightarrow> t2\<close> w show ?case by auto
qed

corollary final_bury_correct2: "(bury c UNIV,s) \<Rightarrow> s' \<Longrightarrow> (c,s) \<Rightarrow> s'"
using bury_correct2[of c UNIV]
by (auto simp: fun_eq_iff[symmetric])

corollary bury_sim: "bury c UNIV \<sim> c"
by(metis final_bury_correct final_bury_correct2)

end