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 n k where 3: "sdrop n (smap f (v ## gtrace r v)) = sconst k"
      using sdescending_stuck[OF 2] by metis
    have "gtrace (sdrop (Suc n) r) (gtarget (stake (Suc n) r) v) = sdrop (Suc n) (gtrace r v)"
      using sscan_sdrop by rule
    also have "smap f \<dots> = sdrop n (smap f (v ## gtrace r v))"
      by (auto, metis 3 id_apply sdrop_smap sdrop_stl siterate.simps(2)
        sscan_const stream.map stream.map_sel(2) stream.sel(2))
    also have "\<dots> = sconst k" using 3 by this
    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 "sset (smap f (gtrace (sdrop n r) (gtarget (stake n r) v))) \<subseteq> Collect 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 "sset (smap f (gtrace (sdrop n r) (gtarget (stake n r) v))) = sset (sconst k)"
      unfolding 1 by rule
    also have "\<dots> \<subseteq> Collect odd" using 4 by simp
    finally show ?thesis using that by simp
  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: "sset (smap f (gtrace (sdrop n ?r) (gtarget (stake n ?r) ?v))) \<subseteq> {a. odd a}"
      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 antimono_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 (no_types, lifting) Suc_leI antimono_def basic_trans_rules(30) empty_iff not_le_imp_less)

  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 "\<forall> k. v \<in> graph A w k \<longrightarrow> k \<le> 2 * card (nodes A)" using graph_le assms(1, 2) 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 "\<forall> k. v \<in> graph A w k \<longrightarrow> k \<le> 2 * card (nodes A)" using graph_le assms(1, 2) 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


(*  Title:      Doc/Corec/Corec.thy
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Andreas Lochbihler, ETH Zuerich
    Author:     Andrei Popescu, Middlesex University
    Author:     Dmitriy Traytel, ETH Zuerich

Tutorial for nonprimitively corecursive definitions.
*)

theory Corec
imports GCD "../Datatypes/Setup" "~~/src/HOL/Library/BNF_Corec"
  "~~/src/HOL/Library/FSet"
begin

section \<open>Introduction
  \label{sec:introduction}\<close>

text \<open>
Isabelle's (co)datatype package @{cite "isabelle-datatypes"} offers a convenient
syntax for introducing codatatypes. For example, the type of (infinite) streams
can be defined as follows (cf. \<^file>\<open>~~/src/HOL/Library/Stream.thy\<close>):
\<close>

    codatatype 'a stream =
      SCons (shd: 'a) (stl: "'a stream")

text \<open>
\noindent
The (co)datatype package also provides two commands, \keyw{primcorec} and
\keyw{prim\-corec\-ur\-sive}, for defining primitively corecursive functions.

This tutorial presents a definitional package for functions beyond
primitive corecursion. It describes @{command corec} and related commands:\
@{command corecursive}, @{command friend_of_corec}, and @{command coinduction_upto}.
It also covers the @{method corec_unique} proof method.
The package is not part of @{theory Main}; it is located in
\<^file>\<open>~~/src/HOL/Library/BNF_Corec.thy\<close>.

The @{command corec} command generalizes \keyw{primcorec} in three main
respects. First, it allows multiple constructors around corecursive calls, where
\keyw{primcorec} expects exactly one. For example:
\<close>

    corec oneTwos :: "nat stream" where
      "oneTwos = SCons 1 (SCons 2 oneTwos)"

text \<open>
Second, @{command corec} allows other functions than constructors to appear in
the corecursive call context (i.e., around any self-calls on the right-hand side
of the equation). The requirement on these functions is that they must be
\emph{friendly}. Intuitively, a function is friendly if it needs to destruct
at most one constructor of input to produce one constructor of output.
We can register functions as friendly using the @{command friend_of_corec}
command, or by passing the @{text friend} option to @{command corec}. The
friendliness check relies on an internal syntactic check in combination with
a parametricity subgoal, which must be discharged manually (typically using
@{method transfer_prover} or @{method transfer_prover_eq}).

Third, @{command corec} allows self-calls that are not guarded by a constructor,
as long as these calls occur in a friendly context (a context consisting
exclusively of friendly functions) and can be shown to be terminating
(well founded). The mixture of recursive and corecursive calls in a single
function can be quite useful in practice.

Internally, the package synthesizes corecursors that take into account the
possible call contexts. The corecursor is accompanined by a corresponding,
equally general coinduction principle. The corecursor and the coinduction
principle grow in expressiveness as we interact with it. In process algebra
terminology, corecursion and coinduction take place \emph{up to} friendly
contexts.

The package fully adheres to the LCF philosophy @{cite mgordon79}: The
characteristic theorems associated with the specified corecursive functions are
derived rather than introduced axiomatically.
(Exceptionally, most of the internal proof obligations are omitted if the
@{text quick_and_dirty} option is enabled.)
The package is described in a pair of scientific papers
@{cite "blanchette-et-al-2015-fouco" and "blanchette-et-al-201x-amico"}. Some
of the text and examples below originate from there.

This tutorial is organized as follows:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item Section \ref{sec:introductory-examples}, ``Introductory Examples,''
describes how to specify corecursive functions and to reason about them.

\item Section \ref{sec:command-syntax}, ``Command Syntax,'' describes the syntax
of the commands offered by the package.

\item Section \ref{sec:generated-theorems}, ``Generated Theorems,'' lists the
theorems produced by the package's commands.

\item Section \ref{sec:proof-methods}, ``Proof Methods,'' briefly describes the
@{method corec_unique} and @{method transfer_prover_eq} proof methods.

\item Section \ref{sec:attribute}, ``Attribute,'' briefly describes the
@{attribute friend_of_corec_simps} attribute, which can be used to strengthen
the tactics underlying the @{command friend_of_corec} and @{command corec}
@{text "(friend)"} commands.

\item Section \ref{sec:known-bugs-and-limitations}, ``Known Bugs and
Limitations,'' concludes with known open issues.
\end{itemize}

Although it is more powerful than \keyw{primcorec} in many respects,
@{command corec} suffers from a number of limitations. Most notably, it does
not support mutually corecursive codatatypes, and it is less efficient than
\keyw{primcorec} because it needs to dynamically synthesize corecursors and
corresponding coinduction principles to accommodate the friends.

\newbox\boxA
\setbox\boxA=\hbox{\texttt{NOSPAM}}

\newcommand\authoremaili{\texttt{jasmin.blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
gmail.\allowbreak com}}

Comments and bug reports concerning either the package or this tutorial should
be directed to the first author at \authoremaili{} or to the
\texttt{cl-isabelle-users} mailing list.
\<close>

section \<open>Introductory Examples
  \label{sec:introductory-examples}\<close>

text \<open>
The package is illustrated through concrete examples featuring different flavors
of corecursion. More examples can be found in the directory
\<^dir>\<open>~~/src/HOL/Corec_Examples\<close>.
\<close>

subsection \<open>Simple Corecursion
  \label{ssec:simple-corecursion}\<close>

text \<open>
The case studies by Rutten~@{cite rutten05} and Hinze~@{cite hinze10} on stream
calculi serve as our starting point. The following definition of pointwise sum
can be performed with either \keyw{primcorec} or @{command corec}:
\<close>

    primcorec ssum :: "('a :: plus) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
      "ssum xs ys = SCons (shd xs + shd ys) (ssum (stl xs) (stl ys))"

text \<open>
\noindent
Pointwise sum meets the friendliness criterion. We register it as a friend using
the @{command friend_of_corec} command. The command requires us to give a
specification of @{const ssum} where a constructor (@{const SCons}) occurs at
the outermost position on the right-hand side. Here, we can simply reuse the
\keyw{primcorec} specification above:
\<close>

    friend_of_corec ssum :: "('a :: plus) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
      "ssum xs ys = SCons (shd xs + shd ys) (ssum (stl xs) (stl ys))"
       apply (rule ssum.code)
      by transfer_prover

text \<open>
\noindent
The command emits two subgoals. The first subgoal corresponds to the equation we
specified and is trivial to discharge. The second subgoal is a parametricity
property that captures the the requirement that the function may destruct at
most one constructor of input to produce one constructor of output. This subgoal
can usually be discharged using the @{text transfer_prover} or
@{method transfer_prover_eq} proof method (Section~\ref{ssec:transfer-prover-eq}).
The latter replaces equality relations by their relator terms according to the
@{thm [source] relator_eq} theorem collection before it invokes
@{method transfer_prover}.

After registering @{const ssum} as a friend, we can use it in the corecursive
call context, either inside or outside the constructor guard:
\<close>

    corec fibA :: "nat stream" where
      "fibA = SCons 0 (ssum (SCons 1 fibA) fibA)"

text \<open>\blankline\<close>

    corec fibB :: "nat stream" where
      "fibB = ssum (SCons 0 (SCons 1 fibB)) (SCons 0 fibB)"

text \<open>
Using the @{text "friend"} option, we can simultaneously define a function and
register it as a friend:
\<close>

    corec (friend)
      sprod :: "('a :: {plus,times}) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
    where
      "sprod xs ys =
       SCons (shd xs * shd ys) (ssum (sprod xs (stl ys)) (sprod (stl xs) ys))"

text \<open>\blankline\<close>

    corec (friend) sexp :: "nat stream \<Rightarrow> nat stream" where
      "sexp xs = SCons (2 ^^ shd xs) (sprod (stl xs) (sexp xs))"

text \<open>
\noindent
The parametricity subgoal is given to @{text transfer_prover_eq}
(Section~\ref{ssec:transfer-prover-eq}).

The @{const sprod} and @{const sexp} functions provide shuffle product and
exponentiation on streams. We can use them to define the stream of factorial
numbers in two different ways:
\<close>

    corec factA :: "nat stream" where
      "factA = (let zs = SCons 1 factA in sprod zs zs)"

text \<open>\blankline\<close>

    corec factB :: "nat stream" where
      "factB = sexp (SCons 0 factB)"

text \<open>
The arguments of friendly functions can be of complex types involving the
target codatatype. The following example defines the supremum of a finite set of
streams by primitive corecursion and registers it as friendly:
\<close>

    corec (friend) sfsup :: "nat stream fset \<Rightarrow> nat stream" where
      "sfsup X = SCons (Sup (fset (fimage shd X))) (sfsup (fimage stl X))"

text \<open>
\noindent
In general, the arguments may be any bounded natural functor (BNF)
@{cite "isabelle-datatypes"}, with the restriction that the target codatatype
(@{typ "nat stream"}) may occur only in a \emph{live} position of the BNF. For
this reason, the following function, on unbounded sets, cannot be registered as
a friend:
\<close>

    primcorec ssup :: "nat stream set \<Rightarrow> nat stream" where
      "ssup X = SCons (Sup (image shd X)) (ssup (image stl X))"

subsection \<open>Nested Corecursion
  \label{ssec:nested-corecursion}\<close>

text \<open>
The package generally supports arbitrary codatatypes with multiple constructors
and nesting through other type constructors (BNFs). Consider the following type
of finitely branching Rose trees of potentially infinite depth:
\<close>

    codatatype 'a tree =
      Node (lab: 'a) (sub: "'a tree list")

text \<open>
We first define the pointwise sum of two trees analogously to @{const ssum}:
\<close>

    corec (friend) tsum :: "('a :: plus) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
      "tsum t u =
       Node (lab t + lab u) (map (\<lambda>(t', u'). tsum t' u') (zip (sub t) (sub u)))"

text \<open>
\noindent
Here, @{const map} is the standard map function on lists, and @{const zip}
converts two parallel lists into a list of pairs. The @{const tsum} function is
primitively corecursive. Instead of @{command corec} @{text "(friend)"}, we could
also have used \keyw{primcorec} and @{command friend_of_corec}, as we did for
@{const ssum}.

Once @{const tsum} is registered as friendly, we can use it in the corecursive
call context of another function:
\<close>

    corec (friend) ttimes :: "('a :: {plus,times}) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
      "ttimes t u = Node (lab t * lab u)
         (map (\<lambda>(t', u'). tsum (ttimes t u') (ttimes t' u)) (zip (sub t) (sub u)))"

text \<open>
All the syntactic convenience provided by \keyw{primcorec} is also supported by
@{command corec}, @{command corecursive}, and @{command friend_of_corec}. In
particular, nesting through the function type can be expressed using
@{text \<lambda>}-abstractions and function applications rather than through composition
(@{term "op \<circ>"}, the map function for @{text \<Rightarrow>}). For example:
\<close>

    codatatype 'a language =
      Lang (\<oo>: bool) (\<dd>: "'a \<Rightarrow> 'a language")

text \<open>\blankline\<close>

    corec (friend) Plus :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Plus r s = Lang (\<oo> r \<or> \<oo> s) (\<lambda>a. Plus (\<dd> r a) (\<dd> s a))"

text \<open>\blankline\<close>

    corec (friend) Times :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Times r s = Lang (\<oo> r \<and> \<oo> s)
         (\<lambda>a. if \<oo> r then Plus (Times (\<dd> r a) s) (\<dd> s a) else Times (\<dd> r a) s)"

text \<open>\blankline\<close>

    corec (friend) Star :: "'a language \<Rightarrow> 'a language" where
      "Star r = Lang True (\<lambda>a. Times (\<dd> r a) (Star r))"

text \<open>\blankline\<close>

    corec (friend) Inter :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Inter r s = Lang (\<oo> r \<and> \<oo> s) (\<lambda>a. Inter (\<dd> r a) (\<dd> s a))"

text \<open>\blankline\<close>

    corec (friend) PLUS :: "'a language list \<Rightarrow> 'a language" where
      "PLUS xs = Lang (\<exists>x \<in> set xs. \<oo> x) (\<lambda>a. PLUS (map (\<lambda>r. \<dd> r a) xs))"

subsection \<open>Mixed Recursion--Corecursion
  \label{ssec:mixed-recursion-corecursion}\<close>

text \<open>
It is often convenient to let a corecursive function perform some finite
computation before producing a constructor. With mixed recursion--corecursion, a
finite number of unguarded recursive calls perform this calculation before
reaching a guarded corecursive call. Intuitively, the unguarded recursive call
can be unfolded to arbitrary finite depth, ultimately yielding a purely
corecursive definition. An example is the @{term primes} function from Di
Gianantonio and Miculan @{cite "di-gianantonio-miculan-2003"}:
\<close>

    corecursive primes :: "nat \<Rightarrow> nat \<Rightarrow> nat stream" where
      "primes m n =
       (if (m = 0 \<and> n > 1) \<or> coprime m n then
          SCons n (primes (m * n) (n + 1))
        else
          primes m (n + 1))"
      apply (relation "measure (\<lambda>(m, n).
        if n = 0 then 1 else if coprime m n then 0 else m - n mod m)")
       apply (auto simp: mod_Suc intro: Suc_lessI)
       apply (metis One_nat_def coprime_Suc_nat gcd.commute gcd_red_nat)
      by (metis diff_less_mono2 lessI mod_less_divisor)

text \<open>
\noindent
The @{command corecursive} command is a variant of @{command corec} that allows
us to specify a termination argument for any unguarded self-call.

When called with @{text "m = 1"} and @{text "n = 2"}, the @{const primes}
function computes the stream of prime numbers. The unguarded call in the
@{text else} branch increments @{term n} until it is coprime to the first
argument @{term m} (i.e., the greatest common divisor of @{term m} and
@{term n} is @{text 1}).

For any positive integers @{term m} and @{term n}, the numbers @{term m} and
@{text "m * n + 1"} are coprime, yielding an upper bound on the number of times
@{term n} is increased. Hence, the function will take the @{text else} branch at
most finitely often before taking the then branch and producing one constructor.
There is a slight complication when @{text "m = 0 \<and> n > 1"}: Without the first
disjunct in the @{text "if"} condition, the function could stall. (This corner
case was overlooked in the original example
@{cite "di-gianantonio-miculan-2003"}.)

In the following examples, termination is discharged automatically by
@{command corec} by invoking @{method lexicographic_order}:
\<close>

    corec catalan :: "nat \<Rightarrow> nat stream" where
      "catalan n =
       (if n > 0 then ssum (catalan (n - 1)) (SCons 0 (catalan (n + 1)))
        else SCons 1 (catalan 1))"

text \<open>\blankline\<close>

    corec collatz :: "nat \<Rightarrow> nat stream" where
      "collatz n = (if even n \<and> n > 0 then collatz (n div 2)
         else SCons n (collatz (3 * n + 1)))"

text \<open>
A more elaborate case study, revolving around the filter function on lazy lists,
is presented in \<^file>\<open>~~/src/HOL/Corec_Examples/LFilter.thy\<close>.
\<close>

subsection \<open>Self-Friendship
  \label{ssec:self-friendship}\<close>

text \<open>
The package allows us to simultaneously define a function and use it as its own
friend, as in the following definition of a ``skewed product'':
\<close>

    corec (friend)
      sskew :: "('a :: {plus,times}) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
    where
      "sskew xs ys =
       SCons (shd xs * shd ys) (sskew (sskew xs (stl ys)) (sskew (stl xs) ys))"

text \<open>
\noindent
Such definitions, with nested self-calls on the right-hand side, cannot be
separated into a @{command corec} part and a @{command friend_of_corec} part.
\<close>

subsection \<open>Coinduction
  \label{ssec:coinduction}\<close>

text \<open>
Once a corecursive specification has been accepted, we normally want to reason
about it. The @{text codatatype} command generates a structural coinduction
principle that matches primitively corecursive functions. For nonprimitive
specifications, our package provides the more advanced proof principle of
\emph{coinduction up to congruence}---or simply \emph{coinduction up-to}.

The structural coinduction principle for @{typ "'a stream"}, called
@{thm [source] stream.coinduct}, is as follows:
%
\begin{indentblock}
@{thm stream.coinduct[no_vars]}
\end{indentblock}
%
Coinduction allows us to prove an equality @{text "l = r"} on streams by
providing a relation @{text R} that relates @{text l} and @{text r} (first
premise) and that constitutes a bisimulation (second premise). Streams that are
related by a bisimulation cannot be distinguished by taking observations (via
the selectors @{const shd} and @{const stl}); hence they must be equal.

The coinduction up-to principle after registering @{const sskew} as friendly is
available as @{thm [source] sskew.coinduct} and as one of the components of
the theorem collection @{thm [source] stream.coinduct_upto}:
%
\begin{indentblock}
@{thm sskew.coinduct[no_vars]}
\end{indentblock}
%
This rule is almost identical to structural coinduction, except that the
corecursive application of @{term R} is generalized to
@{term "stream.v5.congclp R"}.

The @{const stream.v5.congclp} predicate is equipped with the following
introduction rules:

\begin{indentblock}
\begin{description}

\item[@{thm [source] sskew.cong_base}\rm:] ~ \\
@{thm sskew.cong_base[no_vars]}

\item[@{thm [source] sskew.cong_refl}\rm:] ~ \\
@{thm sskew.cong_refl[no_vars]}

\item[@{thm [source] sskew.cong_sym}\rm:] ~ \\
@{thm sskew.cong_sym[no_vars]}

\item[@{thm [source] sskew.cong_trans}\rm:] ~ \\
@{thm sskew.cong_trans[no_vars]}

\item[@{thm [source] sskew.cong_SCons}\rm:] ~ \\
@{thm sskew.cong_SCons[no_vars]}

\item[@{thm [source] sskew.cong_ssum}\rm:] ~ \\
@{thm sskew.cong_ssum[no_vars]}

\item[@{thm [source] sskew.cong_sprod}\rm:] ~ \\
@{thm sskew.cong_sprod[no_vars]}

\item[@{thm [source] sskew.cong_sskew}\rm:] ~ \\
@{thm sskew.cong_sskew[no_vars]}

\end{description}
\end{indentblock}
%
The introduction rules are also available as
@{thm [source] sskew.cong_intros}.

Notice that there is no introduction rule corresponding to @{const sexp},
because @{const sexp} has a more restrictive result type than @{const sskew}
(@{typ "nat stream"} vs. @{typ "('a :: {plus,times}) stream"}.

The version numbers, here @{text v5}, distinguish the different congruence
closures generated for a given codatatype as more friends are registered. As
much as possible, it is recommended to avoid referring to them in proof
documents.

Since the package maintains a set of incomparable corecursors, there is also a
set of associated coinduction principles and a set of sets of introduction
rules. A technically subtle point is to make Isabelle choose the right rules in
most situations. For this purpose, the package maintains the collection
@{thm [source] stream.coinduct_upto} of coinduction principles ordered by
increasing generality, which works well with Isabelle's philosophy of applying
the first rule that matches. For example, after registering @{const ssum} as a
friend, proving the equality @{term "l = r"} on @{typ "nat stream"} might
require coinduction principle for @{term "nat stream"}, which is up to
@{const ssum}.

The collection @{thm [source] stream.coinduct_upto} is guaranteed to be complete
and up to date with respect to the type instances of definitions considered so
far, but occasionally it may be necessary to take the union of two incomparable
coinduction principles. This can be done using the @{command coinduction_upto}
command. Consider the following definitions:
\<close>

    codatatype ('a, 'b) tllist =
      TNil (terminal: 'b)
    | TCons (thd: 'a) (ttl: "('a, 'b) tllist")

text \<open>\blankline\<close>

    corec (friend) square_elems :: "(nat, 'b) tllist \<Rightarrow> (nat, 'b) tllist" where
      "square_elems xs =
       (case xs of
         TNil z \<Rightarrow> TNil z
       | TCons y ys \<Rightarrow> TCons (y ^^ 2) (square_elems ys))"

text \<open>\blankline\<close>

    corec (friend) square_terminal :: "('a, int) tllist \<Rightarrow> ('a, int) tllist" where
      "square_terminal xs =
       (case xs of
         TNil z \<Rightarrow> TNil (z ^^ 2)
       | TCons y ys \<Rightarrow> TCons y (square_terminal ys))"

text \<open>
At this point, @{thm [source] tllist.coinduct_upto} contains three variants of the
coinduction principles:
%
\begin{itemize}
\item @{typ "('a, int) tllist"} up to @{const TNil}, @{const TCons}, and
  @{const square_terminal};
\item @{typ "(nat, 'b) tllist"} up to @{const TNil}, @{const TCons}, and
  @{const square_elems};
\item @{typ "('a, 'b) tllist"} up to @{const TNil} and @{const TCons}.
\end{itemize}
%
The following variant is missing:
%
\begin{itemize}
\item @{typ "(nat, int) tllist"} up to @{const TNil}, @{const TCons},
  @{const square_elems}, and @{const square_terminal}.
\end{itemize}
%
To generate it without having to define a new function with @{command corec},
we can use the following command:
\<close>

    coinduction_upto nat_int_tllist: "(nat, int) tllist"

text \<open>
\noindent
This produces the theorems
%
\begin{indentblock}
@{thm [source] nat_int_tllist.coinduct_upto} \\
@{thm [source] nat_int_tllist.cong_intros}
\end{indentblock}
%
(as well as the individually named introduction rules) and extends
the dynamic collections @{thm [source] tllist.coinduct_upto} and
@{thm [source] tllist.cong_intros}.
\<close>

subsection \<open>Uniqueness Reasoning
  \label{ssec:uniqueness-reasoning}\<close>

text \<open>
It is sometimes possible to achieve better automation by using a more
specialized proof method than coinduction. Uniqueness principles maintain a good
balance between expressiveness and automation. They exploit the property that a
corecursive definition is the unique solution to a fixpoint equation.

The @{command corec}, @{command corecursive}, and @{command friend_of_corec}
commands generate a property @{text f.unique} about the function of interest
@{term f} that can be used to prove that any function that satisfies
@{term f}'s corecursive specification must be equal to~@{term f}. For example:
\[@{thm ssum.unique[no_vars]}\]

The uniqueness principles are not restricted to functions defined using
@{command corec} or @{command corecursive} or registered with
@{command friend_of_corec}. Suppose @{term "t x"} is an arbitrary term
depending on @{term x}. The @{method corec_unique} proof method, provided by our
tool, transforms subgoals of the form
\[@{term "(\<forall>x. f x = H x f) \<Longrightarrow> f x = t x"}\]
into
\[@{term "\<forall>x. t x = H x t"}\]
The higher-order functional @{term H} must be such that @{term "f x = H x f"}
would be a valid @{command corec} specification, but without nested self-calls
or unguarded (recursive) calls. Thus, @{method corec_unique} proves uniqueness
of @{term t} with respect to the given corecursive equation regardless of how
@{term t} was defined. For example:
\<close>

    lemma
      fixes f :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream"
      assumes "\<forall>xs ys. f xs ys =
        SCons (shd ys * shd xs) (ssum (f xs (stl ys)) (f (stl xs) ys))"
      shows "f = sprod"
        using assms
      proof corec_unique
        show "sprod = (\<lambda>xs ys :: nat stream.
            SCons (shd ys * shd xs) (ssum (sprod xs (stl ys)) (sprod (stl xs) ys)))"
          apply (rule ext)+
          apply (subst sprod.code)
          by simp
      qed

text \<open>
The proof method relies on some theorems generated by the package. If no function
over a given codatatype has been defined using @{command corec} or
@{command corecursive} or registered as friendly using @{command friend_of_corec},
the theorems will not be available yet. In such cases, the theorems can be
explicitly generated using the command
\<close>

    coinduction_upto stream: "'a stream"

section \<open>Command Syntax
  \label{sec:command-syntax}\<close>

subsection \<open>\keyw{corec} and \keyw{corecursive}
  \label{ssec:corec-and-corecursive-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "corec"} & : & @{text "local_theory \<rightarrow> local_theory"} \\
  @{command_def "corecursive"} & : & @{text "local_theory \<rightarrow> proof(prove)"}
\end{matharray}

@{rail \<open>
  (@@{command corec} | @@{command corecursive}) target? \<newline>
    @{syntax cr_options}? fix @'where' prop
  ;
  @{syntax_def cr_options}: '(' ((@{syntax plugins} | 'friend' | 'transfer') + ',') ')'
\<close>}

\medskip

\noindent
The @{command corec} and @{command corecursive} commands introduce a corecursive
function over a codatatype.

The syntactic entity \synt{target} can be used to specify a local context,
\synt{fix} denotes name with an optional type signature, and \synt{prop} denotes
a HOL proposition @{cite "isabelle-isar-ref"}.

The optional target is optionally followed by a combination of the following
options:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item
The @{text plugins} option indicates which plugins should be enabled
(@{text only}) or disabled (@{text del}). By default, all plugins are enabled.

\item
The @{text friend} option indicates that the defined function should be
registered as a friend. This gives rise to additional proof obligations.

\item
The @{text transfer} option indicates that an unconditional transfer rule
should be generated and proved @{text "by transfer_prover"}. The
@{text "[transfer_rule]"} attribute is set on the generated theorem.
\end{itemize}

The @{command corec} command is an abbreviation for @{command corecursive}
with appropriate applications of @{method transfer_prover_eq}
(Section~\ref{ssec:transfer-prover-eq}) and @{method lexicographic_order} to
discharge any emerging proof obligations.
\<close>

subsection \<open>\keyw{friend_of_corec}
  \label{ssec:friend-of-corec-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "friend_of_corec"} & : & @{text "local_theory \<rightarrow> proof(prove)"}
\end{matharray}

@{rail \<open>
  @@{command friend_of_corec} target? \<newline>
    @{syntax foc_options}? fix @'where' prop
  ;
  @{syntax_def foc_options}: '(' ((@{syntax plugins} | 'transfer') + ',') ')'
\<close>}

\medskip

\noindent
The @{command friend_of_corec} command registers a corecursive function as
friendly.

The syntactic entity \synt{target} can be used to specify a local context,
\synt{fix} denotes name with an optional type signature, and \synt{prop} denotes
a HOL proposition @{cite "isabelle-isar-ref"}.

The optional target is optionally followed by a combination of the following
options:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item
The @{text plugins} option indicates which plugins should be enabled
(@{text only}) or disabled (@{text del}). By default, all plugins are enabled.

\item
The @{text transfer} option indicates that an unconditional transfer rule
should be generated and proved @{text "by transfer_prover"}. The
@{text "[transfer_rule]"} attribute is set on the generated theorem.
\end{itemize}
\<close>

subsection \<open>\keyw{coinduction_upto}
  \label{ssec:coinduction-upto-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "coinduction_upto"} & : & @{text "local_theory \<rightarrow> local_theory"}
\end{matharray}

@{rail \<open>
  @@{command coinduction_upto} target? name ':' type
\<close>}

\medskip

\noindent
The @{command coinduction_upto} generates a coinduction up-to rule for a given
instance of a (possibly polymorphic) codatatype and notes the result with the
specified prefix.

The syntactic entity \synt{name} denotes an identifier and \synt{type} denotes a
type @{cite "isabelle-isar-ref"}.
\<close>

section \<open>Generated Theorems
  \label{sec:generated-theorems}\<close>

text \<open>
The full list of named theorems generated by the package can be obtained by
issuing the command \keyw{print_theorems} immediately after the datatype definition.
This list excludes low-level theorems that reveal internal constructions. To
make these accessible, add the line
\<close>

    declare [[bnf_internals]]
(*<*)
    declare [[bnf_internals = false]]
(*>*)

text \<open>
In addition to the theorem listed below for each command provided by the
package, all commands update the dynamic theorem collections

\begin{indentblock}
\begin{description}

\item[@{text "t."}\hthm{coinduct_upto}]

\item[@{text "t."}\hthm{cong_intros}]

\end{description}
\end{indentblock}
%
for the corresponding codatatype @{text t} so that they always contain the most
powerful coinduction up-to principles derived so far.
\<close>

subsection \<open>\keyw{corec} and \keyw{corecursive}
  \label{ssec:corec-and-corecursive-theorems}\<close>

text \<open>
For a function @{term f} over codatatype @{text t}, the @{command corec} and
@{command corecursive} commands generate the following properties (listed for
@{const sexp}, cf. Section~\ref{ssec:simple-corecursion}):

\begin{indentblock}
\begin{description}

\item[@{text "f."}\hthm{code} @{text "[code]"}\rm:] ~ \\
@{thm sexp.code[no_vars]} \\
The @{text "[code]"} attribute is set by the @{text code} plugin
@{cite "isabelle-datatypes"}.

\item[@{text "f."}\hthm{coinduct} @{text "[consumes 1, case_names t, case_conclusion D\<^sub>1 \<dots>
  D\<^sub>n]"}\rm:] ~ \\
@{thm sexp.coinduct[no_vars]}

\item[@{text "f."}\hthm{cong_intros}\rm:] ~ \\
@{thm sexp.cong_intros[no_vars]}

\item[@{text "f."}\hthm{unique}\rm:] ~ \\
@{thm sexp.unique[no_vars]} \\
This property is not generated for mixed recursive--corecursive definitions.

\item[@{text "f."}\hthm{inner_induct}\rm:] ~ \\
This property is only generated for mixed recursive--corecursive definitions.
For @{const primes} (Section~\ref{ssec:mixed-recursion-corecursion}, it reads as
follows: \\[\jot]
@{thm primes.inner_induct[no_vars]}

\end{description}
\end{indentblock}

\noindent
The individual rules making up @{text "f.cong_intros"} are available as

\begin{indentblock}
\begin{description}

\item[@{text "f."}\hthm{cong_base}]

\item[@{text "f."}\hthm{cong_refl}]

\item[@{text "f."}\hthm{cong_sym}]

\item[@{text "f."}\hthm{cong_trans}]

\item[@{text "f."}\hthm{cong_C}@{text "\<^sub>1"}, \ldots, @{text "f."}\hthm{cong_C}@{text "\<^sub>n"}] ~ \\
where @{text "C\<^sub>1"}, @{text "\<dots>"}, @{text "C\<^sub>n"} are @{text t}'s
constructors

\item[@{text "f."}\hthm{cong_f}@{text "\<^sub>1"}, \ldots, @{text "f."}\hthm{cong_f}@{text "\<^sub>m"}] ~ \\
where @{text "f\<^sub>1"}, @{text "\<dots>"}, @{text "f\<^sub>m"} are the available
friends for @{text t}

\end{description}
\end{indentblock}
\<close>

subsection \<open>\keyw{friend_of_corec}
  \label{ssec:friend-of-corec-theorems}\<close>

text \<open>
The @{command friend_of_corec} command generates the same theorems as
@{command corec} and @{command corecursive}, except that it adds an optional
@{text "friend."} component to the names to prevent potential clashes (e.g.,
@{text "f.friend.code"}).
\<close>

subsection \<open>\keyw{coinduction_upto}
  \label{ssec:coinduction-upto-theorems}\<close>

text \<open>
The @{command coinduction_upto} command generates the following properties
(listed for @{text nat_int_tllist}):

\begin{indentblock}
\begin{description}

\item[\begin{tabular}{@ {}l@ {}}
  @{text "t."}\hthm{coinduct_upto} @{text "[consumes 1, case_names t,"} \\
  \phantom{@{text "t."}\hthm{coinduct_upto} @{text "["}}@{text "case_conclusion D\<^sub>1 \<dots>
  D\<^sub>n]"}\rm:
\end{tabular}] ~ \\
@{thm nat_int_tllist.coinduct_upto[no_vars]}

\item[@{text "t."}\hthm{cong_intros}\rm:] ~ \\
@{thm nat_int_tllist.cong_intros[no_vars]}

\end{description}
\end{indentblock}

\noindent
The individual rules making up @{text "t.cong_intros"} are available
separately as @{text "t.cong_base"}, @{text "t.cong_refl"}, etc.\
(Section~\ref{ssec:corec-and-corecursive-theorems}).
\<close>

section \<open>Proof Methods
  \label{sec:proof-methods}\<close>

subsection \<open>\textit{corec_unique}
  \label{ssec:corec-unique}\<close>

text \<open>
The @{method corec_unique} proof method can be used to prove the uniqueness of
a corecursive specification. See Section~\ref{ssec:uniqueness-reasoning} for
details.
\<close>

subsection \<open>\textit{transfer_prover_eq}
  \label{ssec:transfer-prover-eq}\<close>

text \<open>
The @{method transfer_prover_eq} proof method replaces the equality relation
@{term "op ="} with compound relator expressions according to
@{thm [source] relator_eq} before calling @{method transfer_prover} on the
current subgoal. It tends to work better than plain @{method transfer_prover} on
the parametricity proof obligations of @{command corecursive} and
@{command friend_of_corec}, because they often contain equality relations on
complex types, which @{method transfer_prover} cannot reason about.
\<close>

section \<open>Attribute
  \label{sec:attribute}\<close>

subsection \<open>\textit{friend_of_corec_simps}
  \label{ssec:friend-of-corec-simps}\<close>

text \<open>
The @{attribute friend_of_corec_simps} attribute declares naturality theorems
to be used by @{command friend_of_corec} and @{command corec} @{text "(friend)"} in
deriving the user specification from reduction to primitive corecursion.
Internally, these commands derive naturality theorems from the parametricity proof
obligations dischared by the user or the @{method transfer_prover_eq} method, but
this derivation fails if in the arguments of a higher-order constant a type variable
occurs on both sides of the function type constructor. The required naturality
theorem can then be declared with @{attribute friend_of_corec_simps}. See
@{file "~~/src/HOL/Corec_Examples/Tests/Iterate_GPV.thy"} for an example.
\<close>

section \<open>Known Bugs and Limitations
  \label{sec:known-bugs-and-limitations}\<close>

text \<open>
This section lists the known bugs and limitations of the corecursion package at
the time of this writing.

\begin{enumerate}
\setlength{\itemsep}{0pt}

\item
\emph{Mutually corecursive codatatypes are not supported.}

\item
\emph{The signature of friend functions may not depend on type variables beyond
those that appear in the codatatype.}

\item
\emph{The internal tactics may fail on legal inputs.}
In some cases, this limitation can be circumvented using the
@{attribute friend_of_corec_simps} attribute
(Section~\ref{ssec:friend-of-corec-simps}).

\item
\emph{The @{text transfer} option is not implemented yet.}

\item
\emph{The constructor and destructor views offered by {\upshape\keyw{primcorec}}
are not supported by @{command corec} and @{command corecursive}.}

\item
\emph{There is no mechanism for registering custom plugins.}

\item
\emph{The package does not interact well with locales.}

\item
\emph{The undocumented @{text corecUU_transfer} theorem is not as polymorphic as
it could be.}

\item
\emph{All type variables occurring in the arguments of a friendly function must occur
as direct arguments of the type constructor of the resulting type.}

\end{enumerate}
\<close>

end


theory  Correspondence_theory  imports DDLE
begin  (*System F *)
lemma limited_corresponds_to_Dstar:
 "(\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<longleftrightarrow> (\<forall>\<Phi> \<Psi>. \<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>>  \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>)"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddevalid_def  sledgehammer
  by auto

(*System G  *)
lemma limited_trans_corresponds_to_SP_Dstar_1:
 "((\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<and> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))
  \<longrightarrow>
  ((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer by smt   (* this direction is provable *)

lemma limited_trans_corresponds_to_SP_Dstar_2: (* this is still too hard for the ATPs *)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow>
  ((\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<and> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
(*
  sledgehammer[timeout=600] () nitpick[timeout=600] nunchaku[timeout=600] (* nunchaku says no countermodel *)
  sledgehammer [timeout=600, remote_leo2 remote_leo3 remote_satallax] ()
   by smt
*)
  (* this direction unfortunately not yet, but we also do not get a countermodel; proof might be to hard *)
  oops

lemma limited_trans_corresponds_to_SP_Dstar_2a: (* splitting the conjunct, limitednedd is easy for the ATPs*)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow>
  (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer by auto

lemma limited_trans_corresponds_to_SP_Dstar_2b: (* splitting the conjunct, transitivity is too hard for the ATPs*)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow>
  ((\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def
(*
  sledgehammer () nitpick nunchaku
  sledgehammer [timeout=600, remote_leo2 remote_leo3 remote_satallax] ()
   by smt
*)

  (* this direction unfortunately not yet, but we also do not get a countermodel; proof might be to hard *)
  sorry

(*** end of header part ***)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory ProvePart
imports Main
begin

text \<open>Introduces a (sort-of) tactic for proving part of a goal by automatic
methods. The split between the proven and unproven part goes down into conjunction,
implication etc. The unproven parts are left in (roughly) their original form.\<close>

text \<open>
The first part is to take a goal and split it into two conjuncts,
e.g. "a \<and> (\<forall>x. b \<and> c x)
    = (((P1 \<longrightarrow> a) \<and> (\<forall>x. (P2 \<longrightarrow> b) \<and> (P3 \<longrightarrow> c x)))
        \<and> ((\<not> P1 \<longrightarrow> a) \<and> (\<forall>x. (\<not> P2 \<longrightarrow> b) \<and> (\<not> P3 \<longrightarrow> c x)))"

The first conjunct is then attacked by some automatic method.

The final part is to eliminate any goals remaining after that
automatic method by setting the Pi to False. The remaining Pi
(whose goal fragments were solved) are set to True. If the
resulting goals cannot be solved by setting to False, or if
no Pi are actually set to true, the process fails.
\<close>

lemma logic_to_conj_thm_workers:
  "A = (A' \<and> A'') \<Longrightarrow> B = (B' \<and> B'')
    \<Longrightarrow> (A \<and> B) = ((A' \<and> B') \<and> (A'' \<and> B''))"
  "B = (B' \<and> B'')
    \<Longrightarrow> (A \<or> B) = ((A \<or> B') \<and> (A \<or> B''))"
  "\<lbrakk> \<And>x. P x = (P' x \<and> P'' x) \<rbrakk>
    \<Longrightarrow> (\<forall>x. P x) = ((\<forall>x. P' x) \<and> (\<forall>x. P'' x))"
  "\<lbrakk> \<And>x. P x = (P' x \<and> P'' x) \<rbrakk>
    \<Longrightarrow> (\<forall>x \<in> S. P x) = ((\<forall>x \<in> S. P' x) \<and> (\<forall>x \<in> S. P'' x))"
  "B = (B' \<and> B'')
    \<Longrightarrow> (A \<longrightarrow> B) = ((A \<longrightarrow> B') \<and> (A \<longrightarrow> B''))"
  by auto

ML \<open>
structure Split_To_Conj = struct

fun abs_name (Abs (s, _, _)) = s
  | abs_name _ = "x"

fun all_type (Const (@{const_name "All"}, T) $ _)
    = domain_type (domain_type T)
  | all_type (Const (@{const_name "Ball"}, T) $ _ $ _)
    = domain_type (domain_type (range_type T))
  | all_type t = raise TERM ("all_type", [t])

fun split_thm prefix ctxt t = let
    val ok = not (String.isPrefix "Q" prefix orelse String.isPrefix "R" prefix)
    val _ = ok orelse error ("split_thm: prefix has prefix Q/R: " ^ prefix)
    fun params (@{term "(\<and>)"} $ x $ y) Ts = params x Ts @ params y Ts
      | params (@{term "(\<or>)"} $ _ $ y) Ts = (Ts, SOME @{typ bool}) :: params y Ts
      | params (all as (Const (@{const_name "All"}, _) $ t)) Ts
        = params (betapply (t, Bound 0)) (all_type all :: Ts)
      | params (ball as (Const (@{const_name "Ball"}, T) $ _ $ t)) Ts
        = (Ts, SOME (domain_type T)) :: params (betapply (t, Bound 0)) (all_type ball :: Ts)
      | params (@{term "(\<longrightarrow>)"} $ _ $ t) Ts = (Ts, SOME @{typ bool}) :: params t Ts
      | params _ Ts = [(Ts, NONE)]
    val ps = params t []
    val Ps = Variable.variant_frees ctxt [t]
        (replicate (length ps) (prefix, @{typ bool}))
        |> map Free
    val Qs = Variable.variant_frees ctxt [t]
        (map (fn (ps, T) => case T of NONE => ("Q", ps ---> @{typ bool})
                | SOME T => ("R", ps ---> T)) ps)
        |> map Free
    val Qs = map (fn (Q, (ps, _)) => Term.list_comb (Q, map Bound (0 upto (length ps - 1))))
        (Qs ~~ ps)
    fun assemble_bits (@{term "(\<and>)"} $ x $ y) Ps = let
        val (x, Ps) = assemble_bits x Ps
        val (y, Ps) = assemble_bits y Ps
      in (@{term "(\<and>)"} $ x $ y, Ps) end
      | assemble_bits (@{term "(\<or>)"} $ _ $ y) Ps = let
        val x = hd Ps
        val (y, Ps) = assemble_bits y (tl Ps)
      in (@{term "(\<or>)"} $ x $ y, Ps) end
      | assemble_bits (all as (Const (@{const_name "All"}, T) $ t)) Ps = let
        val nm = abs_name t
        val (t, Ps) = assemble_bits (betapply (t, Bound 0)) Ps
      in (Const (@{const_name "All"}, T) $ Abs (nm, all_type all, t), Ps) end
      | assemble_bits (ball as (Const (@{const_name "Ball"}, T) $ _ $ t)) Ps = let
        val nm = abs_name t
        val S = hd Ps
        val (t, Ps) = assemble_bits (betapply (t, Bound 0)) (tl Ps)
      in (Const (@{const_name "Ball"}, T) $ S $ Abs (nm, all_type ball, t), Ps) end
      | assemble_bits (@{term "(\<longrightarrow>)"} $ _ $ y) Ps = let
        val x = hd Ps
        val (y, Ps) = assemble_bits y (tl Ps)
      in (@{term "(\<longrightarrow>)"} $ x $ y, Ps) end
      | assemble_bits _ Ps = (hd Ps, tl Ps)
    val bits_lhs = assemble_bits t Qs |> fst
    fun imp tf (P, Q) = if String.isPrefix "R" (fst (dest_Free (head_of Q))) then Q
        else HOLogic.mk_imp (if tf then P else HOLogic.mk_not P, Q)
    val bits_true = assemble_bits t (map (imp true) (Ps ~~ Qs)) |> fst
    val bits_false = assemble_bits t (map (imp false) (Ps ~~ Qs)) |> fst
    val concl = HOLogic.mk_eq (bits_lhs, HOLogic.mk_conj (bits_true, bits_false))
      |> HOLogic.mk_Trueprop
  in (Goal.prove ctxt (map (fst o dest_Free o head_of) Qs) [] concl
    (K (REPEAT_ALL_NEW (resolve_tac ctxt
        @{thms logic_to_conj_thm_workers cases_simp[symmetric]}) 1)),
        map dest_Free Ps)
  end

fun get_split_tac prefix ctxt tac = SUBGOAL (fn (t, i) =>
  let
    val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl t)
    val (thm, Ps) = split_thm prefix ctxt concl
  in (resolve0_tac [ @{thm iffD2} ] THEN' resolve0_tac [thm] THEN' tac Ps) end i)

end
\<close>

text \<open>Testing.\<close>

ML \<open>
Split_To_Conj.split_thm "P" @{context}
  @{term "x & y & (\<forall>t \<in> UNIV. \<forall>n. True \<longrightarrow> z t n)"}
\<close>

ML \<open>
structure Partial_Prove = struct

fun inst_frees_tac _ Ps ct = REPEAT_DETERM o SUBGOAL (fn (t, _) =>
  fn thm => case Term.add_frees t [] |> filter (member (op =) Ps)
  of [] => Seq.empty
  | (f :: _) => let
    val idx = Thm.maxidx_of thm + 1
    val var = ((fst f, idx), snd f)
  in thm |> Thm.generalize (Names.empty, Names.make_set [fst f]) idx
    |> Thm.instantiate (TVars.empty, Vars.make [(var, ct)])
    |> Seq.single
  end)

fun cleanup_tac ctxt Ps
    = inst_frees_tac ctxt Ps @{cterm False}
      THEN' asm_full_simp_tac ctxt

fun finish_tac ctxt Ps = inst_frees_tac ctxt Ps @{cterm True}
    THEN' CONVERSION (Conv.params_conv ~1 (fn ctxt =>
            (Conv.concl_conv ~1 (Simplifier.rewrite (put_simpset HOL_ss ctxt)))
        ) ctxt)

fun test_start_partial_prove ctxt i t = let
    val j = Thm.nprems_of t - i
  in Split_To_Conj.get_split_tac ("P_" ^ string_of_int j ^ "_") ctxt
        (K (K all_tac)) i t
  end

fun test_end_partial_prove ctxt t = let
    fun match_P (s, T) = case space_explode "_" s of
        ["P", n, _] => try (fn () => ((s, T), the (Int.fromString n))) ()
      | _ => NONE
    val Ps = Term.add_frees (Thm.concl_of t) [] |> map_filter match_P
    fun getmax ((x, n) :: xs) max maxes = if n > max then getmax xs n [x]
      else getmax xs max maxes
      | getmax [] max maxes = (max, maxes)
    val (j, Ps) = getmax Ps 0 []
    val i = Thm.nprems_of t - j
  in REPEAT_DETERM (FIRSTGOAL (fn k => if k < i then cleanup_tac ctxt Ps k else no_tac))
    THEN finish_tac ctxt Ps i end t

fun partial_prove tactic ctxt i
    = Split_To_Conj.get_split_tac ("P_" ^ string_of_int i ^ "_") ctxt
      (fn Ps => fn i => tactic i THEN finish_tac ctxt Ps i) i

fun method (ctxtg, []) = (fn ctxt => Method.SIMPLE_METHOD (test_start_partial_prove ctxt 1),
    (ctxtg, []))
  | method _ = error "Partial_Prove: still working on that"

fun fin_method () = Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (test_end_partial_prove ctxt))

end
\<close>

method_setup partial_prove = \<open>Partial_Prove.method\<close>
  "partially prove a compound goal by some automatic method"

method_setup finish_partial_prove = \<open>Partial_Prove.fin_method ()\<close>
  "partially prove a compound goal by some automatic method"

end


theory weird_nat_add3acc_comm23
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

(*hipster add3acc *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (add3acc x y z) = (add3acc x z y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory weird_nat_mul3acc_comm12
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (mul3acc x y z) = (mul3acc y x z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Flattening
imports StackLanguage "../FlatStack/FlatStackLanguage"
begin

fun instruction_convert :: "function_name \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> stack_instruction list \<Rightarrow>
    flat_stack_instruction list" where
  "instruction_convert f ss ls [] = []"
| "instruction_convert f ss ls (Add # \<pi>) = FAdd # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Sub # \<pi>) = FSub # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Neg # \<pi>) = FNeg # instruction_convert f ss ls \<pi>"
| "instruction_convert f ss ls (Eq # \<pi>) = FEq # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Gt # \<pi>) = FGt # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Lt # \<pi>) = FLt # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (And # \<pi>) = FAnd # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Or # \<pi>) = FOr # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Not # \<pi>) = FNot # instruction_convert f ss ls \<pi>"
| "instruction_convert f ss ls (Push (Constant i) # \<pi>) =
    FCon i # instruction_convert f (Suc ss) ls \<pi>"
| "instruction_convert f ss ls (Push (Local v) # \<pi>) =
    FDup (ss + v) # instruction_convert f (Suc ss) ls \<pi>"
| "instruction_convert f ss ls (Push (Argument v) # \<pi>) =
    FDup (ss + ls + v) # instruction_convert f (Suc ss) ls \<pi>"
| "instruction_convert f ss ls (Pop (Constant i) # \<pi>) = FUpd 0 # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Pop (Local v) # \<pi>) =
    FUpd (ss - 1 + v) # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Pop (Argument v) # \<pi>) =
    FUpd (ss - 1 + ls + v) # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (IfJ \<pi>\<^sub>t \<pi>\<^sub>f # \<pi>) =
    FIf (instruction_convert f (ss - 1) ls \<pi>\<^sub>t) (instruction_convert f (ss - 1) ls \<pi>\<^sub>f) #
      instruction_convert f 0 ls \<pi>"
| "instruction_convert f ss ls (Goto s # \<pi>) = [FGoto (CL\<^sub>2 f s)]"
| "instruction_convert f ss ls (Call f' # \<pi>) = undefined # instruction_convert f (ss - 1) ls \<pi>"
| "instruction_convert f ss ls (Return # \<pi>) = undefined # []"
| "instruction_convert f ss ls (Print # \<pi>) = FPrint # instruction_convert f (ss - 1) ls \<pi>"

primrec stack_value_convert :: "stack_value \<Rightarrow> int" where
  "stack_value_convert (IntV i) = i"
| "stack_value_convert (Bool b) = unboolify b"

definition flatten :: "stack_program \<Rightarrow> flat_stack_program" where
  "flatten \<Pi> = (\<lambda>s. case s of
      CL\<^sub>2 f s \<Rightarrow> (case \<Pi> f of
          Some \<pi> \<Rightarrow> (case other_code \<pi> s of
              Some (\<pi>', s') \<Rightarrow> Some (instruction_convert f 0 (local_count \<pi>) \<pi>', CL\<^sub>2 f s')
            | None \<Rightarrow> None)
        | None \<Rightarrow> None))"

definition flatten_frame :: "frame \<Rightarrow> int list" where
  "flatten_frame f =
    map stack_value_convert (frame.locals f @ frame.arguments f @ frame.saved_stack f)"

fun state_convert :: "stack_state \<Rightarrow> flat_stack_state" where
  "state_convert (\<sigma>, \<phi>, (\<pi>, s), \<omega>) = (
    map stack_value_convert \<sigma> @ concat (map flatten_frame \<phi>),
    instruction_convert (frame.name (hd \<phi>)) (length \<sigma>) (length (frame.locals (hd \<phi>))) \<pi>,
    CL\<^sub>2 (frame.name (hd \<phi>)) s, \<omega>)"

(* flattening correct *)

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> finite (dom (flatten \<Pi>))"
  apply (simp add: flatten_def)
  by simp

lemma [simp]: "eval_flat_stack (flatten \<Pi>) (unboolify b1 # unboolify b2 # \<sigma>, FAnd # \<pi>, s, \<omega>)
    (unboolify (b2 \<and> b1) # \<sigma>, \<pi>, s, \<omega>)"
  by (cases b1) (cases b2, (metis boolify_def evf_and unboolify_def)+)+

lemma [simp]: "eval_flat_stack (flatten \<Pi>) (unboolify b1 # unboolify b2 # \<sigma>, FOr # \<pi>, s, \<omega>)
    (unboolify (b2 \<or> b1) # \<sigma>, \<pi>, s, \<omega>)"
  by (cases b1) (cases b2, (metis boolify_def evf_or unboolify_def)+)+

lemma [simp]: "eval_flat_stack (flatten \<Pi>) (unboolify b # \<sigma>, FNot # \<pi>, s, \<omega>)
    (unboolify (\<not> b) # \<sigma>, \<pi>, s, \<omega>)"
  by (cases b) (metis boolify_def evf_not unboolify_def)+

lemma [simp]: "\<Pi> f = Some def \<Longrightarrow> other_code def s = Some (\<pi>, s') \<Longrightarrow>
    flatten \<Pi> (CL\<^sub>2 f s) = Some (instruction_convert f 0 (local_count def) \<pi>, CL\<^sub>2 f s')"
  by (simp add: flatten_def)

lemma [simp]: "length (flatten_frame fr) =
    length (frame.arguments fr) + length (frame.locals fr) + length (frame.saved_stack fr)"
  by (simp add: flatten_frame_def)

lemma [simp]: "n < length (frame.locals fr) \<Longrightarrow>
    flatten_frame fr ! n = stack_value_convert (frame.locals fr ! n)"
  by (simp add: flatten_frame_def nth_append)

lemma [simp]: "n < length (frame.arguments ff) \<Longrightarrow>
    flatten_frame ff ! (length (frame.locals ff) + n) = stack_value_convert (frame.arguments ff ! n)"
  by (simp add: flatten_frame_def nth_append)

lemma [simp]: "eval_stack \<Pi> \<Sigma> \<Sigma>' \<Longrightarrow> valid_state \<Pi> \<Sigma> \<Longrightarrow>
    eval_flat_stack (flatten \<Pi>) (state_convert \<Sigma>) (state_convert \<Sigma>')"
  proof (induction \<Pi> \<Sigma> \<Sigma>' rule: eval_stack.induct)
  case (evs_jump \<Pi> f "def" s \<pi> \<phi> \<omega>)
    hence "valid_frame \<Pi> f" by simp
    with evs_jump show ?case by (cases \<pi>) simp
  next case (evs_push_l n f \<Pi> \<sigma> \<phi> \<pi> s \<omega>)
    hence "stack_value_convert (locals f ! n) =
        (map stack_value_convert \<sigma> @ flatten_frame f @ concat (map flatten_frame \<phi>)) ! (length \<sigma> + n)"
      by (simp add: nth_append)
    with evs_push_l show ?case by simp
  next case (evs_push_a n f \<Pi> \<sigma> \<phi> \<pi> s \<omega>)
    hence "stack_value_convert (arguments f ! n) =
      (map stack_value_convert \<sigma> @ flatten_frame f @ concat (map flatten_frame \<phi>)) !
        (length \<sigma> + length (locals f) + n)" by (simp add: nth_append)
    with evs_push_a show ?case by simp
  next case (evs_pop_l n f \<Pi> v \<sigma> \<phi> \<pi> s \<omega>)
    let ?\<sigma> = "map stack_value_convert \<sigma> @ flatten_frame f @ concat (map flatten_frame \<phi>)"
    let ?\<pi> = "instruction_convert (name f) (length \<sigma>) (length (locals f)) \<pi>"
    from evs_pop_l have "eval_flat_stack (flatten \<Pi>)
      (stack_value_convert v # ?\<sigma>, FUpd (length \<sigma> + n) # ?\<pi>, CL\<^sub>2 (name f) s, \<omega>)
      (?\<sigma>[length \<sigma> + n := stack_value_convert v], ?\<pi>, CL\<^sub>2 (name f) s, \<omega>)" by simp
    with evs_pop_l have "eval_flat_stack (flatten \<Pi>)
      (stack_value_convert v # ?\<sigma>, FUpd (length \<sigma> + n) # ?\<pi>, CL\<^sub>2 (name f) s, \<omega>)
      (map stack_value_convert \<sigma> @ flatten_frame (f\<lparr>locals := locals f[n := v]\<rparr>)
        @ concat (map flatten_frame \<phi>), ?\<pi>, CL\<^sub>2 (name f) s, \<omega>)"
      by (simp add: flatten_frame_def list_update_append map_update)
    thus ?case by simp
  next case (evs_pop_a n f \<Pi> v \<sigma> \<phi> \<pi> s \<omega>)
    let ?\<sigma> = "map stack_value_convert \<sigma>"
    let ?\<phi> = "concat (map flatten_frame \<phi>)"
    from evs_pop_a have "?\<sigma> @ flatten_frame (f\<lparr>arguments := arguments f[n := v]\<rparr>) @ ?\<phi> =
        (?\<sigma> @ flatten_frame f @ ?\<phi>)[length \<sigma> + length (frame.locals f) + n := stack_value_convert v]"
      by (simp add: flatten_frame_def list_update_append map_update)
    with evs_pop_a show ?case by simp
  next case (evs_if_t \<Pi> \<sigma> \<phi> \<pi>\<^sub>t \<pi>\<^sub>f \<pi> s \<omega>)
    thus ?case by simp
  next case (evs_if_f \<Pi> \<sigma> \<phi> \<pi>\<^sub>t \<pi>\<^sub>f \<pi> s \<omega>)
    thus ?case by simp
  next case (evs_goto \<Pi> f "def" s \<pi>')
    hence "valid_frame \<Pi> f" by simp
    with evs_goto show ?case by (cases \<pi>') simp
  next case (evs_call)
    thus ?case by simp
  next case (evs_return)
    thus ?case by simp
  qed simp_all

theorem flattening_correct [simp]: "iterate_ind (eval_stack \<Pi>) \<Sigma> \<Sigma>' \<Longrightarrow> valid_state \<Pi> \<Sigma> \<Longrightarrow>
    iterate_ind (eval_flat_stack (flatten \<Pi>)) (state_convert \<Sigma>) (state_convert \<Sigma>')"
  by (induction "eval_stack \<Pi>" \<Sigma> \<Sigma>' rule: iterate_ind.induct) simp_all

end


theory Auto_Lifter_Proofs_Examples imports Auto_Lifter_Proofs
begin

(*
 * This file contains a few miscellaneous examples of use of the proof infrastructure for the
 * auto-lifter. The proofs here serve as a basic sanity-check on the proof automation.
 *)

value [simp] "schem_lift NA NA"

lemma tlv1 : "lifting_valid_weak (schem_lift NA (SP NX NA)) (\<lambda> _. UNIV)"
  unfolding schem_lift_defs
   by(fastforce simp add: lifting_valid_set_defs intro: lifting_valid_standard)

lemma opt :
  "\<exists> S . lifting_valid_weak_base (schem_lift NA (SO NA)) S"
  unfolding schem_lift_defs
  by(fastforce intro: lifting_valid_fast)

(* could change to: fst_l_S (\<lambda> x . UNIV) = UNIV
   this will be true for most of the lifting sets (but not all.)*)
lemma fst_snd_univ :
  "fst_l_S (\<lambda> x . UNIV) =
   snd_l_S (\<lambda> x . UNIV)"
  by(auto simp add: fst_l_S_def snd_l_S_def split:prod.splits)

term "(schem_lift NA NA)"

term "(schem_lift (SP NA NB) (SP (SO NA) (SO NB)))"

(* OK. so the automation needs to figure out how to equate some sets of things.
   In principle this should not be very difficult. we just need to
   rephrase the lemmas so that the valid set becomes a variable. *)
lemma mrg :
  "\<exists> S . lifting_valid (schem_lift (SP NA NB) (SP (SPRI (SO NA)) (SPRI (SO NB)))) S"
  unfolding schem_lift_defs
   by(fastforce intro: lifting_valid_fast lifting_ortho_fast split: soption.splits)

lemma mrg2 :
  obtains Z where
  "lifting_valid (schem_lift (SP NC (SP NB NA))
    (SP (SPRI (SO NA)) (SP (SPRI (SO NB)) (SPRI (SO NC))))) Z"
  unfolding schem_lift_defs
    by(fastforce intro: lifting_valid_standard lifting_ortho_standard split: soption.splits)

lemma mrg2' :
  "lifting_valid (schem_lift (SP NC (SP NB NA))
    (SP (SPRI (SO NA)) (SP (SPRC (\<lambda> _ . 1) (SO NB)) (SPRI (SO NC)))))
(schem_lift_S (SP NC (SP NB NA))
    (SP (SPRI (SO NA)) (SP (SPRC (\<lambda> _ . 1) (SO NB)) (SPRI (SO NC))))) "
  unfolding schem_lift_defs schem_lift_S_defs
  by(fastforce intro: lifting_valid_standard lifting_ortho_standard )

lemma mrg2'' :
  "lifting_valid (schem_lift (SP NC (SP NB NA))
    (SP (SPRI (SO NA)) (SP (SPRC (\<lambda> _ . 1) (SO NB)) (SPRI (SO NC)))))
(schem_lift_S (SP NC (SP NB NA))
    (SP (SPRI (SO NA)) (SP (SPRC (\<lambda> _ . 1) (SO NB)) (SPRI (SO NC))))) "
  unfolding schem_lift_defs schem_lift_S_defs
  by(fastforce intro: lifting_valid_slower lifting_ortho_standard )

(*
lemma mrg2'' :
  "lifting_valid (schem_lift (SP NC (SP NB NA))
    (SP (SPRI (SO NA)) (SP (SPRI (SO NB)) (SPRI (SO NC)))))
(\<lambda> _ . ok_S) "
  unfolding schem_lift_defs schem_lift_S_defs
  apply(fastforce intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
  apply(rule lifting_valid.intro)
  apply(rule merge_l_valid_weak.ax_g)
    apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
   apply(rule merge_l_valid_weak.intro)
  apply(rule merge_l_ortho.ax_g_comm)
    apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom)
     apply(rule merge_l_ortho.intro)
  apply(rule fst_l_snd_l_ortho.ax_g_comm)
         apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom simp add: ok_S_defs)
  apply(rule fst_l_snd_l_ortho.intro)
         apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom simp add: ok_S_defs)
               apply(rule fst_l_valid_base_ext.ax)
               apply(rule fst_l_valid_base_ext.intro)
               apply(rule prio_l_valid_base_ext.ax)
               apply(rule prio_l_valid_base_ext.intro)
         apply(auto intro: lifting_valid_noaxiom lifting_ortho_noaxiom simp add: ok_S_defs lifting_S_defs)
*)
end


(*  Title:      HOL/HOLCF/IOA/NTP/Correctness.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section {* The main correctness proof: Impl implements Spec *}

theory Correctness
imports Impl Spec
begin

definition
  hom :: "'m impl_state => 'm list" where
  "hom s = rq(rec(s)) @ (if rbit(rec s) = sbit(sen s) then sq(sen s)
                         else tl(sq(sen s)))"

setup {* map_theory_claset (fn ctxt => ctxt delSWrapper "split_all_tac") *}

lemmas hom_ioas = Spec.ioa_def Spec.trans_def sender_trans_def receiver_trans_def impl_ioas
  and impl_asigs = sender_asig_def receiver_asig_def srch_asig_def rsch_asig_def

declare split_paired_All [simp del]

text {*
  A lemma about restricting the action signature of the implementation
  to that of the specification.
*}

lemma externals_lemma:
 "a:externals(asig_of(Automata.restrict impl_ioa (externals spec_sig))) =
  (case a of
      S_msg(m) => True
    | R_msg(m) => True
    | S_pkt(pkt) => False
    | R_pkt(pkt) => False
    | S_ack(b) => False
    | R_ack(b) => False
    | C_m_s => False
    | C_m_r => False
    | C_r_s => False
    | C_r_r(m) => False)"
 apply (simp (no_asm) add: externals_def restrict_def restrict_asig_def Spec.sig_def asig_projections)

  apply (induct_tac "a")
  apply (simp_all (no_asm) add: actions_def asig_projections)
  txt {* 2 *}
  apply (simp (no_asm) add: impl_ioas)
  apply (simp (no_asm) add: impl_asigs)
  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
  apply (simp (no_asm) add: "transitions"(1) unfold_renaming)
  txt {* 1 *}
  apply (simp (no_asm) add: impl_ioas)
  apply (simp (no_asm) add: impl_asigs)
  apply (simp (no_asm) add: asig_of_par asig_comp_def asig_projections)
  done

lemmas sels = sbit_def sq_def ssending_def rbit_def rq_def rsending_def

text {* Proof of correctness *}
lemma ntp_correct:
  "is_weak_ref_map hom (Automata.restrict impl_ioa (externals spec_sig)) spec_ioa"
apply (unfold Spec.ioa_def is_weak_ref_map_def)
apply (simp (no_asm) cong del: if_weak_cong split del: split_if add: Correctness.hom_def
  cancel_restrict externals_lemma)
apply (rule conjI)
 apply (simp (no_asm) add: hom_ioas)
 apply (simp (no_asm_simp) add: sels)
apply (rule allI)+
apply (rule imp_conj_lemma)

apply (induct_tac "a")
apply (simp_all (no_asm_simp) add: hom_ioas)
apply (frule inv4)
apply force

apply (frule inv4)
apply (frule inv2)
apply (erule disjE)
apply (simp (no_asm_simp))
apply force

apply (frule inv2)
apply (erule disjE)

apply (frule inv3)
apply (case_tac "sq (sen (s))=[]")

apply (simp add: hom_ioas)
apply (blast dest!: add_leD1 [THEN leD])

apply (rename_tac m, case_tac "m = hd (sq (sen (s)))")

apply force

apply simp
apply (blast dest!: add_leD1 [THEN leD])

apply simp
done

end


section \<open>Labels\<close>

theory Labels imports Com begin

text \<open>Labels describe a mapping from the inner node label
  to the matching command\<close>

inductive labels :: "cmd \<Rightarrow> nat \<Rightarrow> cmd \<Rightarrow> bool"
where

Labels_Base:
  "labels c 0 c"

| Labels_LAss:
  "labels (V:=e) 1 Skip"

| Labels_Seq1:
  "labels c\<^sub>1 l c \<Longrightarrow> labels (c\<^sub>1;;c\<^sub>2) l (c;;c\<^sub>2)"

| Labels_Seq2:
  "labels c\<^sub>2 l c \<Longrightarrow> labels (c\<^sub>1;;c\<^sub>2) (l + #:c\<^sub>1) c"

| Labels_CondTrue:
  "labels c\<^sub>1 l c \<Longrightarrow> labels (if (b) c\<^sub>1 else c\<^sub>2) (l + 1) c"

| Labels_CondFalse:
  "labels c\<^sub>2 l c \<Longrightarrow> labels (if (b) c\<^sub>1 else c\<^sub>2) (l + #:c\<^sub>1 + 1) c"

| Labels_WhileBody:
  "labels c' l c \<Longrightarrow> labels (while(b) c') (l + 2) (c;;while(b) c')"

| Labels_WhileExit:
  "labels (while(b) c') 1 Skip"

lemma label_less_num_inner_nodes:
  "labels c l c' \<Longrightarrow> l < #:c"
proof(induct c arbitrary:l c')
  case Skip
  from \<open>labels Skip l c'\<close> show ?case by(fastforce elim:labels.cases)
next
  case (LAss V e)
  from \<open>labels (V:=e) l c'\<close> show ?case by(fastforce elim:labels.cases)
next
  case (Seq c\<^sub>1 c\<^sub>2)
  note IH1 = \<open>\<And>l c'. labels c\<^sub>1 l c' \<Longrightarrow> l < #:c\<^sub>1\<close>
  note IH2 = \<open>\<And>l c'. labels c\<^sub>2 l c' \<Longrightarrow> l < #:c\<^sub>2\<close>
  from \<open>labels (c\<^sub>1;;c\<^sub>2) l c'\<close> IH1 IH2 show ?case
    by simp(erule labels.cases,auto,force)
next
  case (Cond b c\<^sub>1 c\<^sub>2)
  note IH1 = \<open>\<And>l c'. labels c\<^sub>1 l c' \<Longrightarrow> l < #:c\<^sub>1\<close>
  note IH2 = \<open>\<And>l c'. labels c\<^sub>2 l c' \<Longrightarrow> l < #:c\<^sub>2\<close>
  from \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) l c'\<close> IH1 IH2 show ?case
    by simp(erule labels.cases,auto,force)
next
  case (While b c)
  note IH = \<open>\<And>l c'. labels c l c' \<Longrightarrow> l < #:c\<close>
  from \<open>labels (while (b) c) l c'\<close> IH show ?case
    by simp(erule labels.cases,fastforce+)
qed

declare One_nat_def [simp del]

lemma less_num_inner_nodes_label:
  "l < #:c \<Longrightarrow> \<exists>c'. labels c l c'"
proof(induct c arbitrary:l)
  case Skip
  from \<open>l < #:Skip\<close> have "l = 0" by simp
  thus ?case by(fastforce intro:Labels_Base)
next
  case (LAss V e)
  from \<open>l < #:(V:=e)\<close> have "l = 0 \<or> l = 1" by auto
  thus ?case by(auto intro:Labels_Base Labels_LAss)
next
  case (Seq c\<^sub>1 c\<^sub>2)
  note IH1 = \<open>\<And>l. l < #:c\<^sub>1 \<Longrightarrow> \<exists>c'. labels c\<^sub>1 l c'\<close>
  note IH2 = \<open>\<And>l. l < #:c\<^sub>2 \<Longrightarrow> \<exists>c'. labels c\<^sub>2 l c'\<close>
  show ?case
  proof(cases "l < #:c\<^sub>1")
    case True
    from IH1[OF this] obtain c' where "labels c\<^sub>1 l c'" by auto
    hence "labels (c\<^sub>1;;c\<^sub>2) l (c';;c\<^sub>2)" by(fastforce intro:Labels_Seq1)
    thus ?thesis by auto
  next
    case False
    hence "#:c\<^sub>1 \<le> l" by simp
    then obtain l' where "l = l' + #:c\<^sub>1" and "l' = l - #:c\<^sub>1" by simp
    from \<open>l = l' + #:c\<^sub>1\<close> \<open>l < #:c\<^sub>1;;c\<^sub>2\<close> have "l' < #:c\<^sub>2" by simp
    from IH2[OF this] obtain c' where "labels c\<^sub>2 l' c'" by auto
    with \<open>l = l' + #:c\<^sub>1\<close> have "labels (c\<^sub>1;;c\<^sub>2) l c'" by(fastforce intro:Labels_Seq2)
    thus ?thesis by auto
  qed
next
  case (Cond b c\<^sub>1 c\<^sub>2)
  note IH1 = \<open>\<And>l. l < #:c\<^sub>1 \<Longrightarrow> \<exists>c'. labels c\<^sub>1 l c'\<close>
  note IH2 = \<open>\<And>l. l < #:c\<^sub>2 \<Longrightarrow> \<exists>c'. labels c\<^sub>2 l c'\<close>
  show ?case
  proof(cases "l = 0")
    case True
    thus ?thesis by(fastforce intro:Labels_Base)
  next
    case False
    hence "0 < l" by simp
    then obtain l' where "l = l' + 1" and "l' = l - 1" by simp
    thus ?thesis
    proof(cases "l' < #:c\<^sub>1")
      case True
      from IH1[OF this] obtain c' where "labels c\<^sub>1 l' c'" by auto
      with \<open>l = l' + 1\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l c'"
        by(fastforce dest:Labels_CondTrue)
      thus ?thesis by auto
    next
      case False
      hence "#:c\<^sub>1 \<le> l'" by simp
      then obtain l'' where "l' = l'' + #:c\<^sub>1" and "l'' = l' - #:c\<^sub>1" by simp
      from \<open>l' = l'' + #:c\<^sub>1\<close> \<open>l = l' + 1\<close> \<open>l < #:if (b) c\<^sub>1 else c\<^sub>2\<close>
      have "l'' < #:c\<^sub>2" by simp
      from IH2[OF this] obtain c' where "labels c\<^sub>2 l'' c'" by auto
      with \<open>l' = l'' + #:c\<^sub>1\<close> \<open>l = l' + 1\<close> have "labels (if (b) c\<^sub>1 else c\<^sub>2) l c'"
        by(fastforce dest:Labels_CondFalse)
      thus ?thesis by auto
    qed
  qed
next
  case (While b c')
  note IH = \<open>\<And>l. l < #:c' \<Longrightarrow> \<exists>c''. labels c' l c''\<close>
  show ?case
  proof(cases "l < 1")
    case True
    hence "l = 0" by simp
    thus ?thesis by(fastforce intro:Labels_Base)
  next
    case False
    show ?thesis
    proof(cases "l < 2")
      case True
      with \<open>\<not> l < 1\<close> have "l = 1" by simp
      thus ?thesis by(fastforce intro:Labels_WhileExit)
    next
      case False
      with \<open>\<not> l < 1\<close> have "2 \<le> l" by simp
      then obtain l' where "l = l' + 2" and "l' = l - 2"
        by(simp del:add_2_eq_Suc')
      from \<open>l = l' + 2\<close> \<open>l < #:while (b) c'\<close> have "l' < #:c'" by simp
      from IH[OF this] obtain c'' where "labels c' l' c''" by auto
      with \<open>l = l' + 2\<close> have "labels (while (b) c') l (c'';;while (b) c')"
        by(fastforce dest:Labels_WhileBody)
      thus ?thesis by auto
    qed
  qed
qed

lemma labels_det:
  "labels c l c'\<Longrightarrow> (\<And>c''. labels c l c''\<Longrightarrow> c' = c'')"
proof(induct rule: labels.induct)
  case (Labels_Base c c'')
  from \<open>labels c 0 c''\<close> obtain l where "labels c l c''" and "l = 0" by auto
  thus ?case by(induct rule: labels.induct,auto)
next
  case (Labels_Seq1 c\<^sub>1 l c c\<^sub>2)
  note IH = \<open>\<And>c''. labels c\<^sub>1 l c'' \<Longrightarrow> c = c''\<close>
  from \<open>labels c\<^sub>1 l c\<close> have "l < #:c\<^sub>1" by(fastforce intro:label_less_num_inner_nodes)
  with \<open>labels (c\<^sub>1;;c\<^sub>2) l c''\<close> obtain cx where "c'' = cx;;c\<^sub>2 \<and> labels c\<^sub>1 l cx"
    by(fastforce elim:labels.cases intro:Labels_Base)
  hence [simp]:"c'' = cx;;c\<^sub>2" and "labels c\<^sub>1 l cx" by simp_all
  from IH[OF \<open>labels c\<^sub>1 l cx\<close>] show ?case by simp
next
  case (Labels_Seq2 c\<^sub>2 l c c\<^sub>1)
  note IH = \<open>\<And>c''. labels c\<^sub>2 l c'' \<Longrightarrow> c = c''\<close>
  from \<open>labels (c\<^sub>1;;c\<^sub>2) (l + #:c\<^sub>1) c''\<close> \<open>labels c\<^sub>2 l c\<close> have "labels c\<^sub>2 l c''"
    by(auto elim:labels.cases dest:label_less_num_inner_nodes)
  from IH[OF this] show ?case .
next
  case (Labels_CondTrue c\<^sub>1 l c b c\<^sub>2)
  note IH = \<open>\<And>c''. labels c\<^sub>1 l c'' \<Longrightarrow>  c = c''\<close>
  from \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) (l + 1) c''\<close> \<open>labels c\<^sub>1 l c\<close> have "labels c\<^sub>1 l c''"
    by(fastforce elim:labels.cases dest:label_less_num_inner_nodes)
  from IH[OF this] show ?case .
next
  case (Labels_CondFalse c\<^sub>2 l c b c\<^sub>1)
  note IH = \<open>\<And>c''. labels c\<^sub>2 l c'' \<Longrightarrow>  c = c''\<close>
  from \<open>labels (if (b) c\<^sub>1 else c\<^sub>2) (l + #:c\<^sub>1 + 1) c''\<close> \<open>labels c\<^sub>2 l c\<close>
  have "labels c\<^sub>2 l c''"
    by(fastforce elim:labels.cases dest:label_less_num_inner_nodes)
  from IH[OF this] show ?case .
next
  case (Labels_WhileBody c' l c b)
  note IH = \<open>\<And>c''. labels c' l c'' \<Longrightarrow> c = c''\<close>
  from \<open>labels (while (b) c') (l + 2) c''\<close> \<open>labels c' l c\<close>
  obtain cx where "c'' = cx;;while (b) c' \<and> labels c' l cx"
    by -(erule labels.cases,auto)
  hence [simp]:"c'' = cx;;while (b) c'" and "labels c' l cx" by simp_all
  from IH[OF \<open>labels c' l cx\<close>] show ?case by simp
qed (fastforce elim:labels.cases)+

end