\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
\<^marker>\<open>contributor "Christoph Matheja"\<close>
\<^marker>\<open>contributor "Kevin Batz"\<close>
chapter \<open>Quantitative Separating Connectives\<close>
theory Quantitative_Separation_Connectives
  imports
    "Separation_Algebra.Separation_Algebra" "HOL-Library.Extended_Nat"
    "HOL-Library.Extended_Nonnegative_Real"
    QSL_Misc
begin

paragraph \<open>Summary\<close>

text \<open>In this theory we introduce the quantitative separating connectives for an arbitrary
    separation algebra and an measurement quantale.

    We define the quantitative separating conjunction, and magic wand.
    Then we prove adjointness of that the operators

    We follow the Paper by Batz et al.  @{cite batzPOPL19}.
  \<close>

term "class.complete_lattice"

subsection \<open>The Locale quant_sep_con\<close>

locale comm_quantale =  complete_lattice Inf Sup inf le less sup bot top
  + comm_monoid oper neutr
  for   Inf :: "'b set \<Rightarrow> 'b" ("\<Sqinter>_" [900] 900)
    and Sup ("\<Squnion>_" [900] 900)
    and inf
    and le (infix "\<le>" 50) and  less (infix "<" 50)
    and sup bot top
    and oper :: "'b  \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>*" 70)
    and neutr :: "'b" ("\<^bold>1") +
  assumes
    Sup_mult_left_distrib: "\<And>c A. c \<^bold>* Sup A = Sup (((\<^bold>*) c) ` A)"
begin

lemma mult_bot: "\<And>x. x \<^bold>* bot = bot"
  using Sup_mult_left_distrib[where A="{}"] by simp

lemma Sup_mult_right_distrib: "Sup I \<^bold>* c = Sup ((\<lambda>i. i \<^bold>* c) ` I)"
  by (auto simp add: commute Sup_mult_left_distrib)

lemma oper_left_mono: "(a::'b) \<le> b \<Longrightarrow> c \<^bold>* a \<le> c \<^bold>* b"
  using Sup_mult_left_distrib[where A="{a,b}" and c=c]
  by (simp add: sup.absorb_iff2)

lemma oper_right_mono: "\<And>a b c. a \<le> b \<Longrightarrow> a \<^bold>* c \<le> b \<^bold>* c"
  using oper_left_mono by (auto simp add: commute)

lemma oper_mono: "\<And>a b c d. a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a \<^bold>* c \<le> b \<^bold>* d"
  apply (erule oper_right_mono [THEN order_trans])
  by (erule oper_left_mono)

(* conjecture: there is a Galois Connection *)
lemma "\<exists>f. (\<forall>A B C. (A \<le> (f C) B) \<longleftrightarrow> ((\<^bold>*) C) A \<le> B)"
  oops

  text \<open>residual\<close>

definition residual where
  "residual x z = Sup {y. x \<^bold>* y \<le> z}"

lemma residual_imp: "x \<^bold>* y \<le> z \<Longrightarrow> y \<le> residual x z"
  unfolding residual_def
  apply(rule Sup_upper) by simp

lemma residual_imp': "y \<le> residual x z \<Longrightarrow> x \<^bold>* y \<le> z"
proof -
  assume "y \<le> residual x z"
  then have "x \<^bold>* y \<le> x \<^bold>* residual x z" by(rule oper_left_mono)
  also have "\<dots> =  x \<^bold>* \<Squnion>{y. x \<^bold>* y \<le> z}" unfolding residual_def by simp
  also have "\<dots> = \<Squnion>{x  \<^bold>* y | y . x \<^bold>* y \<le> z}" apply(subst Sup_mult_left_distrib)
    apply(rule arg_cong[where f=Sup]) by auto
  also have "\<dots> \<le> \<Squnion>{k | k . k \<le> z}" apply(rule Sup_mono) by auto
  also have "\<dots> \<le> z" apply(rule Sup_least) by auto
  finally show ?thesis .
qed

lemma residual_adjoint: "x \<^bold>* y \<le> z \<longleftrightarrow> y \<le> residual x z"
  using residual_imp residual_imp' by blast

(* indeed :) *)
lemma "\<exists>f. (\<forall>A B C. (A \<le> (f C) B) \<longleftrightarrow> ((\<^bold>*) C) A \<le> B)"
  apply(rule exI[where x=residual])
  using residual_adjoint by simp

end

locale quant_sep_con =  comm_quantale Inf Sup inf le less sup bot top  oper neutr
  for   Inf :: "'b set \<Rightarrow> 'b" ("\<Sqinter>_" [900] 900)
    and Sup ("\<Squnion>_" [900] 900)
    and inf
    and le (infix "\<le>" 50) and  less (infix "<" 50)
    and sup bot top
    and oper :: "'b  \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>*" 70)
    and neutr :: "'b" ("\<^bold>1") +
  fixes
    divide :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>div" 70)
  assumes
    \<comment>\<open>Facts about div\<close>
    divide_neutral: "\<And>x::'b. x \<^bold>div \<^bold>1 = x"   (* maybe \<^bold>\<le> suffices *)
    and divide_right_mono_general: "\<And>a b c. a \<le> b \<Longrightarrow> a \<^bold>div c \<le> b \<^bold>div c"
    and divide_right_antimono_general: "\<And>a b c. c \<le> b \<Longrightarrow> a \<^bold>div b \<le> a \<^bold>div c"
    \<comment> \<open>oper and divide are "adjoint" = The essence of equation 79\<close>
    and div_mult_adjoint:
    "\<And>A B C :: 'b.  \<lbrakk>(bot < C \<or> bot < B ) ; (C < top \<or> B < top) \<rbrakk> \<Longrightarrow> (A \<le> B \<^bold>div C) \<longleftrightarrow> A \<^bold>* C \<le> B"
    \<comment> \<open>bot is not neutral\<close>
    and bot_not_neutral: "bot < \<^bold>1"
begin

subsection \<open>stuff about complete lattices:\<close>

lemma nn: "(\<not> x < (top)) = (x = top)"
  using top.not_eq_extremum by blast

lemma nn_bot: "(\<not> bot <  x) = (x = bot)"
  using bot.not_eq_extremum by blast

lemma botnottop: "bot \<noteq> top"
  using bot_not_neutral by auto

lemma gt_botI: "\<not> a \<le> bot \<Longrightarrow> bot < a"
  using local.bot_less by blast

lemma lt_topI: "\<not> e \<le> A \<Longrightarrow>  A < top"
  using local.top.not_eq_extremum local.top_greatest by blast

lemma le_sideconditions:
  fixes a b c :: 'b
  shows "((bot < a \<or> bot < b) \<and> (a < top \<or> b < top) \<longrightarrow> a \<le> b) \<longleftrightarrow> (a \<le> b)"
  by (auto simp: nn nn_bot mult_bot botnottop intro: gt_botI)

lemma l_Sup_cong: "\<And>S S'. S=S' \<Longrightarrow> Sup S = Sup S'"
  by simp

abbreviation SUPR :: "'c set \<Rightarrow>('c \<Rightarrow> 'b) \<Rightarrow> 'b"
  where "SUPR A f \<equiv> \<Squnion>(f ` A)"

abbreviation INFI :: "'c set \<Rightarrow>('c \<Rightarrow> 'b) \<Rightarrow> 'b"
  where "INFI A f \<equiv> \<Sqinter>(f ` A)"

lemma INF_mono_strong: "(\<And>m. m \<in> B \<Longrightarrow> g m < top \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> (INFI A f) \<le> (INFI B g)"
  using Inf_mono_strong [of "g ` B" "f ` A"] by auto

lemma SUP_UNION: "(SUPR (\<Union>y\<in>A. g y) (\<lambda>x. f x)) = (SUPR A (\<lambda>y. SUPR (g y) (\<lambda>x. f x )))"
  apply (rule antisym)
  by  (blast intro: SUP_least SUP_upper2)+

lemma SUP_times_distrib2_general:
  fixes g :: "_\<Rightarrow>_\<Rightarrow>'b"
  shows "SUPR A (\<lambda>(x,y). f x y \<^bold>* g x y) \<le>
            SUPR A (\<lambda>(x,y). f x y) \<^bold>* SUPR A (\<lambda>(x,y). g x y)"
  by (auto intro!: SUP_least intro: SUP_upper2  oper_mono)

lemma SUP_mult_left_distrib: "\<And>c f. c \<^bold>* SUPR I (\<lambda>i. f i) = SUPR I (\<lambda>i. c \<^bold>* f i)"
  by (simp add: image_image Sup_mult_left_distrib)

lemma SUP_mult_right_distrib: "SUPR I (\<lambda>i. f i) \<^bold>* c = SUPR I (\<lambda>i. f i \<^bold>* c)"
  by (simp add: image_image Sup_mult_right_distrib)

lemma sup_times_distrib: "(a::'b) \<^bold>* sup b c = sup (a\<^bold>*b) (a\<^bold>*c)"
  using Sup_mult_left_distrib[where A="{b,c}"] by simp

subsection \<open>Facts derived from @{thm div_mult_adjoint}}:\<close>

lemma top_divide:  "\<And>x. x < top \<Longrightarrow>  top \<^bold>div x = top"
  using div_mult_adjoint
  by (metis local.bot_less local.top_greatest local.top_unique)

lemma divide_bot: "\<And>x::'b. bot < x \<Longrightarrow> x \<^bold>div bot = top"
  using div_mult_adjoint
  by (metis bot.extremum mult_bot le_less_trans nn top.extremum_unique)

context
  assumes "SORT_CONSTRAINT ('a::{sep_algebra})"
begin

subsection \<open>Quantitative Separating Conjunction\<close>

definition
  sep_conj_q  (infixr "**q" 35)
  where
  "P **q Q \<equiv> \<lambda>h. Sup { P x \<^bold>* Q y | x y. h=x+y \<and> x ## y}"

lemma sep_conj_q_alt :
  "(P **q Q) = (\<lambda>h. SUPR {(x,y). h=x+y \<and> x ## y} (\<lambda>(x,y). P x \<^bold>* Q y))"
  unfolding  sep_conj_q_def
  apply(rule ext)  by (auto intro!: l_Sup_cong)

lemma sep_conj_q_SUP:
  "(P **q Q) = (\<lambda>h. (SUPR {(x,y)| x y. h=x+y \<and> x ## y} (\<lambda>i. (\<lambda>(x,y). P x \<^bold>* Q y) i)))"
  unfolding  sep_conj_q_def
  apply(rule ext)  by (auto intro!: l_Sup_cong)

subsection \<open>Quantitative Separating Implication - Magic Wand\<close>

definition
  sep_impl_qq  :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a  \<Rightarrow> 'b ) \<Rightarrow> 'a \<Rightarrow> 'b"   (infixr "-*qq" 35)
  where
  "P -*qq Q \<equiv> \<lambda>h. INFI { h'. h ## h' \<and> (bot < P h' \<or> bot < Q (h+h') )
                                \<and> (P h' < top \<or> Q (h+h') < top)}
                               (\<lambda>h'. (Q (h + h')) \<^bold>div (P h'))"

subsection \<open>Embedding of SL into QSL\<close>

definition emb  where "emb P = (\<lambda>h. if P h then \<^bold>1 else bot)"

lemma emb_range: "emb P x \<in> {bot,\<^bold>1}" unfolding emb_def by auto

lemma emb_squared: "emb P x = emb P x \<^bold>* emb P x"
  apply (cases "emb P x = bot") using emb_range apply (auto simp: mult_bot) by fastforce

lemma emb_1: "emb P h = \<^bold>1 \<longleftrightarrow> P h"
  apply (auto simp: emb_def) using bot_not_neutral by blast

definition sep_empty_q :: "'a \<Rightarrow> 'b"  where
  "sep_empty_q \<equiv> emb (\<lambda>h. h = 0)"

text \<open>The restricted wand with an predicate in the first component:\<close>

abbreviation sep_impl_q (infixr "-*q" 35) where   "(P -*q Q) \<equiv> (emb P -*qq Q)"

lemma sep_impl_q_alt_general:
  fixes  Q :: "'a \<Rightarrow> 'b"
  shows
    "inf \<^bold>1 ((P -*q Q) h) = inf \<^bold>1 (INFI  { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))"
proof -
  have T: "{h'. h ## h' \<and> ((bot::'b) < emb P h' \<or> (bot::'b) < Q (h + h'))
                       \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
      = {h'. h ## h' \<and>  (bot::'b) < emb P h' \<and> (emb P h' < (top::'b) \<or> Q (h + h') < top)}
       \<union>  {h'. h ## h' \<and>(bot::'b) = emb P h' \<and> (bot::'b) < Q (h + h')
                       \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}"
    using bot.not_eq_extremum by fastforce

  let ?A = "{h'. h ## h' \<and> Q (h + h') < top \<and> P h'}"
  let ?B = "{h'. h ## h' \<and> (bot::'b) < emb P h' \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}"
  have AB: "?A \<subseteq> ?B"  by (auto simp: emb_def bot_not_neutral)

  have KK: "\<^bold>1 \<le> (INFI (?B-?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))"
    by(auto simp: le_Inf_iff emb_def divide_neutral intro: lt_topI)

  have 1: "inf \<^bold>1 (INFI ?B (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
      = inf \<^bold>1 (INFI ?A (\<lambda>x. Q (h + x)))"
  proof -
    have B_decompose: "?B = (?B - ?A) \<union> (?A)"  using AB by blast
    have i: "(INFI ?A (\<lambda>h'. Q (h + h') \<^bold>div emb P h')) = (INFI ?A (\<lambda>h'.  Q (h + h')))"
       by (auto simp: emb_def divide_neutral)

    have ii: "inf \<^bold>1 (INFI (?B-?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h')) = \<^bold>1"
      using KK by (auto intro: antisym)

    have "(INFI (?B) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
            = inf (INFI (?B - ?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
                   (INFI (?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))"
      apply(subst B_decompose) by(rule INF_union)
    also have "\<dots> = inf (INFI (?B - ?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
                          (INFI (?A) (\<lambda>h'.  Q (h + h')))"
      unfolding i by simp
    finally
    have iii: "(INFI (?B) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
           = inf (INFI (?B - ?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h')) (INFI (?A) (\<lambda>h'.  Q (h + h')))" .

    have "inf \<^bold>1 (INFI (?B) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
              = inf \<^bold>1 (inf (INFI (?B-?A) (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
                            (INFI (?A) (\<lambda>h'.  Q (h + h'))))"
      unfolding iii by simp
    also have "\<dots> = inf (inf \<^bold>1 (INFI (?B-?A) (\<lambda>h'. Q (h+h') \<^bold>div emb P h')))
                        (INFI ?A (\<lambda>h'. Q (h+h')))"
      by(simp add: inf.assoc)
    also have "\<dots> = inf \<^bold>1 (INFI (?A) (\<lambda>h'.  Q (h + h')))"
      unfolding ii by simp
    finally show ?thesis .
  qed

  have "(\<exists>h'. h ## h' \<and> (bot::'b) < top \<and> Q (h + h') < top  \<and> P h')
             \<Longrightarrow> (INFI { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h'))) < top"
    apply safe subgoal for h'
      apply(rule order.strict_trans1)
       apply(rule INF_lower[where i=h']) by auto
    done

  have "~(\<exists>h'. h ## h' \<and> (bot::'b) < top \<and> Q (h + h') < top  \<and> P h')
           \<Longrightarrow> (INFI { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h'))) = top"
    apply auto
    by (metis Inf_UNIV Inf_top_conv(2) UNIV_I top.not_eq_extremum)

  have 2: "(INFI {h'. h ## h' \<and> (bot::'b) = emb P h' \<and> (bot::'b) < Q (h + h')
                   \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
                 (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
      = top"
    by (simp_all add: divide_bot)

  have F: "{ h'. h ## h' \<and> P h'} = { h'. h ## h' \<and> P h' \<and> Q (h + h') = top}
                                     \<union> { h'. h ## h' \<and> P h' \<and> Q (h + h') < top}"
    using top.not_eq_extremum by blast

  have 3: "(INFI {h'. h ## h' \<and> P h' \<and> Q (h + h') = top} (\<lambda>h'. Q (h + h'))) = top"
    by auto

  have "inf \<^bold>1 ((P -*q Q) h)
     = inf \<^bold>1 (inf (INFI {h'. h ## h' \<and> (bot::'b) < emb P h'
                               \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
                          (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
                   (INFI {h'. h ## h' \<and> (bot::'b) = emb P h'\<and> (bot::'b) < Q (h + h')
                               \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
                          (\<lambda>h'. Q (h + h') \<^bold>div emb P h')))"
    unfolding sep_impl_qq_def T INF_union
    by simp
  also have "\<dots> =  inf \<^bold>1 (inf (INFI {h'. h ## h' \<and> (bot::'b) < emb P h'
                               \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
                          (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
     top)"
    unfolding 2 by simp
  also have "\<dots> = inf \<^bold>1 (INFI {h'. h ## h' \<and> (bot::'b) < emb P h'
                              \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
                           (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))"
    by simp
  also have "\<dots>  = inf \<^bold>1 (INFI {h'.  h ## h'  \<and> Q (h + h') < top \<and> P h'} (\<lambda>x. Q (h + x)))"
    unfolding 1 by simp
  also have "\<dots> = inf \<^bold>1 ( INFI { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))"
    unfolding F INF_union 3
    apply(rule arg_cong[where f="\<lambda>x. inf \<^bold>1 x"])
    by (auto intro: INF_cong)
  finally show "inf \<^bold>1 ((P -*q Q) h) =  inf \<^bold>1 (INFI {h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))" .
qed

lemma sep_impl_q_alt_general':
  fixes  Q :: "'a \<Rightarrow> 'b"
  assumes "\<^bold>1 = top"
  shows
  "((P -*q Q) h) = (INFI { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))"
  using assms sep_impl_q_alt_general by simp

subsubsection \<open>Conservativity of QSL as an assertion language\<close>

lemma Sup_zeroone: "P \<subseteq> {bot,\<^bold>1} \<Longrightarrow> Sup P \<in> {bot,\<^bold>1}"
proof -
  assume " P \<subseteq> {bot,\<^bold>1}"
  then consider "P = {}" | "P={bot}" | "P={\<^bold>1}" | "P={bot,\<^bold>1}" by auto
  then show ?thesis apply(cases)
    by auto
qed

lemma sep_conj_q_range: "((emb P) **q (emb Q)) h \<in> {bot,\<^bold>1}"
  unfolding sep_conj_q_def
  apply(rule Sup_zeroone)
  apply (auto simp: emb_def) using   divide_neutral divide_bot mult_bot      by auto

lemma Inf_zeroone: "P \<noteq> {} \<Longrightarrow> P \<subseteq> {bot,\<^bold>1} \<Longrightarrow> Inf P \<in> {bot,\<^bold>1}"
proof -
  assume "P \<noteq> {}" " P \<subseteq> {bot,\<^bold>1}"
  then consider  "P={bot}" | "P={\<^bold>1}" | "P={bot,\<^bold>1}" by auto
  then show ?thesis apply(cases)
    by auto
qed

lemma Inf_zeroonetop: " P \<subseteq> {bot,\<^bold>1,top} \<Longrightarrow> Inf P \<in> {bot,\<^bold>1,top}"
  by (smt insertI2 insert_Diff insert_absorb2 insert_commute insert_not_empty
        local.Inf_insert local.Inf_lower local.ccInf_empty local.inf_top.right_neutral
        local.le_bot singleton_insert_inj_eq' subset_antisym subset_insert_iff)

(*
lemma Inf_zeroonetop: "P \<subseteq> {bot,\<^bold>1,top} \<Longrightarrow> Inf P \<in> {bot,\<^bold>1,top}"
proof -
  assume " P \<subseteq> {bot,\<^bold>1,top}"
  then consider "P = {}"
    | "P={bot}" | "P={\<^bold>1}" | "P={top}"
    | "P={bot,\<^bold>1}" | "P={bot,top}" | "P={top,\<^bold>1}"
    | "P={bot,\<^bold>1,top}" by auto
  then show ?thesis apply(cases)
    by auto
qed  *)

lemma sep_conj_q_leq1: "((emb P) **q (emb Q)) h \<le> \<^bold>1"
  using sep_conj_q_range[of P Q h] by auto

lemma emb_not_bot: "bot < emb P h \<longleftrightarrow> emb P h = \<^bold>1"
  using bot_not_neutral by (auto simp: emb_def)

lemma emb_not_bot2: "bot \<noteq> emb P h \<longleftrightarrow> emb P h = \<^bold>1"
    "emb P h \<noteq> bot \<longleftrightarrow> emb P h = \<^bold>1"
  using bot_not_neutral by (auto simp: emb_def)

lemma sep_impl_q_rangezeroonetop: "((P -*q (emb Q)) h) \<in> {bot,\<^bold>1,top}"
  unfolding sep_impl_qq_def
    apply(rule Inf_zeroonetop)
  subgoal apply (auto simp: emb_not_bot emb_not_bot2 divide_neutral  )
    apply(auto simp: emb_def divide_neutral divide_bot bot_not_neutral)
    done
  done

lemma inf_1_cuts: "a \<in> {bot, \<^bold>1, top} \<Longrightarrow> inf \<^bold>1 a \<in> {bot, \<^bold>1}"
proof -
  assume "a \<in> {bot, \<^bold>1, top}"
  then have "inf \<^bold>1 a \<in> { \<^bold>1, bot}"
    using inf_bot_right inf_idem inf_top_right by blast
  then show ?thesis
    using bot_ennreal by auto
qed

lemma sep_impl_q_range: "inf \<^bold>1 ((P -*q (emb Q)) h) \<in> {bot, \<^bold>1}"
  apply(rule inf_1_cuts) by(rule sep_impl_q_rangezeroonetop)

lemma quant_wand_conservative:
  fixes P :: "'a \<Rightarrow> bool"
  shows "(P  \<longrightarrow>* Q) h  \<longleftrightarrow> inf \<^bold>1 (((emb P) -*qq (emb Q)) h)  = \<^bold>1"
proof -
  (* rather ugly proof, DB's fault ;) *)
  fix h
  have " ((inf \<^bold>1 ((P -*q (emb Q)) h)) = \<^bold>1)
         \<longleftrightarrow> ((inf \<^bold>1 ((INFI {h'. h ## h' \<and> P h'} (\<lambda>h'. emb Q (h + h'))))) = \<^bold>1)"
    unfolding sep_impl_q_alt_general by simp
  also have "\<dots> \<longleftrightarrow> (\<forall>h'. h ## h' \<and> P h' \<longrightarrow> Q (h + h'))"
    apply(rule iffI)
    subgoal
      apply(cases "{h'. h ## h' \<and> P h'} = {}")
      subgoal by auto
      subgoal proof (safe, goal_cases)
        case (1 h' x)
        from 1(2-4) have "inf \<^bold>1 (INFI {h'. h ## h' \<and> P h'} (\<lambda>h'. emb Q (h + h'))) \<le> bot"
          apply(intro le_infI2)
          apply(intro INF_lower2[where i=h']) by (auto simp: emb_def)
        then show ?case using 1(1) bot_not_neutral by auto
      qed
      done
    subgoal
      by(auto simp add: emb_def INF_constant cong: INF_cong_simp  )
    done
  also have "\<dots> \<longleftrightarrow> (P  \<longrightarrow>* Q) h" unfolding sep_impl_def by auto
  finally show "(P  \<longrightarrow>* Q) h \<longleftrightarrow> inf \<^bold>1 ((P -*q (emb Q)) h) = \<^bold>1" by simp
qed

lemma quant_wand_conservative':
  fixes P :: "'a \<Rightarrow> bool"
  assumes "\<^bold>1 = top"
  shows "(P  \<longrightarrow>* Q) h  \<longleftrightarrow> (((emb P) -*qq (emb Q)) h)  = \<^bold>1"
  using assms quant_wand_conservative by simp

lemma quant_star_conservative:
  fixes P :: "'a \<Rightarrow> bool"
  shows "(P ** Q) h \<longleftrightarrow> ((emb P) **q (emb Q)) h = \<^bold>1"
proof -
  have "(P ** Q) h = (\<exists>xa y. xa ## y \<and> h = xa + y \<and> emb P xa = \<^bold>1 \<and> emb Q y = \<^bold>1)"
    unfolding sep_conj_def emb_1 by auto
  also have "\<dots> = (Sup { emb P x \<^bold>* emb Q y | x y. h=x+y \<and> x ## y} = \<^bold>1)"
    apply rule
    subgoal
      apply(rule antisym)
      subgoal apply(subst sep_conj_q_leq1[unfolded sep_conj_q_def] ) by simp
      subgoal apply(rule Sup_upper) by force
      done
    subgoal
    proof (rule ccontr, goal_cases)
      case 1
      from 1(2) have "\<And>x y. (x,y) \<in> {(x,y) | x y. h = x + y \<and> x ## y}
               \<Longrightarrow> emb P x \<^bold>* emb Q y = bot"
        by (auto simp: emb_def split: if_splits simp: mult_bot)
      then have "Sup {emb P x \<^bold>* emb Q y |x y. h = x + y \<and> x ## y} \<le>  bot"
          by (auto intro: Sup_least)
      with 1(1) show "False" using bot_not_neutral by simp
    qed
    done
  also have "\<dots> = (((emb P) **q (emb Q)) h = \<^bold>1)" unfolding sep_conj_q_def by simp
  finally show ?thesis .
qed

subsection \<open>Properties of Quantitative Separating Connectives\<close>

subsubsection \<open>Commutative monoid\<close>

lemma SUP_UNION_my: "(SUPR A (\<lambda>y. SUPR (g y) (\<lambda>x. f y x ))) = (SUPR (\<Union>y\<in>A. Pair y ` g y) (\<lambda>xy. f (fst xy) (snd xy)))"
  apply (rule antisym)
  subgoal
    apply(rule SUP_least)
    apply(rule SUP_least)
    subgoal for x y
      apply(rule SUP_upper2[where i="(x,y)"]) by auto
    done
  subgoal
    apply(rule SUP_least)
    apply auto subgoal for x y
    apply(rule SUP_upper2[where i=x]) apply simp
      apply(rule SUP_upper2[where i=y]) by auto
    done
  done

lemma pp: "(\<And>x. gg (g x) = x) \<Longrightarrow> SUPR S f = SUPR (g ` S) (f o gg)"
  by (simp add: image_image)

lemma star_assoc:
  fixes x y z :: "'a \<Rightarrow> 'b"
  shows  "(x **q (y **q z))  = ((x **q y) **q z) "
proof (rule ext)
  fix h
  have "(x **q (y **q z)) h
      = (SUPR {(x, y) |x y. h = x + y \<and> x ## y} (\<lambda> (xa, ya).
          x xa \<^bold>* (SUPR {(x, y) |x y. ya = x + y \<and> x ## y} (\<lambda> (x, ya). y x \<^bold>* z ya))))"
    unfolding sep_conj_q_SUP by auto
  also have "\<dots> = (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>xa.
                    case xa of (xa, ya) \<Rightarrow> SUPR {(x, y). ya = x + y \<and> x ## y} (\<lambda>i.
                          (case i of (h21, h22) \<Rightarrow> x xa \<^bold>* y h21 \<^bold>* z h22))))"
    by(simp add: SUP_mult_left_distrib prod.case_distrib assoc)
  also have "\<dots> = (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>xa.
                    SUPR {((fst xa),x, y)| x y . snd xa = x + y \<and> x ## y}
                        (\<lambda>i. (case i of (b, h21, h22) \<Rightarrow> x b \<^bold>* y h21 \<^bold>* z h22))))"
      by(force intro!: arg_cong[where f=Sup])
  also have "\<dots> = (SUPR {(h1, h2, h3). h = h1 + h2 + h3 \<and> h1 ## h2 + h3
                                           \<and> h1 ## h2 \<and> h1 ## h3 \<and> h3 ## h2 }
                    (\<lambda>xa. case xa of (h1, h2, h3) \<Rightarrow> x h1 \<^bold>* y h2 \<^bold>* z h3))"
    apply(subst SUP_UNION[symmetric])
    apply(rule SUP_cong)
    subgoal
      apply safe
      subgoal by (metis fstI sep_add_assoc sep_disj_addD1 sep_disj_addD2 sndI)
      by (auto simp: sep_add_ac dest: sep_disj_addD)
    subgoal by auto
    done
  also have "\<dots> = (SUPR {(x, y). h = x + y \<and> x ## y}
                    (\<lambda>xa. SUPR {(h1,h2,snd xa)| h1 h2. fst xa = h1 + h2 \<and> h1 ## h2}
                       (\<lambda>i. (case i of (h1, h2, h3) \<Rightarrow> x h1 \<^bold>* y h2 \<^bold>* z h3))))"
    apply(subst SUP_UNION[symmetric])
    apply(rule SUP_cong)
    subgoal
      by (auto simp: sep_add_ac dest: sep_disj_addD
               intro: sep_disj_addI1 sep_disj_addI3 sep_disj_commuteI )
    subgoal
      by auto
    done
  also have "\<dots> = (SUPR {(h12, h3). h = h12 + h3 \<and> h12 ## h3} (\<lambda>xa.
                    case xa of (h12,h3) \<Rightarrow> SUPR {(x, y). h12 = x+y \<and> x ## y}
                          (\<lambda>h12. (case h12 of (h1, h2) \<Rightarrow> (x h1 \<^bold>* y h2 \<^bold>* z h3)))))"
    apply(rule SUP_cong)
     apply simp
    apply safe
    apply(rule l_Sup_cong) by force
  also have "\<dots> = ((x **q y) **q z) h"
    unfolding sep_conj_q_SUP apply(auto simp: SUP_mult_right_distrib)
    apply(rule SUP_cong)
     apply simp
    apply safe
    apply(rule SUP_cong) by (auto simp: mult.assoc)
  finally show "(x **q (y **q z)) h  = ((x **q y) **q z) h " .
qed

lemma star_comm:
  fixes X Y :: "_ \<Rightarrow> 'b"
  shows  "(X **q Y) = (Y **q X)"
  unfolding sep_conj_q_SUP
  apply(rule ext)
  apply(rule l_Sup_cong)
  by (auto simp add: commute sep_add_ac)

lemma emp_neutral1:
  "(X **q sep_empty_q) = X"
  unfolding sep_conj_q_def sep_empty_q_def emb_def
  apply(rule ext)
  apply(rule antisym)
  subgoal
    by (auto intro!: Sup_least simp: mult_bot)
  subgoal
    by (auto intro: Sup_upper)
  done

lemma emp_neutral2 :
  "(sep_empty_q **q X) = X"
  by (simp add: star_comm emp_neutral1)

lemmas emp_neutral = emp_neutral1 emp_neutral2

lemma sep_conj_q_left_commute:
  fixes P Q R :: "'a \<Rightarrow> 'b"
  shows  "(P **q Q **q R) = (Q **q P **q R)"
  apply(subst star_assoc)
  apply(subst star_comm)
  apply(subst star_assoc) by simp

lemmas sep_conj_q_c = star_comm sep_conj_q_left_commute

subsubsection \<open>(Sub)distributivity Laws\<close>

abbreviation "fsup Q R \<equiv> (\<lambda>x. sup (Q x) (R x))"

lemma theorem_3_6_general1:
  fixes
      P :: "'a \<Rightarrow> 'b"
  shows
  "(P **q (fsup Q R)) = fsup (P **q Q) (P **q R)"
proof
  fix h
  have "(P **q (fsup Q R)) h = Sup {P x \<^bold>* fsup Q R y |x y. h = x + y \<and> x ## y}"
    unfolding sep_conj_q_def by simp
  also have "\<dots> = Sup { sup (P x \<^bold>* Q y) (P x \<^bold>* R y) |x y. h = x + y \<and> x ## y}"
    apply(subst sup_times_distrib)  by simp
  also have "\<dots> = (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>x. case x of (x,y) \<Rightarrow> sup (P x \<^bold>* Q y) (P x \<^bold>* R y)))"
    apply (rule arg_cong[where f=Sup]) by auto
  also have "\<dots> = (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>x. sup (P (fst x) \<^bold>* Q (snd x)) (P (fst x) \<^bold>* R (snd x))))"
    apply (rule arg_cong[where f=Sup])
    by (meson prod.case_eq_if)
  also have "\<dots> = sup (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>x. P (fst x) \<^bold>* Q (snd x)))
   (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>x. P (fst x) \<^bold>* R (snd x)))"
    apply(subst SUP_sup_distrib[symmetric]) ..
  also have "\<dots> = fsup (P **q Q) (P **q R) h"
    unfolding sep_conj_q_alt apply simp
    by (metis (mono_tags, lifting) SUP_cong prod.case_eq_if)
  finally show "(P **q fsup Q R) h = fsup (P **q Q) (P **q R) h " .
qed

lemma theorem_3_6_general3:
  fixes
      Q :: "_ \<Rightarrow> 'b"
  shows
  "( (emb \<phi>) **q (\<lambda>h. Q h \<^bold>* R h)) h \<le> ((emb \<phi>) **q Q) h \<^bold>* ((emb \<phi>) **q R) h"
  proof -
    have "( (emb \<phi>) **q (\<lambda>h. Q h \<^bold>* R h)) h  =  (SUPR {(h1, h2). h = h1 + h2 \<and> h1 ## h2} (\<lambda> (h1, h2). emb \<phi> h1 \<^bold>* (\<lambda>h. Q h \<^bold>* R h) h2))"
      unfolding sep_conj_q_alt by simp
    also have "... = (SUPR {(h1, h2). h = h1 + h2 \<and> h1 ## h2} (\<lambda>(h1, h2). emb \<phi> h1 \<^bold>* Q h2 \<^bold>* R h2))" apply (rule SUP_cong)
      by (auto simp: assoc)
    also have "... =   (SUPR {(h1, h2). h = h1 + h2 \<and> h1 ## h2} (\<lambda>(h1, h2). (emb \<phi> h1 \<^bold>* Q h2) \<^bold>* ( emb \<phi> h1  \<^bold>* R h2)))"
      apply (subst (1) emb_squared)
      by (simp add: ac_simps)
    also have "... \<le> (SUPR {(h1, h2). h = h1 + h2 \<and> h1 ## h2} (\<lambda>(h1, h2). (emb \<phi> h1  \<^bold>* Q h2)))
                 \<^bold>* (SUPR {(h1, h2). h = h1 + h2 \<and> h1 ## h2} (\<lambda>(h1, h2).  ( emb \<phi> h1  \<^bold>* R h2)))"
      by (rule SUP_times_distrib2_general)
    also have "... = ((emb \<phi>) **q Q) h \<^bold>* ((emb \<phi>) **q R) h"
      by (simp add: local.sep_conj_q_alt)
    finally show "( (emb \<phi>) **q (\<lambda>h. Q h \<^bold>* R h)) h \<le> ((emb \<phi>) **q Q) h \<^bold>* ((emb \<phi>) **q R) h".
  qed

lemma theorem_3_6:
  fixes
      Q :: "'a \<Rightarrow> 'b"
  shows
  "(P **q (fsup Q R)) = fsup (P **q Q) (P **q R)"
  "( (emb \<phi>) **q (\<lambda>h. Q h \<^bold>* R h)) h \<le> ((emb \<phi>) **q Q) h \<^bold>* ((emb \<phi>) **q R) h"
  using theorem_3_6_general1 theorem_3_6_general3 by auto

subsubsection \<open>Or\<close>

lemma emb_or: "emb (X or Y) = (fsup (emb X) (emb Y))"
  unfolding emb_def by auto

subsubsection \<open>monotonicity of @{term "(**q)"}\<close>

text \<open>theorem 3.7\<close>

lemma sep_conj_q_mono:
  fixes X X' :: "_ \<Rightarrow> 'b"
  shows
   "(\<And>x. X x \<le> X' x) \<Longrightarrow> (\<And>y. Y y  \<le> Y' y) \<Longrightarrow> (X **q Y) h \<le> (X' **q Y') h"
  by (force intro: le_funI SUP_mono simp add: sep_conj_q_alt oper_mono le_funD)

lemma sep_conj_q_right_mono:
  fixes P :: "_ \<Rightarrow> 'b"
  assumes P: "\<And>h. P h \<le> I h"
  shows "(P **q R) h \<le> (I **q R) h"
  using sep_conj_q_mono assms by blast

lemma sep_conj_q_left_mono:
  fixes P :: "_ \<Rightarrow> 'b"
  assumes P: "\<And>h. P h \<le> I h"
  shows "(P **q R) h \<le> (I **q R) h"
  using sep_conj_q_mono assms by blast

subsubsection \<open>monotonicity of @{term "(-*qq)"}\<close>

lemma sep_impl_q_left_mono:
  fixes P :: "_\<Rightarrow>'b"
  shows "(\<And>y. Y y \<le> Y' y) \<Longrightarrow> (P -*qq Y) h \<le> (P -*qq Y') h"
  unfolding sep_impl_qq_def
  apply(rule INF_mono_strong)
  subgoal for h'
    apply(rule bexI[where x=h'])
    subgoal by (auto intro!: divide_right_mono_general)
    subgoal using local.less_le_not_le local.top.not_eq_extremum divide_bot local.bot_less
      by (force intro!: divide_right_mono_general)
    done
  done

lemma sep_impl_q_left_mono':
  fixes P :: "_\<Rightarrow>'b"
  shows "(\<And>y. Y y \<le> Y' y) \<Longrightarrow> (P -*qq Y) h \<le> (P -*qq Y') h"
  using sep_impl_q_left_mono by blast

lemma ennreal_inverse_antimono:
  "(a::ennreal) \<le> b \<Longrightarrow> inverse b \<le> inverse a"
  apply(cases a; cases b; cases "a=0"; cases "b=0")
     apply simp_all
   apply(simp add: inverse_ennreal)
  using ennreal_neq_top top.extremum_uniqueI
  by (simp add: le_ennreal_iff)

lemma sep_impl_q_right_antimono:
  shows "(\<And>h. P' h \<le> P h) \<Longrightarrow> (P -*qq Y) h \<le> (P' -*qq Y) h"
  unfolding sep_impl_qq_def
  apply(rule INF_mono_strong)
  subgoal for   h'
    apply(rule bexI[where x=h'])
    by (auto intro!: divide_right_antimono_general  simp: nn top_divide local.less_le_trans )
  done

lemma sep_impl_q_mono:
  shows "(\<And>x. P' x \<le> P x) \<Longrightarrow> (\<And>x. Y x \<le> Y' x) \<Longrightarrow> (P -*qq Y) h  \<le> (P' -*qq Y') h"
  apply(rule order.trans)
  apply(rule sep_impl_q_left_mono[where Y'=Y']) apply simp
  apply(rule sep_impl_q_right_antimono) by simp

subsubsection \<open>adjointness of star and magicwand\<close>

text \<open>theorem 3.9\<close>

lemma adjoint_general:
  shows "(\<forall>h. (X **q P) h \<le> Y h) \<longleftrightarrow> (\<forall>h. X h \<le> (P -*qq Y) h)"
proof -
  (* side condition *)
  let ?sc = "\<lambda>a b. (bot < a \<or> bot < b ) \<and> (a < top \<or> b < top)"

  have le_mult_sc: "\<And>a b c. (?sc a b \<longrightarrow> c \<^bold>* a \<le> b) \<longleftrightarrow> (c \<^bold>* a \<le> b)"
    by (auto simp: nn nn_bot mult_bot botnottop intro: gt_botI)

  have "(\<forall> h. X h \<le> (P -*qq Y) h)
       \<longleftrightarrow> (\<forall>h. X h \<le> (INFI {h'. h ## h' \<and> ?sc (P h') (Y (h+h')) } (\<lambda>h'. Y (h + h') \<^bold>div P h')))"
    unfolding sep_impl_qq_def by simp
  also have "... \<longleftrightarrow> (\<forall>h h'. h ## h' \<longrightarrow> ?sc (P h') (Y (h+h')) \<longrightarrow> X h \<le> Y (h + h') \<^bold>div P h')"
    by (auto simp: le_INF_iff)
  also have "... \<longleftrightarrow>  (\<forall>h h'. h ## h' \<longrightarrow> ?sc (P h') (Y (h+h')) \<longrightarrow> X h \<^bold>* P h' \<le> Y (h + h'))"
    using div_mult_adjoint by auto
  also have "... \<longleftrightarrow> (\<forall>a b. a ## b \<longrightarrow> X a \<^bold>* P b \<le> Y (a + b))"
    by(auto simp: le_mult_sc)
  also have "... \<longleftrightarrow> (\<forall>h. ((\<lambda>h. SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda> (x, y). X x \<^bold>* P y)) h \<le> Y h))"
    by (simp add: SUP_le_iff)
  also have "... \<longleftrightarrow> (\<forall>h. (X **q P) h \<le> Y h)"
    unfolding sep_conj_q_alt  by simp
  finally show ?thesis by simp
qed

lemma adjoint: "(\<forall>h. (X **q (emb P)) h \<le> Y h) \<longleftrightarrow> (\<forall>h. X h \<le> (P -*q Y) h)"
  using adjoint_general by blast

subsubsection \<open>quantitative modus ponens\<close>

text \<open>theorem 3.8\<close>

lemma quant_modus_ponens:
  "( (emb P) **q (P -*q X)) h \<le> X h"
proof -
  have " (P -*q X) h \<le> (P -*q X) h" by simp
  then have "(((P -*q X) **q emb P) h \<le> X h)"
    using adjoint[symmetric, where X="(P -*q X)" and Y=X] by auto
  then show ?thesis apply(subst star_comm) .
qed

lemma quant_modus_ponens_general:
  shows "( P **q (P -*qq X)) h \<le> X h"
proof -
  have " (P -*qq X) h \<le> (P -*qq X) h" by simp
  then have "(((P -*qq X) **q  P) h \<le> X h)"
    using adjoint_general[symmetric, where X="(P -*qq X)" and Y=X]  by auto
  then show ?thesis apply(subst star_comm) .
qed

subsection \<open>Intuitionistic Expectations\<close>

text \<open>In SL, a predicate @{term \<phi>} is called @{term intuitionistic}, iff for all @{term h} and
 @{term h'} with @{term "h \<preceq> h'"} , @{term "\<phi> h"} implies @{term "\<phi> h'"}.\<close>

term "intuitionistic"
term "sep_true"

definition intuitionistic_q :: "('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "intuitionistic_q P = (\<forall>h h'. h \<preceq> h' \<longrightarrow> P h \<le> P h')"

lemma intuitionistic_q_emb_intuitionistic_iff:
  "intuitionistic_q (emb P) \<longleftrightarrow> intuitionistic P"
  unfolding intuitionistic_q_def intuitionistic_def emb_def
  using bot_not_neutral less_le_not_le by fastforce

lemma intuitionistic_qI:
  "(\<And>h h'. h \<preceq> h' \<Longrightarrow> P h \<le> P h') \<Longrightarrow> intuitionistic_q P"
  by (unfold intuitionistic_q_def, fast)

lemma intuitionistic_qI2:
  "(\<And>h h'. h ## h' \<Longrightarrow> P h \<le> P (h + h')) \<Longrightarrow> intuitionistic_q P"
  apply (unfold intuitionistic_q_def sep_substate_def)
  by auto

lemma intuitionistic_qD:
  "intuitionistic_q X \<Longrightarrow>  h ## z \<Longrightarrow> h' = h + z \<Longrightarrow> X h \<le> X h' "
  by (unfold intuitionistic_q_def sep_substate_def, auto)

lemma intuitionistic_q_is_attained_at_h:
  fixes
    X :: "_ \<Rightarrow> 'b"
  assumes "intuitionistic_q X"
  shows "(SUPR {(x, y) |x y. h = x + y \<and> x ## y} (\<lambda>(h1, h2). X h1)) = X h"
  apply(rule antisym)
  subgoal
    apply(rule SUP_least) using assms by(auto dest: intuitionistic_qD)
  subgoal
    apply(rule SUP_upper2[where i="(h,0)"]) by auto
  done

text \<open>Tightest intuitionistic expectations\<close>

abbreviation sep_true_q ("1\<^sub>q")  where "1\<^sub>q \<equiv> (emb sep_true)"

theorem tightest_intuitionistic_expectations_star:
  fixes X :: "'a \<Rightarrow> 'b"
  shows
    "intuitionistic_q (X **q 1\<^sub>q)"
    "\<And>h. X h \<le> (X **q 1\<^sub>q) h"
    "\<And>X' h. intuitionistic_q X' \<Longrightarrow> (\<And>h. X h \<le> X' h) \<Longrightarrow> (X **q 1\<^sub>q) h \<le> X' h"
proof -
  show "intuitionistic_q (X **q 1\<^sub>q)"
  proof (rule intuitionistic_qI2)
    fix h h' :: 'a
    assume *: "h ## h'"
    have "(X **q 1\<^sub>q) h = (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>(h1, h2). X h1 \<^bold>* 1\<^sub>q h2))"
      unfolding sep_conj_q_alt by simp
    also have "\<dots> = (SUPR {(x, y). h = x + y \<and> x ## y} (\<lambda>(h1, h2). X h1 \<^bold>* 1\<^sub>q (h2+h')))"
      by (auto simp: emb_def)
    also have "\<dots> \<le> (SUPR {(x, y). h + h' = x + y \<and> x ## y} (\<lambda>(h1, h2). X h1 \<^bold>* 1\<^sub>q h2))"
      apply(rule SUP_mono) apply safe
      subgoal for h1 h2 apply(rule bexI[where x="(h1,h2 + h')"])
        using * by (auto simp: sep_add_assoc dest: sep_add_disjD intro: sep_disj_addI3)
      done
    also have "\<dots> = (X **q 1\<^sub>q) (h + h')"
      unfolding sep_conj_q_alt by simp
    finally show "(X **q 1\<^sub>q) h \<le> (X **q 1\<^sub>q) (h + h')" .
  qed
next
  fix h
  have "X h \<le> (SUPR {(x, y) |x y. h = x + y \<and> x ## y} (\<lambda> (x, y). X x \<^bold>* emb (\<lambda>s. True) y))"
    by (rule Sup_upper) (auto intro!: image_eqI[where x="(h,0)"] simp: emb_def)
  also have "\<dots> = (X **q 1\<^sub>q) h"
    unfolding sep_conj_q_SUP by simp
  finally show "X h \<le> (X **q 1\<^sub>q) h" .
next
  fix X'
  assume "intuitionistic_q X'" and Xmono: "\<And>h. X h \<le> X' h"
    fix h
    have "(X **q 1\<^sub>q) h \<le> (X' **q 1\<^sub>q) h"
      using sep_conj_q_mono[OF Xmono] by fast
    also have "\<dots> = (SUPR {(x, y) |x y. h = x + y \<and> x ## y} (\<lambda>(x, y). X' x \<^bold>*  1\<^sub>q y))"
      unfolding sep_conj_q_SUP by simp
    also have "\<dots> = (SUPR {(x, y) |x y. h = x + y \<and> x ## y} (\<lambda>(x, y). X' x))"
      by (auto simp add: emb_def)
    also have "\<dots> = X' h"
      apply(rule intuitionistic_q_is_attained_at_h) by fact
    finally show "(X **q 1\<^sub>q) h \<le> X' h" .
qed

lemma intuitionistic_q_is_attained_at_h_wand:
  fixes
    X :: "_ \<Rightarrow> 'b"
  assumes "intuitionistic_q X"
  shows "X h = (INFI {h'. h ## h' \<and> (\<^bold>1 < top \<or> X (h + h') < top) } (\<lambda>h'. X (h + h')) )"
  apply(rule antisym)
  subgoal
    apply(rule Inf_greatest) using assms by(auto dest: intuitionistic_qD)
  subgoal
    apply(cases "X h<top")
    subgoal apply(rule INF_lower2[where i=0])  by auto
    subgoal by(auto simp: nn)
    done
  done

lemma tightest_intuitionistic_expectations_wand_general:
  fixes X :: "'a \<Rightarrow> 'b"
  shows
    "intuitionistic_q (1\<^sub>q -*qq X)"
    "\<And>h. (1\<^sub>q -*qq X) h \<le> X h"
    "\<And>X' h. intuitionistic_q X' \<Longrightarrow> (\<And>h. X' h \<le> X h) \<Longrightarrow>  X' h \<le> (1\<^sub>q -*qq X) h"
proof -
  (* side condition *)
  let ?sc = "\<lambda>a b. (bot < a \<or> bot < b ) \<and> (a < top \<or> b < top)"
  show 1: "intuitionistic_q (1\<^sub>q -*qq X)"
  proof (rule intuitionistic_qI2)
    fix h h' :: 'a
    assume *: "h ## h'"
    have "(1\<^sub>q -*qq X) h = (INFI {h'. h ## h' \<and> ?sc (emb (\<lambda>s. True) h') (X (h + h')) }
                                (\<lambda>h'. X (h + h') \<^bold>div emb (\<lambda>s. True) h'))"
      unfolding sep_impl_qq_def  by simp
    also have "\<dots> \<le> (INFI {h'a. h + h' ## h'a \<and> ?sc (emb (\<lambda>s. True) h'a) (X (h + h'+ h'a))}
                          (\<lambda>h'a. X (h + h' + h'a) \<^bold>div emb (\<lambda>s. True) h'a))"
      apply(rule INF_mono)
      subgoal for h'' apply(rule bexI[where x="h' + h''"])
        using * bot_not_neutral
        by (auto simp: sep_disj_addI3 emb_def sep_add_assoc dest: sep_add_disjD)
      done
    also have "\<dots> = (1\<^sub>q -*qq X) (h + h')"
      unfolding sep_impl_qq_def  by simp
    finally show "(1\<^sub>q -*qq X) h \<le> (1\<^sub>q -*qq X) (h + h')" .
  qed
next
  fix h
  have "(1\<^sub>q -*qq X) h = (INFI {h'. h ## h' \<and> (bot < emb (\<lambda>s. True) h' \<or> bot < X (h + h'))
                                 \<and> (emb (\<lambda>s. True) h' < top \<or> X (h + h') < top)}
                              (\<lambda>h'. X (h + h') \<^bold>div emb (\<lambda>s. True) h'))"
    unfolding sep_impl_qq_def by simp
  also have "\<dots> \<le> X h"
    apply(cases "X h<top")
    subgoal by (rule INF_lower2[where i=0]) (auto simp: bot_not_neutral emb_def divide_neutral)
    subgoal by (auto simp: nn)
    done
  finally show "(1\<^sub>q -*qq X) h \<le> X h" .
next
  fix X'
  assume "intuitionistic_q X'" and Xmono: "\<And>h. X' h \<le> X h"
  fix h (* for arbitrary but fixed h *)
  have "X' h = (INFI {h'. h ## h' \<and> (\<^bold>1 < top \<or> X' (h + h') < top) } (\<lambda>h'. X' (h + h')) )"
    apply(rule intuitionistic_q_is_attained_at_h_wand) by fact
  also have "\<dots> = (INFI {h'. h ## h' \<and> (bot < emb (\<lambda>s. True) h' \<or> bot < X' (h + h'))
                         \<and> (emb (\<lambda>s. True) h' < top \<or> X' (h + h') < top)}
                        (\<lambda>h'. X' (h + h') \<^bold>div emb (\<lambda>s. True) h'))"
    using bot_not_neutral by (auto simp: emb_def divide_neutral )
  also have "\<dots> = (1\<^sub>q -*qq X') h"
    unfolding sep_impl_qq_def by simp
  also have "\<dots> \<le> (1\<^sub>q -*qq X) h"
    apply(rule sep_impl_q_left_mono') by fact
  finally show "X' h \<le> (1\<^sub>q -*qq X) h" .
qed

lemma tightest_intuitionistic_expectations_wand:
  fixes X :: "'a \<Rightarrow> 'b"
  shows
    "intuitionistic_q (sep_true -*q X)"
    "\<And>h. (sep_true -*q X) h \<le> X h"
    "\<And>X' h. intuitionistic_q X' \<Longrightarrow> (\<And>h. X' h \<le> X h) \<Longrightarrow>  X' h \<le> (sep_true -*q X) h"
  using tightest_intuitionistic_expectations_wand_general by auto

abbreviation (input)
  pred_ex_q :: "('b \<Rightarrow> 'a \<Rightarrow> ennreal) \<Rightarrow> 'a \<Rightarrow> ennreal" (binder "EXSq " 10) where
  "EXSq x. P x \<equiv> \<lambda>h. SUP x. P x h"

end
end

section \<open>Showing that quantitative separating connectives
   instantiated for bool yield the boolean separating connectives\<close>

instantiation "bool" :: one
begin
definition "one_bool == True"
instance by standard
end

interpretation BOOL: quant_sep_con Inf Sup inf "(\<le>)" "(<)" sup bot top
      "(\<and>)" "True" "\<lambda>x y. y \<longrightarrow> x"
  unfolding quant_sep_con_def comm_quantale_def apply safe
  subgoal by standard
  subgoal apply standard by auto
  subgoal apply standard by auto
  subgoal apply standard by auto
  done

thm BOOL.oper_left_mono

lemma "BOOL.sep_conj_q = sep_conj"
  apply(rule ext) apply (rule ext)
  unfolding sep_conj_def BOOL.sep_conj_q_def
  by auto

lemma "BOOL.sep_impl_qq = sep_impl"
  apply(rule ext) apply (rule ext)
  unfolding sep_impl_def BOOL.sep_impl_qq_def
  by auto

lemma "BOOL.intuitionistic_q = intuitionistic"
  apply(rule ext)
  unfolding intuitionistic_def BOOL.intuitionistic_q_def
  by auto

lemma "BOOL.sep_impl_qq = BOOL.sep_impl_q"
  unfolding BOOL.sep_impl_qq_def BOOL.emb_def by auto

section \<open>Extensions\<close>

subsection \<open>The Locale quant_sep_con_one\<close>

text \<open>A locale assuming, that the neutral element is also the top element.
      (Bool,<=,and), ([0;1],<=,*) and (ennreal,>=,+) are three examples.
      (ennreal,<=,*) isn't.  \<close>

locale quant_sep_con_one = quant_sep_con Inf Sup inf le less sup bot top oper neutr divide
  for Inf :: "'b set \<Rightarrow> 'b"
    and Sup inf
    and le (infix "\<le>" 50)
    and less (infix "<" 50)
    and sup top bot
    and oper :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>*" 64)
    and divide :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>div" 64)
    and neutr :: "'b" ("\<^bold>1")
    +
  assumes neutral_is_top: "\<^bold>1 = top"
    and CC: "bot < (top::'b)"
begin

context
  assumes "SORT_CONSTRAINT ('a::{sep_algebra})"
begin

lemma sep_impl_q_alt_general'':
  fixes  Q :: "'a \<Rightarrow> 'b"
  shows "(P -*q Q) = (\<lambda>h. INFI { h'. h ## h' \<and> P h'} (\<lambda> h'. Q (h + h')))"
  using sep_impl_q_alt_general neutral_is_top by auto

lemma sep_impl_q_alt_general''':
  fixes  Q :: "'a \<Rightarrow> 'b"
  shows "(P -*q Q) = (\<lambda>h. INFI { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))"
proof  (rule ext)
  fix h
  let ?A ="{h'. h ## h' \<and> (bot::'b) < emb P h' \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}"
  let ?C = " {h'. h ## h' \<and>(bot::'b) = emb P h' \<and> (bot::'b) < Q (h + h')
                   \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}"
  let ?B ="{h'.  h ## h'   \<and> Q (h + h') < top \<and> P h'}"
  have T: "{h'. h ## h' \<and> ((bot::'b) < emb P h' \<or> (bot::'b) < Q (h + h'))
               \<and> (emb P h' < (top::'b) \<or> Q (h + h') < (top::'b))}
            = ?A \<union> ?C"
    using bot.not_eq_extremum by fastforce

  have 1: "(INFI ?A (\<lambda>h'. Q (h + h') \<^bold>div emb P h')) = (INFI ?B (\<lambda>x. Q (h + x)))"
    apply(rule INF_cong)
    subgoal
      apply rule
      subgoal (* ?A \<subseteq> ?B *)
        by (auto simp: divide_neutral emb_def CC bot_not_neutral neutral_is_top[symmetric])
      subgoal (* ?B \<subseteq> ?A *)
        by (auto simp: divide_neutral emb_def CC bot_not_neutral)
      done
    subgoal by (simp add: divide_neutral emb_def)
    done

  have 2: "(INFI ?C (\<lambda>h'. Q (h + h') \<^bold>div emb P h')) = top"
    unfolding emb_def apply auto
    using divide_bot by simp_all

  have F: "{ h'. h ## h' \<and> P h'}
     = { h'. h ## h' \<and> P h' \<and> Q (h + h') = top} \<union> { h'. h ## h' \<and> P h' \<and> Q (h + h') < top}"
    using top.not_eq_extremum by blast

  have 3: "(INFI {h'. h ## h' \<and> P h' \<and> Q (h + h') = top} (\<lambda>h'. Q (h + h'))) = top"
    by auto

  have "(P -*q Q) h = inf (INFI ?A (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))
                        (INFI ?C (\<lambda>h'. Q (h + h') \<^bold>div emb P h'))"
    unfolding sep_impl_qq_def T INF_union
    by simp
  also have "\<dots>  = (INFI ?B (\<lambda>x. Q (h + x)))"
    unfolding 1 2 by simp
  also have "\<dots> = (INFI { h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))"
    unfolding F INF_union 3
    by (auto intro: INF_cong)
  finally show "(P -*q Q) h = (INFI {h'. h ## h' \<and> P h'} (\<lambda>h'. Q (h + h')))" .
qed

end
end

  (*

subsection \<open>The Locale quant_sep_con_oper2\<close>

text \<open>Allowing a second operation on the measuring type.\<close>

locale quant_sep_con_oper2 =  quant_sep_con oper neutr divide
  for
    oper :: "'b::{complete_lattice} \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>*" 70)
    and neutr :: "'b" ("\<^bold>1")
    and divide :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"  (infixl "\<^bold>div" 70) +
  fixes
    oper2 :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<^bold>+" 65)
  assumes
    plusmal_distrib[algebra_simps]: "\<And>a b c. a \<^bold>* (b \<^bold>+ c) = a \<^bold>* b \<^bold>+ a \<^bold>* c"
    and oper2_mono: "\<And>a b c d. a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a \<^bold>+ c \<le> b \<^bold>+ d"
begin

lemma SUP_plus_subdistrib: "\<And>S. \<And>f g::_\<Rightarrow>'b. (SUP x:S. f x \<^bold>+ g x) \<le> (SUP x:S. f x) \<^bold>+ (SUP x:S. g x)"
  by (simp add: SUP_least SUP_upper oper2_mono)

context
  assumes "SORT_CONSTRAINT ('a::{sep_algebra})"
begin

lemma theorem_3_6_general2:
  fixes
    P :: "_ \<Rightarrow> 'b"
  shows
    "((P **q (\<lambda>h. Q h \<^bold>+ R h)) h) \<le> ((P **q Q) h) \<^bold>+ ((P **q R) h)"
proof -
  have "(P **q (\<lambda>h. Q h \<^bold>+ R h)) h = (SUP (x,y):{(x,y)|x y. h = x + y \<and> x ## y}. (P x \<^bold>* Q y) \<^bold>+ (P x \<^bold>* R y) )"
    unfolding sep_conj_q_alt  by (simp add: plusmal_distrib)
  also have "\<dots> = (SUP x:{(x,y)|x y. h = x + y \<and> x ## y}. (P (fst x) \<^bold>* Q (snd x))  \<^bold>+ (P (fst x) \<^bold>* R (snd x)) )"
    apply(rule Sup_cong) by force
  also have "\<dots> \<le> (SUP x:{(x,y)|x y. h = x + y \<and> x ## y}. P (fst x)  \<^bold>* Q (snd x) )
                   \<^bold>+ (SUP x:{(x,y)|x y. h = x + y \<and> x ## y}. P (fst x)  \<^bold>* R (snd x) )"
    by (rule SUP_plus_subdistrib)
  also have "\<dots> = ((P **q Q) h)  \<^bold>+ ((P **q R) h)"
    unfolding sep_conj_q_alt apply simp
    by (metis (mono_tags, lifting) SUP_cong prod.case_eq_if)
  finally show "((P **q (\<lambda>h. Q h \<^bold>+ R h)) h) \<le> ((P **q Q) h) \<^bold>+ ((P **q R) h)" .
qed

end
end*)

end


(*by Ammer*)
theory VEBT_Definitions imports
   Main
  "HOL-Library.Extended_Nat"
  "HOL-Library.Code_Target_Numeral"
  "HOL-Library.Code_Target_Nat"

begin
section \<open>Preliminaries and Preparations\<close>

subsection \<open>Data Type Definition\<close>

datatype VEBT = is_Node: Node (info:"(nat*nat) option")(deg: nat)(treeList: "VEBT list") (summary:VEBT) |
 is_Leaf: Leaf   bool     bool

hide_const (open) info deg treeList summary

locale VEBT_internal begin

subsection \<open>Functions for obtaining high and low bits of an input number.\<close>

definition high :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "high x n = (x div (2^n))"

definition low :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "low x n = (x mod (2^n))"

subsection \<open>Some auxiliary lemmata\<close>

lemma inthall[termination_simp]: "(\<And> x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> n < length xs \<Longrightarrow> P (xs ! n)"
  apply(induction xs arbitrary: n)
  apply auto
  using less_Suc_eq_0_disj
  apply auto
  done

lemma intind: "i < n \<Longrightarrow> P x \<Longrightarrow> P (replicate n x ! i)"
  by (metis in_set_replicate inthall length_replicate)

lemma concat_inth:"(xs @[x]@ys)! (length xs) = x"
  by simp

lemma pos_n_replace: "n<length xs \<Longrightarrow> length xs = length (take n xs @ [y] @drop (Suc n) xs)"
  by simp

lemma inthrepl: "i < n \<Longrightarrow> (replicate n x) ! i = x" by simp

lemma nth_repl: "m<length xs \<Longrightarrow> n <length xs \<Longrightarrow> m\<noteq> n \<Longrightarrow>(take n xs @ [x] @ drop (n+1) xs) ! m = xs ! m"
  by (metis Suc_eq_plus1 append_Cons append_Nil nth_list_update_neq upd_conv_take_nth_drop)

lemma [termination_simp]:assumes "high x deg < length treeList"
  shows"size (treeList ! high x deg) < Suc (size_list size treeList + size s)"
proof-
  have "treeList ! high x deg \<in> set treeList"
    using assms by auto
  then show ?thesis
    using not_less_eq size_list_estimation by fastforce
qed

subsection \<open> Auxiliary functions for defining valid Van Emde Boas Trees\<close>

text \<open>This function checks whether an element occurs  in a Leaf\<close>

fun naive_member :: "VEBT \<Rightarrow> nat \<Rightarrow> bool" where
  "naive_member (Leaf a b) x = (if x = 0 then a else if x = 1 then b else False)"|
  "naive_member (Node _ 0 _ _) _ = False"|
  "naive_member (Node _ deg treeList s) x =  (let pos = high x (deg div 2) in
    (if pos < length treeList then naive_member (treeList ! pos) (low x (deg div 2)) else False))"

text \<open>Test for elements stored by using the provide min-max-fields\<close>

fun membermima :: "VEBT \<Rightarrow> nat \<Rightarrow> bool" where
  "membermima (Leaf _ _) _ = False"|
  "membermima (Node None 0 _ _ )_ =False"|
  "membermima (Node (Some (mi,ma)) 0 _ _) x = (x = mi \<or> x = ma)"|
  "membermima (Node (Some (mi, ma)) deg treeList _) x = (x = mi \<or> x = ma \<or> (
    let pos = high x ( deg div 2) in (if pos < length treeList
    then membermima (treeList ! pos) (low x (deg div 2)) else False)))"|
  "membermima (Node None (deg) treeList _) x = (let pos = high x (deg div 2) in
    (if pos < length treeList then membermima (treeList ! pos) (low x (deg div 2)) else False))"

lemma length_mul_elem:"(\<forall> x \<in> set xs. length x = n) \<Longrightarrow> length (concat xs) = (length xs) * n"
  apply(induction xs)
   apply auto
  done

text \<open>We combine both auxiliary functions: The following test returns true if and only if an element occurs in the tree with respect to our interpretation no matter where it is stored.\<close>

definition both_member_options :: "VEBT \<Rightarrow> nat \<Rightarrow> bool" where
  "both_member_options t x = (naive_member t x \<or> membermima t x)"

end
context begin
  interpretation VEBT_internal .

definition set_vebt :: "VEBT \<Rightarrow> nat set" where
  "set_vebt t = {x. both_member_options t x}"
end

subsection \<open>Inductive Definition of semantically valid Vam Emde Boas Trees\<close>

text \<open>Invariant for verification proofs\<close>

context begin
  interpretation VEBT_internal .

inductive invar_vebt::"VEBT \<Rightarrow> nat \<Rightarrow> bool" where
 "invar_vebt (Leaf  a b) (Suc 0) "|
 "( \<forall> t \<in> set treeList. invar_vebt t n) \<Longrightarrow> invar_vebt summary m  \<Longrightarrow>  length treeList = 2^m
 \<Longrightarrow> m = n \<Longrightarrow> deg = n + m \<Longrightarrow> (\<nexists> i. both_member_options summary i)
 \<Longrightarrow>(\<forall> t \<in> set treeList. \<nexists> x. both_member_options t x)
 \<Longrightarrow> invar_vebt (Node None deg treeList summary) deg"|
 "( \<forall> t \<in> set treeList. invar_vebt t n) \<Longrightarrow> invar_vebt summary m
 \<Longrightarrow>  length treeList = 2^m \<Longrightarrow> m = Suc n \<Longrightarrow> deg = n + m \<Longrightarrow> (\<nexists> i. both_member_options summary i)
 \<Longrightarrow> (\<forall> t \<in> set treeList. \<nexists> x. both_member_options t x)
 \<Longrightarrow> invar_vebt (Node None deg treeList summary) deg"|
 "( \<forall> t \<in> set treeList. invar_vebt t n) \<Longrightarrow> invar_vebt summary m  \<Longrightarrow> length treeList = 2^m \<Longrightarrow> m = n
 \<Longrightarrow>deg = n + m\<Longrightarrow> (\<forall> i < 2^m. (\<exists> x. both_member_options (treeList ! i) x) \<longleftrightarrow> ( both_member_options summary i)) \<Longrightarrow>
                    (mi = ma \<longrightarrow> (\<forall> t \<in> set treeList. \<nexists> x. both_member_options t x)) \<Longrightarrow>
                      mi \<le> ma \<Longrightarrow> ma < 2^deg \<Longrightarrow>
                     (mi \<noteq> ma \<longrightarrow>
                                 (\<forall> i < 2^m.
                                            (high ma n = i \<longrightarrow> both_member_options (treeList ! i) (low ma n)) \<and>
                                            (\<forall> x. (high x n = i \<and> both_member_options (treeList ! i) (low x n)  ) \<longrightarrow> mi < x \<and> x \<le> ma) ) )
 \<Longrightarrow> invar_vebt (Node (Some (mi, ma)) deg treeList summary) deg"|
 "( \<forall> t \<in> set treeList. invar_vebt t n) \<Longrightarrow>invar_vebt summary m  \<Longrightarrow>  length treeList = 2^m
 \<Longrightarrow>  m = Suc n \<Longrightarrow>deg = n + m\<Longrightarrow>(\<forall> i < 2^m. (\<exists> x. both_member_options (treeList ! i) x) \<longleftrightarrow> ( both_member_options summary i)) \<Longrightarrow>
                    (mi = ma \<longrightarrow> (\<forall> t \<in> set treeList. \<nexists> x. both_member_options t x)) \<Longrightarrow>
                      mi \<le> ma \<Longrightarrow> ma < 2^deg \<Longrightarrow>
                     (mi \<noteq> ma \<longrightarrow>
                                 (\<forall> i < 2^m.
                                            (high ma n = i \<longrightarrow> both_member_options (treeList ! i) (low ma n)) \<and>
                                            (\<forall> x. (high x n = i \<and> both_member_options (treeList ! i) (low x n)  ) \<longrightarrow> mi < x \<and> x \<le> ma)))
 \<Longrightarrow> invar_vebt (Node (Some (mi, ma)) deg treeList summary) deg"

end

context VEBT_internal begin

definition "in_children n treeList x \<equiv> both_member_options (treeList ! high x n) (low x n)"

text \<open>functional validness definition\<close>
fun valid' :: "VEBT \<Rightarrow> nat \<Rightarrow> bool" where
  "valid' (Leaf _ _) d \<longleftrightarrow> d=1"
| "valid' (Node mima deg treeList summary) deg' \<longleftrightarrow>
  (
    deg=deg' \<and> (
    let n = deg div 2; m = deg - n in
      ( \<forall> t \<in> set treeList. valid' t n )
    \<and> valid' summary m
    \<and> length treeList = 2^m
    \<and> (
      case mima of
        None \<Rightarrow> (\<nexists> i. both_member_options summary i) \<and> (\<forall> t \<in> set treeList. \<nexists> x. both_member_options t x)
      | Some (mi,ma) \<Rightarrow>
          mi \<le> ma \<and> ma<2^deg
        \<and> (\<forall> i < 2^m. (\<exists> x. both_member_options (treeList ! i) x) \<longleftrightarrow> ( both_member_options summary i))
        \<and> (if mi=ma then (\<forall> t \<in> set treeList. \<nexists> x. both_member_options t x)
           else
             in_children n treeList ma
           \<and> (\<forall>x < 2^deg. in_children n treeList x \<longrightarrow> mi<x \<and> x\<le>ma)
          )
    )
    )
  )
"

text \<open>equivalence proofs\<close>

lemma high_bound_aux: "ma < 2^(n+m) \<Longrightarrow> high ma n < 2^m"
  unfolding high_def
  by (simp add: add.commute less_mult_imp_div_less power_add)

lemma valid_eq1:
  assumes "invar_vebt t d"
  shows "valid' t d"
  using assms apply induction
  apply simp_all
  apply (auto simp: in_children_def dest: high_bound_aux) []
  subgoal for treeList n summary m deg mi ma
    apply (intro allI impI conjI)
    apply (auto simp: in_children_def dest: high_bound_aux) []
    apply (metis add_Suc_right high_bound_aux power_Suc)
    apply (auto simp: in_children_def dest: high_bound_aux) []
    apply (metis add_Suc_right high_bound_aux power_Suc)
    apply (auto simp: in_children_def dest: high_bound_aux) []
    apply (metis add_Suc_right high_bound_aux power_Suc)
    done
  done

lemma even_odd_cases:
  fixes x :: nat
  obtains n where "x=n+n" | n where "x = n + Suc n"
  apply (cases "even x"; simp)
  apply (metis add_self_div_2 div_add)
  by (metis add.commute mult_2 oddE plus_1_eq_Suc)

lemma valid_eq2: "valid' t d \<Longrightarrow> invar_vebt t d"
  apply (induction t d rule: valid'.induct)
  apply (auto intro: invar_vebt.intros simp: Let_def split: option.splits)
  subgoal for deg treeList summary
    apply (rule even_odd_cases[of deg]; simp)
    apply (rule invar_vebt.intros(2); simp)
    apply (rule invar_vebt.intros(3); simp add: algebra_simps) by presburger
  subgoal for deg treeList summary mi ma
    apply (rule even_odd_cases[of deg]; simp)
    subgoal
      apply (rule invar_vebt.intros(4); simp?)
      apply (auto simp: in_children_def) []
       apply (meson le_less_linear le_less_trans)
      apply (metis div_eq_0_iff div_exp_eq gr_implies_not0 high_def)
       done
    subgoal
      apply (rule invar_vebt.intros(5); simp?)
      apply (auto) []
      apply (auto) []
      apply (auto simp: in_children_def) []
      apply (meson le_less_linear le_less_trans)
      apply (metis div_eq_0_iff add_Suc_right div_exp_eq high_def power_Suc power_eq_0_iff zero_neq_numeral)
      done
    done
  done

lemma valid_eq: "valid' t d \<longleftrightarrow> invar_vebt t d"
  using valid_eq1 valid_eq2 by auto

lemma [termination_simp]: assumes "odd (v::nat)" shows "v div 2 < v"
  by (simp add: assms odd_pos)

lemma [termination_simp]:assumes "n > 1" and " odd n" shows" Suc (n div 2) < n"
  by (metis Suc_lessI add_diff_cancel_left' assms(1) assms(2) div_eq_dividend_iff div_less_dividend even_Suc even_Suc_div_two odd_pos one_less_numeral_iff plus_1_eq_Suc semiring_norm(76) zero_less_diff)

end

subsection \<open>Function for generating an empty tree of arbitrary degree respectively order\<close>

context begin
interpretation VEBT_internal .

fun vebt_buildup :: "nat \<Rightarrow> VEBT" where
  "vebt_buildup 0 = Leaf False False"|
  "vebt_buildup (Suc 0) = Leaf False False"|
  "vebt_buildup n = (if even n then (let half = n div 2 in
                   Node None n (replicate (2^half) (vebt_buildup half)) (vebt_buildup half))
                else (let half = n div 2 in
                  Node None n ( replicate (2^(Suc half)) (vebt_buildup half)) (vebt_buildup (Suc half))))"

end

context VEBT_internal begin

lemma buildup_nothing_in_leaf: "\<not> naive_member (vebt_buildup n) x"
proof(induction arbitrary: x rule: vebt_buildup.induct)
  case 1
  then show ?case by simp
next
  case (2 v)
  then show ?case
    by simp
next
  case (3 n)
  let ?n = "Suc(Suc n)"
  show ?case proof(cases "even ?n")
    case True
    let ?half = "?n div 2"
    have "\<not> naive_member (vebt_buildup ?half) y" for y
      using "3.IH"(1) True by blast
    hence 0:"\<forall> t \<in> set  (replicate (2^?half) (vebt_buildup ?half)) . \<not> naive_member t  x"
      by simp
    have "naive_member (vebt_buildup ?n) x \<Longrightarrow> False"
    proof-
      assume "naive_member (vebt_buildup ?n) x"
      hence "high x ?half < 2^?half \<and>
               naive_member ((replicate (2^?half) (vebt_buildup ?half)) ! (high x ?half)) (low x ?half)"
        by (metis True vebt_buildup.simps(3) length_replicate naive_member.simps(3))
      hence "\<exists> t \<in> set  (replicate (2^?half) (vebt_buildup ?half)) . naive_member t  x "
        by (metis \<open>\<And>y. \<not> naive_member (vebt_buildup (Suc (Suc n) div 2)) y\<close> nth_replicate)
      then show False using 0 by simp
    qed
    then show ?thesis
      by blast
  next
    case False
    let ?half = "?n div 2"
    have "\<not> naive_member (vebt_buildup ?half) y" for y
      using "3.IH" False by blast
    hence 0:"\<forall> t \<in> set  (replicate (2^(Suc ?half)) (vebt_buildup ?half)) . \<not> naive_member t  x"
      by simp
    have "naive_member (vebt_buildup ?n) x \<Longrightarrow> False"
    proof-
      assume "naive_member (vebt_buildup ?n) x"
      hence "high x ?half < 2^(Suc ?half) \<and>
               naive_member ((replicate (2^(Suc ?half)) (vebt_buildup ?half)) ! (high x ?half)) (low x ?half)"
        by (metis False vebt_buildup.simps(3) length_replicate naive_member.simps(3))
      hence "\<exists> t \<in> set  (replicate (2^(Suc ?half)) (vebt_buildup ?half)) . naive_member t  x "
        by (metis \<open>\<And>y. \<not> naive_member (vebt_buildup (Suc (Suc n) div 2)) y\<close> nth_replicate)
      then show False using 0 by simp
    qed
    then show ?thesis by force
  qed
qed

lemma buildup_nothing_in_min_max:"\<not> membermima (vebt_buildup n) x"
proof(induction arbitrary: x rule: vebt_buildup.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 va)
  let ?n = "Suc (Suc va)"
  let ?half = "?n div 2"
  show ?case proof(cases "even ?n")
    case True
    have "\<not> membermima (vebt_buildup ?half) y" for y
      using "3.IH"(1) True by blast
    hence 0:"\<forall> t \<in> set  (replicate (2^?half) (vebt_buildup ?half)) . \<not> membermima t  x"
      by simp
    then show ?thesis
      by (metis "3.IH"(1) True vebt_buildup.simps(3) inthrepl length_replicate membermima.simps(5))
  next
    case False
     have "\<not> membermima (vebt_buildup ?half) y" for y
      using "3.IH" False  by blast
    moreover hence 0:"\<forall> t \<in> set  (replicate (2^(Suc ?half)) (vebt_buildup ?half)) . \<not> membermima t  x"
      by simp
    ultimately show ?thesis
      by (metis vebt_buildup.simps(3) inthrepl length_replicate membermima.simps(5))
  qed
qed

text \<open>The empty tree generated by $vebt_buildup$ is indeed a valid tree.\<close>

lemma buildup_gives_valid: "n>0  \<Longrightarrow> invar_vebt (vebt_buildup n) n"
proof( induction n rule: vebt_buildup.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case
    by (simp add: invar_vebt.intros(1))
next
  case (3 va)
  let ?n = "Suc (Suc va)"
  let ?half = "?n div 2"
  show ?case proof(cases "even ?n")
    case True
    hence a:"vebt_buildup ?n =  Node None ?n (replicate (2^?half) (vebt_buildup ?half)) (vebt_buildup ?half)" by simp
    moreover hence "invar_vebt (vebt_buildup ?half) ?half"
      using "3.IH"(1) True by auto
    moreover hence "( \<forall> t \<in> set (replicate (2^?half) (vebt_buildup ?half)). invar_vebt t ?half)" by simp
    moreover have "length (replicate (2^?half) (vebt_buildup ?half)) = 2^?half" by auto
    moreover have "?half+?half = ?n"
      using True by auto
    moreover have " \<forall> t \<in> set (replicate (2^?half) (vebt_buildup ?half)). (\<nexists> x. both_member_options t x)"
    proof
      fix t
      assume "t \<in> set (replicate (2^?half) (vebt_buildup ?half))"
      hence "t = (vebt_buildup ?half)" by simp
      thus "\<nexists> x. both_member_options t x"
        by (simp add: both_member_options_def buildup_nothing_in_leaf buildup_nothing_in_min_max)
    qed
    moreover have " (\<nexists> i. both_member_options (vebt_buildup ?half) i)"
      using both_member_options_def buildup_nothing_in_leaf buildup_nothing_in_min_max by blast
    ultimately have "invar_vebt  (Node None ?n (replicate (2^?half) (vebt_buildup ?half)) (vebt_buildup ?half)) ?n"
      using invar_vebt.intros(2)[of "replicate (2^?half) (vebt_buildup ?half)" ?half "vebt_buildup ?half" ?half ?n]
      by simp
    then show ?thesis using a by auto
  next
    case False
    hence a:"vebt_buildup ?n =  Node None ?n (replicate (2^(Suc ?half)) (vebt_buildup ?half)) (vebt_buildup (Suc ?half))" by simp
    moreover hence "invar_vebt (vebt_buildup (Suc ?half)) (Suc ?half)"
      using "3.IH" False by auto
    moreover have "invar_vebt (vebt_buildup ?half) ?half"
      using "3.IH"(3) False by auto
    moreover hence "( \<forall> t \<in> set (replicate (2^(Suc ?half)) (vebt_buildup ?half)). invar_vebt t ?half)" by simp
    moreover have "length (replicate (2^(Suc ?half)) (vebt_buildup ?half)) = 2^(Suc ?half)" by auto
    moreover have "(Suc ?half)+?half = ?n"
      using False by presburger
    moreover have " \<forall> t \<in> set (replicate (2^(Suc ?half)) (vebt_buildup ?half)). (\<nexists> x. both_member_options t x)"
    proof
      fix t
      assume "t \<in> set (replicate (2^(Suc ?half)) (vebt_buildup ?half))"
      hence "t = (vebt_buildup ?half)" by simp
      thus "\<nexists> x. both_member_options t x"
        by (simp add: both_member_options_def buildup_nothing_in_leaf buildup_nothing_in_min_max)
    qed
    moreover have " (\<nexists> i. both_member_options (vebt_buildup (Suc ?half)) i)"
      using both_member_options_def buildup_nothing_in_leaf buildup_nothing_in_min_max by blast
    moreover have "?half + Suc ?half = ?n"
      using calculation(6) by auto
    ultimately have "invar_vebt  (Node None ?n (replicate (2^(Suc ?half)) (vebt_buildup ?half)) (vebt_buildup (Suc ?half))) ?n"
      using invar_vebt.intros(3)[of "replicate (2^(Suc ?half)) (vebt_buildup ?half)" ?half "vebt_buildup (Suc ?half)" "Suc ?half" ?n ]
      by simp
    then show ?thesis using a by auto
  qed
qed

lemma mi_ma_2_deg: assumes "invar_vebt (Node (Some (mi, ma)) deg treeList summary) n" shows "mi\<le> ma \<and> ma < 2^deg"
proof-
  from  assms show ?thesis proof cases qed blast+
qed

lemma deg_not_0: "invar_vebt t n \<Longrightarrow> n > 0"
  apply(induction t n rule: invar_vebt.induct)
      apply auto
  done

lemma set_n_deg_not_0:assumes " \<forall>t\<in>set treeList. invar_vebt t n"and" length treeList = 2^m "shows " n \<ge> 1"
proof-
  have "length treeList > 0"
    by (simp add: assms(2))
  then obtain t ts where "treeList = t#ts"
    by (metis list.size(3) neq_Nil_conv not_less0)
  hence "invar_vebt t n"
    by (simp add: assms(1))
  hence "n \<ge> 1"
    using deg_not_0 by force
  thus ?thesis by simp
qed

lemma both_member_options_ding: assumes"invar_vebt (Node info deg treeList summary) n "and "x<2^deg"and"
 both_member_options (treeList ! (high x (deg div 2))) (low x (deg div 2))"shows "both_member_options  (Node info deg treeList summary) x"
proof-
  from assms(1) show ?thesis proof(induction "(Node info deg treeList summary)" n rule: invar_vebt.induct)
    case (2 n m)
    hence "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2)) \<or>
           naive_member (treeList ! (high x (deg div 2))) (low x (deg div 2))"
      using assms(3) both_member_options_def by auto
    moreover  hence "deg > 1"
      using "2.hyps"(2) "2.hyps"(5) "2.hyps"(6) deg_not_0 by force
    moreover have "high x (deg div 2)<2^m"
      by (metis "2.hyps"(5) "2.hyps"(6) div_eq_0_iff add_self_div_2 assms(2) div_exp_eq high_def power_not_zero)
    moreover have "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                    \<Longrightarrow> membermima (Node info deg treeList summary) x" using membermima.simps(5)[of "deg-1" treeList summary x]
      using "2.hyps"(4) "2.hyps"(9) \<open>1 < deg\<close> \<open>high x (deg div 2) < 2 ^ m\<close> zero_le_one by fastforce
    moreover have "naive_member  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                   \<Longrightarrow> naive_member (Node info deg treeList summary) x"
      by (smt "2.hyps"(4) Suc_diff_Suc \<open>1 < deg\<close> \<open>high x (deg div 2) < 2 ^ m\<close> diff_zero le_less_trans naive_member.simps(3) zero_le_one)
    ultimately show ?case
      using both_member_options_def by blast
  next
    case (3 n m)
    hence "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2)) \<or>
           naive_member (treeList ! (high x (deg div 2))) (low x (deg div 2))"
      using assms(3) both_member_options_def by auto
    moreover  hence "deg > 1"
      by (metis "3.hyps"(1) "3.hyps"(2) "3.hyps"(4) "3.hyps"(5) "3.hyps"(6) One_nat_def Suc_lessI add_Suc add_gr_0 add_self_div_2 deg_not_0 le_imp_less_Suc plus_1_eq_Suc set_n_deg_not_0)
    moreover have "high x (deg div 2)<2^m"
      by (smt "3.hyps"(5) "3.hyps"(6) div_eq_0_iff add_Suc_right add_self_div_2 assms(2) diff_Suc_1 div_exp_eq div_mult_self1_is_m even_Suc high_def odd_add odd_two_times_div_two_nat one_add_one plus_1_eq_Suc power_not_zero zero_less_Suc)
    moreover have "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                   \<Longrightarrow> membermima (Node info deg treeList summary) x" using membermima.simps(5)[of "deg-1" treeList summary x]
      using "3.hyps"(4) "3.hyps"(9) \<open>1 < deg\<close> \<open>high x (deg div 2) < 2 ^ m\<close> zero_le_one by fastforce
    moreover have "naive_member  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                   \<Longrightarrow> naive_member (Node info deg treeList summary) x"
      by (smt "3.hyps"(4) Suc_diff_Suc \<open>1 < deg\<close> \<open>high x (deg div 2) < 2 ^ m\<close> diff_zero le_less_trans naive_member.simps(3) zero_le_one)
    ultimately show ?case
      using both_member_options_def by blast
  next
    case (4 n m mi ma)
    hence "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2)) \<or>
           naive_member (treeList ! (high x (deg div 2))) (low x (deg div 2))"
      using assms(3) both_member_options_def by auto
    moreover  hence "deg > 1"
      using "4.hyps"(2) "4.hyps"(5) "4.hyps"(6) deg_not_0 by force
    moreover have "high x (deg div 2)<2^m"
      by (metis "4.hyps"(5) "4.hyps"(6) div_eq_0_iff add_self_div_2 assms(2) div_exp_eq high_def power_not_zero)
    moreover have "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                   \<Longrightarrow> membermima (Node info deg treeList summary) x" using membermima.simps(5)[of "deg-1" treeList summary x]
      by (smt "4.hyps"(12) "4.hyps"(4) Suc_diff_Suc calculation(2) calculation(3) diff_zero le_less_trans membermima.simps(4) zero_le_one)
    moreover have "naive_member  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                    \<Longrightarrow> naive_member (Node info deg treeList summary) x"
      by (metis "4.hyps"(4) calculation(2) calculation(3) gr_implies_not0 naive_member.simps(3) old.nat.exhaust)  ultimately show ?case
      using both_member_options_def by blast
  next
    case (5 n m mi ma)
    hence "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2)) \<or>
           naive_member (treeList ! (high x (deg div 2))) (low x (deg div 2))"
      using assms(3) both_member_options_def by auto
    moreover  hence "deg > 1"
      by (metis "5.hyps"(1) "5.hyps"(2) "5.hyps"(4) "5.hyps"(5) "5.hyps"(6) One_nat_def Suc_lessI add_Suc add_gr_0 add_self_div_2 deg_not_0 le_imp_less_Suc plus_1_eq_Suc set_n_deg_not_0)
    moreover have "high x (deg div 2)<2^m"
      by (metis "5.hyps"(5) "5.hyps"(6) div_eq_0_iff add_Suc_right add_self_div_2 assms(2) div_exp_eq even_Suc_div_two even_add high_def nat.simps(3) power_not_zero)
    moreover have "membermima  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                    \<Longrightarrow> membermima (Node info deg treeList summary) x" using membermima.simps(5)[of "deg-1" treeList summary x]
      by (smt "5.hyps"(12) "5.hyps"(4) Suc_diff_Suc calculation(2) calculation(3) diff_zero le_less_trans membermima.simps(4) zero_le_one)
    moreover have "naive_member  (treeList ! (high x (deg div 2))) (low x (deg div 2))
                     \<Longrightarrow> naive_member (Node info deg treeList summary) x"
      using "5.hyps"(4) "5.hyps"(5) "5.hyps"(6) calculation(3) by auto
    ultimately show ?case
      using both_member_options_def by blast
  qed
qed

lemma exp_split_high_low: assumes "x < 2^(n+m)" and "n > 0" and "m> 0"
  shows "high x n < 2^m" and "low x n < 2^n"
  using assms by (simp_all add: high_bound_aux low_def)

lemma low_inv: assumes "x< 2^n " shows "low (y*2^n + x) n = x" unfolding low_def
  by (simp add: assms)

lemma high_inv: assumes "x< 2^n " shows "high (y*2^n + x) n = y" unfolding high_def
  by (simp add: assms)

lemma both_member_options_from_chilf_to_complete_tree:
  assumes "high x (deg div 2) < length treeList" and "deg \<ge>1" and "both_member_options (treeList ! ( high x (deg div 2))) (low x (deg div 2))"
  shows "both_member_options (Node (Some (mi, ma)) deg treeList summary) x"
proof-
  have "membermima (treeList ! ( high x (deg div 2))) (low x (deg div 2)) \<or>
        naive_member (treeList ! ( high x (deg div 2))) (low x (deg div 2))" using assms
    using both_member_options_def by blast
  moreover  have "membermima (treeList ! ( high x (deg div 2))) (low x (deg div 2)) \<Longrightarrow>
        membermima (Node (Some (mi, ma)) deg treeList summary) x"
    using membermima.simps(4)[of mi ma "deg-1" treeList summary x]
    by (metis Suc_1 Suc_leD assms(1) assms(2) le_add_diff_inverse plus_1_eq_Suc)
  moreover have "naive_member (treeList ! ( high x (deg div 2))) (low x (deg div 2)) \<Longrightarrow>
        naive_member (Node (Some (mi, ma)) deg treeList summary) x"
    using naive_member.simps(3)[of "Some (mi, ma)" "deg-1" treeList summary x]
    by (metis Suc_1 Suc_leD assms(1) assms(2) le_add_diff_inverse plus_1_eq_Suc)
  ultimately show ?thesis
    using both_member_options_def by blast
qed

lemma both_member_options_from_complete_tree_to_child:
  assumes "deg \<ge>1" and  "both_member_options (Node (Some (mi, ma)) deg treeList summary) x"
  shows "both_member_options (treeList ! ( high x (deg div 2))) (low x (deg div 2)) \<or> x = mi \<or> x = ma"
proof-
  have "naive_member (Node (Some (mi, ma)) deg treeList summary) x \<or>
       membermima (Node (Some (mi, ma)) deg treeList summary) x "
    using assms(2) both_member_options_def by auto
  moreover have " naive_member (Node (Some (mi, ma)) deg treeList summary) x
                   \<Longrightarrow> naive_member (treeList ! ( high x (deg div 2))) (low x (deg div 2))"
    using naive_member.simps(3)[of "Some (mi, ma)" "deg-1" treeList summary x]
    by (metis assms(1) le_add_diff_inverse plus_1_eq_Suc)
  moreover have " membermima (Node (Some (mi, ma)) deg treeList summary) x
                  \<Longrightarrow> membermima (treeList ! ( high x (deg div 2))) (low x (deg div 2))\<or> x = mi \<or> x = ma"
    by (smt (z3) assms(1) le_add_diff_inverse membermima.simps(4) plus_1_eq_Suc)
  ultimately show ?thesis
    using both_member_options_def by presburger
qed

lemma pow_sum: "(divide::nat \<Rightarrow> nat \<Rightarrow> nat) ((2::nat) ^((a::nat)+(b::nat))) (2^a) = 2^b"
  by (induction a) simp+

fun elim_dead::"VEBT \<Rightarrow> enat \<Rightarrow> VEBT" where
"elim_dead (Leaf a b) _ = Leaf a b "|
"elim_dead (Node info deg treeList summary) \<infinity> =
 (Node info deg (map (\<lambda> t. elim_dead t (enat (2^(deg div 2)))) treeList)
 (elim_dead summary \<infinity>))"|
"elim_dead  (Node info deg treeList summary) (enat l) =
 (Node info deg (take (l div (2^(deg div 2))) (map (\<lambda> t. elim_dead t (enat (2^(deg div 2))))treeList))
                       (elim_dead summary ((enat (l div (2^(deg div 2))))))) "

lemma elimnum: "invar_vebt (Node info deg treeList summary) n \<Longrightarrow>
     elim_dead (Node info deg treeList summary) (enat ((2::nat)^n)) = (Node info deg treeList summary)"
proof(induction rule: invar_vebt.induct)
  case (1 a b)
  then show ?case
    by simp
next
  case (2 treeList n summary m deg)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "2.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      using "2.IH"(1) by blast
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (simp add: "2.IH"(1) map_idI)
  have "deg div 2 = n"
    by (simp add: "2.hyps"(3) "2.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "2.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "2"(4) by simp
  moreover hence " ( elim_dead summary ((enat ((2^deg) div (2^(deg div 2)))))) = summary"
    using "2.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(3)[of None deg treeList summary "2^deg"]
    using \<open>deg div 2 = n\<close> by metis
next
  case (3 treeList n summary m deg)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "3.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      using "3.IH"(1) by blast
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (simp add: "3.IH"(1) map_idI)
  have "deg div 2 = n"
    by (simp add: "3.hyps"(3) "3.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "3.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "3"(4) by simp
  moreover hence " ( elim_dead summary ((enat ((2^deg) div (2^(deg div 2)))))) = summary" using "3.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(3)[of None deg treeList summary "2^deg"]
    using \<open>deg div 2 = n\<close> by metis
next
  case (4 treeList n summary m deg mi ma)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "4.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      using "4.IH"(1) by blast
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (simp add: "4.IH"(1) map_idI)
  have "deg div 2 = n"
    by (simp add: "4.hyps"(3) "4.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "4.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "4"(4) by simp
  moreover hence " ( elim_dead summary ((enat ((2^deg) div (2^(deg div 2)))))) = summary" using "4.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(3)[of "Some (mi, ma)" deg treeList summary "2^deg"]
    using \<open>deg div 2 = n\<close> by metis
next
  case (5 treeList n summary m deg mi ma)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "5.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      using "5.IH"(1) by blast
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (simp add: "5.IH"(1) map_idI)
  have "deg div 2 = n"
    by (simp add: "5.hyps"(3) "5.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "5.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "5"(4) by simp
  moreover hence " ( elim_dead summary ((enat ((2^deg) div (2^(deg div 2)))))) = summary" using "5.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(3)[of "Some (mi, ma)" deg treeList summary "2^deg"]
    using \<open>deg div 2 = n\<close> by metis
qed

lemma elimcomplete: "invar_vebt (Node info deg treeList summary) n \<Longrightarrow>
      elim_dead (Node info deg treeList summary) \<infinity> = (Node info deg treeList summary)"
proof(induction rule: invar_vebt.induct)
  case (1 a b)
  then show ?case
    by simp
next
  case (2 treeList n summary m deg)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "2.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      apply(cases "(treeList ! i)")
       apply (smt (z3) "2.IH"(1) \<open>treeList ! i \<in> set treeList\<close> elim_dead.simps(1) elimnum invar_vebt.cases)+
      done
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (metis "2.hyps"(2) in_set_conv_nth map_idI)
  have "deg div 2 = n"
    by (simp add: "2.hyps"(3) "2.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "2.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "2"(4) by simp
  moreover hence " ( elim_dead summary \<infinity>) = summary" using "2.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(2)[of None  deg treeList summary]
    using \<open>deg div 2 = n\<close> b by presburger
next
  case (3 treeList n summary m deg)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "3.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      apply(cases "(treeList ! i)")
       apply (smt (z3) "3.IH"(1) \<open>treeList ! i \<in> set treeList\<close> elim_dead.simps(1) elimnum invar_vebt.cases)+
      done
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (metis "3.hyps"(2) in_set_conv_nth map_idI)
  have "deg div 2 = n"
    by (simp add: "3.hyps"(3) "3.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "3.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "3"(4) by simp
  moreover hence " ( elim_dead summary \<infinity>) = summary" using "3.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(2)[of None  deg treeList summary]
    using \<open>deg div 2 = n\<close> b by presburger
next
  case (4 treeList n summary m deg mi ma)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "4.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      apply(cases "(treeList ! i)")
       apply (smt (z3) "4.IH"(1) \<open>treeList ! i \<in> set treeList\<close> elim_dead.simps(1) elimnum invar_vebt.cases)+
      done
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (metis "4.hyps"(2) in_set_conv_nth map_idI)
  have "deg div 2 = n"
    by (simp add: "4.hyps"(3) "4.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "4.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "4"(4) by simp
  moreover hence " ( elim_dead summary \<infinity>) = summary" using "4.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(2)[of "Some (mi, ma)"  deg treeList summary]
    using \<open>deg div 2 = n\<close> b by presburger
next
  case (5 treeList n summary m deg mi ma)
  have a:"i < 2^m \<longrightarrow> (elim_dead (treeList ! i) (enat( 2^n)) = treeList ! i)" for i
  proof
    assume  "i < 2^m"
    hence "treeList ! i \<in> set treeList"
      by (simp add: "5.hyps"(2))
    thus "elim_dead (treeList ! i) (enat (2 ^ n)) = treeList ! i"
      apply(cases "(treeList ! i)")
       apply (smt (z3) "5.IH"(1) \<open>treeList ! i \<in> set treeList\<close> elim_dead.simps(1) elimnum invar_vebt.cases)+
      done
  qed
  hence b:"map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList = treeList"
    by (metis "5.hyps"(2) in_set_conv_nth map_idI)
  have "deg div 2 = n"
    by (simp add: "5.hyps"(3) "5.hyps"(4))
  hence "(2^m ::nat) = ( (2^deg) div (2^(deg div 2))::nat) "
    using "5.hyps"(4) pow_sum by metis
  hence "take (2^deg div (2^(deg div 2)))(map (\<lambda> t. elim_dead t (enat (2 ^ n))) treeList) = treeList"
    using b "5"(4) by simp
  moreover hence " ( elim_dead summary \<infinity>) = summary" using "5.IH"(2)
    by (metis \<open>2 ^ m = 2 ^ deg div 2 ^ (deg div 2)\<close>)
  ultimately show ?case using  elim_dead.simps(2)[of "Some (mi, ma)"  deg treeList summary]
    using \<open>deg div 2 = n\<close> b by presburger
qed

end
end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Injections from A to B\<close>

theory Twelvefold_Way_Entry2
imports Twelvefold_Way_Entry1
begin

text \<open>
Note that the cardinality theorems of both structures, distinct lists
and finite injective functions, are already available. Hence, this
development creates the bijection between those two structures and
transfers the one cardinality theorem to the other structures and vice
versa, although not strictly needed as both cardinality theorems were
already available.
\<close>

subsection \<open>Properties for Bijections\<close>

lemma inj_on_implies_distinct:
  assumes "bij_betw enum {0..<card A} A"
  assumes "f \<in> A \<rightarrow>\<^sub>E B"
  assumes "inj_on f A"
  shows "distinct (sequence_of A enum f)"
proof -
  {
    fix i j
    assume bounds: "i < length (sequence_of A enum f)" "j < length (sequence_of A enum f)"
    assume "i \<noteq> j"
    from bounds assms(1, 2) have bounds': "i < card A" "j < card A"
      using length_sequence_of by fastforce+
    from this assms(1) have in_A: "enum i \<in> A" "enum j \<in> A"
      using bij_betwE by fastforce+
    from \<open>i \<noteq> j\<close>  bounds' assms(1) have "enum i \<noteq> enum j"
      by (metis bij_betw_inv_into_left lessThan_iff atLeast0LessThan)
    from this have "f (enum i) \<noteq> f (enum j)"
      using assms(3) in_A inj_onD by fastforce
    from this bounds' have "sequence_of A enum f ! i \<noteq> sequence_of A enum f ! j"
      by (simp add: nth_sequence_of)
  }
  from this show ?thesis
    by (auto simp add: distinct_conv_nth)
qed

lemma distinct_implies_inj_on:
  assumes "bij_betw enum {0..<card A} A"
  assumes "length xs = card A"
  assumes "distinct xs"
  shows "inj_on (function_of A enum xs) A"
proof (rule inj_onI)
  let ?idx_of = "\<lambda>x. inv_into {0..<length xs} enum x"
  fix x y
  assume "x \<in> A" "y \<in> A" "function_of A enum xs x = function_of A enum xs y"
  from this have "xs ! ?idx_of x = xs ! ?idx_of y"
    unfolding function_of_def by simp
  have "?idx_of x = ?idx_of y"
  proof -
    have "?idx_of x < length xs"
      using \<open>x \<in> A\<close> assms(1,2)
      by (metis atLeast0LessThan bij_betw_imp_surj_on inv_into_into lessThan_iff)
    moreover have "?idx_of y < length xs"
      using \<open>y \<in> A\<close> assms(1,2)
      by (metis atLeast0LessThan bij_betw_imp_surj_on inv_into_into lessThan_iff)
    moreover note \<open>xs ! ?idx_of x = xs ! ?idx_of y\<close> \<open>distinct xs\<close>
    ultimately show ?thesis
      by (auto dest: nth_eq_iff_index_eq[where i="?idx_of x" and j="?idx_of y"])
  qed
  from this \<open>bij_betw _ _ _\<close> show "x = y"
    by (metis \<open>x \<in> A\<close> \<open>y \<in> A\<close> \<open>length xs = card A\<close> bij_betw_inv_into_right)
qed

lemma image_sequence_of_inj:
  assumes "bij_betw enum {0..<card A} A"
  shows "sequence_of A enum ` {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} \<subseteq> {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
proof
  fix xs
  assume "xs \<in> sequence_of A enum ` {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
  from this obtain f where xs: "xs = sequence_of A enum f" and f: "f \<in> A \<rightarrow>\<^sub>E B" "inj_on f A" by auto
  moreover from xs f \<open>bij_betw _ _ _\<close> have "set xs \<subseteq> B"
    using set_sequence_of subsetCE by blast
  moreover from xs f \<open>bij_betw _ _ _\<close> have "length xs = card A"
    using length_sequence_of by auto
  moreover from xs f \<open>bij_betw _ _ _\<close> have "distinct xs"
    using inj_on_implies_distinct by simp
  ultimately show "xs \<in> {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}" by auto
qed

lemma image_function_of_distinct:
  assumes "bij_betw enum {0..<card A} A"
  shows "function_of A enum ` {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
proof
  fix f
  assume f: "f \<in> function_of A enum ` {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
  from f assms have "f \<in> A \<rightarrow>\<^sub>E B"
    using function_of_in_extensional_funcset by blast
  moreover from f assms have "inj_on f A"
    by (auto simp add: assms distinct_implies_inj_on)
  ultimately show "f \<in> {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}" by auto
qed

subsection \<open>Bijections\<close>

lemma bij_betw_sequence_of:
  assumes "bij_betw enum {0..<card A} A"
  shows "bij_betw (sequence_of A enum) {f. f \<in> A \<rightarrow>\<^sub>E B \<and> inj_on f A} {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
proof (rule bij_betw_byWitness[where f'="function_of A enum"])
  show "\<forall>f\<in>{f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}. function_of A enum (sequence_of A enum f) = f"
    using assms by (auto simp add: function_of_sequence_of)
  show "\<forall>xs\<in>{xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}. sequence_of A enum (function_of A enum xs) = xs"
    using assms by (auto simp add: sequence_of_function_of)
  show "sequence_of A enum ` {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} \<subseteq> {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
    using assms by (simp add: image_sequence_of_inj)
  show "function_of A enum ` {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
    using assms by (simp add: image_function_of_distinct)
qed

lemma bij_betw_function_of:
  assumes "bij_betw enum {0..<card A} A"
  shows "bij_betw (function_of A enum) {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
proof (rule bij_betw_byWitness[where f'="sequence_of A enum"])
  show "\<forall>f\<in>{f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}. function_of A enum (sequence_of A enum f) = f"
    using assms by (auto simp add: function_of_sequence_of)
  show "\<forall>xs\<in>{xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}. sequence_of A enum (function_of A enum xs) = xs"
    using assms by (auto simp add: sequence_of_function_of)
  show "sequence_of A enum ` {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} \<subseteq> {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
    using assms by (simp add: image_sequence_of_inj)
  show "function_of A enum ` {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
    using assms by (simp add: image_function_of_distinct)
qed

subsection \<open>Cardinality\<close>

lemma
  assumes "finite A" "finite B" "card A \<le> card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} = \<Prod>{card B - card A + 1..card B}"
proof -
  obtain enum where "bij_betw enum {0..<card A} A"
    using \<open>finite A\<close> ex_bij_betw_nat_finite by blast
  have "bij_betw (sequence_of A enum) {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
    using \<open>bij_betw enum {0..<card A} A\<close> by (rule bij_betw_sequence_of)
  from this have "card {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} = card {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs}"
    by (rule bij_betw_same_card)
  also have "card {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} = card {xs. length xs = card A \<and> distinct xs \<and> set xs \<subseteq> B}"
    by meson
  also have "card {xs. length xs = card A \<and> distinct xs \<and> set xs \<subseteq> B} = \<Prod>{card B - card A + 1..card B}"
    using \<open>finite B\<close> \<open>card A \<le> card B\<close> by (rule List.card_lists_distinct_length_eq)
  finally show ?thesis .
qed

lemma card_sequences:
  assumes "finite A" "finite B" "card A \<le> card B"
  shows "card {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} = fact (card B) div fact (card B - card A)"
proof -
  obtain enum where "bij_betw enum {0..<card A} A"
    using \<open>finite A\<close> ex_bij_betw_nat_finite by blast
  have "bij_betw (function_of A enum) {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
    using \<open>bij_betw enum {0..<card A} A\<close> by (rule bij_betw_function_of)
  from this have "card {xs. set xs \<subseteq> B \<and> length xs = card A \<and> distinct xs} = card {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
    by (rule bij_betw_same_card)
  also have "card {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} = fact (card B) div fact (card B - card A)"
    using \<open>finite A\<close> \<open>finite B\<close> \<open>card A \<le> card B\<close> by (rule card_extensional_funcset_inj_on)
  finally show ?thesis .
qed

end


section \<open>Control Flow Graphs\<close>
theory CFG
imports "../Syntax/Program"
begin
  text \<open>As part of our semantics, we translate programs to control flow graphs,
    to reflect the meaning of the structured control commands.

    The nodes of the control flow graphs are commands, and the edges are
    labeled with syntactic labels, which are interpreted in a next step.

    Note that, by summarizing the CFG generation and interpretation of labels,
    one gets a standard small-step semantics, which we, however, consider less
    readable than this two-step approach via a CFG.
    \<close>

  datatype effect = Basic bcom | Func fcom | Skip
  hide_const (open) Basic Func Skip

  datatype guard = Pos exp | Neg exp
  hide_const (open) Pos Neg

  datatype label = Effect effect | Guard guard
  hide_const (open) Effect Guard

  context begin interpretation com_syntax .
    abbreviation "while_unfold_node b c \<equiv> IF b THEN (c;; WHILE b DO c) ELSE SKIP"
  end

  inductive cfg :: "com \<Rightarrow> label \<Rightarrow> com \<Rightarrow> bool" where
    basic: "cfg (com.Basic c) (label.Effect (effect.Basic c)) com.Skip"
  | func: "cfg (com.Func c) (label.Effect (effect.Func c)) com.Skip"
  | seq1: "cfg (com.Seq com.Skip c) (label.Effect effect.Skip) c"
  | seq2: "\<lbrakk> cfg c\<^sub>1 a c\<^sub>1' \<rbrakk> \<Longrightarrow> cfg (com.Seq c\<^sub>1 c\<^sub>2) a (com.Seq c\<^sub>1' c\<^sub>2)"
  | if_true: "cfg (com.If b c\<^sub>1 c\<^sub>2) (label.Guard (guard.Pos b)) c\<^sub>1"
  | if_false: "cfg (com.If b c\<^sub>1 c\<^sub>2) (label.Guard (guard.Neg b)) c\<^sub>2"
  | while: "cfg (com.While b c) (label.Effect effect.Skip) (while_unfold_node b c)"

  subsection \<open>Functional Version of CFG\<close>
  text \<open>We also formalize a functional version of the CFG, and show it equivalent with
    the relational version. This is required for both, animating the semantics,
    and simplifying some proofs like determinism.\<close>

  datatype edge = Effect effect com | Cond exp com com
  hide_const (open) Effect Cond

  primrec cfg_step :: "com \<Rightarrow> edge" where
    "cfg_step com.Skip = undefined"
  | "cfg_step (com.Basic c) = edge.Effect (effect.Basic c) com.Skip"
  | "cfg_step (com.Func c) = edge.Effect (effect.Func c) com.Skip"
  | "cfg_step (com.Seq c1 c2) = (
      if c1 = com.Skip then
        edge.Effect effect.Skip c2
      else
       (
        case cfg_step c1 of
          edge.Effect a c1' \<Rightarrow> edge.Effect a (com.Seq c1' c2)
        | edge.Cond e c11' c12' \<Rightarrow> edge.Cond e (com.Seq c11' c2) (com.Seq c12' c2)
      )
    )"
  | "cfg_step (com.If b c1 c2) = edge.Cond b c1 c2"
  | "cfg_step (com.While b c) = edge.Effect effect.Skip (while_unfold_node b c)"

  lemma step2cfg1:
    assumes "c\<noteq>com.Skip"
    assumes "cfg_step c = edge.Effect e c'"
    shows "cfg c (label.Effect e) c'"
    using assms
    apply (induction c arbitrary: e c')
    apply (auto intro: cfg.intros split: split_if_asm edge.splits)
    done

  lemma step2cfg2:
    assumes "c\<noteq>com.Skip"
    assumes "cfg_step c = edge.Cond e c1' c2'"
    shows "cfg c (label.Guard (guard.Pos e)) c1' \<and> cfg c ((label.Guard (guard.Neg e))) c2'"
    using assms
    apply (induction c arbitrary: e c1' c2')
    by (auto intro: cfg.intros split: edge.splits split_if_asm)

  lemma cfg2step:
    assumes "cfg c l c'"
    obtains e where "c\<noteq>com.Skip" "l=label.Effect e" "cfg_step c = edge.Effect e c'"
          | c2' b where "c\<noteq>com.Skip" "l=label.Guard (guard.Pos b)" "cfg_step c = edge.Cond b c' c2'"
          | c2' b where "c\<noteq>com.Skip" "l=label.Guard (guard.Neg b)" "cfg_step c = edge.Cond b c2' c'"
    using assms
    by induction auto

  subsection \<open>Meta-Theorems\<close>

  text \<open>We show that there is no label from the skip-node,
    and that each other node has exactly one or two outgoing labels,
    and if it is two outgoing labels, they are opposite guards: \<close>

  definition cfg_outgoing :: "com \<Rightarrow> (label \<times> com) set" where
    "cfg_outgoing c \<equiv> {(a,c'). cfg c a c'}"

  lemma cfg_outgoing_alt: "cfg_outgoing c = (
    if c=com.Skip then
      {}
    else
      (case cfg_step c of
        (edge.Effect e c') \<Rightarrow> {(label.Effect e, c')}
      | (edge.Cond e c1' c2') \<Rightarrow> {
          (label.Guard (guard.Pos e),c1'),
          (label.Guard (guard.Neg e),c2')
        }
      )
    )"
    by (auto simp: cfg_outgoing_def elim: cfg2step split: edge.splits
      dest: step2cfg1 step2cfg2)

  lemma skip_stuck_simp[simp]: "\<not>cfg com.Skip a c"
    by (auto elim: cfg.cases)

  lemma skip_stuck[simp]: "cfg_outgoing com.Skip = {}"
    unfolding cfg_outgoing_def by auto

  lemma cfg_outgoing_cases:
    obtains
      "c=com.Skip" "cfg_outgoing c = {}"
    | e c' where "c\<noteq>com.Skip" "cfg_outgoing c = {(label.Effect e,c')}"
    | b c\<^sub>1' c\<^sub>2' where "c\<noteq>com.Skip" "cfg_outgoing c =
      {(label.Guard (guard.Pos b),c\<^sub>1'), (label.Guard (guard.Neg b),c\<^sub>2')}"
    unfolding cfg_outgoing_alt
    by (fastforce split: edge.splits)

end