section \<open>Rankings\<close>

theory Ranking
imports
  "Alternate"
  "Graph"
begin

  subsection \<open>Rankings\<close>

  type_synonym 'state ranking = "'state node \<Rightarrow> nat"

  definition ranking :: "('label, 'state) nba \<Rightarrow> 'label stream \<Rightarrow> 'state ranking \<Rightarrow> bool" where
    "ranking A w f \<equiv>
      (\<forall> v \<in> gunodes A w. f v \<le> 2 * card (nodes A)) \<and>
      (\<forall> v \<in> gunodes A w. \<forall> u \<in> gusuccessors A w v. f u \<le> f v) \<and>
      (\<forall> v \<in> gunodes A w. gaccepting A v \<longrightarrow> even (f v)) \<and>
      (\<forall> v \<in> gunodes A w. \<forall> r k. gurun A w r v \<longrightarrow> smap f (gtrace r v) = sconst k \<longrightarrow> odd k)"

  subsection \<open>Ranking Implies Word not in Language\<close>

  lemma ranking_stuck:
    assumes "ranking A w f"
    assumes "v \<in> gunodes A w" "gurun A w r v"
    obtains n k
    where "smap f (gtrace (sdrop n r) (gtarget (stake n r) v)) = sconst k"
  proof -
    have 0: "f u \<le> f v" if "v \<in> gunodes A w" "u \<in> gusuccessors A w v" for v u
      using assms(1) that unfolding ranking_def by auto
    have 1: "shd (v ## gtrace r v) \<in> gunodes A w" using assms(2) by auto
    have 2: "sdescending (smap f (v ## gtrace r v))"
    using 1 assms(3)
    proof (coinduction arbitrary: r v rule: sdescending.coinduct)
      case sdescending
      obtain u s where 1: "r = u ## s" using stream.exhaust by blast
      have 2: "v \<in> gunodes A w" using sdescending(1) by simp
      have 3: "gurun A w (u ## s) v" using sdescending(2) 1 by auto
      have 4: "u \<in> gusuccessors A w v" using 3 by auto
      have 5: "u \<in> gureachable A w v" using graph.reachable_successors 4 by blast
      show ?case
      unfolding 1
      proof (intro exI conjI disjI1)
        show "f u \<le> f v" using 0 2 4 by this
        show "shd (u ## gtrace s u) \<in> gunodes A w" using 2 5 by auto
        show "gurun A w s u" using 3 by auto
      qed auto
    qed
    obtain s k where 3: "smap f (v ## gtrace r v) = s @- sconst k"
      using sdescending_stuck[OF 2] by metis
    have "gtrace (sdrop (Suc (length s)) r) (gtarget (stake (Suc (length s)) r) v) = sdrop (Suc (length s)) (gtrace r v)"
      using sscan_sdrop by rule
    also have "smap f \<dots> = sdrop (length s) (smap f (v ## gtrace r v))"
      by (metis "3" id_apply sdrop_simps(2) sdrop_smap sdrop_stl shift_eq siterate.simps(2) stream.sel(2))
    also have "\<dots> = sconst k" unfolding 3 using shift_eq by metis
    finally show ?thesis using that by blast
  qed

  lemma ranking_stuck_odd:
    assumes "ranking A w f"
    assumes "v \<in> gunodes A w" "gurun A w r v"
    obtains n
    where "Ball (sset (smap f (gtrace (sdrop n r) (gtarget (stake n r) v)))) odd"
  proof -
    obtain n k where 1: "smap f (gtrace (sdrop n r) (gtarget (stake n r) v)) = sconst k"
      using ranking_stuck assms by this
    have 2: "gtarget (stake n r) v \<in> gunodes A w"
      using assms(2, 3) by (simp add: graph.nodes_target graph.run_stake)
    have 3: "gurun A w (sdrop n r) (gtarget (stake n r) v)"
      using assms(2, 3) by (simp add: graph.run_sdrop)
    have 4: "odd k" using 1 2 3 assms(1) unfolding ranking_def by meson
    have 5: "Ball (sset (smap f (gtrace (sdrop n r) (gtarget (stake n r) v)))) odd"
      unfolding 1 using 4 by simp
    show ?thesis using that 5 by this
  qed

  lemma ranking_language:
    assumes "ranking A w f"
    shows "w \<notin> language A"
  proof
    assume 1: "w \<in> language A"
    obtain r p where 2: "run A (w ||| r) p" "p \<in> initial A" "infs (accepting A) (p ## r)" using 1 by rule
    let ?r = "fromN 1 ||| r"
    let ?v = "(0, p)"
    have 3: "?v \<in> gunodes A w" "gurun A w ?r ?v" using 2(1, 2) by (auto intro: run_grun)

    obtain n where 4: "Ball (sset (smap f (gtrace (sdrop n ?r) (gtarget (stake n ?r) ?v)))) odd"
      using ranking_stuck_odd assms 3 by this
    let ?s = "stake n ?r"
    let ?t = "sdrop n ?r"
    let ?u = "gtarget ?s ?v"

    have "sset (gtrace ?t ?u) \<subseteq> gureachable A w ?v"
    proof (intro graph.reachable_trace graph.reachable_target graph.reachable.reflexive)
      show "gupath A w ?s ?v" using graph.run_stake 3(2) by this
      show "gurun A w ?t ?u" using graph.run_sdrop 3(2) by this
    qed
    also have "\<dots> \<subseteq> gunodes A w" using 3(1) by blast
    finally have 7: "sset (gtrace ?t ?u) \<subseteq> gunodes A w" by this
    have 8: "\<And> p. p \<in> gunodes A w \<Longrightarrow> gaccepting A p \<Longrightarrow> even (f p)"
      using assms unfolding ranking_def by auto
    have 9: "\<And> p. p \<in> sset (gtrace ?t ?u) \<Longrightarrow> gaccepting A p \<Longrightarrow> even (f p)" using 7 8 by auto

    have 19: "infs (accepting A) (smap snd ?r)" using 2(3) by simp
    have 18: "infs (gaccepting A) ?r" using 19 by simp
    have 17: "infs (gaccepting A) (gtrace ?r ?v)" using 18 unfolding gtrace_alt_def by this
    have 16: "infs (gaccepting A) (gtrace (?s @- ?t) ?v)" using 17 unfolding stake_sdrop by this
    have 15: "infs (gaccepting A) (gtrace ?t ?u)" using 16 by simp
    have 13: "infs (even \<circ> f) (gtrace ?t ?u)" using infs_mono[OF _ 15] 9 by simp
    have 12: "infs even (smap f (gtrace ?t ?u))" using 13 by (simp add: comp_def)
    have 11: "Bex (sset (smap f (gtrace ?t ?u))) even" using 12 infs_any by metis

    show False using 4 11 by auto
  qed

  subsection \<open>Word not in Language Implies Ranking\<close>

  subsubsection \<open>Removal of Endangered Nodes\<close>

  definition clean :: "('label, 'state) nba \<Rightarrow> 'label stream \<Rightarrow> 'state node set \<Rightarrow> 'state node set" where
    "clean A w V \<equiv> {v \<in> V. infinite (greachable A w V v)}"

  lemma clean_decreasing: "clean A w V \<subseteq> V" unfolding clean_def by auto
  lemma clean_successors:
    assumes "v \<in> V" "u \<in> gusuccessors A w v"
    shows "u \<in> clean A w V \<Longrightarrow> v \<in> clean A w V"
  proof -
    assume 1: "u \<in> clean A w V"
    have 2: "u \<in> V" "infinite (greachable A w V u)" using 1 unfolding clean_def by auto
    have 3: "u \<in> greachable A w V v" using graph.reachable.execute assms(2) 2(1) by blast
    have 4: "greachable A w V u \<subseteq> greachable A w V v" using 3 by blast
    have 5: "infinite (greachable A w V v)" using 2(2) 4 by (simp add: infinite_super)
    show "v \<in> clean A w V" unfolding clean_def using assms(1) 5 by simp
  qed

  subsubsection \<open>Removal of Safe Nodes\<close>

  definition prune :: "('label, 'state) nba \<Rightarrow> 'label stream \<Rightarrow> 'state node set \<Rightarrow> 'state node set" where
    "prune A w V \<equiv> {v \<in> V. \<exists> u \<in> greachable A w V v. gaccepting A u}"

  lemma prune_decreasing: "prune A w V \<subseteq> V" unfolding prune_def by auto
  lemma prune_successors:
    assumes "v \<in> V" "u \<in> gusuccessors A w v"
    shows "u \<in> prune A w V \<Longrightarrow> v \<in> prune A w V"
  proof -
    assume 1: "u \<in> prune A w V"
    have 2: "u \<in> V" "\<exists> x \<in> greachable A w V u. gaccepting A x" using 1 unfolding prune_def by auto
    have 3: "u \<in> greachable A w V v" using graph.reachable.execute assms(2) 2(1) by blast
    have 4: "greachable A w V u \<subseteq> greachable A w V v" using 3 by blast
    show "v \<in> prune A w V" unfolding prune_def using assms(1) 2(2) 4 by auto
  qed

  subsubsection \<open>Run Graph Interation\<close>

  definition graph :: "('label, 'state) nba \<Rightarrow> 'label stream \<Rightarrow> nat \<Rightarrow> 'state node set" where
    "graph A w k \<equiv> alternate (clean A w) (prune A w) k (gunodes A w)"

  abbreviation "level A w k l \<equiv> {v \<in> graph A w k. fst v = l}"

  lemma graph_0[simp]: "graph A w 0 = gunodes A w" unfolding graph_def by simp
  lemma graph_Suc[simp]: "graph A w (Suc k) = (if even k then clean A w else prune A w) (graph A w k)"
    unfolding graph_def by simp

  lemma graph_antimono: "antimono (graph A w)"
    using alternate_antimono clean_decreasing prune_decreasing
    unfolding monotone_def le_fun_def graph_def
    by metis
  lemma graph_nodes: "graph A w k \<subseteq> gunodes A w" using graph_0 graph_antimono le0 antimonoD by metis
  lemma graph_successors:
    assumes "v \<in> gunodes A w" "u \<in> gusuccessors A w v"
    shows "u \<in> graph A w k \<Longrightarrow> v \<in> graph A w k"
  using assms
  proof (induct k arbitrary: u v)
    case 0
    show ?case using 0(2) by simp
  next
    case (Suc k)
    have 1: "v \<in> graph A w k" using Suc using antimono_iff_le_Suc graph_antimono rev_subsetD by blast
    show ?case using Suc(2) clean_successors[OF 1 Suc(4)] prune_successors[OF 1 Suc(4)] by auto
  qed

  lemma graph_level_finite:
    assumes "finite (nodes A)"
    shows "finite (level A w k l)"
  proof -
    have "level A w k l \<subseteq> {v \<in> gunodes A w. fst v = l}" by (simp add: graph_nodes subset_CollectI)
    also have "{v \<in> gunodes A w. fst v = l} \<subseteq> {l} \<times> nodes A" using gnodes_nodes by force
    also have "finite ({l} \<times> nodes A)" using assms(1) by simp
    finally show ?thesis by this
  qed

  lemma find_safe:
    assumes "w \<notin> language A"
    assumes "V \<noteq> {}" "V \<subseteq> gunodes A w"
    assumes "\<And> v. v \<in> V \<Longrightarrow> gsuccessors A w V v \<noteq> {}"
    obtains v
    where "v \<in> V" "\<forall> u \<in> greachable A w V v. \<not> gaccepting A u"
  proof (rule ccontr)
    assume 1: "\<not> thesis"
    have 2: "\<And> v. v \<in> V \<Longrightarrow> \<exists> u \<in> greachable A w V v. gaccepting A u" using that 1 by auto
    have 3: "\<And> r v. v \<in> initial A \<Longrightarrow> run A (w ||| r) v \<Longrightarrow> fins (accepting A) r" using assms(1) by auto
    obtain v where 4: "v \<in> V" using assms(2) by force
    obtain x where 5: "x \<in> greachable A w V v" "gaccepting A x" using 2 4 by blast
    obtain y where 50: "gpath A w V y v" "x = gtarget y v" using 5(1) by rule
    obtain r where 6: "grun A w V r x" "infs (\<lambda> x. x \<in> V \<and> gaccepting A x) r"
    proof (rule graph.recurring_condition)
      show "x \<in> V \<and> gaccepting A x" using greachable_subset 4 5 by blast
    next
      fix v
      assume 1: "v \<in> V \<and> gaccepting A v"
      obtain v' where 20: "v' \<in> gsuccessors A w V v" using assms(4) 1 by (meson IntE equals0I)
      have 21: "v' \<in> V" using 20 by auto
      have 22: "\<exists> u \<in> greachable A w V v'. u \<in> V \<and> gaccepting A u"
        using greachable_subset 2 21 by blast
      obtain r where 30: "gpath A w V r v'" "gtarget r v' \<in> V \<and> gaccepting A (gtarget r v')"
        using 22 by blast
      show "\<exists> r. r \<noteq> [] \<and> gpath A w V r v \<and> gtarget r v \<in> V \<and> gaccepting A (gtarget r v)"
      proof (intro exI conjI)
        show "v' # r \<noteq> []" by simp
        show "gpath A w V (v' # r) v" using 20 30 by auto
        show "gtarget (v' # r) v \<in> V" using 30 by simp
        show "gaccepting A (gtarget (v' # r) v)" using 30 by simp
      qed
    qed auto
    obtain u where 100: "u \<in> ginitial A" "v \<in> gureachable A w u" using 4 assms(3) by blast
    have 101: "gupath A w y v" using gpath_subset 50(1) subset_UNIV by this
    have 102: "gurun A w r x" using grun_subset 6(1) subset_UNIV by this
    obtain t where 103: "gupath A w t u" "v = gtarget t u" using 100(2) by rule
    have 104: "gurun A w (t @- y @- r) u" using 101 102 103 50(2) by auto
    obtain s q where 7: "t @- y @- r = fromN (Suc 0) ||| s" "u = (0, q)"
      using grun_elim[OF 104] 100(1) by blast
    have 8: "run A (w ||| s) q" using grun_run[OF 104[unfolded 7]] by simp
    have 9: "q \<in> initial A" using 100(1) 7(2) by auto
    have 91: "sset (trace (w ||| s) q) \<subseteq> reachable A q"
      using nba.reachable_trace nba.reachable.reflexive 8 by this
    have 10: "fins (accepting A) s" using 3 9 8 by this
    have 12: "infs (gaccepting A) r" using infs_mono[OF _ 6(2)] by simp
    have "s = smap snd (t @- y @- r)" unfolding 7(1) by simp
    also have "infs (accepting A) \<dots>" using 12 by (simp add: comp_def)
    finally have 13: "infs (accepting A) s" by this
    show False using 10 13 by simp
  qed

  lemma remove_run:
    assumes "finite (nodes A)" "w \<notin> language A"
    assumes "V \<subseteq> gunodes A w" "clean A w V \<noteq> {}"
    obtains v r
    where
      "grun A w V r v"
      "sset (gtrace r v) \<subseteq> clean A w V"
      "sset (gtrace r v) \<subseteq> - prune A w (clean A w V)"
  proof -
    obtain u where 1: "u \<in> clean A w V" "\<forall> x \<in> greachable A w (clean A w V) u. \<not> gaccepting A x"
    proof (rule find_safe)
      show "w \<notin> language A" using assms(2) by this
      show "clean A w V \<noteq> {}" using assms(4) by this
      show "clean A w V \<subseteq> gunodes A w" using assms(3) by (meson clean_decreasing subset_iff)
    next
      fix v
      assume 1: "v \<in> clean A w V"
      have 2: "v \<in> V" using 1 clean_decreasing by blast
      have 3: "infinite (greachable A w V v)" using 1 clean_def by auto
      have "gsuccessors A w V v \<subseteq> gusuccessors A w v" by auto
      also have "finite \<dots>" using 2 assms(1, 3) finite_nodes_gsuccessors by blast
      finally have 4: "finite (gsuccessors A w V v)" by this
      have 5: "infinite (insert v (\<Union>((greachable A w V) ` (gsuccessors A w V v))))"
        using graph.reachable_step 3 by metis
      obtain u where 6: "u \<in> gsuccessors A w V v" "infinite (greachable A w V u)" using 4 5 by auto
      have 7: "u \<in> clean A w V" using 6 unfolding clean_def by auto
      show "gsuccessors A w (clean A w V) v \<noteq> {}" using 6(1) 7 by auto
    qed auto
    have 2: "u \<in> V" using 1(1) unfolding clean_def by auto
    have 3: "infinite (greachable A w V u)" using 1(1) unfolding clean_def by simp
    have 4: "finite (gsuccessors A w V v)" if "v \<in> greachable A w V u" for v
    proof -
      have 1: "v \<in> V" using that greachable_subset 2 by blast
      have "gsuccessors A w V v \<subseteq> gusuccessors A w v" by auto
      also have "finite \<dots>" using 1 assms(1, 3) finite_nodes_gsuccessors by blast
      finally show ?thesis by this
    qed
    obtain r where 5: "grun A w V r u" using graph.koenig[OF 3 4] by this
    have 6: "greachable A w V u \<subseteq> V" using 2 greachable_subset by blast
    have 7: "sset (gtrace r u) \<subseteq> V"
      using graph.reachable_trace[OF graph.reachable.reflexive 5(1)] 6 by blast
    have 8: "sset (gtrace r u) \<subseteq> clean A w V"
      unfolding clean_def using 7 infinite_greachable_gtrace[OF 5(1)] by auto
    have 9: "sset (gtrace r u) \<subseteq> greachable A w (clean A w V) u"
      using 5 8 by (metis graph.reachable.reflexive graph.reachable_trace grun_subset)
    show ?thesis
    proof
      show "grun A w V r u" using 5(1) by this
      show "sset (gtrace r u) \<subseteq> clean A w V" using 8 by this
      show "sset (gtrace r u) \<subseteq> - prune A w (clean A w V)"
      proof (intro subsetI ComplI)
        fix p
        assume 10: "p \<in> sset (gtrace r u)" "p \<in> prune A w (clean A w V)"
        have 20: "\<exists> x \<in> greachable A w (clean A w V) p. gaccepting A x"
          using 10(2) unfolding prune_def by auto
        have 30: "greachable A w (clean A w V) p \<subseteq> greachable A w (clean A w V) u"
          using 10(1) 9 by blast
        show "False" using 1(2) 20 30 by force
      qed
    qed
  qed

  lemma level_bounded:
    assumes "finite (nodes A)" "w \<notin> language A"
    obtains n
    where "\<And> l. l \<ge> n \<Longrightarrow> card (level A w (2 * k) l) \<le> card (nodes A) - k"
  proof (induct k arbitrary: thesis)
    case (0)
    show ?case
    proof (rule 0)
      fix l :: nat
      have "finite ({l} \<times> nodes A)" using assms(1) by simp
      also have "level A w 0 l \<subseteq> {l} \<times> nodes A" using gnodes_nodes by force
      also (card_mono) have "card \<dots> = card (nodes A)" using assms(1) by simp
      finally show "card (level A w (2 * 0) l) \<le> card (nodes A) - 0" by simp
    qed
  next
    case (Suc k)
    show ?case
    proof (cases "graph A w (Suc (2 * k)) = {}")
      case True
      have 3: "graph A w (2 * Suc k) = {}" using True prune_decreasing by simp blast
      show ?thesis using Suc(2) 3 by simp
    next
      case False
      obtain v r where 1:
        "grun A w (graph A w (2 * k)) r v"
        "sset (gtrace r v) \<subseteq> graph A w (Suc (2 * k))"
        "sset (gtrace r v) \<subseteq> - graph A w (Suc (Suc (2 * k)))"
      proof (rule remove_run)
        show "finite (nodes A)" "w \<notin> language A" using assms by this
        show "clean A w (graph A w (2 * k)) \<noteq> {}" using False by simp
        show "graph A w (2 * k) \<subseteq> gunodes A w" using graph_nodes by this
      qed auto
      obtain l q where 2: "v = (l, q)" by force
      obtain n where 90: "\<And> l. n \<le> l \<Longrightarrow> card (level A w (2 * k) l) \<le> card (nodes A) - k"
        using Suc(1) by blast
      show ?thesis
      proof (rule Suc(2))
        fix j
        assume 100: "n + Suc l \<le> j"
        have 6: "graph A w (Suc (Suc (2 * k))) \<subseteq> graph A w (Suc (2 * k))"
          using graph_antimono antimono_iff_le_Suc by blast
        have 101: "gtrace r v !! (j - Suc l) \<in> graph A w (Suc (2 * k))" using 1(2) snth_sset by auto
        have 102: "gtrace r v !! (j - Suc l) \<notin> graph A w (Suc (Suc (2 * k)))" using 1(3) snth_sset by blast
        have 103: "gtrace r v !! (j - Suc l) \<in> level A w (Suc (2 * k)) j"
          using 1(1) 100 101 2 by (auto elim: grun_elim)
        have 104: "gtrace r v !! (j - Suc l) \<notin> level A w (Suc (Suc (2 * k))) j" using 100 102 by simp
        have "level A w (2 * Suc k) j = level A w (Suc (Suc (2 * k))) j" by simp
        also have "\<dots> \<subset> level A w (Suc (2 * k)) j" using 103 104 6 by blast
        also have "\<dots> \<subseteq> level A w (2 * k) j" by (simp add: Collect_mono clean_def)
        finally have 105: "level A w (2 * Suc k) j \<subset> level A w (2 * k) j" by this
        have "card (level A w (2 * Suc k) j) < card (level A w (2 * k) j)"
          using assms(1) 105 by (simp add: graph_level_finite psubset_card_mono)
        also have "\<dots> \<le> card (nodes A) - k" using 90 100 by simp
        finally show "card (level A w (2 * Suc k) j) \<le> card (nodes A) - Suc k" by simp
      qed
    qed
  qed
  lemma graph_empty:
    assumes "finite (nodes A)" "w \<notin> language A"
    shows "graph A w (Suc (2 * card (nodes A))) = {}"
  proof -
    obtain n where 1: "\<And> l. l \<ge> n \<Longrightarrow> card (level A w (2 * card (nodes A)) l) = 0"
      using level_bounded[OF assms(1, 2), of "card (nodes A)"] by auto
    have "graph A w (2 * card (nodes A)) =
      (\<Union> l \<in> {..< n}. level A w (2 * card (nodes A)) l) \<union>
      (\<Union> l \<in> {n ..}. level A w (2 * card (nodes A)) l)"
      by auto
    also have "(\<Union> l \<in> {n ..}. level A w (2 * card (nodes A)) l) = {}"
      using graph_level_finite assms(1) 1 by fastforce
    also have "finite ((\<Union> l \<in> {..< n}. level A w (2 * card (nodes A)) l) \<union> {})"
      using graph_level_finite assms(1) by auto
    finally have 100: "finite (graph A w (2 * card (nodes A)))" by this
    have 101: "finite (greachable A w (graph A w (2 * card (nodes A))) v)" for v
      using 100 greachable_subset[of A w "graph A w (2 * card (nodes A))" v]
      using finite_insert infinite_super by auto
    show ?thesis using 101 by (simp add: clean_def)
  qed
  lemma graph_le:
    assumes "finite (nodes A)" "w \<notin> language A"
    assumes "v \<in> graph A w k"
    shows "k \<le> 2 * card (nodes A)"
    using graph_empty graph_antimono assms
    by (metis Suc_leI empty_iff monotone_def not_le_imp_less rev_subsetD)

  subsection \<open>Node Ranks\<close>

  definition rank :: "('label, 'state) nba \<Rightarrow> 'label stream \<Rightarrow> 'state node \<Rightarrow> nat" where
    "rank A w v \<equiv> GREATEST k. v \<in> graph A w k"

  lemma rank_member:
    assumes "finite (nodes A)" "w \<notin> language A" "v \<in> gunodes A w"
    shows "v \<in> graph A w (rank A w v)"
  unfolding rank_def
  proof (rule GreatestI_nat)
    show "v \<in> graph A w 0" using assms(3) by simp
    show "k \<le> 2 * card (nodes A)" if "v \<in> graph A w k" for k
      using graph_le assms(1, 2) that by blast
  qed
  lemma rank_removed:
    assumes "finite (nodes A)" "w \<notin> language A"
    shows "v \<notin> graph A w (Suc (rank A w v))"
  proof
    assume "v \<in> graph A w (Suc (rank A w v))"
    then have 2: "Suc (rank A w v) \<le> rank A w v"
      unfolding rank_def using Greatest_le_nat graph_le assms by metis
    then show "False" by auto
  qed
  lemma rank_le:
    assumes "finite (nodes A)" "w \<notin> language A"
    assumes "v \<in> gunodes A w" "u \<in> gusuccessors A w v"
    shows "rank A w u \<le> rank A w v"
  unfolding rank_def
  proof (rule Greatest_le_nat)
    have 1: "u \<in> gureachable A w v" using graph.reachable_successors assms(4) by blast
    have 2: "u \<in> gunodes A w" using assms(3) 1 by auto
    show "v \<in> graph A w (GREATEST k. u \<in> graph A w k)"
    unfolding rank_def[symmetric]
    proof (rule graph_successors)
      show "v \<in> gunodes A w" using assms(3) by this
      show "u \<in> gusuccessors A w v" using assms(4) by this
      show "u \<in> graph A w (rank A w u)" using rank_member assms(1, 2) 2 by this
    qed
    show "k \<le> 2 * card (nodes A)" if "v \<in> graph A w k" for k
      using graph_le assms(1, 2) that by blast
  qed

  lemma language_ranking:
    assumes "finite (nodes A)" "w \<notin> language A"
    shows "ranking A w (rank A w)"
  unfolding ranking_def
  proof (intro conjI ballI allI impI)
    fix v
    assume 1: "v \<in> gunodes A w"
    have 2: "v \<in> graph A w (rank A w v)" using rank_member assms 1 by this
    show "rank A w v \<le> 2 * card (nodes A)" using graph_le assms 2 by this
  next
    fix v u
    assume 1: "v \<in> gunodes A w" "u \<in> gusuccessors A w v"
    show "rank A w u \<le> rank A w v" using rank_le assms 1 by this
  next
    fix v
    assume 1: "v \<in> gunodes A w" "gaccepting A v"
    have 2: "v \<in> graph A w (rank A w v)" using rank_member assms 1(1) by this
    have 3: "v \<notin> graph A w (Suc (rank A w v))" using rank_removed assms by this
    have 4: "v \<in> prune A w (graph A w (rank A w v))" using 2 1(2) unfolding prune_def by auto
    have 5: "graph A w (Suc (rank A w v)) \<noteq> prune A w (graph A w (rank A w v))" using 3 4 by blast
    show "even (rank A w v)" using 5 by auto
  next
    fix v r k
    assume 1: "v \<in> gunodes A w" "gurun A w r v" "smap (rank A w) (gtrace r v) = sconst k"
    have "sset (gtrace r v) \<subseteq> gureachable A w v"
      using 1(2) by (metis graph.reachable.reflexive graph.reachable_trace)
    then have 6: "sset (gtrace r v) \<subseteq> gunodes A w" using 1(1) by blast
    have 60: "rank A w ` sset (gtrace r v) \<subseteq> {k}"
      using 1(3) by (metis equalityD1 sset_sconst stream.set_map)
    have 50: "sset (gtrace r v) \<subseteq> graph A w k"
      using rank_member[OF assms] subsetD[OF 6] 60 unfolding image_subset_iff by auto
    have 70: "grun A w (graph A w k) r v" using grun_subset 1(2) 50 by this
    have 7: "sset (gtrace r v) \<subseteq> clean A w (graph A w k)"
      unfolding clean_def using 50 infinite_greachable_gtrace[OF 70] by auto
    have 8: "sset (gtrace r v) \<inter> graph A w (Suc k) = {}" using rank_removed[OF assms] 60 by blast
    have 9: "sset (gtrace r v) \<noteq> {}" using stream.set_sel(1) by auto
    have 10: "graph A w (Suc k) \<noteq> clean A w (graph A w k)" using 7 8 9 by blast
    show "odd k" using 10 unfolding graph_Suc by auto
  qed

  subsection \<open>Correctness Theorem\<close>

  theorem language_ranking_iff:
    assumes "finite (nodes A)"
    shows "w \<notin> language A \<longleftrightarrow> (\<exists> f. ranking A w f)"
    using ranking_language language_ranking assms by blast

end


theory Scratch_CopyArray
  imports Refine_Imperative_HOL.IICF
begin

definition fill_one_spec :: "int list \<Rightarrow> int list nres" where
  "fill_one_spec l \<equiv> RETURN (map (\<lambda>_. 1) l)"

definition fill_one1 :: "int list \<Rightarrow> int list nres" where
  "fill_one1 l \<equiv> RETURN (fold (\<lambda>i l. (list_update l i 1)) [0..<length l] l)"

lemma fold_fix_length: "x \<le> length l \<Longrightarrow> length (fold (\<lambda>i l. (list_update l i 1)) [0..<x] l) = length l"
  by (induction x) auto

lemma fill_replicate_partial: "x \<le> length l \<Longrightarrow> take x (fold (\<lambda>i l. (list_update l i 1)) [0..<x] l) = replicate x 1" for x
  by (induction x) (auto simp: take_update_last replicate_append_same fold_fix_length)

corollary fill_replicate: "fold (\<lambda>i l. (list_update l i 1)) [0..<length l] l = replicate (length l) 1"
  using fill_replicate_partial by (fastforce simp: fold_fix_length)

corollary fill_length_cong:
  assumes "length l0 = length l1"
  shows "fold (\<lambda>i l. (list_update l i 1)) [0..<length l0] l1 = replicate (length l1) 1"
  unfolding assms fill_replicate ..

lemma fill_one1_refine: "(fill_one1, fill_one_spec) \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding fill_one_spec_def fill_one1_def
  apply (refine_vcg)
  apply (vc_solve simp: fill_replicate map_replicate_const)
  done

definition fill_one2 :: "int list \<Rightarrow> int list nres" where
  "fill_one2 l \<equiv> nfoldli [0..<length l] (\<lambda>_. True) (\<lambda>i l'. ASSERT (i < length l') \<then> RETURN (list_update l' i 1)) l"

lemma fill_one2_refine: "(fill_one2, fill_one1) \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding fill_one2_def fill_one1_def
  apply (refine_vcg nfoldli_rule[where I="\<lambda>l1 l2 l. take (length l1) l = replicate (length l1) 1 \<and> length l1 + length l2 = length l"])
        apply (vc_solve simp: upt_eq_lel_conv take_update_last replicate_append_same fill_length_cong)
  done

sepref_definition fill_one3 is fill_one2 :: "(array_assn int_assn)\<^sup>d \<rightarrow>\<^sub>a (array_assn int_assn)"
  unfolding fill_one2_def
  by sepref

lemmas fill_one3_correct = fill_one3.refine[FCOMP fill_one2_refine, FCOMP fill_one1_refine]

lemma fill_one2_refine': "(fill_one2, fill_one_spec) \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding fill_one2_def fill_one_spec_def
  apply (refine_vcg nfoldli_rule[where I="\<lambda>l1 l2 l. l = map (\<lambda>_. 1) (take (length l1) l) @ drop (length l1) l \<and> length l = length l1 + length l2"])
        apply (vc_solve simp: upt_eq_lel_conv replicate_append_same[symmetric] map_replicate_const upd_conv_take_nth_drop)
  subgoal premises prems
    apply (rewrite prems(1))
    apply simp
    done
  done

end


subsection\<open>SC and Implication-only formulas\<close>
theory MiniSC
imports MiniFormulas SC
begin

abbreviation "is_mini_mset \<Gamma> \<equiv> \<forall>F \<in> set_mset \<Gamma>. is_mini_formula F"
lemma to_mini_mset_is: "is_mini_mset (image_mset to_mini_formula \<Gamma>)" by simp

lemma SC_full_to_mini:
  defines "tms \<equiv> image_mset to_mini_formula"
  assumes asm: "\<Gamma> \<Rightarrow> \<Delta>"
  shows "tms \<Gamma> \<Rightarrow> tms \<Delta>"
proof -
  have tmsi[simp]: "tms (F,S) = to_mini_formula F, tms S" for F S unfolding tms_def by simp
  from asm show ?thesis
  proof(induction \<Gamma> \<Delta> rule: SCp.induct)
    case (BotL \<Gamma>)
    hence "\<bottom> \<in># tms \<Gamma>" unfolding tms_def by force
    thus ?case using SCp.BotL by blast
  next
    case (Ax k \<Gamma> \<Delta>)
    hence "Atom k \<in># tms \<Gamma>" "Atom k \<in># tms \<Delta>" unfolding tms_def using image_iff by fastforce+
    thus ?case using SCp.Ax[of k] by blast
  next
    case (NotR F \<Gamma> \<Delta>) thus ?case
      unfolding tmsi to_mini_formula.simps
      using weakenR SCp.ImpR by blast
  next
    case (NotL \<Gamma> F \<Delta>) from this(2) show ?case
      by(auto intro!: SCp.ImpL)
  next
    case ImpR thus ?case using SCp.ImpR by simp
  next
    case ImpL thus ?case using SCp.ImpL by simp
  next
    case AndR from AndR(3,4) show ?case
      using weakenR by(auto intro!: SCp.ImpR SCp.ImpL)
  next
    case AndL from AndL(2) show ?case
      using weakenR[where 'a='a] by(fastforce intro!: SCp.ImpR SCp.ImpL)
  next
    case OrR from OrR(2) show ?case
      using weakenR by(fastforce intro!: SCp.ImpR SCp.ImpL)
  next
    case (OrL F \<Gamma> \<Delta> G)
    note SCp.ImpL
    moreover {
      have "to_mini_formula F, tms \<Gamma> \<Rightarrow> tms \<Delta>" using  OrL(3)[unfolded tmsi] .
      with weakenR have "to_mini_formula F, tms \<Gamma> \<Rightarrow> \<bottom>, tms \<Delta>" by blast (* sooo close. *)
      with SCp.ImpR have "tms \<Gamma> \<Rightarrow> to_mini_formula F \<^bold>\<rightarrow> \<bottom>, tms \<Delta>" . }
    moreover have "to_mini_formula G, tms \<Gamma> \<Rightarrow> tms \<Delta>" using \<open>tms (G, \<Gamma>) \<Rightarrow> tms \<Delta>\<close> unfolding tmsi .
    ultimately have "(to_mini_formula F \<^bold>\<rightarrow> \<bottom>) \<^bold>\<rightarrow> to_mini_formula G, tms \<Gamma> \<Rightarrow> tms \<Delta>" .
    thus ?case unfolding tmsi to_mini_formula.simps .
  qed
qed

lemma SC_mini_to_full:
  defines "tms \<equiv> image_mset to_mini_formula"
  assumes asm: "tms \<Gamma> \<Rightarrow> tms \<Delta>"
  shows "\<Gamma> \<Rightarrow> \<Delta>"
proof -
  have tmsi[simp]: "tms (F,S) = to_mini_formula F, tms S" for F S unfolding tms_def by simp
  note ImpL_inv ImpR_inv[dest]
  have no: "f \<noteq> (\<lambda>F G. Not F)" "f \<noteq> Or" "f \<noteq> And" if "f F G, S' = tms S" for f F G S S'
    by (metis that is_mini_formula.simps(4-6) msed_map_invR tms_def to_mini_is_mini union_commute)+
  note dr = no(1)[where f="\<lambda>F G. Not F", simplified, dest!]
            no(2)[where f=Or, simplified, dest!]
            no(3)[where f=And, simplified, dest!]
  have whai(* we have an implication *): "
    (\<exists>S2 H J. S = H \<^bold>\<rightarrow> J, S2 \<and> F = to_mini_formula H \<and> G = to_mini_formula J) \<or>
    (\<exists>S2 H J. S = H \<^bold>\<or> J, S2 \<and> F = (to_mini_formula H \<^bold>\<rightarrow> \<bottom>) \<and> G = to_mini_formula J) \<or>
    (\<exists>S2 H J. S = H \<^bold>\<and> J, S2 \<and> F =  to_mini_formula H \<^bold>\<rightarrow> to_mini_formula J \<^bold>\<rightarrow> \<bottom> \<and> G = \<bottom>) \<or>
    (\<exists>S2 H. S = \<^bold>\<not> H, S2 \<and> F = to_mini_formula H \<and> G = \<bottom>)
  " if "F \<^bold>\<rightarrow> G, S1 = tms S" for F G S1 S proof - (* ohno\<dots> *)
    note that[unfolded tms_def]
    then obtain S2 pim where S2: "S1 = image_mset to_mini_formula S2"
                        and   S: "S = pim, S2"
                        and pim: "F \<^bold>\<rightarrow> G = to_mini_formula pim"
      by (metis msed_map_invR union_commute)
    show ?thesis using pim unfolding S by(cases pim; simp; blast)
  qed
  from asm show ?thesis
  proof(induction "tms \<Gamma>"  "tms \<Delta>" arbitrary: \<Gamma> \<Delta> rule: SCp.induct)
    have *: "to_mini_formula F = \<bottom> \<Longrightarrow> F = \<bottom>" for F by(cases F; simp)
    case BotL thus ?case unfolding tms_def using * SCp.BotL by (metis image_iff multiset.set_map)
  next
    have *: "Atom k = to_mini_formula F \<Longrightarrow> F = Atom k" for F k by(cases F; simp)
    case (Ax _ k) thus ?case
      unfolding tms_def unfolding in_image_mset Set.image_iff
      apply(elim bexE)
      apply(drule *)+
      apply(intro SCp.Ax)
    by simp_all
  next
    case (ImpL \<Gamma>' F G)
    note whai[OF ImpL(5)]
    thus ?case proof(elim disjE exE conjE)
      fix S2 H J
      assume *: "\<Gamma> = H \<^bold>\<rightarrow> J, S2" "F = to_mini_formula H" "G = to_mini_formula J"
      hence "\<Gamma>' = tms S2" "F, tms \<Delta> = tms (H,\<Delta>)" "G, \<Gamma>' = tms (J, S2)" "tms \<Delta> = tms \<Delta>" using ImpL.hyps(5) add_left_imp_eq by auto
      from ImpL(2)[OF this(1,2)] ImpL(4)[OF this(3-)]
      show ?thesis using SCp.ImpL by(simp add: *)
    next
      fix S2 H J
      assume *: "\<Gamma> = H \<^bold>\<or> J, S2" "F = to_mini_formula H \<^bold>\<rightarrow> \<bottom>" "G = to_mini_formula J"
      hence "\<Gamma>' = tms S2" "F, tms \<Delta> = tms (H \<^bold>\<rightarrow> \<bottom>,\<Delta>)" "G, \<Gamma>' = tms (J, S2)" "tms \<Delta> = tms \<Delta>" using ImpL.hyps(5) add_left_imp_eq by auto
      from ImpL(2)[OF this(1,2)] ImpL(4)[OF this(3-)]
      show ?thesis using Bot_delR by(force intro!: SCp.OrL dest!: ImpR_inv simp: *)
    next
      fix S2 H J
      assume *: "\<Gamma> = H \<^bold>\<and> J, S2" "F = to_mini_formula H \<^bold>\<rightarrow> to_mini_formula J \<^bold>\<rightarrow> \<bottom>" "G = \<bottom>"
      hence "\<Gamma>' = tms S2" "F, tms \<Delta> = tms (H \<^bold>\<rightarrow> J \<^bold>\<rightarrow> \<bottom>,\<Delta>)" "G, \<Gamma>' = tms (\<bottom>, S2)" "tms \<Delta> = tms \<Delta>" using ImpL.hyps(5) add_left_imp_eq by auto
      from ImpL(2)[OF this(1,2)]
      show ?thesis using Bot_delR SCp.AndL ImpR_inv * by (metis add_mset_remove_trivial inL1)
    next
      fix S2 H
      assume *: "\<Gamma> = \<^bold>\<not> H, S2" "F = to_mini_formula H" "G = \<bottom>"
      hence "\<Gamma>' = tms S2" "F, tms \<Delta> = tms (H,\<Delta>)" "G, \<Gamma>' = tms (\<bottom>, S2)" "tms \<Delta> = tms \<Delta>" using ImpL.hyps(5) add_left_imp_eq by auto
      from ImpL(2)[OF this(1,2)]
      show ?thesis by(force intro!: SCp.NotL dest!: ImpR_inv simp: *)
    qed
  next
    case (ImpR F G \<Delta>')
    note whai[OF ImpR(3)]
    thus ?case proof(elim disjE  exE conjE)
      fix S2 H J
      assume "\<Delta> = H \<^bold>\<rightarrow> J, S2" "F = to_mini_formula H" "G = to_mini_formula J"
      thus ?thesis using ImpR.hyps(2,3) by (auto intro!: SCp.ImpR)
    next
      fix S2 H J
      assume *: "\<Delta> = H \<^bold>\<or> J, S2" "F = to_mini_formula H \<^bold>\<rightarrow> \<bottom>" "G = to_mini_formula J"
      hence "\<Delta>' = tms S2" "F, tms \<Delta> = tms (H \<^bold>\<rightarrow> \<bottom>,\<Delta>)" "G, \<Delta>' = tms (J, S2)" "tms \<Delta> = tms \<Delta>" using ImpR.hyps(3) add_left_imp_eq by auto
      thus ?thesis using SCp.OrR[where 'a='a] * ImpR.hyps(2) by (simp add: NotL_inv)
    next
      have botoff: "\<Gamma> \<Rightarrow> H, \<bottom>, S2 \<Longrightarrow> \<Gamma> \<Rightarrow> H, S2" for \<Gamma> H S2 using Bot_delR by fastforce
      fix S2 H J
      assume *: "\<Delta> = H \<^bold>\<and> J, S2" "F = to_mini_formula H \<^bold>\<rightarrow> to_mini_formula J \<^bold>\<rightarrow> \<bottom>" "G = \<bottom>"
      hence "F, tms \<Gamma> = tms (H \<^bold>\<rightarrow> J \<^bold>\<rightarrow> \<bottom>, \<Gamma>)" " G, \<Delta>' = tms (\<bottom>, S2)"
        using ImpR.hyps(3) by(auto) (* hm, not optimal that we need mini_mini\<dots> *)
      from ImpR(2)[OF this] show ?thesis by(auto simp add: * intro!: SCp.intros(3-) dest!: ImpL_inv botoff)
    next
      (* verbose version *)
      fix S2 H
      assume "\<Delta> = \<^bold>\<not> H, S2" "F = to_mini_formula H" "G = \<bottom>"
      then obtain S2 H where *: "\<Delta> = \<^bold>\<not> H, S2" "F = to_mini_formula H \<and> G = \<bottom>" by blast
      hence "F, tms \<Gamma> = tms (H, \<Gamma>)" "G, \<Delta>' = tms (\<bottom>, S2)" using ImpR(3) by simp_all
      with ImpR(2) have "H, \<Gamma> \<Rightarrow> \<bottom>, S2" .
      hence "\<Gamma> \<Rightarrow> \<^bold>\<not> H, S2" using SCp.NotR Bot_delR by fastforce
      thus "\<Gamma> \<Rightarrow> \<Delta>" by(simp add: *)
    qed
  qed auto
qed

theorem MiniSC_eq: "image_mset to_mini_formula \<Gamma> \<Rightarrow> image_mset to_mini_formula \<Delta> \<longleftrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
  using SC_mini_to_full SC_full_to_mini by blast

end


theory Short_Theory_12_14
  imports "HOL-IMP.BExp" "HOL-IMP.Star"
begin

datatype
  com = SKIP
  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
  | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [60, 0] 61)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
  where
    Skip: "(SKIP,s) \<Rightarrow> s" |
    Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
    Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
    RepeatTrue: "\<lbrakk> bval b t; (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
    RepeatFalse: "\<lbrakk> \<not>bval b s\<^sub>2; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
      \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
lemmas big_step_induct = big_step.induct[split_format(complete)]
declare big_step.intros [intro]

lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
 \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
\<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_IfE[elim!]: "\<lbrakk>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_WhileE[elim]: "\<lbrakk>
  (WHILE b DO c, s) \<Rightarrow> t;
  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_RepeatE[elim]: "\<lbrakk>
  (REPEAT c UNTIL b, s) \<Rightarrow> t;
  \<lbrakk>bval b t; (c, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
  \<And>s\<^sub>2. \<lbrakk>\<not> bval b s\<^sub>2; (c, s) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induct arbitrary: u rule: big_step.induct) blast+

lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
      case WhileFalse
      thus ?thesis by blast
    next
      case WhileTrue
      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
      \<comment> \<open>first, the body of the True-branch:\<close>
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
    qed
  qed
  moreover
  \<comment> \<open>now the other direction:\<close>
  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
      case IfFalse
      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
      thus ?thesis using \<open>\<not>bval b s\<close> by blast
    next
      case IfTrue
      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
    qed
  qed
  ultimately
  show ?thesis by blast
qed

lemma unfold_repeat:
  "(REPEAT c UNTIL b) \<sim> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b)" (is "?r \<sim> ?sr")
proof -
  {
    fix s t
    assume "(?r, s) \<Rightarrow> t"
    then have "(?sr, s) \<Rightarrow> t"
    proof cases
      case RepeatTrue
      thus ?thesis by blast
    next
      case (RepeatFalse s\<^sub>2)
      from RepeatFalse(1, 2) have "\<not>(bval b t \<and> (c, s) \<Rightarrow> t)"
        by (cases "s\<^sub>2 = t") (auto simp add: big_step_determ)
      with \<open>(?r, s) \<Rightarrow> t\<close> obtain s' where
        "\<not> bval b s'" "(c, s) \<Rightarrow> s'" and "(?r, s') \<Rightarrow> t" by auto
      from this(1, 3) have "(IF b THEN SKIP ELSE ?r, s') \<Rightarrow> t" by (rule IfFalse)
      with \<open>(c, s) \<Rightarrow> s'\<close> show ?thesis by (rule Seq)
    qed
  }
  moreover
  {
    fix s t
    assume "(?sr, s) \<Rightarrow> t"
    then have "(?r, s) \<Rightarrow> t"
    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
      case (Seq s\<^sub>2)
      from Seq(2) show "(?r, s) \<Rightarrow> t"
      proof cases
        case IfTrue
        from IfTrue(2) have "s\<^sub>2 = t" by auto
        with Seq(1) IfTrue(1) show ?thesis by auto
      next
        case IfFalse
        with Seq(1) show ?thesis by auto
      qed
    qed
  }
  ultimately
  show ?thesis by blast
qed

type_synonym assn = "state \<Rightarrow> bool"

definition hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
  "\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
  ("_[_'/_]" [1000,0,0] 999) where
  "s[a/x] == s(x := aval a s)"

inductive hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50) where
  Skip: "\<turnstile> {P} SKIP {P}" |
  Assign: "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}" |
  Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q}; \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk> \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}" |
  If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
    \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}" |
  While: "\<lbrakk>\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}\<rbrakk> \<Longrightarrow> \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}" |
  Repeat: "\<lbrakk>\<turnstile> {P} c {Q}; \<forall>s. Q s \<and> \<not>bval b s \<longrightarrow> P s\<rbrakk> \<Longrightarrow> \<turnstile> {P} REPEAT c UNTIL b {\<lambda>s. Q s \<and> bval b s}" |
  conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
    \<Longrightarrow> \<turnstile> {P'} c {Q'}"

lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If

lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If

text\<open>The assignment and While rule are awkward to use in actual proofs
because their pre and postcondition are of a very special form and the actual
goal would have to match this form exactly. Therefore we derive two variants
with arbitrary pre and postconditions.\<close>

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

lemma While':
assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile> {P} WHILE b DO c {Q}"
  by(rule weaken_post[OF While[OF assms(1)] assms(2)])

lemma Repeat':
  assumes "\<turnstile> {P} c {Q}" and "\<forall>s. Q s \<and> \<not>bval b s \<longrightarrow> P s" and "\<forall>s. Q s \<and> bval b s \<longrightarrow> Q' s"
  shows "\<turnstile> {P} REPEAT c UNTIL b {Q'}"
  by (rule weaken_post [OF Repeat [OF assms(1) assms(2)] assms(3)])

lemma hoare_sound: "\<turnstile> {P} c {Q} \<Longrightarrow> \<Turnstile> {P} c {Q}"
proof(induction rule: hoare.induct)
  case (While P b c)
  have "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow>  P s  \<Longrightarrow>  P t \<and> \<not> bval b t" for s t
  proof(induction "WHILE b DO c" s t rule: big_step_induct)
    case WhileFalse thus ?case by blast
  next
    case WhileTrue thus ?case
      using While.IH unfolding hoare_valid_def by blast
  qed
  thus ?case unfolding hoare_valid_def by blast
next
  case (Repeat P c Q b)
  have "(REPEAT c UNTIL b, s) \<Rightarrow> t \<Longrightarrow> P s \<Longrightarrow> Q t \<and> bval b t" for s t
  proof (induct "REPEAT c UNTIL b" s t rule: big_step_induct) (* note: case analysis sufficed *)
    case (RepeatTrue t s)
    from Repeat(3) RepeatTrue(1, 2, 4) show ?case unfolding hoare_valid_def by blast
  next
    case (RepeatFalse s\<^sub>2 s\<^sub>1 s\<^sub>3)
    from Repeat(2, 3) RepeatFalse(1, 2, 5, 6) show ?case unfolding hoare_valid_def by blast
  qed
  thus ?case unfolding hoare_valid_def by blast
qed (auto simp: hoare_valid_def)

definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
"wp c Q = (\<lambda>s. \<forall>t. (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

lemma wp_SKIP[simp]: "wp SKIP Q = Q"
  by (rule ext) (auto simp: wp_def)

lemma wp_Ass[simp]: "wp (x::=a) Q = (\<lambda>s. Q(s[a/x]))"
  by (rule ext) (auto simp: wp_def)

lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) Q = wp c\<^sub>1 (wp c\<^sub>2 Q)"
  by (rule ext) (auto simp: wp_def)

lemma wp_If[simp]:
  "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q =
  (\<lambda>s. if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)"
  by (rule ext) (auto simp: wp_def)

lemma wp_While_If:
  "wp (WHILE b DO c) Q s =
  wp (IF b THEN c;;WHILE b DO c ELSE SKIP) Q s"
  unfolding wp_def by (metis unfold_while)

lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
  wp (WHILE b DO c) Q s = wp (c;; WHILE b DO c) Q s"
  by(simp add: wp_While_If)

lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) Q s = Q s"
  by(simp add: wp_While_If)

lemma wp_Repeat_If:
  "wp (REPEAT c UNTIL b) Q s =
  wp (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b) Q s"
  unfolding wp_def by (metis unfold_repeat)

lemma wp_Repeat [simp]: "wp c (\<lambda>s. wp (REPEAT c UNTIL b) Q s \<and> \<not>bval b s \<or> Q s \<and> bval b s) s = wp (REPEAT c UNTIL b) Q s"
  unfolding wp_def by (auto simp add: wp_Repeat_If)

lemma wp_c_bval_or: "wp c (bval b) s \<or> wp c (\<lambda>s. \<not>bval b s) s"
  unfolding wp_def
proof (cases "\<forall>t. (c, s) \<Rightarrow> t \<longrightarrow> bval b t")
  case False
  then obtain t\<^sub>0 where H: "(c, s) \<Rightarrow> t\<^sub>0" "\<not>bval b t\<^sub>0" by blast
  then show "(\<forall>t. (c, s) \<Rightarrow> t \<longrightarrow> bval b t) \<or> (\<forall>t. (c, s) \<Rightarrow> t \<longrightarrow> \<not> bval b t)" (is "?L \<or> ?R")
  proof -
    have "?R"
    proof (intro allI impI)
      fix t
      assume "(c, s) \<Rightarrow> t"
      with H(1) have "t = t\<^sub>0" by (simp add: big_step_determ)
      with H(2) show "\<not>bval b t" by simp
    qed
    then show ?thesis by blast
  qed
qed simp

lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
proof(induction c arbitrary: Q)
  case If thus ?case by(auto intro: conseq)
next
  case (While b c)
  let ?w = "WHILE b DO c"
  show "\<turnstile> {wp ?w Q} ?w {Q}"
  proof(rule While')
    show "\<turnstile> {\<lambda>s. wp ?w Q s \<and> bval b s} c {wp ?w Q}"
    proof(rule strengthen_pre[OF _ While.IH])
      show "\<forall>s. wp ?w Q s \<and> bval b s \<longrightarrow> wp c (wp ?w Q) s" by auto
    qed
    show "\<forall>s. wp ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
  qed
next
  case (Repeat c b)
  let ?r = "REPEAT c UNTIL b"
  show "\<turnstile> {wp ?r Q} ?r {Q}"
  proof (rule Repeat')
    show "\<turnstile> {wp (REPEAT c UNTIL b) Q} c {\<lambda>s. (wp (REPEAT c UNTIL b) Q s \<and> \<not>bval b s) \<or> (Q s \<and> bval b s)}"
      by (rule strengthen_pre [OF _ Repeat]) simp
  qed auto
qed auto

lemma hoare_complete: assumes "\<Turnstile> {P}c{Q}" shows "\<turnstile> {P}c{Q}"
proof(rule strengthen_pre)
  show "\<forall>s. P s \<longrightarrow> wp c Q s" using assms
    by (auto simp: hoare_valid_def wp_def)
  show "\<turnstile> {wp c Q} c {Q}" by(rule wp_is_pre)
qed

corollary hoare_sound_complete: "\<turnstile> {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
  by (metis hoare_complete hoare_sound)

end