section\<open>VC to HC\<close>

theory Definitions_HC
  imports Main "../Three_Sat_To_Set_Cover"  "Poly_Reductions_Lib.Graph_Auxiliaries"
    "../VC_Set_To_VC_List/VC_Set_To_VC_List"
    Graph_Theory.Digraph  Graph_Theory.Arc_Walk Graph_Theory.Vertex_Walk
begin

subsection\<open>Definitions\<close>

datatype ('a, 'b) hc_node = Cover nat | Edge 'a 'b nat

(*pre_digraph.cycle already assumes that every node is only contained once*)
(*Case for empty c is already in cycle*)
definition
  "is_hc (G::('a,('a \<times> 'a)) pre_digraph) (c:: 'a list)  \<equiv>
    ((pre_digraph.cycle G (vwalk_arcs c) \<and> (\<forall>x\<in> verts G. x \<in> set c))\<or> card (verts G) \<le> 1)
    \<and> set c \<subseteq> verts G \<and> distinct (tl c)"

definition
  "hc \<equiv> {G. \<exists>c. wf_digraph G \<and> is_hc G c \<and> ((tail G = fst \<and> head G = snd) \<or> arcs G = {})
    \<and> finite (verts G)}"

definition next_edge where
  "next_edge v E e1 e2 \<equiv> \<exists>i j. i<length E \<and> j<length E \<and> e1 = E!i \<and> e2 = E!j \<and> v \<in> e1 \<and> v \<in> e2
        \<and> i<j \<and> \<not> (\<exists>k < size E. v \<in> E!k \<and> i < k \<and> k < j)"

definition first_edge where
  "first_edge v e E \<equiv> (\<exists>i<length E. e = E!i\<and> v \<in> e \<and>
              \<not> (\<exists>j < size E. v \<in> E!j \<and> j < i))"

definition last_edge where
  "last_edge v e E \<equiv> \<exists>i<length E. e = E!i\<and> v \<in> e \<and>
              \<not> (\<exists>j < size E. v \<in> E!j \<and> i < j)"

definition
  "vc_hc \<equiv> \<lambda>(E, k).
    if ugraph (set E) \<and>  k \<le> card (\<Union> (set E)) \<and> distinct E
        then  \<lparr>verts = {Cover i|i. i< k} \<union> {Edge v e 0|v e. e\<in> set E \<and> v \<in> e}\<union>
            {Edge v e 1|v e. e\<in> set E \<and> v \<in> e},
          arcs = {(Edge v e 0, Edge v e 1)|v e. e\<in> set E \<and> v \<in> e} \<union>
            {(Edge v e 0, Edge u e 0)|u v e. e\<in>set E \<and> v \<in> e \<and> u \<in> e \<and> u \<noteq> v} \<union>
            {(Edge v e 1, Edge u e 1)|u v e. e\<in> set E \<and> v \<in> e \<and> u \<in> e \<and> u \<noteq> v} \<union>
            {(Edge v e1 1, Edge v e2 0)| v e1 e2. next_edge v E e1 e2} \<union>
            {(Edge v e 1, Cover n)| v e n. last_edge v e E \<and> n < k}\<union>
            {(Cover n, Edge v e 0)| v e n. first_edge v e E \<and> n < k} \<union>
            {(Cover i, Cover j) |i j.  i < k \<and> j < k},
          tail = fst, head = snd \<rparr>
        else \<lparr>verts = {Cover 0, Cover 1}, arcs = {}, tail = fst, head = snd\<rparr>"

definition get_second where
  "get_second e \<equiv> SOME v. v \<in> e"

subsection\<open>Proofs for Definitions\<close>

lemma else_not_in_hc:
  assumes "G = \<lparr>verts = {Cover 0, Cover 1}, arcs = {}, tail = fst, head = snd\<rparr>"
  shows "G \<notin> hc"
proof
  assume "G \<in> hc"
  then have "\<exists> c. pre_digraph.cycle G (vwalk_arcs c) \<and> (\<forall>x\<in> verts G. x \<in> set c)
    \<and> set c \<subseteq> verts G \<and> distinct (tl c)"
    using assms hc_def
    by (simp add: hc_def doubleton_eq_iff is_hc_def)
  then obtain c where c_def: "pre_digraph.cycle G (vwalk_arcs c)" "(\<forall>x\<in> verts G. x \<in> set c)"
    by blast
  with pre_digraph.cycle_def have not_empty: "vwalk_arcs c \<noteq> []"
    by fastforce
  from pre_digraph.cycle_def pre_digraph.awalk_def c_def have subset: "set (vwalk_arcs c) \<subseteq> arcs G"
    by metis
  have "arcs G = {}"
    using assms
    by(auto)
  with subset  have "set (vwalk_arcs c) = {}"
    by auto
  then show "False"
    using not_empty
    by(auto)
qed

lemma else_wf_digraph:
  assumes "G = \<lparr>verts = {Cover 0, Cover 1}, arcs = {}, tail = fst, head = snd\<rparr>"
  shows "wf_digraph G"
  by(auto simp add: hc_def wf_digraph_def is_hc_def assms)

lemma if_else_in_hc:
  assumes "G = \<lparr>verts = {Cover 0}, arcs = {}, tail = fst, head = snd\<rparr>"
  shows "G \<in> hc"
  using set_replicate_conv_if by (fastforce simp: hc_def wf_digraph_def is_hc_def assms)

lemma if_else_wf_digraph:
  assumes "G = \<lparr>verts = {Cover 0}, arcs = {}, tail = fst, head = snd\<rparr>"
  shows "wf_digraph G"
  by(auto simp add: hc_def wf_digraph_def is_hc_def assms)

lemma get_second_in_edge:
  assumes "u = get_second e" "e \<noteq> {}"
  shows "u \<in> e"
  using assms unfolding get_second_def by(auto simp add: some_in_eq)

lemma first_not_next:
  assumes "first_edge v e1 E" "next_edge v E e2 e1" "distinct E"
  shows False
  using assms
  unfolding first_edge_def next_edge_def
  by(auto simp add: nth_eq_iff_index_eq)

lemma last_not_next:
  assumes "last_edge v e1 E" "next_edge v E e1 e2" "distinct E"
  shows False
  using assms
  unfolding last_edge_def next_edge_def
  by(auto simp add: nth_eq_iff_index_eq)

lemma hd_is_first_edge:
  assumes "e = hd E" "v\<in> e" "E \<noteq> []"
  shows "first_edge v e E"
  using assms unfolding first_edge_def by(auto simp add: hd_conv_nth)

lemma next_edge_cons:
  assumes "(\<exists>e1. next_edge v E e1 e2)"
  shows "(\<exists>e1. next_edge v (a#E) e1 e2)"
proof -
  obtain e1 where e1_def: "next_edge v E e1 e2"
    using assms
    by auto
  then obtain i j where ij_def: "i<length E \<and> j<length E \<and>  e1 = E!i \<and> e2 = E!j \<and> v \<in> e1 \<and> v \<in> e2
      \<and> i<j \<and> \<not> (\<exists>k < size E. v \<in> E!k \<and> i < k \<and> k < j)"
    using next_edge_def
    by metis
  then have 1: "i+1<length (a#E) \<and> (j+1)<length (a#E) \<and>  e1 = (a#E)!(i+1)
      \<and> e2 = (a#E)!(j+1) \<and> v \<in> e1 \<and> v \<in> e2 \<and> (i+1)<(j+1)"
    by auto
  have "\<not> (\<exists>k < size (a#E). v \<in> (a#E)!k \<and> (i+1) < k \<and> k < (j+1))"
  proof(rule ccontr)
    assume "\<not> \<not> (\<exists>k<length (a # E). v \<in> (a # E) ! k \<and> i + 1 < k \<and> k < j + 1)"
    then have "(\<exists>k<length (a # E). v \<in> (a # E) ! k \<and> i + 1 < k \<and> k < j + 1)"
      by auto
    then obtain k where k_def: "k<length (a # E)\<and> v \<in> (a # E) ! k \<and> i + 1 < k \<and> k < j + 1"
      by blast
    then have 0: "k \<noteq> 0"
      by simp
    then have 1: "k-1 < length E \<and> v \<in> E!(k-1)"
      using k_def
      by force
    have "i  < k-1 \<and> k-1 < j"
      using k_def 0
      by linarith
    then have "(\<exists>k < size (E). v \<in> (E)!k \<and> i < k \<and> k < j)"
      using 1 by blast
    then show False
      using ij_def
      by auto
  qed
  then have "next_edge v (a#E) e1 e2"
    using next_edge_def 1
    by metis
  then show ?thesis
    by auto
qed

lemma first_edge_cons_not_in:
  assumes "first_edge v e E" "v \<notin> a"
  shows "first_edge v e (a#E)"
proof -
  obtain i where i_def:  "i<length E \<and> e = E!i\<and> v \<in> e \<and>
              \<not> (\<exists>j < size E. v \<in> E!j \<and> j < i)"
    using assms first_edge_def
    by metis
  then have 1: "i+1 < length (a#E) \<and> e = (a#E)!(i+1) \<and> v \<in> e"
    by auto
  have 2: "\<not> (\<exists>j < size (a#E). v \<in> (a#E)!j \<and> j < (i+1))"
  proof (rule ccontr)
    assume "\<not> \<not> (\<exists>j < size (a#E). v \<in> (a#E)!j \<and> j < (i+1))"
    then have "(\<exists>j < size (a#E). v \<in> (a#E)!j \<and> j < (i+1))"
      by auto
    then obtain j where j_def: "j < size (a#E) \<and> v \<in> (a#E)!j \<and> j < (i+1)"
      by auto
    then show False proof(cases "j = 0")
      case True
      then have "v \<in> a"
        using j_def
        by auto
      then show ?thesis
        using assms
        by simp
    next
      case False
      then have "(j-1) < length E \<and> v \<in> E!(j-1) \<and> j-1 < i"
        using j_def
        by fastforce
      then show ?thesis
        using i_def
        by blast
    qed
  qed
  then show ?thesis
    using 1 2 first_edge_def
    by metis
qed

lemma first_edge_cons_in:
  assumes "first_edge v e E" "v \<in> a"
  shows "next_edge v (a#E) a e"
proof -
  obtain i where i_def:  "i<length E \<and> e = E!i\<and> v \<in> e \<and>
              \<not> (\<exists>j < size E. v \<in> E!j \<and> j < i)"
    using assms first_edge_def by metis
  then have 1: "i+1 < length (a#E) \<and> e = (a#E)!(i+1) \<and> v \<in> e"
    by auto
  then have 2: "0 < length (a#E) \<and> a = (a#E) ! 0 \<and> v \<in> a \<and> 0 < i+1"
    using assms
    by simp
  then have 3: "0 < length (a#E) \<and>
          i+1 < length (a#E) \<and> a = (a#E) ! 0 \<and> e = (a#E) ! (i+1)  \<and> v \<in> a \<and> v \<in> e \<and> 0 < (i+1)"
    using 1 2
    by argo
  have "\<not> (\<exists>k < size (a#E). v \<in> (a#E)!k \<and> 0 < k \<and> k < i+1)"
  proof(rule ccontr, simp)
    presume "\<exists>k<length (a # E). v \<in> (a # E) ! k \<and> 0 < k \<and> k < i + 1"
    then obtain k where k_def: "k<length (a # E)\<and> v \<in> (a # E) ! k \<and> 0 < k \<and> k < i + 1"
      by auto
    then have "k > 0"
      by simp
    then have "k-1<length (E)\<and> v \<in> (E) ! (k-1) \<and> k-1 < i "
      using k_def
      by fastforce
    then show False
      using i_def
      by blast
  qed auto
  then have "0 < length (a#E) \<and>
          i+1 < length (a#E) \<and> a = (a#E) ! 0 \<and> e = (a#E) ! (i+1)  \<and> v \<in> a \<and> v \<in> e \<and> 0 < (i+1)
      \<and> \<not> (\<exists>k < size (a#E). v \<in> (a#E)!k \<and> 0 < k \<and> k < i+1)"
    using 3
    by auto
  then have "\<exists>i j. i < length (a#E) \<and>
          j < length (a#E) \<and> a = (a#E) ! i \<and> e = (a#E) ! j  \<and> v \<in> a \<and> v \<in> e \<and> i < j
      \<and> \<not> (\<exists>k < size (a#E). v \<in> (a#E)!k \<and> i < k \<and> k < j)"
    by metis
  then show ?thesis
    using next_edge_def
    by metis
qed

lemma first_Edge_or_next_edge:
  assumes "e \<in> set E" "v \<in> e"
  shows "first_edge v e E \<or> (\<exists>e1. next_edge v E e1 e)"
  using assms
proof(induction E)
  case Nil
  then show ?case
    by auto
next
  case (Cons a E)
  then show ?case
  proof(cases "e = a")
    case True
    then have "e = hd (a#E)" by simp
    then have "first_edge v e (a#E)"
      using assms
      by (simp add: hd_is_first_edge)
    then show ?thesis
      by simp
  next
    case False
    then have "e \<in> set E"
      using Cons
      by simp
    then have 1: "first_edge v e E \<or> (\<exists>e1. next_edge v E e1 e)"
      using Cons
      by auto
    then show ?thesis proof
      assume a1: "first_edge v e E"
      then show ?thesis proof(cases "v \<in> a")
        case True
        then have "next_edge v (a#E) a e"
          using first_edge_cons_in a1
          by fast
        then show ?thesis
          by auto
      next
        case False
        then have "first_edge v e (a#E)"
          using 1 first_edge_cons_not_in a1
          by metis
        then show ?thesis
          by simp
      qed
    next
      assume "(\<exists>e1. next_edge v E e1 e)"
      then have "(\<exists>e1. next_edge v (a#E) e1 e)"
        using next_edge_cons
        by fast
      then show ?thesis
        by auto
    qed
  qed
qed

lemma get_second_explicit:
  assumes  "v \<in> e" "u \<in> e" "card e = 2" "v \<noteq> u"
  shows "get_second (e - {v}) = u"
proof -
  have "\<exists>u v. e = {u, v} \<and> u \<noteq> v"
    using e_in_E_e_explicit assms
    by blast
  then have "e = {u, v}"
    using assms
    by blast
  then show ?thesis
    using assms
    unfolding get_second_def
    by auto
qed

lemma get_second_in_e:
  assumes  "v \<in> e" "card e = 2"
  shows "get_second (e - {v}) \<in> e"
  using assms e_in_E_e_explicit unfolding get_second_def by blast

lemma get_secon_in_set:
  assumes "e \<noteq> {}"
  shows "get_second e \<in> e"
  using assms unfolding get_second_def by (meson all_not_in_conv someI_ex)

lemma get_second_minus_noteq_minus:
  assumes "v \<in> e" "card e = 2"
  shows "get_second (e - {v}) \<noteq> v"
  using assms get_secon_in_set
  by (metis emptyE get_second_in_edge is_singletonI' is_singleton_altdef member_remove odd_one
      one_dvd remove_def)

lemma get_second_in_set:
  "get_second S \<in> S" if "S \<noteq> {}"
  using that unfolding get_second_def by (auto intro: someI)

subsubsection\<open>Edge sets are finite\<close>

lemma fin_Cov:
  shows "finite {Cover i|i. i< k}"
  by simp

lemma card_S_Edge:
  assumes "S= {(v, e)|v e. e\<in> set E \<and> v \<in> e}"  "\<forall>e\<in> set E. card e = 2"
  shows "card S \<le> 2 * length E"
  using assms
proof(induction E arbitrary: S)
  case Nil
  then show ?case
    by auto
next
  case (Cons a E)
  then have 0: "{(v, e) |v e. e \<in> set (a # E) \<and> v \<in> e} =
    {(v, e) |v e. e \<in> set (E) \<and> v \<in> e} \<union> {(v, e)|v e. e = a \<and> v \<in> e}"
    by auto
  have 1: "card {(v, e) |v e. e \<in> set (E) \<and> v \<in> e} \<le> 2 * length E"
    using Cons assms
    by simp
  have "card a = 2"
    using Cons
    by simp
  then obtain u v where "a = {u, v}" "u\<noteq> v"
    using Cons e_in_E_e_explicit
    by metis
  then have "{(v, e)|v e. e = a \<and> v \<in> e} = {(v, a), (u, a)}"
    by blast
  then have 2: "card {(v, e)|v e. e = a \<and> v \<in> e} = 2"
    using \<open>u \<noteq> v\<close>
    by auto
  then have "card {(v, e) |v e. e \<in> set (a # E) \<and> v \<in> e} \<le>
    card {(v, e) |v e. e \<in> set (E) \<and> v \<in> e} + card {(v, e)|v e. e = a \<and> v \<in> e}"
    using 0
    by (metis (no_types, lifting) card_Un_le)
  then show ?case
    using 1 2 Cons
    by fastforce
qed

lemma fin_S_Edge:
  assumes "S = {(v, e)|v e. e\<in> set E \<and> v \<in> e}" "\<forall>e\<in> set E. card e = 2"
  shows "finite S"
proof -
  have "{(v, e)|v e. e\<in> set E \<and> v \<in> e} \<subseteq> (\<Union> (set E)) \<times> set E"
    by auto
  moreover have "finite \<dots>"
    using assms(2) by (force intro: card_ge_0_finite)
  ultimately show ?thesis
    unfolding \<open>S = _\<close> by (rule finite_subset)
qed

lemma finite_verts_finite_edges:
  assumes "\<forall>e \<in> set E. card e = 2"
  shows "finite {Edge v e i|v e. e\<in> set E \<and> v \<in> e}"
proof -
  have "{Edge v e i|v e. e\<in> set E \<and> v \<in> e} \<subseteq> (\<lambda>(v, e). Edge v e i) ` ((\<Union> (set E)) \<times> set E)"
    by auto
  moreover have "finite \<dots>"
    using assms by (force intro: card_ge_0_finite)
  ultimately show ?thesis
    by (rule finite_subset)
qed

lemma card_Edge_set:
  assumes "v \<noteq> u"
  shows "card {Edge v a i, Edge u a i} \<le> 2"
proof -
  have 1: "card {Edge u a i} = 1"  "card {Edge v a i} = 1"
    by auto
  have "{Edge v a i, Edge u a i} = {Edge u a i} \<union> {Edge v a i}"
    by simp
  then have "card {Edge u a i, Edge v a i} \<le> card {Edge u a i} + card {Edge v a i}"
    by (metis card_Un_le insert_commute)
  then show ?thesis
    using 1
    by (simp add: insert_commute)
qed

lemma card_verts_set_Edge_i:
  assumes "\<forall>e \<in> set E. card e = 2" "T = {Edge v e i|v e. e\<in> set E \<and> v \<in> e}"
  shows "card T \<le> 2 * length E"
  using assms
proof(induction E arbitrary: T)
  case Nil
  then show ?case
    by auto
next
  case (Cons a E)
  then have "T = {Edge v e i|v e. e\<in> set E \<and> v \<in> e} \<union> {Edge v a i|v. v \<in> a}"
    by(auto)
  then have "card T \<le> card {Edge v e i|v e. e\<in> set E \<and> v \<in> e} + card {Edge v a i|v. v \<in> a}"
    by (simp add: card_Un_le)
  then have 1: "card T \<le> 2 * length E + card {Edge v a i|v. v \<in> a}"
    using Cons
    by fastforce
  have "card {Edge v a i|v. v \<in> a} \<le> 2"
  proof -
    have "card a = 2"
      using Cons
      by auto
    then obtain u v where uv_def: "a = {u, v}" "u \<noteq> v"
      by (meson e_in_E_e_explicit)
    then have 1: "{Edge v a i|v. v \<in> a} = {Edge v a i, Edge u a i}"
      by fastforce
    have "card {Edge v a i, Edge u a i} \<le> 2"
      using card_Edge_set uv_def
      by metis
    then show ?thesis
      using 1
      by auto
  qed
  then have "card T \<le> 2 * length E + 2"
    using 1
    by linarith
  then show ?case
    by simp
qed

subsection\<open>Auxiliary lemmas\<close>

lemma ugraph_implies_smaller_set_ugraph:
  assumes "ugraph (insert a (set E'))"
  shows "ugraph (set E')"
  using assms by (simp add: ugraph_def)

lemma edge_contains_minus_one_not_empty:
  assumes "e \<in> set E'" "ugraph (set E')" "u \<in> e"
  shows "e-{u} \<noteq> {}"
  using subset_singletonD assms ugraph_def by fastforce

end


(* Author: Dmitriy Traytel *)

header "Initial Normalization of the Input"

(*<*)
theory Init_Normalization
imports Pi_Regular_Exp "~~/src/HOL/Library/Simps_Case_Conv"
begin
(*>*)

fun toplevel_inters where
  "toplevel_inters (Inter r s) = toplevel_inters r \<union> toplevel_inters s"
| "toplevel_inters r = {r}"

lemma toplevel_inters_nonempty[simp]:
  "toplevel_inters r \<noteq> {}"
  by (induct r) auto

lemma toplevel_inters_finite[simp]:
  "finite (toplevel_inters r)"
  by (induct r) auto

context alphabet
begin

lemma toplevel_inters_wf:
  "wf n s = (\<forall>r\<in>toplevel_inters s. wf n r)"
  by (induct s) auto

end

context project
begin

lemma toplevel_inters_lang:
  "r \<in> toplevel_inters s \<Longrightarrow> lang n s \<subseteq> lang n r"
  by (induct s) auto

lemma toplevel_inters_lang_INT:
  "lang n s = (\<Inter>r\<in>toplevel_inters s. lang n r)"
  by (induct s) auto

lemma toplevel_inters_in_lang:
  "w \<in> lang n s = (\<forall>r\<in>toplevel_inters s. w \<in> lang n r)"
  by (induct s) auto

lemma lang_flatten_INTERSECT_finite[simp]:
  "finite X \<Longrightarrow> w \<in> lang n (flatten INTERSECT X) =
    (if X = {} then w \<in> lists (\<Sigma> n) else (\<forall>r \<in> X. w \<in> lang n r))"
  unfolding lang_INTERSECT using sorted_list_of_set[of X] by auto

end

fun merge_distinct where
  "merge_distinct [] xs = xs"
| "merge_distinct xs [] = xs"
| "merge_distinct (a # xs) (b # ys) =
    (if a = b then merge_distinct xs (b # ys)
    else if a < b then a # merge_distinct xs (b # ys)
    else b # merge_distinct (a # xs) ys)"

lemma set_merge_distinct[simp]: "set (merge_distinct xs ys) = set xs \<union> set ys"
  by (induct xs ys rule: merge_distinct.induct) auto

lemma sorted_merge_distinct[simp]: "\<lbrakk>sorted xs; sorted ys\<rbrakk> \<Longrightarrow> sorted (merge_distinct xs ys)"
  by (induct xs ys rule: merge_distinct.induct) (auto simp: sorted_Cons)

lemma distinct_merge_distinct[simp]: "\<lbrakk>sorted xs; distinct xs; sorted ys; distinct ys\<rbrakk> \<Longrightarrow>
  distinct (merge_distinct xs ys)"
  by (induct xs ys rule: merge_distinct.induct) (auto simp: sorted_Cons)

lemma sorted_list_of_set_merge_distinct[simp]: "\<lbrakk>sorted xs; distinct xs; sorted ys; distinct ys\<rbrakk> \<Longrightarrow>
  merge_distinct xs ys = sorted_list_of_set (set xs \<union> set ys)"
  by (auto intro: sorted_distinct_set_unique)

fun zip_with_option where
  "zip_with_option f (Some a) (Some b) = Some (f a b)"
| "zip_with_option _ _ _ = None"

lemma zip_with_option_eq_Some[simp]:
  "zip_with_option f x y = Some z \<longleftrightarrow> (\<exists>a b. z = f a b \<and> x = Some a \<and> y = Some b)"
  by (induct f x y rule: zip_with_option.induct) auto

fun Pluss where
  "Pluss (Plus r s) = zip_with_option merge_distinct (Pluss r) (Pluss s)"
| "Pluss Zero = Some []"
| "Pluss Full = None"
| "Pluss r = Some [r]"

lemma Pluss_None[symmetric]: "Pluss r = None \<longleftrightarrow> Full \<in> toplevel_summands r"
  by (induct r) auto

lemma Pluss_Some: "Pluss r = Some xs \<longleftrightarrow>
  (Full \<notin> set xs \<and> xs = sorted_list_of_set (toplevel_summands r - {Zero}))"
proof (induct r arbitrary: xs)
  case (Plus r s)
  show ?case
  proof safe
    assume "Pluss (Plus r s) = Some xs"
    then obtain a b where *: "Pluss r = Some a" "Pluss s = Some b" "xs = merge_distinct a b" by auto
    with Plus(1)[of a] Plus(2)[of b]
      show "xs = sorted_list_of_set (toplevel_summands (Plus r s) - {Zero})" by (simp add: Un_Diff)
    assume "Full \<in> set xs" with Plus(1)[of a] Plus(2)[of b] * show False by (simp add: Pluss_None)
  next
    assume "Full \<notin> set (sorted_list_of_set (toplevel_summands (Plus r s) - {Zero}))"
    with Plus(1)[of "sorted_list_of_set (toplevel_summands r - {Zero})"]
      Plus(2)[of "sorted_list_of_set (toplevel_summands s - {Zero})"]
      show "Pluss (Plus r s) = Some (sorted_list_of_set (toplevel_summands (Plus r s) - {Zero}))"
        by (simp add: Un_Diff)
  qed
qed force+

fun Inters where
  "Inters (Inter r s) = zip_with_option merge_distinct (Inters r) (Inters s)"
| "Inters Zero = None"
| "Inters Full = Some []"
| "Inters r = Some [r]"

lemma Inters_None[symmetric]: "Inters r = None \<longleftrightarrow> Zero \<in> toplevel_inters r"
  by (induct r) auto

lemma Inters_Some: "Inters r = Some xs \<longleftrightarrow>
  (Zero \<notin> set xs \<and> xs = sorted_list_of_set (toplevel_inters r - {Full}))"
proof (induct r arbitrary: xs)
  case (Inter r s)
  show ?case
  proof safe
    assume "Inters (Inter r s) = Some xs"
    then obtain a b where *: "Inters r = Some a" "Inters s = Some b" "xs = merge_distinct a b" by auto
    with Inter(1)[of a] Inter(2)[of b]
      show "xs = sorted_list_of_set (toplevel_inters (Inter r s) - {Full})" by (simp add: Un_Diff)
    assume "Zero \<in> set xs" with Inter(1)[of a] Inter(2)[of b] * show False by (simp add: Inters_None)
  next
    assume "Zero \<notin> set (sorted_list_of_set (toplevel_inters (Inter r s) - {Full}))"
    with Inter(1)[of "sorted_list_of_set (toplevel_inters r - {Full})"]
      Inter(2)[of "sorted_list_of_set (toplevel_inters s - {Full})"]
      show "Inters (Inter r s) = Some (sorted_list_of_set (toplevel_inters (Inter r s) - {Full}))"
        by (simp add: Un_Diff)
  qed
qed force+

definition inPlus where
  "inPlus r s = (case Pluss (Plus r s) of None \<Rightarrow> Full | Some rs \<Rightarrow> PLUS rs)"

lemma inPlus_alt: "inPlus r s = (let X = toplevel_summands (Plus r s) - {Zero} in
  flatten PLUS (if Full \<in> X then {Full} else X))"
proof (cases "Pluss r" "Pluss s" rule: option.exhaust[case_product option.exhaust])
  case Some_Some then show ?thesis by (simp add: inPlus_def Pluss_None) (simp add: Pluss_Some Un_Diff)
qed (simp_all add: inPlus_def Pluss_None)

fun inTimes where
  "inTimes Zero _ = Zero"
| "inTimes _ Zero = Zero"
| "inTimes One r = r"
| "inTimes r One = r"
| "inTimes (Times r s) t = Times r (inTimes s t)"
| "inTimes r s = Times r s"

fun inStar where
  "inStar Zero = One"
| "inStar Full = Full"
| "inStar One = One"
| "inStar (Star r) = Star r"
| "inStar r = Star r"

definition inInter where
  "inInter r s = (case Inters (Inter r s) of None \<Rightarrow> Zero | Some rs \<Rightarrow> INTERSECT rs)"

lemma inInter_alt: "inInter r s = (let X = toplevel_inters (Inter r s) - {Full} in
  flatten INTERSECT (if Zero \<in> X then {Zero} else X))"
proof (cases "Inters r" "Inters s" rule: option.exhaust[case_product option.exhaust])
  case Some_Some then show ?thesis by (simp add: inInter_def Inters_None) (simp add: Inters_Some Un_Diff)
qed (simp_all add: inInter_def Inters_None)

fun inNot where
  "inNot Zero = Full"
| "inNot Full = Zero"
| "inNot (Not r) = r"
| "inNot (Plus r s) = Inter (inNot r) (inNot s)"
| "inNot (Inter r s) = Plus (inNot r) (inNot s)"
| "inNot r = Not r"

fun inPr where
  "inPr Zero = Zero"
| "inPr One = One"
| "inPr (Plus r s) = Plus (inPr r) (inPr s)"
| "inPr r = Pr r"

primrec inorm where
  "inorm Zero = Zero"
| "inorm Full = Full"
| "inorm One = One"
| "inorm (Atom a) = Atom a"
| "inorm (Plus r s) = Plus (inorm r) (inorm s)"
| "inorm (Times r s) = Times (inorm r) (inorm s)"
| "inorm (Star r) = inStar (inorm r)"
| "inorm (Not r) = inNot (inorm r)"
| "inorm (Inter r s) = inInter (inorm r) (inorm s)"
| "inorm (Pr r) = inPr (inorm r)"

context alphabet begin

lemma wf_inPlus[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (inPlus r s)"
  by (subst (asm) (1 2) toplevel_summands_wf) (auto simp: inPlus_alt)

lemma wf_inTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (inTimes r s)"
  by (induct r s rule: inTimes.induct) auto

lemma wf_inStar[simp]: "wf n r \<Longrightarrow> wf n (inStar r)"
  by (induct r rule: inStar.induct) auto

lemma wf_inNot[simp]: "wf n r \<Longrightarrow> wf n (inNot r)"
  by (induct r rule: inNot.induct) auto

lemma wf_inPr[simp]: "wf (Suc n) r \<Longrightarrow> wf n (inPr r)"
  by (induct r rule: inPr.induct) auto

lemma wf_inorm[simp]: "wf n r \<Longrightarrow> wf n (inorm r)"
  by (induct r arbitrary: n) auto

end

context project begin

lemma lang_inTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (inTimes r s) = lang n (Times r s)"
  by (induct r s rule: inTimes.induct) (auto simp: conc_assoc)

lemma lang_inStar[simp]: "wf n r \<Longrightarrow> lang n (inStar r) = lang n (Star r)"
  by (induct r rule: inStar.induct)
    (auto intro: star_if_lang dest: subsetD[OF star_subset_lists, rotated])

lemma Zero_toplevel_inters[dest]: "Zero \<in> toplevel_inters r \<Longrightarrow> lang n r = {}"
  by (metis lang.simps(1) subset_empty toplevel_inters_lang)

lemma toplevel_inters_Full: "\<lbrakk>toplevel_inters r = {Full}; wf n r\<rbrakk> \<Longrightarrow> lang n r = lists (\<Sigma> n)"
  by (metis antisym lang.simps(2) subsetI toplevel_inters.simps(3) toplevel_inters_in_lang)

lemma toplevel_inters_subset_singleton[simp]: "toplevel_inters r \<subseteq> {s} \<longleftrightarrow> toplevel_inters r = {s}"
  by (metis subset_refl subset_singletonD toplevel_inters_nonempty)

lemma lang_inInter[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (inInter r s) = lang n (Inter r s)"
  using lang_subset_lists[of n, unfolded lang.simps(2)[symmetric]]
    toplevel_inters_nonempty[of r] toplevel_inters_nonempty[of s]
  apply (auto 0 2 simp: inInter_alt toplevel_inters_in_lang[of _ n r] toplevel_inters_in_lang[of _ n s]
     toplevel_inters_wf[of n r] toplevel_inters_wf[of n s] Ball_def simp del: toplevel_inters_nonempty
     dest!: toplevel_inters_Full[of _ n] split: if_splits)
  by fastforce+

lemma lang_inNot[simp]: "wf n r \<Longrightarrow> lang n (inNot r) = lang n (Not r)"
  by (induct r rule: inNot.induct) (auto dest: lang_subset_lists)

lemma lang_inPr[simp]: "wf (Suc n) r \<Longrightarrow> lang n (inPr r) = lang n (Pr r)"
  by (induct r rule: inPr.induct) auto

lemma lang_inorm[simp]: "wf n r \<Longrightarrow> lang n (inorm r) = lang n r"
  by (induct r arbitrary: n) auto

end

(*<*)
end
(*>*)


section \<open>Combinability\<close>

text \<open>This section corresponds to Section 3 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

theory Combinability
  imports UnboundedLogic
begin

context logic
begin

text \<open>The definition of combinable assertions corresponds to Definition 4 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

definition combinable :: "('d, 'c, 'a) interp \<Rightarrow> ('a, 'b, 'c, 'd) assertion \<Rightarrow> bool" where
  "combinable \<Delta> A \<longleftrightarrow> (\<forall>p q. Star (Mult p A) (Mult q A), \<Delta> \<turnstile> Mult (sadd p q) A)"

lemma combinable_instantiate:
  assumes "combinable \<Delta> A"
      and "a, s, \<Delta> \<Turnstile> A"
      and "b, s, \<Delta> \<Turnstile> A"
      and "Some x = p \<odot> a \<oplus> q \<odot> b"
    shows "x, s, \<Delta> \<Turnstile> Mult (sadd p q) A"
  by (meson assms(1) assms(2) assms(3) assms(4) combinable_def entails_def logic.sat.simps(2) logic_axioms sat.simps(1))

lemma combinable_instantiate_one:
  assumes "combinable \<Delta> A"
      and "a, s, \<Delta> \<Turnstile> A"
      and "b, s, \<Delta> \<Turnstile> A"
      and "Some x = p \<odot> a \<oplus> q \<odot> b"
      and "sadd p q = one"
    shows "x, s, \<Delta> \<Turnstile> A"
  using assms(1) assms(2) assms(3) assms(4) assms(5) combinable_instantiate one_neutral by fastforce

lemma combinableI_old:
  assumes "\<And>a b p q x \<sigma> s. a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = (sadd p q) \<odot> x \<Longrightarrow> x, s, \<Delta> \<Turnstile> A"
  shows "combinable \<Delta> A"
proof -
  have "\<And>p q. Star (Mult p A) (Mult q A), \<Delta> \<turnstile> Mult (sadd p q) A"
  proof (rule entailsI)
    fix p q \<sigma> s
    assume "\<sigma>, s, \<Delta> \<Turnstile> Star (Mult p A) (Mult q A)"
    then obtain a b where "a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b"
      by auto
    moreover obtain x where "\<sigma> = (sadd p q) \<odot> x"
      using unique_inv by auto
    ultimately have "x, s, \<Delta> \<Turnstile> A" using assms
      by blast
    then show "\<sigma>, s, \<Delta> \<Turnstile> Mult (sadd p q) A"
      using \<open>\<sigma> = sadd p q \<odot> x\<close> by fastforce
    qed
  then show ?thesis
    by (simp add: combinable_def)
qed

lemma combinableI:
  assumes "\<And>a b p q x \<sigma> s. a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one \<Longrightarrow> x, s, \<Delta> \<Turnstile> A"
  shows "combinable \<Delta> A"
proof (rule combinableI_old)
  fix a b p q x \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x"
  let ?p = "smult (sinv (sadd p q)) p"
  let ?q = "smult (sinv (sadd p q)) q"
  have "Some x = ?p \<odot> a \<oplus> ?q \<odot> b"
  proof -
    have "Some ((smult (sinv (sadd p q)) (sadd p q)) \<odot> x) = ?p \<odot> a \<oplus> ?q \<odot> b"
      by (metis \<open>a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> double_mult logic.plus_mult logic_axioms)
    then show ?thesis
      by (simp add: one_neutral sinv_inverse smult_comm)
  qed
  moreover have "sadd ?p ?q = one"
    by (metis logic.smult_comm logic_axioms sinv_inverse smult_distrib)
  ultimately show "x, s, \<Delta> \<Turnstile> A"
    using \<open>a, s, \<Delta> \<Turnstile> A \<and> b, s, \<Delta> \<Turnstile> A \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> assms by blast
qed

lemma combinable_wand:
  assumes "combinable \<Delta> B"
    shows "combinable \<Delta> (Wand A B)"
proof (rule combinableI_old)
  fix a b p q x \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> Wand A B \<and> b, s, \<Delta> \<Turnstile> Wand A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x"
  show "x, s, \<Delta> \<Turnstile> Wand A B"
  proof (rule sat_wand)
    fix aa \<sigma>'
    assume "aa, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = x \<oplus> aa"
    then have "Some ((sadd p q) \<odot> \<sigma>') = \<sigma> \<oplus> ((sadd p q) \<odot> aa)"
      by (simp add: \<open>a, s, \<Delta> \<Turnstile> Wand A B \<and> b, s, \<Delta> \<Turnstile> Wand A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> plus_mult)
    moreover have "Some ((sadd p q) \<odot> aa) = p \<odot> aa \<oplus> q \<odot> aa"
      by (simp add: distrib_mult)
    moreover have "a ## aa"
    proof -
      have "p \<odot> a ## (sadd p q) \<odot> aa"
        by (metis \<open>a, s, \<Delta> \<Turnstile> Wand A B \<and> b, s, \<Delta> \<Turnstile> Wand A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> asso2 calculation(1) commutative compatible_def option.discI)
      then show ?thesis
        using compatible_multiples by blast
    qed
    then obtain aaa where "Some aaa = a \<oplus> aa"
      using compatible_def by auto
    moreover have "b ## aa"
    proof -
      have "q \<odot> b ## (sadd p q) \<odot> aa"
        by (metis \<open>a, s, \<Delta> \<Turnstile> Wand A B \<and> b, s, \<Delta> \<Turnstile> Wand A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> asso2 calculation(1) compatible_def option.discI)
      then show ?thesis
        using compatible_multiples by blast
    qed
    then obtain baa where "Some baa = b \<oplus> aa"
      using compatible_def by auto
    ultimately have "Some (mult (sadd p q) \<sigma>') = p \<odot> aaa \<oplus> q \<odot> baa"
    proof -
      obtain a1 where "Some a1 = \<sigma> \<oplus> (p \<odot> aa)"
        by (metis \<open>Some (sadd p q \<odot> \<sigma>') = \<sigma> \<oplus> sadd p q \<odot> aa\<close> compatible_multiples option.exhaust_sel pre_logic.compatible_def unique_inv)
      then obtain a2 where "Some a2 = p \<odot> a \<oplus> (p \<odot> aa)"
        by (meson \<open>\<And>thesis. (\<And>aaa. Some aaa = a \<oplus> aa \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> plus_mult)
      then have "Some a1 = a2 \<oplus> q \<odot> b"
      proof -
        obtain bc where "q \<odot> b \<oplus> p \<odot> aa = Some bc"
          by (metis \<open>b ## aa\<close> compatible_iff compatible_multiples one_neutral option.exhaust_sel pre_logic.compatible_def)
        then have "\<sigma> \<oplus> p \<odot> aa = p \<odot> a \<oplus> bc"
          using asso1[of "p \<odot> a" "q \<odot> b" \<sigma> "p \<odot> aa" bc]
          by (metis \<open>a, s, \<Delta> \<Turnstile> Wand A B \<and> b, s, \<Delta> \<Turnstile> Wand A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close>)
        then show ?thesis
          by (metis \<open>Some a1 = \<sigma> \<oplus> p \<odot> aa\<close> \<open>Some a2 = p \<odot> a \<oplus> p \<odot> aa\<close> \<open>q \<odot> b \<oplus> p \<odot> aa = Some bc\<close> asso1 commutative)
      qed
      moreover have "a2 = p \<odot> aaa"
        by (metis \<open>Some a2 = p \<odot> a \<oplus> p \<odot> aa\<close> \<open>Some aaa = a \<oplus> aa\<close> option.inject plus_mult)
      moreover have "Some (q \<odot> baa) = q \<odot> b \<oplus> q \<odot> aa"
        by (simp add: \<open>Some baa = b \<oplus> aa\<close> plus_mult)
      ultimately show ?thesis
        by (metis \<open>Some (sadd p q \<odot> \<sigma>') = \<sigma> \<oplus> sadd p q \<odot> aa\<close> \<open>Some (sadd p q \<odot> aa) = p \<odot> aa \<oplus> q \<odot> aa\<close> \<open>Some a1 = \<sigma> \<oplus> p \<odot> aa\<close> asso1)
    qed
    moreover have "aaa, s, \<Delta> \<Turnstile> B \<and> baa, s, \<Delta> \<Turnstile> B"
      using \<open>Some aaa = a \<oplus> aa\<close> \<open>Some baa = b \<oplus> aa\<close> \<open>a, s, \<Delta> \<Turnstile> Wand A B \<and> b, s, \<Delta> \<Turnstile> Wand A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> \<open>aa, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = x \<oplus> aa\<close> by auto
    ultimately have "mult (sadd p q) \<sigma>', s, \<Delta> \<Turnstile> Mult (sadd p q) B"
      by (meson assms logic.combinable_def logic.entails_def logic_axioms sat.simps(1) sat.simps(2))
    then show "\<sigma>', s, \<Delta> \<Turnstile> B"
      using can_divide sat.simps(1) by metis
  qed
qed

lemma combinable_star:
  assumes "combinable \<Delta> A"
      and "combinable \<Delta> B"
    shows "combinable \<Delta> (Star A B)"
proof (rule combinableI_old)
  fix a b p q x \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> Star A B \<and> b, s, \<Delta> \<Turnstile> Star A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x"
  then obtain aa ab ba bb where "Some a = aa \<oplus> ab" "Some b = ba \<oplus> bb" "aa, s, \<Delta> \<Turnstile> A"
   "ab, s, \<Delta> \<Turnstile> B" "ba, s, \<Delta> \<Turnstile> A" "bb, s, \<Delta> \<Turnstile> B"
    by auto
  then obtain xa xb where "Some xa = p \<odot> aa \<oplus> q \<odot> ba" "Some xb = p \<odot> ab \<oplus> q \<odot> bb"
    by (metis \<open>a, s, \<Delta> \<Turnstile> Star A B \<and> b, s, \<Delta> \<Turnstile> Star A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> asso2 commutative compatible_iff compatible_multiples one_neutral option.discI option.exhaust_sel pre_logic.compatible_def)
  then have "xa, s, \<Delta> \<Turnstile> Mult (sadd p q) A"
    by (meson \<open>aa, s, \<Delta> \<Turnstile> A\<close> \<open>ba, s, \<Delta> \<Turnstile> A\<close> assms(1) entails_def logic.combinable_def logic.sat.simps(1) logic.sat.simps(2) logic_axioms)
  moreover have "xb, s, \<Delta> \<Turnstile> Mult (sadd p q) B"
    by (meson \<open>Some xb = p \<odot> ab \<oplus> q \<odot> bb\<close> \<open>ab, s, \<Delta> \<Turnstile> B\<close> \<open>bb, s, \<Delta> \<Turnstile> B\<close> assms(2) combinable_def entails_def sat.simps(1) sat.simps(2))
  moreover have "Some \<sigma> = xa \<oplus> xb"
    using \<open>Some a = aa \<oplus> ab\<close> \<open>Some b = ba \<oplus> bb\<close> \<open>Some xa = p \<odot> aa \<oplus> q \<odot> ba\<close> \<open>Some xb = p \<odot> ab \<oplus> q \<odot> bb\<close> \<open>a, s, \<Delta> \<Turnstile> Star A B \<and> b, s, \<Delta> \<Turnstile> Star A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> move_sum plus_mult by blast
  then obtain xa' xb' where "Some x = xa' \<oplus> xb'" "xa = sadd p q \<odot> xa'" "xb = sadd p q \<odot> xb'"
    by (metis \<open>a, s, \<Delta> \<Turnstile> Star A B \<and> b, s, \<Delta> \<Turnstile> Star A B \<and> Some \<sigma> = p \<odot> a \<oplus> q \<odot> b \<and> \<sigma> = sadd p q \<odot> x\<close> plus_mult unique_inv)
  ultimately show "x, s, \<Delta> \<Turnstile> Star A B"
    by (metis logic.can_divide logic_axioms sat.simps(1) sat.simps(2))
qed

lemma combinable_mult:
  assumes "combinable \<Delta> A"
  shows "combinable \<Delta> (Mult \<pi> A)"
proof (rule combinableI)
  fix a b p q x \<sigma> s
  assume asm: "a, s, \<Delta> \<Turnstile> Mult \<pi> A \<and> b, s, \<Delta> \<Turnstile> Mult \<pi> A \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
  then obtain a' b' where "a', s, \<Delta> \<Turnstile> A" "b', s, \<Delta> \<Turnstile> A" "a = \<pi> \<odot> a'" "b = \<pi> \<odot> b'" by auto

  let ?p = "smult p \<pi>"
  let ?q = "smult q \<pi>"

  have "Some x = ?p \<odot> a' \<oplus> ?q \<odot> b'"
    by (simp add: \<open>a = \<pi> \<odot> a'\<close> \<open>b = \<pi> \<odot> b'\<close> asm double_mult)
  moreover have "sadd ?p ?q = \<pi>"
    using asm smult_comm smult_distrib sone_neutral by force
  ultimately show "x, s, \<Delta> \<Turnstile> Mult \<pi> A"
    by (metis \<open>a', s, \<Delta> \<Turnstile> A\<close> \<open>b', s, \<Delta> \<Turnstile> A\<close> assms combinable_instantiate)
qed

lemma combinable_and:
  assumes "combinable \<Delta> A"
      and "combinable \<Delta> B"
    shows "combinable \<Delta> (And A B)"
proof (rule combinableI)
  fix a b p q x \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> And A B \<and> b, s, \<Delta> \<Turnstile> And A B \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
  then obtain "a, s, \<Delta> \<Turnstile> A" "b, s, \<Delta> \<Turnstile> A" "a, s, \<Delta> \<Turnstile> B" "b, s, \<Delta> \<Turnstile> B" by auto
  then show "x, s, \<Delta> \<Turnstile> And A B"
    by (meson \<open>a, s, \<Delta> \<Turnstile> And A B \<and> b, s, \<Delta> \<Turnstile> And A B \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one\<close> assms(1) assms(2) combinable_instantiate_one sat.simps(7))
qed

lemma combinable_forall:
  assumes "combinable \<Delta> A"
    shows "combinable \<Delta> (Forall x A)"
proof (rule combinableI)
  fix a b p q y \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> Forall x A \<and> b, s, \<Delta> \<Turnstile> Forall x A \<and> Some y = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
  show "y, s, \<Delta> \<Turnstile> Forall x A"
  proof (rule sat_forall)
    fix v show "y, s(x := v), \<Delta> \<Turnstile> A"
      by (meson \<open>a, s, \<Delta> \<Turnstile> Forall x A \<and> b, s, \<Delta> \<Turnstile> Forall x A \<and> Some y = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one\<close> assms combinable_instantiate_one sat.simps(9))
  qed
qed

definition unambiguous where
  "unambiguous \<Delta> A x \<longleftrightarrow> (\<forall>\<sigma>1 \<sigma>2 v1 v2 s. \<sigma>1 ## \<sigma>2 \<and> \<sigma>1, s(x := v1), \<Delta> \<Turnstile> A \<and> \<sigma>2, s(x := v2), \<Delta> \<Turnstile> A \<longrightarrow> v1 = v2)"

lemma unambiguousI:
  assumes "\<And>\<sigma>1 \<sigma>2 v1 v2 s. \<sigma>1 ## \<sigma>2 \<and> \<sigma>1, s(x := v1), \<Delta> \<Turnstile> A \<and> \<sigma>2, s(x := v2), \<Delta> \<Turnstile> A \<Longrightarrow> v1 = v2"
  shows "unambiguous \<Delta> A x"
  by (simp add: assms unambiguous_def)

lemma unambiguous_star:
  assumes "unambiguous \<Delta> A x"
  shows "unambiguous \<Delta> (Star A B) x"
proof (rule unambiguousI)
  fix \<sigma>1 \<sigma>2 v1 v2 s
  assume "\<sigma>1 ## \<sigma>2 \<and> \<sigma>1, s(x := v1), \<Delta> \<Turnstile> Star A B \<and> \<sigma>2, s(x := v2), \<Delta> \<Turnstile> Star A B"
  then obtain a1 b1 a2 b2 where "Some \<sigma>1 = a1 \<oplus> b1" "Some \<sigma>2 = a2 \<oplus> b2" "a1, s(x := v1), \<Delta> \<Turnstile> A"
 "a2, s(x := v2), \<Delta> \<Turnstile> A" "b1, s(x := v1), \<Delta> \<Turnstile> B" "b2, s(x := v2), \<Delta> \<Turnstile> B" by auto
  then have "a1 ## a2"
    by (metis \<open>\<sigma>1 ## \<sigma>2 \<and> \<sigma>1, s(x := v1), \<Delta> \<Turnstile> Star A B \<and> \<sigma>2, s (x := v2), \<Delta> \<Turnstile> Star A B\<close> asso2 asso3 commutative)
  then show "v1 = v2"
    using \<open>a1, s(x := v1), \<Delta> \<Turnstile> A\<close> \<open>a2, s(x := v2), \<Delta> \<Turnstile> A\<close> assms unambiguous_def by fastforce
qed

lemma combinable_exists:
  assumes "combinable \<Delta> A"
      and "unambiguous \<Delta> A x"
    shows "combinable \<Delta> (Exists x A)"
proof (rule combinableI)
  fix a b p q y \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> Exists x A \<and> b, s, \<Delta> \<Turnstile> Exists x A \<and> Some y = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
  then have "a ## b"
    by (metis logic.compatible_multiples logic_axioms option.discI pre_logic.compatible_def)
  moreover obtain v1 v2 where "a, s(x := v1), \<Delta> \<Turnstile> A" "b, s(x := v2), \<Delta> \<Turnstile> A"
    using \<open>a, s, \<Delta> \<Turnstile> Exists x A \<and> b, s, \<Delta> \<Turnstile> Exists x A \<and> Some y = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one\<close> by auto
  ultimately have "v1 = v2"
    using assms(2) unambiguous_def by force
  then show "y, s, \<Delta> \<Turnstile> Exists x A"
    by (metis (mono_tags, opaque_lifting) \<open>a, s(x := v1), \<Delta> \<Turnstile> A\<close> \<open>a, s, \<Delta> \<Turnstile> Exists x A \<and> b, s, \<Delta> \<Turnstile> Exists x A \<and> Some y = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one\<close> \<open>b, s(x := v2), \<Delta> \<Turnstile> A\<close> assms(1) combinable_instantiate_one logic.sat.simps(8) logic_axioms)
qed

lemma combinable_pure:
  assumes "pure A"
  shows "combinable \<Delta> A"
  using assms combinableI_old pure_def by blast

lemma combinable_imp:
  assumes "pure A"
      and "combinable \<Delta> B"
  shows "combinable \<Delta> (Imp A B)"
proof (rule combinableI)
  fix a b p q x \<sigma> s
  assume "a, s, \<Delta> \<Turnstile> Imp A B \<and> b, s, \<Delta> \<Turnstile> Imp A B \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
  then show "x, s, \<Delta> \<Turnstile> Imp A B"
    using assms(1) assms(2) combinable_instantiate_one pure_def sat.simps(5)
    by metis
qed

lemma combinable_wildcard:
  assumes "combinable \<Delta> A"
  shows "combinable \<Delta> (Wildcard A)"
proof (rule combinableI)
  fix a b p q x \<sigma> s
  assume asm: "a, s, \<Delta> \<Turnstile> Wildcard A \<and> b, s, \<Delta> \<Turnstile> Wildcard A \<and> Some x = p \<odot> a \<oplus> q \<odot> b \<and> sadd p q = one"
  then obtain a' b' pa pb where "a', s, \<Delta> \<Turnstile> A" "b', s, \<Delta> \<Turnstile> A" "a = pa \<odot> a'" "b = pb \<odot> b'" by auto
  then have "Some x = (smult p pa) \<odot> a' \<oplus> (smult q pb) \<odot> b'"
    by (simp add: asm double_mult)
  then have "x, s, \<Delta> \<Turnstile> Mult (sadd (smult p pa) (smult q pb)) A"
    using \<open>a', s, \<Delta> \<Turnstile> A\<close> \<open>b', s, \<Delta> \<Turnstile> A\<close> assms combinable_instantiate by blast
  then show "x, s, \<Delta> \<Turnstile> Wildcard A"
    by fastforce
qed

end

end


(*  Title:      Basis.thy
    Author:     Peter Gammie
*)

theory Basis
imports
  HOLCF
  "HOL-Library.Product_Order"
  "HOL-Library.Dual_Ordered_Lattice"
  "HOLCF-Library.Nat_Discrete"
begin

subsection\<open>Auxiliary lemmas\<close>

lemma cfun_map_below_ID:
  assumes e: "e \<sqsubseteq> ID"
  shows "cfun_map\<cdot>e\<cdot>e \<sqsubseteq> ID"
proof(intro cfun_belowI)
  fix f x
  from e have "cfun_map\<cdot>e\<cdot>e\<cdot>f\<cdot>x \<sqsubseteq> ID\<cdot>(f\<cdot>(ID\<cdot>x))"
    by (simp del: ID1) (fast intro: monofun_cfun)
  thus "cfun_map\<cdot>e\<cdot>e\<cdot>f\<cdot>x \<sqsubseteq> ID\<cdot>f\<cdot>x" by simp
qed

lemma cfun_below_ID:
  "\<lbrakk> f \<sqsubseteq> ID; x \<sqsubseteq> y \<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> y"
by (auto simp: cfun_below_iff elim: below_trans)

lemma oo_below:
  "\<lbrakk> f \<sqsubseteq> f'; g \<sqsubseteq> g' \<rbrakk> \<Longrightarrow> f oo g \<sqsubseteq> f' oo g'"
by (simp add: oo_def cfun_below_iff monofun_cfun)

lemma cont_case_nat[simp]:
  "\<lbrakk>cont (\<lambda>x. f x); \<And>n. cont (\<lambda>x. g x n) \<rbrakk> \<Longrightarrow> cont (\<lambda>x. case_nat (f x) (g x) n)"
by (cases n, simp_all)

lemma cont2cont_if_below_const [cont2cont, simp]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. if f x \<sqsubseteq> d then \<bottom> else g x)"
proof (rule cont_apply [OF f])
  show "\<And>x. cont (\<lambda>y. if y \<sqsubseteq> d then \<bottom> else g x)"
    unfolding cont_def is_lub_def is_ub_def ball_simps
    by (simp add: lub_below_iff)
  show "\<And>y. cont (\<lambda>x. if y \<sqsubseteq> d then \<bottom> else g x)"
    by (simp add: g)
qed

lemma cont2cont_foldl [simp, cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo \<Rightarrow> 'b"
  fixes xs :: "'c list"
  fixes z :: "'a \<Rightarrow> 'b"
  assumes "cont (\<lambda>(x, y, z). f x y z)"
  assumes "cont z"
  shows "cont (\<lambda>x. foldl (f x) (z x) xs)"
using assms by (induct xs rule: rev_induct) (auto simp: prod_cont_iff intro: cont_apply)

lemma cont2cont_foldr [simp, cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'c::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'b"
  fixes xs :: "'c list"
  fixes z :: "'a \<Rightarrow> 'b"
  assumes "cont (\<lambda>(x, y, z). f x y z)"
  assumes "cont z"
  shows "cont (\<lambda>x. foldr (f x) xs (z x))"
using assms by (induct xs) (auto simp: prod_cont_iff intro: cont_apply)

text\<open>

The following proof is due to
\citet[Eqn~2.28]{DBLP:journals/siamcomp/Scott76}.

\<close>

lemma fix_argument_promote:
  assumes "cont g"
  shows "(\<Lambda> x. fix\<cdot>(g x)) = fix\<cdot>(\<Lambda> f x. g x\<cdot>(f\<cdot>x))"
proof(rule below_antisym)
  have "(\<Lambda> x. g x\<cdot>(fix\<cdot>(g x))) = (\<Lambda> x. fix\<cdot>(g x))"
    by (subst fix_eq) simp
  with \<open>cont g\<close> show "fix\<cdot>(\<Lambda> f x. g x\<cdot>(f\<cdot>x)) \<sqsubseteq> (\<Lambda> x. fix\<cdot>(g x))"
    by (simp add: fix_least cont2cont_LAM)
next
  show "(\<Lambda> x. fix\<cdot>(g x)) \<sqsubseteq> fix\<cdot>(\<Lambda> f x. g x\<cdot>(f\<cdot>x))"
  proof(rule cfun_belowI)
    fix y
    from \<open>cont g\<close>
    have "g y\<cdot>(fix\<cdot>(\<Lambda> f x. g x\<cdot>(f\<cdot>x))\<cdot>y) = fix\<cdot>(\<Lambda> f x. g x\<cdot>(f\<cdot>x))\<cdot>y"
      by (subst fix_eq, simp add: cont2cont_LAM)
    with \<open>cont g\<close> show "(\<Lambda> x. fix\<cdot>(g x))\<cdot>y \<sqsubseteq> fix\<cdot>(\<Lambda> f x. g x\<cdot>(f\<cdot>x))\<cdot>y"
      by (simp add: fix_least)
  qed
qed

lemma fix_argument_promote_fun:
  fixes g :: "'a::type \<Rightarrow> 'b::pcpo \<rightarrow> 'b"
  shows "(\<lambda>x. fix\<cdot>(g x)) = (\<mu> f. (\<lambda>x. g x\<cdot>(f x)))"
proof(rule below_antisym)
  have "(\<lambda>x. g x\<cdot>(fix\<cdot>(g x))) = (\<lambda>x. fix\<cdot>(g x))"
    by (subst fix_eq) simp
  then show "(\<mu> f. (\<lambda>x. g x\<cdot>(f x))) \<sqsubseteq> (\<lambda>x. fix\<cdot>(g x))"
    by (simp add: fix_least cont_fun)
next
  show "(\<lambda>x. fix\<cdot>(g x)) \<sqsubseteq> (\<mu> f. (\<lambda>x. g x\<cdot>(f x)))"
  proof(rule fun_belowI)
    fix y
    have "g y\<cdot>((\<mu> f. (\<lambda>x. g x\<cdot>(f x))) y) = (\<mu> f. (\<lambda>x. g x\<cdot>(f x))) y"
      by (subst fix_eq, simp add: cont_fun)
    thus "fix\<cdot>(g y) \<sqsubseteq> (\<mu> f. (\<lambda>x. g x\<cdot>(f x))) y"
      by (simp add: fix_least)
  qed
qed

lemma adm_cart_prod [intro, simp]:
  assumes X: "adm (\<lambda>x. x \<in> X)"
  assumes Y: "adm (\<lambda>x. x \<in> Y)"
  shows "adm (\<lambda>x. x \<in> X \<times> Y)"
proof(rule admI)
  fix A assume A: "chain A" and Ai: "\<forall>i. A i \<in> X \<times> Y"
  from Ai have "\<forall>i. fst (A i) \<in> X" and "\<forall>i. snd (A i) \<in> Y" by (auto simp: mem_Times_iff)
  with A X Y show "Lub A \<in> X \<times> Y" by (auto intro: admD intro!: adm_subst simp: lub_prod)
qed

lemma adm_exists_unique [intro, simp]:
  assumes Q: "\<And>y. adm (\<lambda>x. Q x y)"
  assumes P: "\<And>x x'. P x \<and> P x' \<longrightarrow> x = x'"
  shows "adm (\<lambda>x. \<exists>y. P y \<and> Q x y)"
proof(rule admI)
  fix Y assume Y: "chain Y" and Yi: "\<forall>i. \<exists>y. P y \<and> Q (Y i) y"
  then obtain y where Py: "P y" by blast
  with P Q Y Yi have "Q (Lub Y) y"
    by - (rule admD, fastforce+)
  with Py show "\<exists>y. P y \<and> Q (Lub Y) y" by blast
qed

subsubsection\<open>Order monics\<close>

text\<open>

Order monics are invertible with respect to the partial order. They
don't need to be continuous!

All domain data constructors are @{term "below_monic_cfun"}.

\<close>

definition
  below_monic :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool"
where
  "below_monic f \<equiv> \<forall>x y. f x \<sqsubseteq> f y \<longrightarrow> x \<sqsubseteq> y"

abbreviation
  below_monic_cfun :: "('a::cpo \<rightarrow> 'b::cpo) \<Rightarrow> bool"
where
  "below_monic_cfun f \<equiv> below_monic (Rep_cfun f)"

lemma below_monicI:
  "(\<And>x y. f x \<sqsubseteq> f y \<Longrightarrow> x \<sqsubseteq> y) \<Longrightarrow> below_monic f"
unfolding below_monic_def by simp

lemma below_monicE:
  "\<lbrakk> below_monic f; f x \<sqsubseteq> f y \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y"
unfolding below_monic_def by simp

lemma below_monic_inj:
  "below_monic (f :: 'a::cpo \<Rightarrow> 'b::cpo) \<Longrightarrow> inj f"
by (auto intro!: below_antisym injI elim: below_monicE)

lemma below_monic_indexed:
  assumes "below_monic_cfun f"
  shows "below_monic (\<lambda>y i. f\<cdot>(y i))"
by (metis (no_types, lifting) assms below_fun_def below_monicE below_monicI)

lemma below_monic_ID [iff]:
  "below_monic_cfun ID"
by (rule below_monicI) simp

lemma below_monic_cfcomp [iff]:
  "below_monic_cfun f \<Longrightarrow> below_monic_cfun (cfcomp\<cdot>f)"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_K [iff]:
  "below_monic_cfun f \<Longrightarrow> below_monic_cfun (\<Lambda> c _. f\<cdot>c)"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_fun_K [iff]:
  "below_monic_cfun f \<Longrightarrow> below_monic_cfun (\<Lambda> c. (\<lambda>_. f\<cdot>c))"
by (rule below_monicI) (auto simp: fun_below_iff dest: below_monicE)

lemma below_monic_cfcomp2 [iff]:
  "\<lbrakk> below_monic_cfun f; below_monic_cfun g \<rbrakk> \<Longrightarrow> below_monic_cfun (f oo g)"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_pair [iff]:
  "\<lbrakk> below_monic_cfun f; below_monic_cfun g \<rbrakk> \<Longrightarrow> below_monic_cfun (\<Lambda> x. (f\<cdot>x, g\<cdot>x))"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_pair_split [iff]:
  "\<lbrakk> below_monic_cfun f; below_monic_cfun g \<rbrakk> \<Longrightarrow> below_monic_cfun (\<Lambda> x. (f\<cdot>(fst x), g\<cdot>(snd x)))"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_sinl [iff]:
  "below_monic_cfun sinl"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_sinr [iff]:
  "below_monic_cfun sinr"
by (rule below_monicI) (auto simp: cfun_below_iff elim: below_monicE)

lemma below_monic_chain_inv:
  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes Y: "chain (Y :: nat \<Rightarrow> 'b::cpo)"
  assumes Yi: "\<forall>i. \<exists>y. Y i = f y \<and> P y"
  assumes f: "below_monic f"
  shows "\<exists>Y'. chain Y' \<and> (\<forall>i. Y i = f (Y' i) \<and> P (Y' i))"
proof -
  let ?Y' = "\<lambda>i. SOME y. Y i = f y \<and> P y"
  have "chain ?Y'"
  proof(rule chainI)
    fix i :: nat
    show "(SOME x. Y i = f x \<and> P x) \<sqsubseteq> (SOME y. Y (Suc i) = f y \<and> P y)"
      apply -
      using spec[OF Yi, where x=i] spec[OF Yi, where x="Suc i"]
      apply clarsimp
      apply (rule someI2)
       apply blast
      apply (rule someI2)
       apply blast
      apply (rule below_monicE[OF f])
      using chain_mono[OF Y, where i=i and j="Suc i"]
      apply simp
      done
  qed
  moreover
  from Yi have "Y i = f (?Y' i) \<and> P (?Y' i)" for i by (metis (mono_tags, lifting) someI_ex)
  ultimately show ?thesis by blast
qed

lemma adm_below_monic_exists:
  "\<lbrakk> adm P; below_monic (f::'a::cpo \<Rightarrow> 'b::cpo); cont f \<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<exists>y. x = f y \<and> P y)"
apply (rule admI)
apply (drule below_monic_chain_inv)
apply simp_all
apply (metis (full_types) admD cont2contlubE lub_eq)
done

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
chapter "New Prove Rule for iid loops"
theory ERT_Of_IID_Loop
imports PGCL_With_State IID_Loops
begin

paragraph \<open>Summary\<close>

text \<open>This theory formalizes the new proof rules for ert of f-iid loops and generalizes the
      result to angelic weakest preexpectation.
      The first result is Theorem 4 of @{cite batzESOP18}
    \<close>

paragraph \<open>Main Lemmas\<close>

text \<open>
  \<^item> prove_rule: proof rule for ert = Theorem 4 of @{cite batzESOP18}
  \<^item> prove_rule_awp: generalization of the proof rule to non-deterministic programs
\<close>

section \<open>New Prove Rule for deterministic case\<close>

lemma
  assumes [simp]: "deter C" "unaffected x C"
    and wp1: "wp (compile C) 1 = 1"
shows deter_decompose: "ert (compile C) (1  + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))
            = 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + wp (compile C) (\<lbrakk>b\<rbrakk>) * x "
proof -
  have rearrange: "(1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x) = ((\<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x) + 1)" by auto
  show "ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))
      = 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f)  + wp (compile C) (\<lbrakk>b\<rbrakk>)  * x "
    unfolding rearrange
    by (auto simp: wp1 decompose_wpert scale_unaffected_expectations_right)
qed

lemma assumes "fiid C b f"
    and [simp]: "unaffected (ert (compile C) 0) C"
        "deter C"
        "wp (compile C) 1 = 1"
        "unaffected x C"
shows deter_unaff_unroll:
      "unaffected (ert (compile C) (1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x)) C"
proof -
  from assms have [simp]:"unaffected (wp (compile C) \<lbrakk>b\<rbrakk>) C"
        "unaffected (wp (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f)) C" unfolding fiid_def by auto

  have B: "ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) = ert (compile C) 0 + wp (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f)"
    by (auto simp: decompose_ert[symmetric])

  have [simp]: "unaffected 1 C"  unfolding unaffected_def Vars_def by auto

  show 2: "unaffected (ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))) C"
    by(auto simp: deter_decompose B intro!: unaffected_plus unaffected_mult)
qed

text \<open>This is the ert proof rule for f-iid loops. It is Theorem 4 in @{cite batzESOP18}.\<close>

theorem
  fixes b :: "state \<Rightarrow> bool" and  f :: exp and C
  assumes wp1: "wp (compile C) 1 = 1" \<comment> \<open>loop body terminates almost-surely\<close>
    and "fiid C b f"
    and "unaffected (ert (compile C) 0) C" \<comment> \<open>every iteration runs in the same expected time\<close>
    and det: "deter C"
  shows prove_rule: "ert (compile (While b C)) f \<sigma> = 1 + (if b \<sigma> then (1 + ert (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) \<sigma>)
                                                                          / (1- (wp (compile C) \<lbrakk>b\<rbrakk> \<sigma>))
                                                      else f \<sigma>)"
proof -
  from assms have "unaffected (wp (compile C) \<lbrakk>b\<rbrakk>) C"
        "unaffected (wp (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f)) C" unfolding fiid_def by auto

  let ?f = "\<lambda>W. 1 + (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) + (\<lbrakk>b\<rbrakk>*W)"
  let ?g = "\<lambda>W. ert (compile C) W"
  let ?h = "\<lambda>s' r. 1 + ert (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) s' + wp (compile C) \<lbrakk>b\<rbrakk> s' * r"

  have eq: "lfp (\<lambda>x. ?f (?g x)) = ?f (lfp (\<lambda>x. ?g (?f x)))"
    apply(rule lfp_rolling[where g="?f", symmetric])
     apply(auto simp: mono_def le_fun_def lift2_def)
    using mono_ert[unfolded mono_def]
    by (smt le_fun_def)

  have eq2: "(\<lambda>W x. 1 + (if b x then ert (compile C) W x else f x))
        =  (\<lambda>W. ?f (?g W))" unfolding lift2_def apply(rule) by auto
  have "ert (compile (While b C)) f = lfp (\<lambda>x. ?f (?g x))"
    by(simp add: eq2)

  {
    fix s' :: state

    have *: "sup_continuous (\<lambda>x. ?g (?f x))" "sup_continuous (?h s)" for s :: state
      by (rule sup_continuous_compose[where f="ert (compile C)"]) (auto intro!: order_continuous_intros sup_continuous_ert)

    from * have L: "lfp (\<lambda>W s. ?g (?f W) s) s' = lfp (%r. ?h s' r) \<and> unaffected (lfp (\<lambda>W s. ?g (?f W) s)) C"
    proof(induction rule: lfp_parallel_induct)
      case bot
      then show ?case by (auto simp: unaffected_def Vars_def)
    next
      case (step x y)
      then have "unaffected x C" by auto

      have i: "ert (compile C) (1  + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))
            = 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + wp (compile C) (\<lbrakk>b\<rbrakk>) * x "
        apply (rule deter_decompose) by fact+

      have ii: "unaffected (ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))) C"
        apply(rule deter_unaff_unroll) by fact+

      show "?g (?f x) s' = ?h s' y \<and> unaffected (?g (?f x)) C"
        apply(safe)
        subgoal using i step by simp
        subgoal using ii by auto
        done
    next
      case (cont X Y)
      then show ?case apply (auto simp: unaffected_def Vars_def SUP_image)
        by (metis cont.IH unaffaccted_fun_upd)
    qed
  }
  then have "lfp (\<lambda>W s. ?g (?f W) s) \<sigma> = lfp (%r. ?h \<sigma> r)" by simp
  also have "\<dots> = (1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) \<sigma>) / (1 - wp (compile C) \<lbrakk>b\<rbrakk> \<sigma>)" (is "?A = ?B")
  proof (cases "wp (compile C) \<lbrakk>b\<rbrakk> \<sigma> < 1")
    case False
    with wp_le1 have is1: "wp (compile C) \<lbrakk>b\<rbrakk> \<sigma> = 1"
        by (metis lift2_def linear not_one_le_zero order.not_eq_order_implies_strict)
    then show "?A = ?B" by(subst lfp_linear_inf) (auto simp: add_pos_nonneg )
  qed (simp add: lfp_linear)

  finally have l: "lfp (\<lambda>W s. ?g (?f W) s) \<sigma> = (1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) \<sigma>)
                      / (1 - wp (compile C) \<lbrakk>b\<rbrakk> \<sigma>)"
    by auto

  show "ert (compile (While b C)) f \<sigma> =  1 + (if b \<sigma> then (1 + ert (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) \<sigma>)
                                                               /  (1- (wp (compile C) \<lbrakk>b\<rbrakk> \<sigma>))
                                                      else f \<sigma>)"
    apply(simp) unfolding eq eq2   apply auto
     apply(subst l) unfolding lift2_def  by auto
qed

section "New Prove Rule for non-deterministic"

lemma
  decompose_wpert_awp: \<comment> \<open>generalization of @{thm decompose_wpert} to angelic weakest preexpectation.\<close>
  " ert (compile C) (f+g) \<le>  ert (compile C) f + awp (compile C) g"
proof (induct C arbitrary: f g)
  case Skip
  then show ?case by (auto simp: nn_integral_add ac_simps)
next
  case (Assign x1 x2)
  then show ?case by (auto simp: nn_integral_add ac_simps)
next
  case (Seq C1 C2)
  have "ert (compile (C1;; C2)) (f+g) = ert (compile C1) (ert (compile C2) (f+g))" by auto
  also have "\<dots> \<le> ert (compile C1) (ert (compile C2) f + awp (compile C2) g)" by(intro monoD[OF mono_ert] Seq(2))
  also have "\<dots> \<le> ert (compile C1) (ert (compile C2) f) + awp (compile C1) (awp (compile C2) g)"
    by (intro monoD[OF mono_ert] Seq(1))
  also have "\<dots> = ert (compile (C1;; C2)) f + awp (compile (C1;; C2)) g" by auto
  finally show ?case .
next
  case (Par C1 C2)
  thm sup.mono
  have "ert (compile C1) (f + g) \<squnion> ert (compile C2) (f + g) \<le> (ert (compile C1) f + awp (compile C1) g) \<squnion> (ert (compile C2) f + awp (compile C2) g)"
    by (intro sup.mono Par)
  also have "\<dots> \<le> (ert (compile C1) f \<squnion> ert (compile C2) f) + (awp (compile C1) g \<squnion> awp (compile C2) g)"
    by (intro sup_least add_mono) auto
  finally show ?case
    by (simp del: plus_fun_apply sup_apply)
next
  case (If x1 C1 C2) then show ?case
    by (auto simp: le_fun_def ac_simps intro!: add_increasing[of 1 _ _])
next
  case (While b C)

  let ?P = "\<lambda>F W x. 1 + (if b x then ert (compile C) W x else F x)"
  let ?P' = "\<lambda>F W x. (if b x then awp (compile C) W x else F x)"
  have *: "\<And>F. mono (?P F)"
    by (auto simp: mono_def le_fun_def intro!: add_mono mono_ert[THEN monoD, THEN le_funD])
  have **: "\<And>F. mono (?P' F)"
    by (auto simp: mono_def le_fun_def intro!: add_mono mono_awp[THEN monoD, THEN le_funD])

  have "?P (\<lambda>x. f x + g x) (lfp (?P f) + lfp (?P' g)) \<le> ?P f (lfp (?P f)) + ?P' g (lfp (?P' g))"
    using While
    by (simp add: le_fun_def plus_fun_def)
  also have "\<dots> = lfp (?P f) + lfp (?P' g)"
    unfolding lfp_unfold[OF *, symmetric] lfp_unfold[OF **, symmetric] ..
  finally show ?case
    by (clarsimp intro!: lfp_lowerbound simp add: plus_fun_def cong: if_cong)

qed

corollary decompose_ert_awp: "ert (compile C) (f+g) s \<le>  ert (compile C) f s + awp (compile C) g s"
  using decompose_wpert_awp by (simp add: le_fun_def)

corollary decompose_ert_awp0: "ert (compile C) f \<le> ert (compile C) 0 + awp (compile C) f"
  using decompose_wpert_awp[where f=0 and g=f] by auto

lemma "Vars (ert (compile C) f) \<subseteq> Vars (ert (compile C) 0) \<union> Vars f"
  oops

(* counter example for monotonicity of awp *)

lemma "Vars f \<subseteq> Vars g \<Longrightarrow> Vars (awp (compile C) f) \<subseteq> Vars (awp (compile C) g)"
  oops

notepad begin
   define f :: exp where "f = (%s.   (1 - s ''y''))"
  define g :: exp where "g = (%s.   s ''y'')"
  define C :: spgcl where "C = Par (Assign ''y'' (\<lambda>s. return_pmf (1- s ''b''))) (Assign ''y'' (\<lambda>s. return_pmf (1)))"

  have f: "Vars f = {''y''}" apply (auto simp: Vars_def f_def)
    apply(rule exI[where x=1])
    apply(rule exI[where x=0])  by (auto )

  have g: "Vars g = {''y''}" by (auto simp: Vars_def g_def)

  have af: "Vars (awp (compile C) f) = {''b''}" apply(auto simp: C_def Vars_def f_def)
    apply(rule exI[where x="1"])
    apply(rule exI[where x=0])   apply (auto simp: zero_ereal_def[symmetric] one_ereal_def[symmetric] one_ennreal_def[symmetric])
    by (metis le_sup_iff not_one_le_zero order_refl)

  have k: "\<And>v. of_nat (Suc 0 - v) \<le> (1::ennreal)"
    by (simp add: ennreal_of_nat_eq_real_of_nat)

  have ag: "Vars (awp (compile C) g) = {}" apply(auto simp: C_def Vars_def g_def)
    subgoal for v v' using k[of v] k[of v']
      by (simp add: sup.absorb2)
    done

  from f g af ag have "~(Vars f \<subseteq> Vars g \<longrightarrow> Vars (awp (compile C) f) \<subseteq> Vars (awp (compile C) g))"
    by auto

  have i: "Vars (awp (compile C) 0) = {}" "Vars 0 = {}" by(auto simp: C_def Vars_def)

  {
    assume "\<And> F f g. Vars F \<subseteq> Vars f \<union> Vars g \<Longrightarrow> Vars (awp (compile C) F) \<subseteq> Vars (awp (compile C) f) \<union> Vars (awp (compile C) g)"

    from this[where F=f and f=0 and g=g]
    have "Vars f \<subseteq> Vars g \<longrightarrow> Vars (awp (compile C) f) \<subseteq> Vars (awp (compile C) g)"
      unfolding i by auto
  }
end

(* counter example for unaff plus *)

lemma unaff_awp: "unaffected (awp (compile C) f) C \<Longrightarrow> unaffected (awp (compile C) g) C \<Longrightarrow> unaffected (awp (compile C) (f+g)) C"
  oops

text \<open>This rule - while being intuitive - is unfortunately wrong! here is a counterexample:\<close>

notepad
begin

  define f :: exp where "f = (%s. (if s ''x'' = 3 then 0 else (if s ''x''=1 then 1000 else (1 - s ''y''))))"
  define g :: exp where "g = (%s. (if s ''x'' = 3 then 0 else (if s ''x''=1 then (1 - s ''y'') else 1000)))"

  have fg: "f+g = (%s. (if s ''x'' = 3 then 0 else 1000 + (1 - s ''y'')))"
    unfolding f_def g_def by auto

  define C :: spgcl where "C = Par (Assign ''x'' (\<lambda>s. return_pmf 3);; Assign ''y'' (\<lambda>s. return_pmf 3))
                                (Par (Assign ''x'' (\<lambda>s. return_pmf 1)) (Assign ''x'' (\<lambda>s. return_pmf 2)))"

  then have k2: "\<And>v. (1 - of_nat v)\<le> (1000::ennreal)"
    by (metis ennreal_diff_le_mono_left of_nat_1 of_nat_mono of_nat_numeral one_le_numeral)

  have m: "Mod C = {''x'', ''y''}" by(auto simp: C_def)

  have i: "Vars (awp (compile C) f) = {}"
    apply(auto simp: Vars_def C_def f_def)
    subgoal for v v' using k2[of v] k2[of v']
      by (simp add: sup.absorb2  sup.absorb1)
    done

  have ii: "Vars (awp (compile C) g) = {}"
    apply(auto simp: Vars_def C_def g_def)
    subgoal for v v' using k2[of v] k2[of v']
      by (simp add: sup.absorb2  sup.absorb1)
    done

  have iii: "Vars (awp (compile C) (f+g)) = {''y''}"
    apply(auto simp: Vars_def C_def fg)
    apply(rule exI[where x=0])
    apply(rule exI[where x=1])
    by (simp add: sup.absorb2)

   have "\<not>(unaffected (awp (compile C) f) C \<longrightarrow> unaffected (awp (compile C) g) C \<longrightarrow> unaffected (awp (compile C) (f+g)) C)"
     unfolding unaffected_def i ii iii m by auto
end

theorem
  fixes b :: "state \<Rightarrow> bool" and  f :: exp and C
  assumes (* "fiid C b f" and   ua: "unaffected (ert (compile C) 0) C" and *)
    awp1: "awp (compile C) 1 = 1" (* loop body terminates almost-surely *)
   and t: "\<And>x. unaffected x C \<Longrightarrow> unaffected (ert (compile C) (1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x)) C"
  shows prove_rule_awp: "ert (compile (While b C)) f s' \<le> 1 + (if b s' then (1 + ert (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) s')
                                                                          / (1- (awp (compile C) \<lbrakk>b\<rbrakk> s'))
                                                      else f s')"
proof -

  let ?f = "\<lambda>W. 1 + (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) + (\<lbrakk>b\<rbrakk>*W)"
  let ?g = "\<lambda>W. ert (compile C) W"
  let ?h = "%s' r. 1 + ert (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) s' + awp (compile C) \<lbrakk>b\<rbrakk> s' * r"

  have eq: "lfp (\<lambda>x. ?f (?g x)) = ?f (lfp (\<lambda>x. ?g (?f x)))"
    apply(rule lfp_rolling[where g="?f", symmetric])
     apply(auto simp: mono_def le_fun_def lift2_def)
    using mono_ert[unfolded mono_def]
    by (smt le_fun_def)

  have eq2: "(\<lambda>W x. 1 + (if b x then ert (compile C) W x else f x))
        =  (\<lambda>W. ?f (?g W))" unfolding lift2_def apply(rule) by auto
  have "ert (compile (While b C)) f = lfp (\<lambda>x. ?f (?g x))"
    by(simp add: eq2)

  {
    fix s' :: state
    assume x: "b s'"

    have *: "sup_continuous (\<lambda>x. ?g (?f x))" "sup_continuous (?h s)" for s :: state
      by (rule sup_continuous_compose[where f="ert (compile C)"]) (auto intro!: order_continuous_intros sup_continuous_ert)

    from * x have L: "lfp (\<lambda>W s. ?g (?f W) s) s' \<le> lfp (%r. ?h s' r) \<and> unaffected (lfp (\<lambda>W s. ?g (?f W) s)) C"
    proof(induction rule: lfp_parallel_induct)
      case bot
      then show ?case by (auto simp: unaffected_def Vars_def)
    next
      case (step x y)
      then have un_x[simp]: " unaffected x C" by simp

      { fix s'
        have "ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))
              \<le> awp (compile C) 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + awp (compile C) (\<lbrakk>b\<rbrakk> * x)"
          (is "?A \<le> ?B")
        proof -
          have reorder: "(1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x) = ((\<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x) + 1)" by auto
          have "?A = ert (compile C) ((\<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x) + 1)" by (simp add: reorder)
          also have "\<dots> \<le> ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x) + awp (compile C) 1"
            by (auto simp: decompose_wpert_awp)
          also have "\<dots> \<le> ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f)  + awp (compile C) (\<lbrakk>b\<rbrakk> * x) + awp (compile C) 1"
            using decompose_wpert_awp add_right_mono by blast
          finally show "?A \<le> ?B" by (simp add: ac_simps)
        qed
      } note decompose=this

      have A: "ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))
          \<le> awp (compile C) 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + awp (compile C) (\<lbrakk>b\<rbrakk> * x)"
        apply(rule decompose) done
      also have "\<dots> = 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + awp (compile C) (\<lbrakk>b\<rbrakk>) * x"
        by (auto simp: awp1 scale_unaffected_awp_right)
      finally have A: "ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))
          \<le> 1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f)  + awp (compile C) (\<lbrakk>b\<rbrakk>)  * x " by simp

      have B: "ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) \<le> ert (compile C) 0 + awp (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f)"
        by (rule decompose_ert_awp0)

      have "unaffected 1 C"  unfolding unaffected_def Vars_def by auto

      {
        from un_x
        have 2: "unaffected (ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))) C"
          by(rule t)
        (*
        from assms have "unaffected (wp (compile C) \<lbrakk>b\<rbrakk>) C"
            "unaffected (wp (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f)) C" unfolding fiid_def by auto
        then have a1: "unaffected (awp (compile C) \<lbrakk>b\<rbrakk>) C"
           and a2: "unaffected (awp (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f)) C" sorry

        from step have "unaffected x C" by simp
        then have a1': "unaffected (awp (compile C) (\<lbrakk>b\<rbrakk> * x)) C"
          apply(subst scale_unaffected_awp_right) apply simp
          apply(intro unaffected_mult) apply(rule a1) .

        have a3: "unaffected (awp (compile C) 1) C"
          unfolding awp1 unaffected_def Vars_def by auto

        have l: "(0 + (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x))) = (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x))" by auto
        from unaff_ert[OF ua unaff_awp[OF a3 unaff_awp[OF a2 a1']]]
        have 2: "unaffected (ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))) C"
          by (simp add: ab_semigroup_add_class.add_ac(1))
        *)
      } note 2 = this

      show ?case apply(safe) subgoal using A[THEN le_funD, of s', simplified] step
          by (meson ennreal_add_left_cancel_le mult_left_mono order_trans zero_le)
          subgoal using 2 by auto
        done
    next
      case (cont X Y)
      then show ?case apply (auto simp: unaffected_def Vars_def SUP_image)
        apply (simp add: SUP_subset_mono)
        by (metis cont.IH unaffaccted_fun_upd)
    qed
  }
  then have "b s' \<Longrightarrow> lfp (\<lambda>W s. ?g (?f W) s) s' \<le> lfp (%r. ?h s' r)" by simp
  also have "\<dots> = (1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) s') / (1 - awp (compile C) \<lbrakk>b\<rbrakk> s')"  (is "?A = ?B")
  proof (cases "awp (compile C) \<lbrakk>b\<rbrakk> s' < 1")
    case False
    with awp_le1 have is1: "awp (compile C) \<lbrakk>b\<rbrakk> s' = 1"
        by (metis lift2_def linear not_one_le_zero order.not_eq_order_implies_strict)
    then show "?A = ?B" by(subst lfp_linear_inf) (auto simp: add_pos_nonneg )
  qed (simp add: lfp_linear)
  finally have l: "b s' \<Longrightarrow> lfp (\<lambda>W s. ?g (?f W) s) s' \<le> (1 + ert (compile C) (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) s')
                      / (1 - awp (compile C) \<lbrakk>b\<rbrakk> s')"
    by auto

  show "ert (compile (While b C)) f s' \<le>  1 + (if b s' then (1 + ert (compile C) (\<lbrakk>\<^bold>\<not>b\<rbrakk>*f) s')
                                                               /  (1- (awp (compile C) \<lbrakk>b\<rbrakk> s'))
                                                      else f s')"
    apply(simp) unfolding eq eq2   apply auto
     using l unfolding lift2_def  by auto
qed

(* with the preconditions of the deterministic case,
 one can always show the compound assumption ("t" in prove_rule_awp),
 thus, prove_rule also is a corollary of prove_rule_awp *)
lemma assumes "fiid C b f"
    and "unaffected (ert (compile C) 0) C"
    and det: "deter C"
    and "awp (compile C) 1 = 1"
    and "unaffected x C"
shows
      "unaffected (ert (compile C) (1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x)) C"
proof -
  from assms awp_is_wp_if_deter have wp1: "wp (compile C) 1 = 1" by simp

  show ii: "unaffected (ert (compile C) (1 + (\<lbrakk>\<^bold>\<not> b\<rbrakk> * f) + (\<lbrakk>b\<rbrakk> * x))) C"
    apply(rule deter_unaff_unroll) by fact+
qed

subsection "Example"

experiment
begin

definition "innerb (N::nat) = (WHILE (%s. s ''b'' \<noteq> 1) DO
        Par (Assign ''b'' (%s. return_pmf 1)) (
        Assign ''b'' (%s. map_pmf (\<lambda>b. if b then 0 else 1)
                         (bernoulli_pmf (real (s ''a'') / N)))))"

definition "coco N = Assign ''b'' (\<lambda>s. return_pmf (0)) ;; Assign ''a'' (\<lambda>s. return_pmf (1)) ;; innerb N"

lemma fixes N::nat
  assumes N: "N>1"
  shows "ert (compile (coco N)) f s \<le> 3 + ( (1 + (1 + f (s(''a'' := Suc 0,''b'' := 1)))) * N) / (N -1)"
proof -

  {
    fix f :: exp
    fix l::nat
    fix s :: state assume a: "s ''b'' = 0"  "s ''b'' = 0 \<or> s ''b''=1" "l<N" and b[simp]: "s ''a''=l"

    let ?S ="Par (Assign ''b'' (%s. return_pmf 1)) (
        Assign ''b'' (%s. map_pmf (\<lambda>b. if b then 0 else 1)
                         (bernoulli_pmf (real (s ''a'') / N))))"

    (* do not even need assumption unaffected x ?S *)
    have "\<And>f x b.  unaffected (ert (compile ?S) (1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x)) ?S"
      by (auto simp: Vars_def lift2_def unaffected_def)
(*
    let ?S ="Par (Assign ''b'' (%s. return_pmf 1)) (
        Assign ''b'' (%s. map_pmf (\<lambda>b. if b then s ''c'' else 1)
                         (bernoulli_pmf (real (s ''a'') / N))))"
    (* do not even need assumption unaffected x ?S *)
    have "\<And>f x b.  unaffected (ert (compile ?S) (1 + \<lbrakk>\<^bold>\<not> b\<rbrakk> * f + \<lbrakk>b\<rbrakk> * x)) ?S"
      apply (auto simp:   lift2_def unaffected_def)
      apply(drule Vars_supD) apply safe
       apply(drule Vars_plusD) apply safe apply(simp add: Vars_def)
      subgoal by (auto simp: Vars_def lift2_def unaffected_def)
      apply(drule Vars_plusD) apply safe  apply(simp add: Vars_def)
    proof (goal_cases)
      case (1 f x b)
      thm Vars_integralD
      then show ?case  sorry
    qed
      apply(drule Vars_integralD) apply safe  apply(simp add: Vars_def)
      sorry
*)
    {
      fix A :: ennreal assume "l<N"
      from N have "(1 - 1 / N)<1" by auto
      then have "A \<ge> (A * (1 - l / real N))" using \<open>l<N\<close>
        by (smt divide_nonneg_nonneg ennreal_le_1 mult.right_neutral mult_left_mono of_nat_0_le_iff zero_le)
      then have p: "A \<squnion> (A * (1 - real l / real N)) = A"
        using sup.absorb1 by blast
    } note 1=this

    have "\<And>A B::ennreal. (1 + A) \<squnion> (1 + B) = 1 + (A \<squnion> B)"
      by (simp add: sup_const_add_ennreal)

    have "(1 + (f (s(''b'' := Suc 0))) \<squnion> (1 + (f (s(''b'' := Suc 0))) * ennreal (1 - 1 / real N)))
          = (1 + (f (s(''b'' := Suc 0)))) \<squnion> ((1 + (f (s(''b'' := Suc 0))) * ennreal (1 - 1 / real N)))" by auto

    let ?S ="Par (Assign ''b'' (%s. return_pmf 1)) (
        Assign ''b'' (%s. map_pmf (\<lambda>b. if b then 0 else 1)
                         (bernoulli_pmf (real (s ''a'') / N))))"
    let ?b = "(%s. s ''b'' \<noteq> 1)"
    have "ert (compile (innerb N)) f s \<le> 1 + (if ?b s then (1 + ert (compile ?S) (\<lbrakk>\<^bold>\<not>?b\<rbrakk>*f) s)
                                                                          / (1- (awp (compile ?S) \<lbrakk>?b\<rbrakk> s))
                                                      else f s)"
      unfolding innerb_def
      apply(rule prove_rule_awp)
      subgoal by (auto 4 3)
      subgoal (* the hardest goal ? *)
         (* apply (auto dest!:  simp: unaffected_def lift2_def)
        apply(drule Vars_supD)
        apply safe subgoal apply(drule Vars_plusD) apply safe apply(simp add: Vars_def)
          by (auto simp: Vars_def)
        apply(drule Vars_plusD)
        apply safe
         apply(simp add: Vars_def)
          *)
        by (auto simp: Vars_def lift2_def unaffected_def) (* I'm impressed by auto here *)
     done
   also have "\<dots> = 1 + (1 + (1 + (f (s(''b'' := Suc 0))) \<squnion> (1 + (f (s(''b'' := Suc 0))) * ennreal (1 - l / real N)))) / (1 - ennreal (l / real N))"
     using a N by (auto simp: lift2_def sup.absorb2)
   also have "\<dots> = 1 + (1 + (1 + f (s(''b'' := Suc 0)))) / (1 - ennreal (l / real N))"
     apply (simp only: sup_const_add_ennreal ) using a by(simp only: 1)
    finally
    have "ert (compile (innerb N)) f s \<le> 1 + (1 + (1 + f (s(''b'' := 1)))) / (1 - ennreal (l / real N))" by simp
  } note k=this

  from N have *: "\<And>l. 1 - real l / real N = (real N - l) / real N"
    by(simp add: diff_divide_distrib)
  have l: "(2::ennreal) = ennreal 2" by auto
  { fix A :: ennreal and l assume l: "l<N"
    have i: "1 / (1 - ennreal (real l / real N)) = N / (N-l)"
      using N using l apply(auto simp del: ennreal_1 simp add: ennreal_minus ennreal_1[symmetric] divide_ennreal)
      unfolding * by auto
    have "A / (1 - ennreal (real l / real N)) = A * (1 / (1 - ennreal (real l / real N)))"
      by (simp add: divide_ennreal_def)
    also have "\<dots> = A * (N / (N-l))" unfolding i by auto
    also have "\<dots>=  (A * N) / (N - l)"
      by (metis l divide_ennreal ennreal_of_nat_eq_real_of_nat ennreal_times_divide of_nat_0_le_iff of_nat_0_less_iff zero_less_diff)
    finally have eq: "A / (1 - ennreal (l / real N))
        =  (A * N) / (N - l)" .
  } note pf=this

  { fix l assume l: "l<N"
        have "ert (compile (innerb N)) f (s(''b'' := 0, ''a'' := l))
        \<le> 1 + (1 + (1 + f ((s(''b'' := 0, ''a'' := l))(''b'' := 1)))) / (1 - ennreal (l / N))" apply(rule k)
          using l by auto
      also have "\<dots> = 1 + (1 + (1 + f (s(''a'' := l, ''b'' := 1)))) * of_nat N / of_nat (N - l)" apply(subst pf)
       using l by auto
      finally have
      "ert (compile (innerb N)) f (s(''b'' := 0, ''a'' := l)) \<le> 1 + ( (1 + (1 + f (s(''a'' := l,''b'' := 1)))) * N) / (N -l)"
        .
    } note i=this

  show ?thesis unfolding coco_def apply auto
    using i[of 1] N apply auto
    by (metis (no_types, lifting) One_nat_def Suc_numeral add_numeral_left ennreal_add_left_cancel_le numeral_3_eq_3 numeral_One numeral_eq_iff)
qed

end

end