theory "Cardinality-Domain-Lists"
imports "../Launchbury/Vars" "../Launchbury/Nominal-HOLCF" "../Launchbury/Env" "Cardinality-Domain" "Set-Cpo" "Env-Set-Cpo"
begin

fun no_call_in_path where
  "no_call_in_path x [] \<longleftrightarrow> True"
 | "no_call_in_path x (y#xs) \<longleftrightarrow> y \<noteq> x \<and> no_call_in_path x xs"

fun one_call_in_path where
  "one_call_in_path x [] \<longleftrightarrow> True"
 | "one_call_in_path x (y#xs) \<longleftrightarrow> (if x = y then no_call_in_path x xs else one_call_in_path x xs)"

lemma no_call_in_path_set_conv:
  "no_call_in_path x p \<longleftrightarrow> x \<notin> set p"
  by(induction p) auto

lemma one_call_in_path_filter_conv:
  "one_call_in_path x p \<longleftrightarrow> length (filter (\<lambda> x'. x' = x) p) \<le> 1"
  by(induction p) (auto simp add: no_call_in_path_set_conv filter_empty_conv)

lemma no_call_in_tail: "no_call_in_path x (tl p) \<longleftrightarrow> (no_call_in_path x p \<or> one_call_in_path x p \<and> hd p = x)"
  by(induction p) auto

lemma no_imp_one: "no_call_in_path x p \<Longrightarrow> one_call_in_path x p"
  by (induction p) auto

lemma one_imp_one_tail: "one_call_in_path x p \<Longrightarrow> one_call_in_path x (tl p)"
  by (induction p) (auto split: if_splits intro: no_imp_one)

lemma more_than_one_setD:
  "\<not> one_call_in_path x p \<Longrightarrow> x \<in> set p"
  by (induction p) (auto split: if_splits)

lemma no_call_in_path[eqvt]: "no_call_in_path p x \<Longrightarrow> no_call_in_path (\<pi> \<bullet> p) (\<pi> \<bullet> x)"
  by (induction p x rule: no_call_in_path.induct) auto

lemma one_call_in_path[eqvt]: "one_call_in_path p x \<Longrightarrow> one_call_in_path (\<pi> \<bullet> p) (\<pi> \<bullet> x)"
  by (induction p x rule: one_call_in_path.induct) (auto dest: no_call_in_path)

definition pathCard :: "var list  \<Rightarrow> (var \<Rightarrow> two)"
  where "pathCard p x = (if no_call_in_path x p then none else (if one_call_in_path x p then once else many))"

lemma pathCard_Nil[simp]: "pathCard [] = \<bottom>"
   by rule (simp add: pathCard_def)

lemma pathCard_Cons[simp]: "pathCard (x#xs) x = two_add\<cdot>once\<cdot>(pathCard xs x)"
  unfolding pathCard_def
  by (auto simp add: two_add_simp)

lemma pathCard_Cons_other[simp]: "x' \<noteq> x \<Longrightarrow> pathCard (x#xs) x' = pathCard xs x'"
  unfolding pathCard_def by auto

lemma no_call_in_path_filter[simp]: "no_call_in_path x [x\<leftarrow>xs . x \<in> S] \<longleftrightarrow> no_call_in_path x xs \<or> x \<notin> S"
  by (induction xs) auto

lemma one_call_in_path_filter[simp]: "one_call_in_path x [x\<leftarrow>xs . x \<in> S] \<longleftrightarrow> one_call_in_path x xs \<or> x \<notin> S"
  by (induction xs) auto

definition pathsCard :: "var list set \<Rightarrow> (var \<Rightarrow> two)"
  where "pathsCard ps x = (if (\<forall> p \<in> ps. no_call_in_path x p) then none else (if (\<forall> p\<in>ps. one_call_in_path x p) then once else many))"

lemma paths_Card_above:
  "p \<in> ps \<Longrightarrow> pathCard p \<sqsubseteq> pathsCard ps"
  by (rule fun_belowI) (auto simp add: pathsCard_def pathCard_def)

lemma pathsCard_below:
  assumes  "\<And> p. p \<in> ps \<Longrightarrow> pathCard p \<sqsubseteq> ce"
  shows "pathsCard ps \<sqsubseteq> ce"
proof(rule fun_belowI)
  fix x
  show "pathsCard ps x \<sqsubseteq> ce x"
    by (auto simp add: pathsCard_def pathCard_def split: if_splits dest!: fun_belowD[OF assms, where x = x] elim: below_trans[rotated] dest: no_imp_one)
qed

lemma pathsCard_mono:
  "ps \<subseteq> ps' \<Longrightarrow> pathsCard ps \<sqsubseteq> pathsCard ps'"
  by (auto intro: pathsCard_below paths_Card_above)

lemmas pathsCard_mono' = pathsCard_mono[folded below_set_def]

lemma record_call_pathsCard:
  "pathsCard ({ tl p | p . p \<in> fs \<and> hd p = x}) \<sqsubseteq> record_call x\<cdot>(pathsCard fs)"
proof (rule pathsCard_below)
  fix p'
  assume "p' \<in> {tl p |p. p \<in> fs \<and> hd p = x}"
  then obtain p where "p' = tl p" and "p \<in> fs" and "hd p = x" by auto

  have "pathCard (tl p) \<sqsubseteq> record_call x\<cdot>(pathCard p)"
    apply (rule fun_belowI)
    using `hd p = x` by (auto simp add: pathCard_def record_call_simp no_call_in_tail dest: one_imp_one_tail)

  hence "pathCard (tl p) \<sqsubseteq> record_call x\<cdot>(pathsCard fs)"
    by (rule below_trans[OF _ monofun_cfun_arg[OF  paths_Card_above[OF `p \<in> fs`]]])
  thus "pathCard p' \<sqsubseteq> record_call x\<cdot>(pathsCard fs)" using `p' = _` by simp
qed

lemma pathCards_noneD:
  "pathsCard ps x = none \<Longrightarrow> x \<notin> \<Union>(set ` ps)"
  by (auto simp add: pathsCard_def no_call_in_path_set_conv split:if_splits)

lemma cont_pathsCard[THEN cont_compose, cont2cont, simp]:
  "cont pathsCard"
  by(fastforce intro!: cont2cont_lambda cont_if_else_above simp add: pathsCard_def below_set_def)

lemma pathsCard_eqvt[eqvt]: "\<pi> \<bullet> pathsCard ps x = pathsCard (\<pi> \<bullet> ps) (\<pi> \<bullet> x)"
  unfolding pathsCard_def by perm_simp rule

lemma edom_pathsCard[simp]: "edom (pathsCard ps) = \<Union>(set ` ps)"
  unfolding edom_def pathsCard_def
  by (auto simp add:  no_call_in_path_set_conv)

lemma env_restr_pathsCard[simp]: "pathsCard ps f|` S = pathsCard (filter (\<lambda> x. x \<in> S) ` ps)"
  by (auto simp add: pathsCard_def lookup_env_restr_eq)

end


(*<*)
theory Code_Double
  imports IEEE_Floating_Point.IEEE_Properties
    IEEE_Floating_Point.Conversion_IEEE_Float
    "HOL-Library.Code_Target_Int"
    Containers.Collection_Eq
    Containers.Collection_Order
begin
(*>*)

section \<open>Code adaptation for IEEE double-precision floats\<close>

subsection \<open>copysign\<close>

lift_definition copysign :: "('e, 'f) float \<Rightarrow> ('e, 'f) float \<Rightarrow> ('e, 'f) float" is
  "\<lambda>(_, e::'e word, f::'f word) (s::1 word, _, _). (s, e, f)" .

subsection \<open>Additional lemmas about generic floats\<close>

lemma is_nan_some_nan[simp]: "is_nan (some_nan :: ('e, 'f) float)"
  unfolding some_nan_def
  by (rule someI[where x="Abs_float (0, -1 :: 'e word, 1)"])
    (auto simp add: is_nan_def exponent_def fraction_def emax_def Abs_float_inverse[simplified])

lemma not_is_nan_0[simp]: "\<not> is_nan 0"
  unfolding is_nan_def by (simp add: zero_simps)

lemma not_is_nan_1[simp]: "\<not> is_nan 1"
  unfolding is_nan_def by transfer simp

lemma is_nan_plus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x + y)"
  unfolding plus_float_def fadd_def by auto

lemma is_nan_minus: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x - y)"
  unfolding minus_float_def fsub_def by auto

lemma is_nan_times: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x * y)"
  unfolding times_float_def fmul_def by auto

lemma is_nan_divide: "is_nan x \<or> is_nan y \<Longrightarrow> is_nan (x / y)"
  unfolding divide_float_def fdiv_def by auto

lemma is_nan_float_sqrt: "is_nan x \<Longrightarrow> is_nan (float_sqrt x)"
  unfolding float_sqrt_def fsqrt_def by simp

lemma nan_fcompare: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare x y = Und"
  unfolding fcompare_def by simp

lemma nan_not_less: "is_nan x \<or> is_nan y \<Longrightarrow> \<not> x < y"
  unfolding less_float_def flt_def fcompare_def by simp

lemma nan_not_zero: "is_nan x \<Longrightarrow> \<not> is_zero x"
  unfolding is_nan_def is_zero_def by simp

lemma nan_not_infinity: "is_nan x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_nan_def is_infinity_def by simp

lemma zero_not_infinity: "is_zero x \<Longrightarrow> \<not> is_infinity x"
  unfolding is_zero_def is_infinity_def by simp

lemma zero_not_nan: "is_zero x \<Longrightarrow> \<not> is_nan x"
  unfolding is_zero_def is_nan_def by simp

lemma minus_one_power_one_word: "(-1 :: real) ^ unat (x :: 1 word) = (if unat x = 0 then 1 else -1)"
proof -
  have "unat x = 0 \<or> unat x = 1"
    using le_SucE[OF unat_one_word_le] by auto
  then show ?thesis by auto
qed

definition valofn :: "('e, 'f) float \<Rightarrow> real" where
  "valofn x = (2^exponent x / 2^bias TYPE(('e, 'f) float)) *
      (1 + real (fraction x) / 2^LENGTH('f))"

definition valofd :: "('e, 'f) float \<Rightarrow> real" where
  "valofd x = (2 / 2^bias TYPE(('e, 'f) float)) * (real (fraction x) / 2^LENGTH('f))"

lemma valof_alt: "valof x = (if exponent x = 0 then
    if sign x = 0 then valofd x else - valofd x
  else if sign x = 0 then valofn x else - valofn x)"
  unfolding valofn_def valofd_def
  by transfer (auto simp: minus_one_power_one_word unat_eq_0 field_simps)

lemma fraction_less_2p: "fraction (x :: ('e, 'f) float) < 2^LENGTH('f)"
  by transfer auto

lemma valofn_ge_0: "0 \<le> valofn x"
  unfolding valofn_def by simp

lemma valofn_ge_2p: "2^exponent (x :: ('e, 'f) float) / 2^bias TYPE(('e, 'f) float) \<le> valofn x"
  unfolding valofn_def by (simp add: field_simps)

lemma valofn_less_2p:
  fixes x :: "('e, 'f) float"
  assumes "exponent x < e"
  shows "valofn x < 2^e / 2^bias TYPE(('e, 'f) float)"
proof -
  have "1 + real (fraction x) / 2^LENGTH('f) < 2"
    by (simp add: fraction_less_2p)
  then have "valofn x < (2^exponent x / 2^bias TYPE(('e, 'f) float)) * 2"
    unfolding valofn_def by (simp add: field_simps)
  also have "... \<le> 2^e / 2^bias TYPE(('e, 'f) float)"
    using assms by (auto simp: less_eq_Suc_le field_simps elim: order_trans[rotated, OF exp_less])
  finally show ?thesis .
qed

lemma valofd_ge_0: "0 \<le> valofd x"
  unfolding valofd_def by simp

lemma valofd_less_2p: "valofd (x :: ('e, 'f) float) < 2 / 2^bias TYPE(('e, 'f) float)"
  unfolding valofd_def
  by (simp add: fraction_less_2p field_simps)

lemma valofn_le_imp_exponent_le:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x \<le> valofn y"
  shows "exponent x \<le> exponent y"
proof (rule ccontr)
  assume "\<not> exponent x \<le> exponent y"
  then have "valofn y < 2^exponent x / 2^bias TYPE(('e, 'f) float)"
    using valofn_less_2p[of y] by auto
  also have "... \<le> valofn x" by (rule valofn_ge_2p)
  finally show False using assms by simp
qed

lemma valofn_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofn x = valofn y"
  shows "exponent x = exponent y" "fraction x = fraction y"
proof -
  from assms show "exponent x = exponent y"
    by (auto intro!: antisym valofn_le_imp_exponent_le)
  with assms show "fraction x = fraction y"
    unfolding valofn_def by (simp add: field_simps)
qed

lemma valofd_eq:
  fixes x y :: "('e, 'f) float"
  assumes "valofd x = valofd y"
  shows "fraction x = fraction y"
  using assms unfolding valofd_def by (simp add: field_simps)

lemma is_zero_valof_conv: "is_zero x \<longleftrightarrow> valof x = 0"
  unfolding is_zero_def valof_alt
  using valofn_ge_2p[of x] by (auto simp: valofd_def field_simps dest: order.antisym)

lemma valofd_neq_valofn:
  fixes x y :: "('e, 'f) float"
  assumes "exponent y \<noteq> 0"
  shows "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x"
proof -
  have "valofd x < 2 / 2^bias TYPE(('e, 'f) float)" by (rule valofd_less_2p)
  also have "... \<le> 2 ^ IEEE.exponent y / 2 ^ bias TYPE(('e, 'f) IEEE.float)"
    using assms by (simp add: self_le_power field_simps)
  also have "... \<le> valofn y" by (rule valofn_ge_2p)
  finally show "valofd x \<noteq> valofn y" "valofn y \<noteq> valofd x" by simp_all
qed

lemma sign_gt_0_conv: "0 < sign x \<longleftrightarrow> sign x = 1"
  by (cases x rule: sign_cases) simp_all

lemma valof_eq:
  assumes "\<not> is_zero x \<or> \<not> is_zero y"
  shows "valof x = valof y \<longleftrightarrow> x = y"
proof
  assume *: "valof x = valof y"
  with assms have "valof y \<noteq> 0" by (simp add: is_zero_valof_conv)
  with * show "x = y"
    unfolding valof_alt
    using valofd_ge_0[of x] valofd_ge_0[of y] valofn_ge_0[of x] valofn_ge_0[of y]
    by (auto simp: valofd_neq_valofn sign_gt_0_conv split: if_splits
        intro!: float_eqI elim: valofn_eq valofd_eq)
qed simp

lemma zero_fcompare: "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> fcompare x y = ccode.Eq"
  unfolding fcompare_def by (simp add: zero_not_infinity zero_not_nan is_zero_valof_conv)

subsection \<open>Doubles with a unified NaN value\<close>

quotient_type double = "(11, 52) float" / "\<lambda>x y. is_nan x \<and> is_nan y \<or> x = y"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation double :: "{zero, one, plus, minus, uminus, times, ord}"
begin

lift_definition zero_double :: "double" is "0" .
lift_definition one_double :: "double" is "1" .

lift_definition plus_double :: "double \<Rightarrow> double \<Rightarrow> double" is plus
  by (auto simp: is_nan_plus)

lift_definition minus_double :: "double \<Rightarrow> double \<Rightarrow> double" is minus
  by (auto simp: is_nan_minus)

lift_definition uminus_double :: "double \<Rightarrow> double" is uminus
  by auto

lift_definition times_double :: "double \<Rightarrow> double \<Rightarrow> double" is times
  by (auto simp: is_nan_times)

lift_definition less_eq_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(\<le>)"
  by (auto simp: nan_not_le)

lift_definition less_double :: "double \<Rightarrow> double \<Rightarrow> bool" is "(<)"
  by (auto simp: nan_not_less)

instance ..

end

instantiation double :: inverse
begin

lift_definition divide_double :: "double \<Rightarrow> double \<Rightarrow> double" is divide
  by (auto simp: is_nan_divide)

definition inverse_double :: "double \<Rightarrow> double" where
  "inverse_double x = 1 div x"

instance ..

end

lift_definition sqrt_double :: "double \<Rightarrow> double" is float_sqrt
  by (auto simp: is_nan_float_sqrt)

no_notation plus_infinity ("\<infinity>")

lift_definition infinity :: "double" is plus_infinity .

lift_definition nan :: "double" is some_nan .

lift_definition is_zero :: "double \<Rightarrow> bool" is IEEE.is_zero
  by (auto simp: nan_not_zero)

lift_definition is_infinite :: "double \<Rightarrow> bool" is IEEE.is_infinity
  by (auto simp: nan_not_infinity)

lift_definition is_nan :: "double \<Rightarrow> bool" is IEEE.is_nan
  by auto

lemma is_nan_conv: "is_nan x \<longleftrightarrow> x = nan"
  by transfer auto

lift_definition copysign_double :: "double \<Rightarrow> double \<Rightarrow> double" is
  "\<lambda>x y. if IEEE.is_nan y then some_nan else copysign x y"
  by auto

text \<open>Note: @{const copysign_double} deviates from the IEEE standard in cases where
  the second argument is a NaN.\<close>

lift_definition fcompare_double :: "double \<Rightarrow> double \<Rightarrow> ccode" is fcompare
  by (auto simp: nan_fcompare)

lemma nan_fcompare_double: "is_nan x \<or> is_nan y \<Longrightarrow> fcompare_double x y = Und"
  by transfer (rule nan_fcompare)

consts compare_double :: "double \<Rightarrow> double \<Rightarrow> integer"

specification (compare_double)
  compare_double_less: "compare_double x y < 0 \<longleftrightarrow> is_nan x \<and> \<not> is_nan y \<or> fcompare_double x y = ccode.Lt"
  compare_double_eq: "compare_double x y = 0 \<longleftrightarrow> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Eq"
  compare_double_greater: "compare_double x y > 0 \<longleftrightarrow> \<not> is_nan x \<and> is_nan y \<or> fcompare_double x y = ccode.Gt"
  by (rule exI[where x="\<lambda>x y. if is_nan x then if is_nan y then 0 else -1
    else if is_nan y then 1 else (case fcompare_double x y of ccode.Eq \<Rightarrow> 0 | ccode.Lt \<Rightarrow> -1 | ccode.Gt \<Rightarrow> 1)"],
        transfer, auto simp: fcompare_def)

lemmas compare_double_simps = compare_double_less compare_double_eq compare_double_greater

lemma compare_double_le_0: "compare_double x y \<le> 0 \<longleftrightarrow>
  is_nan x \<or> fcompare_double x y \<in> {ccode.Eq, ccode.Lt}"
  by (rule linorder_cases[of "compare_double x y" 0]; simp)
    (auto simp: compare_double_simps nan_fcompare_double)

lift_definition double_of_integer :: "integer \<Rightarrow> double" is
  "\<lambda>x. zerosign 0 (intround To_nearest (int_of_integer x))" .

definition double_of_int where [code del]: "double_of_int x = double_of_integer (integer_of_int x)"

lift_definition integer_of_double :: "double \<Rightarrow> integer" is
  "\<lambda>x. if IEEE.is_nan x \<or> IEEE.is_infinity x then undefined
     else integer_of_int \<lfloor>valof (intround float_To_zero (valof x) :: (11, 52) float)\<rfloor>"
  by auto

definition int_of_double: "int_of_double x = int_of_integer (integer_of_double x)"

subsection \<open>Linear ordering\<close>

definition lcompare_double :: "double \<Rightarrow> double \<Rightarrow> integer" where
  "lcompare_double x y = (if is_zero x \<and> is_zero y then
      compare_double (copysign_double 1 x) (copysign_double 1 y)
    else compare_double x y)"

lemma fcompare_double_swap: "fcompare_double x y = ccode.Gt \<longleftrightarrow> fcompare_double y x = ccode.Lt"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_refl: "\<not> is_nan x \<Longrightarrow> fcompare_double x x = ccode.Eq"
  by transfer (auto simp: fcompare_def)

lemma fcompare_double_Eq1: "fcompare_double x y = ccode.Eq \<Longrightarrow> fcompare_double y z = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Eq2: "fcompare_double y z = ccode.Eq \<Longrightarrow> fcompare_double x y = c \<Longrightarrow> fcompare_double x z = c"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_Lt_trans: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y z = ccode.Lt \<Longrightarrow> fcompare_double x z = ccode.Lt"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma fcompare_double_eq: "\<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> fcompare_double x y = ccode.Eq \<Longrightarrow> x = y"
  by transfer (auto simp: fcompare_def valof_eq IEEE.is_infinity_def split: if_splits intro!: float_eqI)

lemma fcompare_double_Lt_asym: "fcompare_double x y = ccode.Lt \<Longrightarrow> fcompare_double y x = ccode.Lt \<Longrightarrow> False"
  by transfer (auto simp: fcompare_def split: if_splits)

lemma compare_double_swap: "0 < compare_double x y \<longleftrightarrow> compare_double y x < 0"
  by (auto simp: compare_double_simps fcompare_double_swap)

lemma compare_double_refl: "compare_double x x = 0"
  by (auto simp: compare_double_eq intro!: fcompare_double_refl)

lemma compare_double_trans: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y z \<le> 0 \<Longrightarrow> compare_double x z \<le> 0"
  by (fastforce simp: compare_double_le_0 nan_fcompare_double
      dest: fcompare_double_Eq1 fcompare_double_Eq2 fcompare_double_Lt_trans)

lemma compare_double_antisym: "compare_double x y \<le> 0 \<Longrightarrow> compare_double y x \<le> 0 \<Longrightarrow>
  \<not> is_zero x \<or> \<not> is_zero y \<Longrightarrow> x = y"
  unfolding compare_double_le_0
  by (auto simp: nan_fcompare_double is_nan_conv
      intro: fcompare_double_eq fcompare_double_eq[symmetric]
      dest: fcompare_double_Lt_asym)

lemma zero_compare_double_copysign: "compare_double (copysign_double 1 x) (copysign_double 1 y) \<le> 0 \<Longrightarrow>
  is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> compare_double x y \<le> 0"
  unfolding compare_double_le_0
  by transfer (auto simp: nan_not_zero zero_fcompare split: if_splits)

lemma is_zero_double_cases: "is_zero x \<Longrightarrow> (x = 0 \<Longrightarrow> P) \<Longrightarrow> (x = -0 \<Longrightarrow> P) \<Longrightarrow> P"
  by transfer (auto elim!: is_zero_cases)

lemma copysign_1_0[simp]: "copysign_double 1 0 = 1" "copysign_double 1 (-0) = -1"
  by (transfer, simp, transfer, auto)+

lemma is_zero_uminus_double[simp]: "is_zero (- x) \<longleftrightarrow> is_zero x"
  by transfer simp

lemma not_is_zero_one_double[simp]: "\<not> is_zero 1"
  by (transfer, unfold IEEE.is_zero_def, transfer, simp)

lemma uminus_one_neq_one_double[simp]: "- 1 \<noteq> (1 :: double)"
  by (transfer, transfer, simp)

definition lle_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lle_double x y \<longleftrightarrow> lcompare_double x y \<le> 0"

definition lless_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "lless_double x y \<longleftrightarrow> lcompare_double x y < 0"

lemma lcompare_double_ge_0: "lcompare_double x y \<ge> 0 \<longleftrightarrow> lle_double y x"
  unfolding lle_double_def lcompare_double_def
  using compare_double_swap not_less by auto

lemma lcompare_double_gt_0: "lcompare_double x y > 0 \<longleftrightarrow> lless_double y x"
  unfolding lless_double_def lcompare_double_def
  using compare_double_swap by auto

lemma lcompare_double_eq_0: "lcompare_double x y = 0 \<longleftrightarrow> x = y"
proof
  assume *: "lcompare_double x y = 0"
  show "x = y" proof (cases "is_zero x \<and> is_zero y")
    case True
    with * show ?thesis
      by (fastforce simp: lcompare_double_def compare_double_simps is_nan_conv
          elim: is_zero_double_cases dest!: fcompare_double_eq[rotated])
  next
    case False
    with * show ?thesis
      by (auto simp: lcompare_double_def linorder_not_less[symmetric] compare_double_swap
          intro!: compare_double_antisym)
  qed
next
  assume "x = y"
  then show "lcompare_double x y = 0"
    by (simp add: lcompare_double_def compare_double_refl)
qed

lemmas lcompare_double_0_folds = lle_double_def[symmetric] lless_double_def[symmetric]
  lcompare_double_ge_0 lcompare_double_gt_0 lcompare_double_eq_0

interpretation double_linorder: linorder lle_double lless_double
proof
  fix x y z :: double
  show "lless_double x y \<longleftrightarrow> lle_double x y \<and> \<not> lle_double y x"
    unfolding lless_double_def lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
  show "lle_double x x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_refl)
  show "lle_double x z" if "lle_double x y" and "lle_double y z"
    using that
    by (auto 0 3 simp: lle_double_def lcompare_double_def not_le compare_double_swap
        split: if_splits dest: compare_double_trans zero_compare_double_copysign
        zero_compare_double_copysign[OF less_imp_le] compare_double_antisym)
  show "x = y" if "lle_double x y" and "lle_double y x"
  proof (cases "is_zero x \<and> is_zero y")
    case True
    with that show ?thesis
      by (auto 0 3 simp: lle_double_def lcompare_double_def elim: is_zero_double_cases
          dest!: compare_double_antisym)
  next
    case False
    with that show ?thesis
      by (auto simp: lle_double_def lcompare_double_def elim!: compare_double_antisym)
  qed
  show "lle_double x y \<or> lle_double y x"
    unfolding lle_double_def lcompare_double_def
    by (auto simp: compare_double_swap not_le)
qed

instantiation double :: equal
begin

definition equal_double :: "double \<Rightarrow> double \<Rightarrow> bool" where
  "equal_double x y \<longleftrightarrow> lcompare_double x y = 0"

instance by intro_classes (simp add: equal_double_def lcompare_double_eq_0)

end

derive (eq) ceq double

definition comparator_double :: "double comparator" where
  "comparator_double x y = (let c = lcompare_double x y in
    if c = 0 then order.Eq else if c < 0 then order.Lt else order.Gt)"

lemma comparator_double: "comparator comparator_double"
  unfolding comparator_double_def
  by (auto simp: lcompare_double_0_folds split: if_splits intro!: comparator.intro)

local_setup \<open>
  Comparator_Generator.register_foreign_comparator @{typ double}
    @{term comparator_double}
    @{thm comparator_double}
\<close>

derive ccompare double

subsubsection \<open>Code setup\<close>

declare [[code drop:
      "0 :: double"
      "1 :: double"
      "plus :: double \<Rightarrow> _"
      "minus :: double \<Rightarrow> _"
      "uminus :: double \<Rightarrow> _"
      "times :: double \<Rightarrow> _"
      "less_eq :: double \<Rightarrow> _"
      "less :: double \<Rightarrow> _"
      "divide :: double \<Rightarrow> _"
      "Code_Evaluation.term_of :: double \<Rightarrow> _"
      sqrt_double infinity nan is_zero is_infinite is_nan copysign_double fcompare_double
      double_of_integer integer_of_double
      ]]

code_printing
  code_module FloatUtil \<rightharpoonup> (OCaml)
\<open>module FloatUtil : sig
  val iszero : float -> bool
  val isinfinite : float -> bool
  val isnan : float -> bool
  val copysign : float -> float -> float
  val compare : float -> float -> Z.t
end = struct
  let iszero x = (Stdlib.classify_float x = Stdlib.FP_zero);;
  let isinfinite x = (Stdlib.classify_float x = Stdlib.FP_infinite);;
  let isnan x = (Stdlib.classify_float x = Stdlib.FP_nan);;
  let copysign x y = if isnan y then Stdlib.nan else Stdlib.copysign x y;;
  let compare x y = Z.of_int (Stdlib.compare x y);;
end;;\<close>

code_reserved OCaml Stdlib FloatUtil

code_printing
  type_constructor double \<rightharpoonup> (OCaml) "float"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(~-.)"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(+.)"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.( *. )"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.('/.)"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.(-.)"
  | constant "0 :: double" \<rightharpoonup> (OCaml) "0.0"
  | constant "1 :: double" \<rightharpoonup> (OCaml) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<=)"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "Stdlib.(<)"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (OCaml) "Stdlib.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (OCaml) "Stdlib.infinity"
  | constant "nan :: double" \<rightharpoonup> (OCaml) "Stdlib.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (OCaml) "FloatUtil.isnan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (OCaml) "FloatUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "FloatUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (OCaml) "Z.to'_float"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (OCaml) "Z.of'_float"

ML \<open>
if Real.precision <> 53 then
  error "SML real type must be double precision for Eval code adaptation"
else ();

signature REALUTIL = sig
  val nan : real
  val iszero : real -> bool
  val isinfinite : real -> bool
  val copysign : real -> real -> real
  val compare : real -> real -> int
  val toInt : real -> int
  val toTerm : real -> term
end
structure RealUtil : REALUTIL = struct
  val nan = 1.0 / 0.0;
  fun iszero x = (Real.class x = IEEEReal.ZERO);
  fun isinfinite x = (Real.class x = IEEEReal.INF);
  fun copysign x y = if Real.isNan y then nan else Real.copySign (x, y);

  fun compare x y = (case Real.compare (x, y) of
      LESS => ~1
    | EQUAL => 0
    | GREATER => 1);

  fun toInt x = Real.toInt IEEEReal.TO_ZERO x;

  fun toTerm x =
    (case Real.class x of
      IEEEReal.NAN => @{const nan}
    | IEEEReal.INF => if Real.signBit x then @{term "- infinity"} else @{term "infinity"}
    | IEEEReal.ZERO => if Real.signBit x then @{term "-0 :: double"} else @{term "0 :: double"}
    | _ => case Real.toManExp x of {man = m, exp = e} =>
      let
        val i = Real.floor (m * Math.pow (2.0, 53.0));
        val e = e - 53;
      in
        @{term abs_double} $ (@{term "of_finite_Float :: Float.float \<Rightarrow> (11, 52) float"} $
          (@{term Float} $ HOLogic.mk_number @{typ int} i $ HOLogic.mk_number @{typ int} e))
      end);
end\<close>

code_printing
  type_constructor double \<rightharpoonup> (Eval) "real"
  | constant "uminus :: double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.~"
  | constant "(+) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.+ ((_), (_))"
  | constant "(*) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.* ((_), (_))"
  | constant "(/) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.'/ ((_), (_))"
  | constant "(-) :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.- ((_), (_))"
  | constant "0 :: double" \<rightharpoonup> (Eval) "0.0"
  | constant "1 :: double" \<rightharpoonup> (Eval) "1.0"
  | constant "(\<le>) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.<= ((_), (_))"
  | constant "(<) :: double \<Rightarrow> double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.< ((_), (_))"
  | constant "sqrt_double :: double \<Rightarrow> double" \<rightharpoonup> (Eval) "Math.sqrt"
  | constant "infinity :: double" \<rightharpoonup> (Eval) "Real.posInf"
  | constant "nan :: double" \<rightharpoonup> (Eval) "RealUtil.nan"
  | constant "is_zero :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "RealUtil.iszero"
  | constant "is_infinite :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "RealUtil.isinfinite"
  | constant "is_nan :: double \<Rightarrow> bool" \<rightharpoonup> (Eval) "Real.isNan"
  | constant "copysign_double :: double \<Rightarrow> double \<Rightarrow> double" \<rightharpoonup> (Eval) "RealUtil.copysign"
  | constant "compare_double :: double \<Rightarrow> double \<Rightarrow> integer" \<rightharpoonup> (Eval) "RealUtil.compare"
  | constant "double_of_integer :: integer \<Rightarrow> double" \<rightharpoonup> (Eval) "Real.fromInt"
  | constant "integer_of_double :: double \<Rightarrow> integer" \<rightharpoonup> (Eval) "RealUtil.toInt"
  | constant "Code_Evaluation.term_of :: double \<Rightarrow> term" \<rightharpoonup> (Eval) "RealUtil.toTerm"

hide_const (open) fcompare_double

(*<*)
end
(*>*)


theory While_Default
imports "HOL-Library.While_Combinator"
begin

context
  fixes d :: "'a"
  and b :: "'a \<Rightarrow> bool"
  and c :: "'a \<Rightarrow> 'a"
begin

definition while_default :: "'a \<Rightarrow> 'a" where
  "while_default s =
     (if \<forall>k. b ((c^^k) s) then d else the (while_option b c s))"

lemma while_default_code[code]:
   "while_default s = (if b s then while_default (c s) else s)"
proof (cases "\<forall>k. b ((c^^k) s)")
  case True
  moreover
  from spec[OF True, of "0"] have "b s" by simp_all
  moreover
  from spec[OF True, of "Suc m" for m] have "\<forall>k. b ((c^^k) (c s))"
    by (simp add: funpow_Suc_right del: funpow.simps(2))
  ultimately show ?thesis unfolding while_default_def by simp
next
  case False
  define k where "k = (LEAST k. \<not> b ((c ^^ k) s))"
  with False have k: "\<not> b ((c ^^ k) s)"
    "\<And>l. \<not> b ((c ^^ l) s) \<Longrightarrow> k \<le> l"
    by (auto intro!: LeastI_ex[of "\<lambda>k. \<not> b ((c ^^ k) s)"] Least_le)
  show ?thesis
  proof (cases k)
    case 0
    with k(1) have "\<not> b s" by auto
    with False show ?thesis by (auto simp add: while_default_def while_option_unfold)
  next
    case (Suc k)
    with k(2) have "b ((c ^^ 0) s)" by blast
    then have "b s" by simp
    with k(1) Suc False show ?thesis unfolding while_default_def
      by (subst while_option_unfold) (auto simp add: funpow_Suc_right simp del: funpow.simps(2))
  qed
qed

lemma while_default_rule:
  assumes c: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P (c s)"
  and t: "\<And>s. P s \<Longrightarrow> \<not> b s \<Longrightarrow> Q s"
  and s: "P s" and d: "Q d"
  shows "Q (while_default s)"
proof (cases "\<forall>k. b ((c^^k) s)")
  case False
  then obtain t where "while_option b c s = Some t" unfolding while_option_def by auto
  with False show ?thesis using while_option_rule[of P b c s t] while_option_stop[of b c s t] s c t
    by (auto simp add: while_default_def)
qed (simp add: while_default_def d t)

end

end


(*  Title:       Miscellanneous Definitions and Lemmas
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)

section \<open>Miscellanneous Definitions and Lemmas\<close>

theory Misc
imports Main "HOL-Library.Multiset" "HOL-Library.Subseq_Order"
begin
text_raw \<open>\label{thy:Misc}\<close>

text \<open>Here we provide a collection of miscellaneous definitions and helper lemmas\<close>

subsection "Miscellanneous (1)"
text \<open>This stuff is used in this theory itself, and thus occurs in first place. There is another ,,Miscellaneous''-section at the end of this theory\<close>
subsubsection "AC-operators"

text \<open>Locale to declare AC-laws as simplification rules\<close>
locale AC =
  fixes f
  assumes commute[simp]: "f x y = f y x"
  assumes assoc[simp]: "f (f x y) z = f x (f y z)"

lemma (in AC) left_commute[simp]: "f x (f y z) = f y (f x z)"
  by (simp only: assoc[symmetric]) simp

text \<open>Locale to define functions from surjective, unique relations\<close>
locale su_rel_fun =
  fixes F and f
  assumes unique: "\<lbrakk>(A,B)\<in>F; (A,B')\<in>F\<rbrakk> \<Longrightarrow> B=B'"
  assumes surjective: "\<lbrakk>!!B. (A,B)\<in>F \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  assumes f_def: "f A == THE B. (A,B)\<in>F"

lemma (in su_rel_fun) repr1: "(A,f A)\<in>F" proof (unfold f_def)
  obtain B where "(A,B)\<in>F" by (rule surjective)
  with theI[where P="\<lambda>B. (A,B)\<in>F", OF this] show "(A, THE x. (A, x) \<in> F) \<in> F" by (blast intro: unique)
qed

lemma (in su_rel_fun) repr2: "(A,B)\<in>F \<Longrightarrow> B=f A" using repr1
  by (blast intro: unique)

lemma (in su_rel_fun) repr: "(f A = B) = ((A,B)\<in>F)" using repr1 repr2
  by (blast)

subsection \<open>Abbreviations for list order\<close>

abbreviation ileq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  (infix "\<preceq>" 50) where
  "(\<preceq>) \<equiv> (\<le>)"

abbreviation ilt :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  (infix "\<prec>" 50) where
  "(\<prec>) \<equiv> (<)"

subsection \<open>Multisets\<close>

(*
  The following is a syntax extension for multisets. Unfortunately, it depends on a change in the Library/Multiset.thy, so it is commented out here, until it will be incorporated
  into Library/Multiset.thy by its maintainers.

  The required change in Library/Multiset.thy is removing the syntax for single:
     - single :: "'a => 'a multiset"    ("{#_#}")
     + single :: "'a => 'a multiset"

  And adding the following translations instead:

     + syntax
     + "_multiset" :: "args \<Rightarrow> 'a multiset" ("{#(_)#}")

     + translations
     +   "{#x, xs#}" == "{#x#} + {#xs#}"
     +   "{# x #}" == "single x"

  This translates "{# \<dots> #}" into a sum of singletons, that is parenthesized to the right. ?? Can we also achieve left-parenthesizing ??

*)

  (* Let's try what happens if declaring AC-rules for multiset union as simp-rules *)
(*declare union_ac[simp] -- don't do it !*)

subsubsection \<open>Case distinction\<close>

lemma multiset_induct'[case_names empty add]: "\<lbrakk>P {#}; \<And>M x. P M \<Longrightarrow> P ({#x#}+M)\<rbrakk> \<Longrightarrow> P M"
  by (induct rule: multiset_induct) (auto simp add: union_commute)

subsubsection \<open>Count\<close>
  lemma count_ne_remove: "\<lbrakk> x ~= t\<rbrakk> \<Longrightarrow> count S x = count (S-{#t#}) x"
    by (auto)
  lemma mset_empty_count[simp]: "(\<forall>p. count M p = 0) = (M={#})"
    by (auto simp add: multiset_eq_iff)

subsubsection \<open>Union, difference and intersection\<close>

  lemma size_diff_se: "\<lbrakk>t \<in># S\<rbrakk> \<Longrightarrow> size S = size (S - {#t#}) + 1" proof (unfold size_multiset_overloaded_eq)
    let ?SIZE = "sum (count S) (set_mset S)"
    assume A: "t \<in># S"
    from A have SPLITPRE: "finite (set_mset S) & {t}\<subseteq>(set_mset S)" by auto
    hence "?SIZE = sum (count S) (set_mset S - {t}) + sum (count S) {t}" by (blast dest: sum.subset_diff)
    hence "?SIZE = sum (count S) (set_mset S - {t}) + count (S) t" by auto
    moreover with A have "count S t = count (S-{#t#}) t + 1" by auto
    ultimately have D: "?SIZE = sum (count S) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (arith)
    moreover have "sum (count S) (set_mset S - {t}) = sum (count (S-{#t#})) (set_mset S - {t})" proof -
      have "ALL x:(set_mset S - {t}) . count S x = count (S-{#t#}) x" by (auto iff add: count_ne_remove)
      thus ?thesis by simp
    qed
    ultimately have D: "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (simp)
    moreover
    { assume CASE: "t \<notin># S - {#t#}"
      from CASE have "set_mset S - {t} = set_mset (S - {#t#})"
        by (simp add: at_most_one_mset_mset_diff)
      with CASE D have "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1"
        by (simp add: not_in_iff)
    }
    moreover
    { assume CASE: "t \<in># S - {#t#}"
      from CASE have 1: "set_mset S = set_mset (S-{#t#})"
        by (rule more_than_one_mset_mset_diff [symmetric])
      moreover from D have "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t} + 1" by simp
      moreover from SPLITPRE sum.subset_diff have "sum (count (S-{#t#})) (set_mset S) = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t}" by (blast)
      ultimately have "?SIZE = sum (count (S-{#t#})) (set_mset (S-{#t#})) + 1" by simp
    }
    ultimately show "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1" by blast
  qed

  (* TODO: Check whether this proof can be done simpler *)
  lemma mset_union_diff_comm: "t \<in># S \<Longrightarrow> T + (S - {#t#}) = (T + S) - {#t#}" proof -
    assume "t \<in># S"
    then obtain S' where S: "S = add_mset t S'"
      by (metis insert_DiffM)
    then show ?thesis
      by auto
  qed

  lemma mset_right_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># B)\<rbrakk> \<Longrightarrow> a\<in>#A"
    by (simp)
  lemma mset_left_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># A)\<rbrakk> \<Longrightarrow> a\<in>#B"
    by (simp)

  lemmas mset_cancel_union = mset_right_cancel_union mset_left_cancel_union

  lemma mset_right_cancel_elem: "\<lbrakk>a \<in># A+{#b#}; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
    apply(subgoal_tac "~(a \<in># {#b#})")
    apply(auto)
  done

  lemma mset_left_cancel_elem: "\<lbrakk>a \<in># {#b#}+A; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
    apply(subgoal_tac "~(a \<in># {#b#})")
    apply(auto)
  done

  lemmas mset_cancel_elem = mset_right_cancel_elem mset_left_cancel_elem

  lemma mset_diff_cancel1elem[simp]: "~(a \<in># B) \<Longrightarrow> {#a#}-B = {#a#}" proof -
    assume A: "~(a \<in># B)"
    hence "count ({#a#}-B) a = count ({#a#}) a" by (auto simp add: not_in_iff)
    moreover have "ALL e . e~=a \<longrightarrow> count ({#a#}-B) e = count ({#a#}) e" by auto
    ultimately show ?thesis by (auto simp add: multiset_eq_iff)
  qed

  (*lemma union_diff_assoc_se: "t \<in># B \<Longrightarrow> (A+B)-{#t#} = A + (B-{#t#})"
    by (auto iff add: multiset_eq_iff)
  lemma union_diff_assoc_se2: "t \<in># A \<Longrightarrow> (A+B)-{#t#} = (A-{#t#}) + B"
    by (auto iff add: multiset_eq_iff)
  lemmas union_diff_assoc_se = union_diff_assoc_se1 union_diff_assoc_se2*)

  lemma union_diff_assoc: "C-B={#} \<Longrightarrow> (A+B)-C = A + (B-C)"
    by (simp add: multiset_eq_iff)

  lemma mset_union_2_elem: "{#a#}+{#b#} = M + {#c#} \<Longrightarrow> {#a#}=M & b=c | a=c & {#b#}=M"
    by (auto simp: add_eq_conv_diff)

  lemma mset_un_cases[cases set, case_names left right]:
    "\<lbrakk>a \<in># A + B; a\<in>#A \<Longrightarrow> P; a\<in>#B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
    by (auto)

  lemma mset_unplusm_dist_cases[cases set, case_names left right]:
    assumes A: "add_mset s A = B+C"
    assumes L: "\<lbrakk>B=add_mset s (B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
    assumes R: "\<lbrakk>C=add_mset s (C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
    shows P
  proof -
    from A[symmetric] have "s \<in># B+C" by simp
    thus ?thesis proof (cases rule: mset_un_cases)
      case left hence 1: "B=add_mset s (B-{#s#})" by simp
      with A have "add_mset s A = add_mset s ((B-{#s#})+C)" by (simp add: union_ac)
      hence 2: "A = (B-{#s#})+C" by (simp)
      from L[OF 1 2] show ?thesis .
    next
      case right hence 1: "C=add_mset s (C-{#s#})" by simp
      with A have "add_mset s A = add_mset s (B+(C-{#s#}))" by (simp add: union_ac)
      hence 2: "A = B+(C-{#s#})" by (simp)
      from R[OF 1 2] show ?thesis .
    qed
  qed

  lemma mset_unplusm_dist_cases2[cases set, case_names left right]:
    assumes A: "B+C = add_mset s A"
    assumes L: "\<lbrakk>B=add_mset s (B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
    assumes R: "\<lbrakk>C=add_mset s (C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
    shows P
    using mset_unplusm_dist_cases[OF A[symmetric]] L R by blast

  lemma mset_single_cases[cases set, case_names loc env]:
    assumes A: "add_mset s c = add_mset r' c'"
    assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'={#s#}+(c'-{#s#}); c={#r'#}+(c-{#r'#}); c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
    shows "P"
  proof -
    { assume CASE: "s=r'"
      with A have "c=c'" by simp
      with CASE CASES have ?thesis by auto
    } moreover {
      assume CASE: "s\<noteq>r'"
      have "s\<in>#{#s#}+c" by simp
      with A have "s \<in># {#r'#} + c'" by simp
      with CASE have "s \<in># c'"
        by simp
      from insert_DiffM[OF this, symmetric] have 1: "c' = add_mset s (c' - {#s#})" .
      with A have "{#s#}+c = {#s#}+({#r'#}+(c' - {#s#}))" by (auto simp add: union_ac)
      hence 2: "c={#r'#}+(c' - {#s#})" by (auto)
      hence 3: "c-{#r'#} = (c' - {#s#})" by auto
      from 1 2 3 CASES have ?thesis by auto
    } ultimately show ?thesis by blast
  qed

  lemma mset_single_cases'[cases set, case_names loc env]:
    assumes A: "add_mset s c = add_mset r' c'"
    assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'={#s#}+cc; c={#r'#}+cc; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
    shows "P"
    using A  CASES by (auto elim!: mset_single_cases)

  lemma mset_single_cases2[cases set, case_names loc env]:
    assumes A: "add_mset s c = add_mset r' c'"
    assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'=(c'-{#s#})+{#s#}; c=(c-{#r'#})+{#r'#}; c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
    shows "P"
  proof -
    from A have "add_mset s c = add_mset r' c'" by simp
    thus ?thesis proof (cases rule: mset_single_cases)
      case loc with CASES show ?thesis by simp
    next
      case env with CASES show ?thesis by (simp add: union_ac)
    qed
  qed

  lemma mset_single_cases2'[cases set, case_names loc env]:
    assumes A: "add_mset s c = add_mset r' c'"
    assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'=cc+{#s#}; c=cc+{#r'#}; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
    shows "P"
    using A  CASES by (auto elim!: mset_single_cases2)

  lemma mset_un_single_un_cases [consumes 1, case_names left right]:
    assumes A: "add_mset a A = B + C"
      and CASES: "a \<in># B \<Longrightarrow> A = (B - {#a#}) + C \<Longrightarrow> P"
        "a \<in># C \<Longrightarrow> A = B + (C - {#a#}) \<Longrightarrow> P"
    shows P
  proof -
    have "a \<in># A+{#a#}" by simp
    with A have "a \<in># B+C" by auto
    thus ?thesis proof (cases rule: mset_un_cases)
      case left hence "B=B-{#a#}+{#a#}" by auto
      with A have "A+{#a#} = (B-{#a#})+C+{#a#}" by (auto simp add: union_ac)
      hence "A=(B-{#a#})+C" by simp
      with CASES(1)[OF left] show ?thesis by blast
    next
      case right hence "C=C-{#a#}+{#a#}" by auto
      with A have "A+{#a#} = B+(C-{#a#})+{#a#}" by (auto simp add: union_ac)
      hence "A=B+(C-{#a#})" by simp
      with CASES(2)[OF right] show ?thesis by blast
    qed
  qed

      (* TODO: Can this proof be done more automatically ? *)
  lemma mset_distrib[consumes 1, case_names dist]: assumes A: "(A::'a multiset)+B = M+N" "!!Am An Bm Bn. \<lbrakk>A=Am+An; B=Bm+Bn; M=Am+Bm; N=An+Bn\<rbrakk> \<Longrightarrow> P" shows "P"
  proof -
    have BN_MA: "B - N = M - A"
      by (metis (no_types) add_diff_cancel_right assms(1) union_commute)
    have H: "A = A\<inter># C + (A - C) \<inter># D" if "A + B = C + D" for A B C D :: "'a multiset"
      by (metis add.commute diff_intersect_left_idem mset_subset_eq_add_left subset_eq_diff_conv
          subset_mset.add_diff_inverse subset_mset.inf_absorb1 subset_mset.inf_le1 that)
    have A': "A = A\<inter># M + (A - M) \<inter># N"
      using A(1) H by blast
    moreover have B': "B = (B - N) \<inter># M + B\<inter># N"
      using A(1) H[of B A N M] by (auto simp: ac_simps)
    moreover have "M = A \<inter># M + (B - N) \<inter># M"
      using H[of M N A B] BN_MA[symmetric] A(1) by (metis (no_types) diff_intersect_left_idem
          diff_union_cancelR multiset_inter_commute subset_mset.diff_add subset_mset.inf.cobounded1
          union_commute)
    moreover have "N = (A - M) \<inter># N + B \<inter># N"
      by (metis A' assms(1) diff_union_cancelL inter_union_distrib_left inter_union_distrib_right
          mset_subset_eq_multiset_union_diff_commute subset_mset.inf.cobounded1 subset_mset.inf.commute)
    ultimately show P
      using A(2) by blast
  qed

subsubsection \<open>Singleton multisets\<close>

lemma mset_size_le1_cases[case_names empty singleton,consumes 1]: "\<lbrakk> size M \<le> Suc 0; M={#} \<Longrightarrow> P; !!m. M={#m#} \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (cases M) auto

lemma diff_union_single_conv2:
  "a \<in># J \<Longrightarrow> J + I - {#a#} = (J - {#a#}) + I"
  using diff_union_single_conv [of a J I]
  by (simp add: union_ac)

lemmas diff_union_single_convs = diff_union_single_conv diff_union_single_conv2

lemma mset_contains_eq: "(m \<in># M) = ({#m#}+(M-{#m#})=M)" proof (auto)
  assume "add_mset m (M - {#m#}) = M"
  moreover have "m \<in># {#m#} + (M - {#m#})" by simp
  ultimately show "m \<in># M" by simp
qed

subsubsection \<open>Pointwise ordering\<close>

  lemma mset_le_incr_right1: "(a::'a multiset)\<subseteq>#b \<Longrightarrow> a\<subseteq>#b+c" using mset_subset_eq_mono_add[of a b "{#}" c, simplified] .
  lemma mset_le_incr_right2: "(a::'a multiset)\<subseteq>#b \<Longrightarrow> a\<subseteq>#c+b" using mset_le_incr_right1
    by (auto simp add: union_commute)
  lemmas mset_le_incr_right = mset_le_incr_right1 mset_le_incr_right2

  lemma mset_le_decr_left1: "(a::'a multiset)+c\<subseteq>#b \<Longrightarrow> a\<subseteq>#b" using mset_le_incr_right1 mset_subset_eq_mono_add_right_cancel
    by blast
  lemma mset_le_decr_left2: "c+(a::'a multiset)\<subseteq>#b \<Longrightarrow> a\<subseteq>#b" using mset_le_decr_left1
    by (auto simp add: union_ac)
  lemma mset_le_add_mset_decr_left1: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b"
    by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
  lemma mset_le_add_mset_decr_left2: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> {#c#}\<subseteq>#b"
    by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)

  lemmas mset_le_decr_left = mset_le_decr_left1 mset_le_decr_left2 mset_le_add_mset_decr_left1
    mset_le_add_mset_decr_left2

  lemma mset_union_subset: "(A::'a multiset)+B \<subseteq># C \<Longrightarrow> A\<subseteq>#C \<and> B\<subseteq>#C"
    by (auto dest: mset_le_decr_left)

  lemma mset_le_add_mset: "add_mset x B \<subseteq># C \<Longrightarrow> {#x#}\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
    by (auto dest: mset_le_decr_left)

  lemma mset_le_subtract_left: "(A::'a multiset)+B \<subseteq># X \<Longrightarrow> B \<subseteq># X-A \<and> A\<subseteq>#X"
    by (auto dest: mset_le_subtract[of "A+B" "X" "A"] mset_union_subset)
  lemma mset_le_subtract_right: "(A::'a multiset)+B \<subseteq># X \<Longrightarrow> A \<subseteq># X-B \<and> B\<subseteq>#X"
    by (auto dest: mset_le_subtract[of "A+B" "X" "B"] mset_union_subset)

lemma mset_le_subtract_add_mset_left: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-{#x#} \<and> {#x#}\<subseteq>#X"
    by (auto dest: mset_le_subtract[of "add_mset x B" "X" "{#x#}"] mset_le_add_mset)

  lemma mset_le_subtract_add_mset_right: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> {#x#} \<subseteq># X-B \<and> B\<subseteq>#X"
    by (auto dest: mset_le_subtract[of "add_mset x B" "X" "B"] mset_le_add_mset)

  lemma mset_le_addE: "\<lbrakk> (xs::'a multiset) \<subseteq># ys; !!zs. ys=xs+zs \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" using mset_subset_eq_exists_conv
    by blast

  declare subset_mset.diff_add[simp, intro]

  lemma mset_2dist2_cases:
    assumes A: "{#a, b#} \<subseteq># A + B"
    assumes CASES: "{#a, b#} \<subseteq># A \<Longrightarrow> P" "{#a, b#} \<subseteq># B \<Longrightarrow> P"
      "a \<in># A \<Longrightarrow> b \<in># B \<Longrightarrow> P" "a \<in># B \<Longrightarrow> b \<in># A \<Longrightarrow> P"
    shows "P"
  proof -
    from A have "count A a + count B a \<ge> 1"
      "count A b + count B b \<ge> 1"
      using mset_subset_eq_count [of "{#a, b#}" "A + B" a] mset_subset_eq_count [of "{#a, b#}" "A + B" b]
      by (auto split: if_splits)
    then have B: "a \<in># A \<or> a \<in># B"
      "b \<in># A \<or> b \<in># B"
      by (auto simp add: not_in_iff Suc_le_eq)
    { assume C: "a \<in># A" "b \<in># A - {#a#}"
      with mset_subset_eq_mono_add [of "{#a#}" "{#a#}" "{#b#}" "A-{#a#}"]
      have "{#a, b#} \<subseteq># A" by (auto simp: add_mset_commute)
    } moreover {
      assume C: "a \<in># A" "b \<notin># A - {#a#}"
      with B A have "b \<in># B"
        by (auto simp: insert_subset_eq_iff diff_union_single_convs
            simp del: subset_mset.add_diff_assoc2)
    } moreover {
      assume C: "a \<notin># A" "b \<in># B - {#a#}"
      with A have "a \<in># B" using B by blast
      with C mset_subset_eq_mono_add [of "{#a#}" "{#a#}" "{#b#}" "B-{#a#}"]
      have "{#a, b#} \<subseteq># B" by (auto simp: add_mset_commute)
    } moreover {
      assume C: "a \<notin># A" "b \<notin># B - {#a#}"
      with A have "a \<in># B \<and> b \<in># A"
        apply (intro conjI)
         apply (auto dest!: mset_subset_eq_insertD simp: insert_union_subset_iff; fail)[]
        by (metis (no_types, lifting) B(1) add_mset_remove_trivial insert_DiffM2
            mset_diff_cancel1elem single_subset_iff subset_eq_diff_conv subset_mset.diff_diff_right
            union_single_eq_member)
    } ultimately show P using CASES by blast
  qed

  lemma mset_union_subset_s: "{#a#}+B \<subseteq># C \<Longrightarrow> a \<in># C \<and> B \<subseteq># C"
    by (drule mset_union_subset) simp

  lemma mset_le_single_cases[consumes 1, case_names empty singleton]: "\<lbrakk>M\<subseteq>#{#a#}; M={#} \<Longrightarrow> P; M={#a#} \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
    by (induct M) auto

  lemma mset_le_mono_add_single: "\<lbrakk>a \<in># ys; b \<in># ws\<rbrakk> \<Longrightarrow> {#a, b#} \<subseteq># ys + ws" using mset_subset_eq_mono_add[of "{#a#}" _ "{#b#}", simplified] by (simp add: add_mset_commute)

  lemma mset_size1elem: "\<lbrakk>size P \<le> 1; q \<in># P\<rbrakk> \<Longrightarrow> P={#q#}"
    by (auto elim: mset_size_le1_cases)
  lemma mset_size2elem: "\<lbrakk>size P \<le> 2; {#q#}+{#q'#} \<subseteq># P\<rbrakk> \<Longrightarrow> P={#q#}+{#q'#}"
    by (auto elim: mset_le_addE)

subsubsection \<open>Image under function\<close>

notation image_mset (infixr "`#" 90)

lemma mset_map_single_rightE[consumes 1, case_names orig]: "\<lbrakk>f `# P = {#y#}; !!x. \<lbrakk> P={#x#}; f x = y \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (cases P) auto

lemma mset_map_split_orig: "!!M1 M2. \<lbrakk>f `# P = M1+M2; !!P1 P2. \<lbrakk>P=P1+P2; f `# P1 = M1; f `# P2 = M2\<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  apply (induct P)
  apply fastforce
  apply (force elim!: mset_un_single_un_cases simp add: union_ac) (* TODO: This proof need's quite long. Try to write a faster one. *)
  done

lemma mset_map_id: "\<lbrakk>!!x. f (g x) = x\<rbrakk> \<Longrightarrow> f `# g `# X = X"
  by (induct X) auto

text \<open>The following is a very specialized lemma. Intuitively, it splits the original multiset\<close>
text \<open>The following is a very specialized   by a splitting of some pointwise supermultiset of its image.

  Application:
  This lemma came in handy when proving the correctness of a constraint system that collects at most k sized submultisets of the sets of spawned threads.
\<close>
lemma mset_map_split_orig_le: assumes A: "f `# P \<subseteq># M1+M2" and EX: "!!P1 P2. \<lbrakk>P=P1+P2; f `# P1 \<subseteq># M1; f `# P2 \<subseteq># M2\<rbrakk> \<Longrightarrow> Q" shows "Q"
  using A EX by (auto elim: mset_le_distrib mset_map_split_orig)

subsection \<open>Lists\<close>

subsubsection \<open>Reverse lists\<close>
  lemma list_rev_decomp[rule_format]: "l~=[] \<longrightarrow> (EX ll e . l = ll@[e])"
    apply(induct_tac l)
    apply(auto)
  done

  (* Was already there as rev_induct
  lemma list_rev_induct: "\<lbrakk>P []; !! l e . P l \<Longrightarrow> P (l@[e]) \<rbrakk> \<Longrightarrow> P l"
    by (blast intro: rev_induct)
  proof (induct l rule: measure_induct[of length])
    fix x :: "'a list"
    assume A: "\<forall>y. length y < length x \<longrightarrow> P [] \<longrightarrow> (\<forall>x xa. P (x::'a list) \<longrightarrow> P (x @ [xa])) \<longrightarrow> P y" "P []" and IS: "\<And>l e. P l \<Longrightarrow> P (l @ [e])"
    show "P x" proof (cases "x=[]")
      assume "x=[]" with A show ?thesis by simp
    next
      assume CASE: "x~=[]"
      then obtain xx e where DECOMP: "x=xx@[e]" by (blast dest: list_rev_decomp)
      hence LEN: "length xx < length x" by auto
      with A IS have "P xx" by auto
      with IS have "P (xx@[e])" by auto
      with DECOMP show ?thesis by auto
    qed
  qed
  *)

  text \<open>Caution: Same order of case variables in snoc-case as @{thm [source] rev_exhaust}, the other way round than @{thm [source] rev_induct} !\<close>
  lemma length_compl_rev_induct[case_names Nil snoc]: "\<lbrakk>P []; !! l e . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (l@[e])\<rbrakk> \<Longrightarrow> P l"
    apply(induct_tac l rule: length_induct)
    apply(case_tac "xs" rule: rev_cases)
    apply(auto)
  done

  lemma list_append_eq_Cons_cases: "\<lbrakk>ys@zs = x#xs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
    by (auto iff add: append_eq_Cons_conv)
  lemma list_Cons_eq_append_cases: "\<lbrakk>x#xs = ys@zs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
    by (auto iff add: Cons_eq_append_conv)

subsubsection "folding"

text "Ugly lemma about foldl over associative operator with left and right neutral element"
lemma foldl_A1_eq: "!!i. \<lbrakk> !! e. f n e = e; !! e. f e n = e; !!a b c. f a (f b c) = f (f a b) c \<rbrakk> \<Longrightarrow> foldl f i ww = f i (foldl f n ww)"
proof (induct ww)
  case Nil thus ?case by simp
next
  case (Cons a ww i) note IHP[simplified]=this
  have "foldl f i (a # ww) = foldl f (f i a) ww" by simp
  also from IHP have "\<dots> = f (f i a) (foldl f n ww)" by blast
  also from IHP(4) have "\<dots> = f i (f a (foldl f n ww))" by simp
  also from IHP(1)[OF IHP(2,3,4), where i=a] have "\<dots> = f i (foldl f a ww)" by simp
  also from IHP(2)[of a] have "\<dots> = f i (foldl f (f n a) ww)" by simp
  also have "\<dots> = f i (foldl f n (a#ww))" by simp
  finally show ?case .
qed

lemmas foldl_conc_empty_eq = foldl_A1_eq[of "(@)" "[]", simplified]
lemmas foldl_un_empty_eq = foldl_A1_eq[of "(\<union>)" "{}", simplified, OF Un_assoc[symmetric]]

lemma foldl_set: "foldl (\<union>) {} l = \<Union>{x. x\<in>set l}"
  apply (induct l)
  apply simp_all
  apply (subst foldl_un_empty_eq)
  apply auto
  done

subsubsection \<open>Miscellaneous\<close>
  lemma length_compl_induct[case_names Nil Cons]: "\<lbrakk>P []; !! e l . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (e#l)\<rbrakk> \<Longrightarrow> P l"
    apply(induct_tac l rule: length_induct)
    apply(case_tac "xs")
    apply(auto)
  done

  text \<open>Simultaneous induction over two lists, prepending an element to one of the lists in each step\<close>
  lemma list_2pre_induct[case_names base left right]: assumes BASE: "P [] []" and LEFT: "!!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2" and RIGHT: "!!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2')" shows "P w1 w2"
  proof -
    { \<comment> \<open>The proof is done by induction over the sum of the lengths of the lists\<close>
      fix n
      have "!!w1 w2. \<lbrakk>length w1 + length w2 = n; P [] []; !!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2; !!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2') \<rbrakk> \<Longrightarrow> P w1 w2 "
        apply (induct n)
        apply simp
        apply (case_tac w1)
        apply auto
        apply (case_tac w2)
        apply auto
        done
    } from this[OF _ BASE LEFT RIGHT] show ?thesis by blast
  qed

  lemma list_decomp_1: "length l=1 \<Longrightarrow> EX a . l=[a]"
    by (case_tac l, auto)

  lemma list_decomp_2: "length l=2 \<Longrightarrow> EX a b . l=[a,b]"
    by (case_tac l, auto simp add: list_decomp_1)

  lemma drop_all_conc: "drop (length a) (a@b) = b"
    by (simp)

  lemma list_rest_coinc: "\<lbrakk>length s2 <= length s1; s1@r1 = s2@r2\<rbrakk> \<Longrightarrow> EX r1p . r2=r1p@r1"
  proof -
    assume A: "length s2 <= length s1" "s1@r1 = s2@r2"
    hence "r1 = drop (length s1) (s2@r2)" by (auto simp only:drop_all_conc dest: sym)
    moreover from A have "length s1 = length s1 - length s2 + length s2" by arith
    ultimately have "r1 = drop ((length s1 - length s2)) r2" by (auto)
    hence "r2 = take ((length s1 - length s2)) r2 @ r1" by auto
    thus ?thesis by auto
  qed

  lemma list_tail_coinc: "n1#r1 = n2#r2 \<Longrightarrow> n1=n2 & r1=r2"
    by (auto)

  lemma last_in_set[intro]: "\<lbrakk>l\<noteq>[]\<rbrakk> \<Longrightarrow> last l \<in> set l"
    by (induct l) auto

subsection \<open>Induction on nat\<close>
  lemma nat_compl_induct[case_names 0 Suc]: "\<lbrakk>P 0; !! n . ALL nn . nn <= n \<longrightarrow> P nn \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
    apply(induct_tac n rule: nat_less_induct)
    apply(case_tac n)
    apply(auto)
  done

subsection \<open>Functions of type @{typ "bool\<Rightarrow>bool"}\<close>
  lemma boolfun_cases_helper: "g=(\<lambda>x. False) | g=(\<lambda>x. x) | g=(\<lambda>x. True) | g= (\<lambda>x. \<not>x)"
  proof -
    { assume "g False" "g True"
      hence "g = (\<lambda>x. True)" by (rule_tac ext, case_tac x, auto)
    } moreover {
      assume "g False" "\<not>g True"
      hence "g = (\<lambda>x. \<not>x)" by (rule_tac ext, case_tac x, auto)
    } moreover {
      assume "\<not>g False" "g True"
      hence "g = (\<lambda>x. x)" by (rule_tac ext, case_tac x, auto)
    } moreover {
      assume "\<not>g False" "\<not>g True"
      hence "g = (\<lambda>x. False)" by (rule_tac ext, case_tac x, auto)
    } ultimately show ?thesis by fast
  qed

  lemma boolfun_cases[case_names False Id True Neg]: "\<lbrakk>g=(\<lambda>x. False) \<Longrightarrow> P g; g=(\<lambda>x. x) \<Longrightarrow> P g; g=(\<lambda>x. True) \<Longrightarrow> P g; g=(\<lambda>x. \<not>x) \<Longrightarrow> P g\<rbrakk> \<Longrightarrow> P g"
  proof -
    note boolfun_cases_helper[of g]
    moreover assume "g=(\<lambda>x. False) \<Longrightarrow> P g" "g=(\<lambda>x. x) \<Longrightarrow> P g" "g=(\<lambda>x. True) \<Longrightarrow> P g" "g=(\<lambda>x. \<not>x) \<Longrightarrow> P g"
    ultimately show ?thesis by fast
  qed

  subsection \<open>Definite and indefinite description\<close>
  text "Combined definite and indefinite description for binary predicate"
  lemma some_theI: assumes EX: "\<exists>a b . P a b" and BUN: "!! b1 b2 . \<lbrakk>\<exists>a . P a b1; \<exists>a . P a b2\<rbrakk> \<Longrightarrow> b1=b2"
    shows "P (SOME a . \<exists>b . P a b) (THE b . \<exists>a . P a b)"
  proof -
    from EX have "EX b . P (SOME a . EX b . P a b) b" by (rule someI_ex)
    moreover from EX have "EX b . EX a . P a b" by blast
    with BUN theI'[of "\<lambda>b . EX a . P a b"] have "EX a . P a (THE b . EX a . P a b)" by (unfold Ex1_def, blast)
    moreover note BUN
    ultimately show ?thesis by (fast)
  qed

end


section \<open> Simple Buffer in UTP CSP \<close>

theory utp_csp_buffer
  imports "UTP1-Circus.utp_circus_easy_parser"
begin

subsection \<open> Definitions \<close>

text \<open> A stateful CSP (Circus) process is parametrised over two alphabets: one for the state-space,
  which consists of the state variables, and one for events, which consists of channels. We first
  define the statespace using the \textbf{alphabet} command. The single state variable $buf$ is
  a list of natural numbers that is currently in the buffer. \<close>

alphabet st_buffer =
  buff :: "nat list"
  val  :: "nat"

text \<open> Channels are created using the \textbf{datatype} command. In this case we can either input
  a value to go in the buffer, or output one presently in the buffer. \<close>

chantype ch_buffer =
  inp :: nat
  outp :: nat

text \<open> We create a useful type to describe an action of the buffer as a CSP action parametrised
  by the state and event alphabet. \<close>

type_synonym act_buffer = "(st_buffer, ch_buffer) action"

text \<open> We define an action that initialises the buffer state by setting it to empty. \<close>

abbreviation Init :: act_buffer where
"Init \<equiv> buff :=\<^sub>C []"

text \<open> We define the main body of behaviour for the buffer as an abbreviation. We can either
  input a value and then place it into the buffer, or else, provided that the buffer is non-empty,
  we can output a value presently in the buffer. \<close>

utp_lift_notation chan_apply (0)

abbreviation DoBuff :: act_buffer where
"DoBuff \<equiv> (inp?(val) ;; buff := buff @ [val]
           \<box> (length(&buff) > 0) && outp!(hd(buff)) ;; buff := tl(buff))"

text \<open> The main action of the buffer first initialises the single state variable $buff$, and
  enters a recursive loop where it does \emph{DoBuff} over and over. \<close>

definition Buffer :: act_buffer where
[rdes_def]: "Buffer = Init ;; while true do DoBuff od"

subsection \<open> Calculations \<close>

text \<open> The @{term Init} action is represented by a simple contract with a true precondition,
  false pericondition (i.e. there is no intermediate behaviour), and finally sets the state
  variable to be empty, whilst leaving the state unchanged. There are no constraints on
  the initial state. \<close>

lemma Init_contract:
  "Init = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> false \<diamondop> \<Phi>(true,[&buff \<mapsto>\<^sub>s []],\<guillemotleft>[]\<guillemotright>))"
  by (rdes_simp)

lemma DoBuff_contract:
  "DoBuff = \<^bold>R\<^sub>s (true\<^sub>r \<turnstile>
                \<E>(true, \<guillemotleft>[]\<guillemotright>, (\<Sqinter> x \<bullet> {(inp\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u}\<^sub>u) \<union>\<^sub>u ({(outp\<cdot>(hd(&buff)))\<^sub>u}\<^sub>u \<triangleleft> U(0 < length(&buff)) \<triangleright> {}\<^sub>u)) \<diamondop>
                ((\<Sqinter> x \<bullet> \<Phi>(true,[&buff \<mapsto>\<^sub>s buff @ [\<guillemotleft>x\<guillemotright>], val \<mapsto>\<^sub>s \<guillemotleft>x\<guillemotright>],U([(inp\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u]))) \<or>
                 \<Phi>(U(0 < length(&buff)), [&buff \<mapsto>\<^sub>s tl(buff)], U([(outp\<cdot>(hd(&buff)))\<^sub>u]))))"
  by (rdes_eq)

lemma Buffer_contract:
  "Buffer = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> \<Phi>(true,[&buff \<mapsto>\<^sub>s []],\<guillemotleft>[]\<guillemotright>) ;;
                       ((\<Sqinter> x \<bullet> \<Phi>(true, [&buff \<mapsto>\<^sub>s buff @ [\<guillemotleft>x\<guillemotright>], val \<mapsto>\<^sub>s \<guillemotleft>x\<guillemotright>], U([(inp\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u]))) \<or>
                        \<Phi>(U(0 < length(&buff)), [&buff \<mapsto>\<^sub>s tl(buff)], U([(outp\<cdot>hd(&buff))\<^sub>u])))\<^sup>\<star>\<^sup>c ;;
                        \<E>(true,\<guillemotleft>[]\<guillemotright>, (\<Sqinter> x \<bullet> {(inp\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u}\<^sub>u) \<union>\<^sub>u ({(outp\<cdot>hd(&buff))\<^sub>u}\<^sub>u \<triangleleft> U(0 < length(&buff)) \<triangleright> {}\<^sub>u)) \<diamondop>
                       false)"
  unfolding Buffer_def DoBuff_contract by (rdes_simp)

subsection \<open> Verifications \<close>

text \<open> We first show that the buffer always outputs the same elements that were input first. \<close>

abbreviation "inps t \<equiv> [x. inp_C x \<leftarrow> t]"
abbreviation "outps t \<equiv> [x. outp_C x \<leftarrow> t]"

lemma P1_lemma:
  "[true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> (buff @ inps(\<guillemotleft>trace\<guillemotright>))) | false]\<^sub>C \<sqsubseteq> while\<^sub>C true do DoBuff od"
  apply (rdes_refine_split)
    apply (simp_all add: rpred closure usubst)
  apply (rule conjI)
   apply (rule crf_star_inductl)
    apply (simp add: closure)
   apply (rule RR_refine_intro)
  apply (simp_all add: closure)
   apply (rel_auto)
   apply (smt Prefix_Order.Cons_prefix_Cons Prefix_Order.prefix_Nil append_Cons append_Nil ch_buffer.simps(6) concat_map_maps hd_Cons_tl maps_simps(1) not_Cons_self2)
   apply (rule crf_star_inductl)
    apply (simp add: closure)
   apply (rule RR_refine_intro)
  apply (simp_all add: closure)
   apply (rel_auto)
    apply (smt Prefix_Order.Cons_prefix_Cons append.left_neutral append_Cons ch_buffer.simps(6) concat_map_maps hd_Cons_tl less_eq_list_def maps_simps(1) prefix_code(2))
done

lemma P1: "[true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> inps(\<guillemotleft>trace\<guillemotright>)) | false]\<^sub>C \<sqsubseteq> Buffer"
proof -
  have "[true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> inps(\<guillemotleft>trace\<guillemotright>)) | false]\<^sub>C
        \<sqsubseteq>
        Init ;; [true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> inps(\<guillemotleft>trace\<guillemotright>)) | false]\<^sub>C"
    by (rdes_refine)
  moreover have "Init ;; [true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> inps(\<guillemotleft>trace\<guillemotright>)) | false]\<^sub>C
                 \<sqsubseteq>
                 Init ;; [true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> (buff @ inps(\<guillemotleft>trace\<guillemotright>))) | false]\<^sub>C"
    by (rdes_refine)
  moreover have "Init ;; [true \<turnstile> U(outps(\<guillemotleft>trace\<guillemotright>) \<le> (buff @ inps(\<guillemotleft>trace\<guillemotright>))) | false]\<^sub>C
                 \<sqsubseteq>
                 Buffer"
    by (simp add: Buffer_def P1_lemma urel_dioid.mult_isol)
  ultimately show ?thesis
    by (simp)
qed

lemma Buffer_deadlock_free: "CDF \<sqsubseteq> Buffer"
  unfolding Buffer_def
  by (rdes_refine; blast)

end


theory ExampleContinuous
  imports BigStepParallel
begin

text \<open>Some common variables\<close>
definition X :: char where "X = CHR ''x''"
definition Y :: char where "Y = CHR ''y''"
definition Z :: char where "Z = CHR ''z''"

lemma vars_distinct [simp]: "X \<noteq> Y" "X \<noteq> Z" "Y \<noteq> Z" "Y \<noteq> X" "Z \<noteq> X" "Z \<noteq> Y"
  unfolding X_def Y_def Z_def by auto

subsection \<open>Examples of ODE\<close>

lemma example_ode:
  "\<Turnstile> {\<lambda>s tr. \<forall>s'. (ODE\<^sub>t (s(X := s X + 1)) ode b s' @- Q s') tr}
       X ::= (\<lambda>s. s X + 1); Cont ode b
      {Q}"
  apply (rule Valid_seq)
   prefer 2 apply (rule Valid_ode')
  by (rule Valid_assign)

lemma example_ode':
  "\<Turnstile> {\<lambda>s tr. s = st \<and> Q s tr}
        Cont ode b; X ::= (\<lambda>s. s X + 1)
      {\<lambda>s tr. \<exists>s'. s = s'(X := s' X + 1) \<and> (Q st @\<^sub>t ODE\<^sub>t st ode b s') tr}"
  apply (rule Valid_seq)
   apply (rule Valid_ode_sp_st)
  apply (rule Valid_strengthen_post)
   prefer 2 apply (rule Valid_assign_sp)
  apply (auto simp add: entails_def)
  subgoal for s tr x
    apply (rule exI[where x="s(X := x)"])
    by auto
  done

subsection \<open>Tests for ODE\<close>

text \<open>
  c ::= <x_dot = 1 & x < 1>
\<close>
lemma testHL12:
  assumes "a < 1"
  shows "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(X := a)) \<and> Q tr}
      Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>s. s X < 1)
    {\<lambda>s tr. s = ((\<lambda>_. 0)(X := 1)) \<and> (Q @\<^sub>t Wait\<^sub>t (1 - a) (\<lambda>t. State ((\<lambda>_. 0)(X := t + a))) ({}, {})) tr}"
proof -
  have 1: "ODEsol (ODE ((\<lambda>_ _. 0)(X := \<lambda>_. 1))) (\<lambda>t. (\<lambda>_. 0)(X := t + a)) (1 - a)"
     unfolding ODEsol_def solves_ode_def has_vderiv_on_def
     using assms apply auto
     apply (rule exI[where x="1"])
     apply auto
     apply (rule has_vector_derivative_projI)
     apply (auto simp add: state2vec_def)
     apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     by simp
  have 2: "local_lipschitz {- 1<..} UNIV (\<lambda>t v. ODE2Vec (ODE ((\<lambda>_ _. 0)(X := \<lambda>_. 1))) (vec2state v))"
  proof -
    have eq: "(\<chi> a. (if a = X then \<lambda>_. 1 else (\<lambda>_. 0)) (($) v)) = (\<chi> a. if a = X then 1 else 0)" for v::vec
      by auto
    show ?thesis
      unfolding fun_upd_def vec2state_def
      apply (auto simp add: state2vec_def eq)
      by (rule local_lipschitz_constI)
  qed
  show ?thesis
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_ode_unique_solution_st[OF _ 1 _ _ _ 2])
    using assms by (auto simp add: entails_def)
qed

subsection \<open>Test with ODE, loop and parallel\<close>

text \<open>
  The system to be analyzed is c1 || c2, where
    c1 ::= (<x_dot = 1 & x < 1>; ch1!x; ch2?x>)*
    c2 ::= (ch1?y; ch2!(y-1))*
\<close>

text \<open>
  For the left side, there are two cases for analyzing the loop body:
   - if initial value of x is less than 1 (testHL13a') and
   - if initial value of x is not less than 1 (testHL13a'').
\<close>
lemma testHL13a':
  assumes "a < 1"
  shows "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(X := a)) \<and> Q tr}
      Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>s. s X < 1);
      Cm (''ch1''[!](\<lambda>s. s X));
      Cm (''ch2''[?]X)
    {\<lambda>s tr. \<exists>v. s = (\<lambda>_. 0)(X := v) \<and>
            (Q @\<^sub>t Wait\<^sub>t (1 - a) (\<lambda>t. State ((\<lambda>_. 0)(X := t + a))) ({}, {})
               @\<^sub>t Out\<^sub>t (State ((\<lambda>_. 0)(X := 1))) ''ch1'' 1
               @\<^sub>t In\<^sub>t (State ((\<lambda>_. 0)(X := 1))) ''ch2'' v) tr}"
proof -
  have 1: "ODEsol (ODE ((\<lambda>_ _. 0)(X := \<lambda>_. 1))) (\<lambda>t. (\<lambda>_. 0)(X := t + a)) (1 - a)"
     unfolding ODEsol_def solves_ode_def has_vderiv_on_def
     using assms apply auto
     apply (rule exI[where x="1"])
     apply auto
     apply (rule has_vector_derivative_projI)
     apply (auto simp add: state2vec_def)
     apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     by simp
  have 2: "local_lipschitz {- 1<..} UNIV (\<lambda>t v. ODE2Vec (ODE ((\<lambda>_ _. 0)(X := \<lambda>_. 1))) (vec2state v))"
  proof -
    have eq: "(\<chi> a. (if a = X then \<lambda>_. 1 else (\<lambda>_. 0)) (($) v)) = (\<chi> a. if a = X then 1 else 0)" for v::vec
      by auto
    show ?thesis
      unfolding fun_upd_def vec2state_def
      apply (auto simp add: state2vec_def eq)
      by (rule local_lipschitz_constI)
  qed
  show ?thesis
    apply (rule Valid_seq)
     apply (rule Valid_ode_unique_solution_st[OF _ 1 _ _ _ 2])
        using assms apply auto apply (rule Valid_seq)
     apply (rule Valid_send_sp_st)
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_receive_sp_st)
    by (auto simp add: entails_def join_assoc)
qed

lemma testHL13a'':
  assumes "\<not>a < 1"
  shows "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(X := a)) \<and> Q tr}
      Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>s. s X < 1);
      Cm (''ch1''[!](\<lambda>s. s X));
      Cm (''ch2''[?]X)
    {\<lambda>s tr. \<exists>v. s = (\<lambda>_. 0)(X := v) \<and>
            (Q @\<^sub>t Out\<^sub>t (State ((\<lambda>_. 0)(X := a))) ''ch1'' a
               @\<^sub>t In\<^sub>t (State ((\<lambda>_. 0)(X := a))) ''ch2'' v) tr}"
  apply (rule Valid_seq)
   apply (rule Valid_ode_exit_st)
  using assms apply auto[1]
  apply (rule Valid_seq)
  apply (rule Valid_send_sp_st)
  apply (rule Valid_strengthen_post)
   prefer 2 apply (rule Valid_receive_sp_st)
  by (auto simp add: entails_def join_assoc)

text \<open>
  Trace invariant to be satisfied by the left side.
  Here
   - a is the initial value of variable x,
   - vs is the list of values received from channel ch2.
\<close>
fun left_blocks :: "real \<Rightarrow> real list \<Rightarrow> tassn" where
  "left_blocks a [] = emp\<^sub>t"
| "left_blocks a (v # rest) =
    (if a < 1 then
       Wait\<^sub>t (1 - a) (\<lambda>t. State ((\<lambda>_. 0)(X := t + a))) ({}, {}) @\<^sub>t
       Out\<^sub>t (State ((\<lambda>_. 0)(X := 1))) ''ch1'' 1 @\<^sub>t
       In\<^sub>t (State ((\<lambda>_. 0)(X := 1))) ''ch2'' v @\<^sub>t left_blocks v rest
     else
       Out\<^sub>t (State ((\<lambda>_. 0)(X := a))) ''ch1'' a @\<^sub>t
       In\<^sub>t (State ((\<lambda>_. 0)(X := a))) ''ch2'' v @\<^sub>t left_blocks v rest)"

fun last_val :: "real \<Rightarrow> real list \<Rightarrow> real" where
  "last_val a [] = a"
| "last_val a (x # xs) = last_val x xs"

lemma last_val_snoc [simp]:
  "last_val a (xs @ [v]) = v"
  by (induct xs arbitrary: a, auto)

lemma left_blocks_snoc:
  "left_blocks a (vs @ [v]) =
    (if last_val a vs < 1 then
      left_blocks a vs @\<^sub>t
      Wait\<^sub>t (1 - last_val a vs) (\<lambda>t. State ((\<lambda>_. 0)(X := t + last_val a vs))) ({}, {}) @\<^sub>t
      Out\<^sub>t (State ((\<lambda>_. 0)(X := 1))) ''ch1'' 1 @\<^sub>t
      In\<^sub>t (State ((\<lambda>_. 0)(X := 1))) ''ch2'' v
    else
      left_blocks a vs @\<^sub>t
      Out\<^sub>t (State ((\<lambda>_. 0)(X := last_val a vs))) ''ch1'' (last_val a vs) @\<^sub>t
      In\<^sub>t (State ((\<lambda>_. 0)(X := last_val a vs))) ''ch2'' v)"
  apply (induct vs arbitrary: a)
  by (auto simp add: join_assoc)

lemma testHL13a:
  "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(X := a)) \<and> emp\<^sub>t tr}
      Rep (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>s. s X < 1);
           Cm (''ch1''[!](\<lambda>s. s X));
           Cm (''ch2''[?]X))
    {\<lambda>s tr. \<exists>vs. s = ((\<lambda>_. 0)(X := last_val a vs)) \<and> left_blocks a vs tr}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
  apply (rule Valid_ex_pre)
  subgoal for vs
    apply (cases "last_val a vs < 1")
    apply (rule Valid_strengthen_post)
      prefer 2 apply (rule testHL13a') apply auto[1]
    subgoal apply (auto simp add: entails_def)
      subgoal for tr v apply (rule exI[where x="vs@[v]"])
        by (auto simp add: left_blocks_snoc)
      done
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule testHL13a'') apply auto[1]
    apply (auto simp add: entails_def)
    subgoal for tr v apply (rule exI[where x="vs@[v]"])
      by (auto simp add: left_blocks_snoc)
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by (auto simp add: emp_assn_def)

text \<open>
  Trace invariant to be satisfied by the right side.
  Here
   - a is the initial value of variable y,
   - vs is the list of values received from channel ch1.
\<close>
fun right_blocks :: "real \<Rightarrow> real list \<Rightarrow> tassn" where
  "right_blocks a [] = emp\<^sub>t"
| "right_blocks a (v # rest) =
    In\<^sub>t (State ((\<lambda>_. 0)(Y := a))) ''ch1'' v @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(Y := v))) ''ch2'' (v - 1) @\<^sub>t
    right_blocks v rest"

lemma right_blocks_snoc:
  "right_blocks a (vs @ [v]) =
    right_blocks a vs @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(Y := last_val a vs))) ''ch1'' v @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(Y := v))) ''ch2'' (v - 1)"
  apply (induct vs arbitrary: a)
  by (auto simp add: join_assoc)

lemma testHL13b:
  "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(Y := a)) \<and> emp\<^sub>t tr}
      Rep (Cm (''ch1''[?]Y);
           Cm (''ch2''[!](\<lambda>s. s Y - 1)))
    {\<lambda>s tr. \<exists>ws. s = ((\<lambda>_. 0)(Y := last_val a ws)) \<and> right_blocks a ws tr}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
  apply (rule Valid_ex_pre)
  subgoal for ws
    apply (rule Valid_seq)
     apply (rule Valid_receive_sp_st)
    apply (rule Valid_ex_pre)
    subgoal for w
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_send_sp_st)
    apply (auto simp add: entails_def)
    subgoal for tr
      apply (rule exI[where x="ws@[w]"])
      by (auto simp add: right_blocks_snoc join_assoc)
    done
  done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by (auto simp add: emp_assn_def)

text \<open>
  Trace invariant for the overall system.
\<close>
fun tot_blocks :: "nat \<Rightarrow> tassn" where
  "tot_blocks 0 = emp\<^sub>t"
| "tot_blocks (Suc n) = (
    Wait\<^sub>t 1 (\<lambda>t. ParState (State ((\<lambda>_. 0)(X := t))) (State ((\<lambda>_. 0)(Y := 1)))) ({}, {''ch1''}) @\<^sub>t
    IO\<^sub>t ''ch1'' 1 @\<^sub>t IO\<^sub>t ''ch2'' 0 @\<^sub>t tot_blocks n)"

lemma combineHL13:
  "combine_assn {''ch1'', ''ch2''} (left_blocks 0 vs) (right_blocks 1 ws) \<Longrightarrow>\<^sub>t
   tot_blocks (length vs)"
proof (induct vs arbitrary: ws)
  case Nil
  then show ?case
  proof (cases ws)
    case Nil
    then show ?thesis by auto
  next
    case (Cons w ws')
    then show ?thesis
      by (auto simp add: combine_assn_emp_in)
  qed
next
  case (Cons a vs)
  note Cons1 = Cons
  then show ?case
  proof (cases ws)
    case Nil
    then show ?thesis
      apply auto
      apply (rule entails_tassn_trans)
       apply (rule combine_assn_wait_emp)
      by (rule false_assn_entails)
  next
    case (Cons b list)
    show ?thesis
      apply (auto simp add: Cons)
      apply (rule entails_tassn_trans)
       apply (rule combine_assn_wait_in)
         apply auto
      apply (rule entails_tassn_cancel_left)
      apply (rule entails_tassn_trans)
       apply (rule combine_assn_out_in)
       apply auto apply (rule entails_tassn_cancel_left)
      apply (rule entails_tassn_trans)
       apply (rule combine_assn_in_out)
       apply auto apply (rule entails_tassn_cancel_left)
      by (rule Cons1)
  qed
qed

lemma testHL13:
  "\<Turnstile>\<^sub>p
    {pair_assn (\<lambda>s. s = ((\<lambda>_. 0)(X := 0))) (\<lambda>s. s = ((\<lambda>_. 0)(Y := 1)))}
      Parallel
       (Single (Rep (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>s. s X < 1);
                Cm (''ch1''[!](\<lambda>s. s X));
                Cm (''ch2''[?]X)))) {''ch1'', ''ch2''}
       (Single (Rep (Cm (''ch1''[?]Y);
                Cm (''ch2''[!](\<lambda>s. s Y - 1)))))
    {\<exists>\<^sub>gn. trace_gassn (tot_blocks n)}"
  apply (rule ParValid_conseq')
    apply (rule ParValid_Parallel')
     apply (rule testHL13a)
    apply (rule testHL13b)
   apply (auto simp add: sing_gassn_ex sing_gassn_split)
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for vs ws
    unfolding sync_gassn_state_left sync_gassn_state_right
    apply (rule entails_ex_gassn)
    apply (rule exI[where x="length vs"])
    apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
    apply (rule entails_tassn_trans)
     prefer 2 apply (rule combineHL13)
    apply (rule combine_assn_mono)
    by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done

subsection \<open>Test with interrupt, loop and parallel\<close>

text \<open>
  The system to be analyzed is c1 || c2, where
    c1 ::= (<x_dot = 1 & True> |> [](ch1!x -> skip); ch2?x)*
    c2 ::= (wait 1; ch1?y; ch2!(y-1))*
\<close>

text \<open>
  For the left side, first anlyze the ODE with interrupt.
\<close>
lemma testHL14o:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(X := a) \<and> P tr}
      Interrupt (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>_. True)
                [(''ch1''[!](\<lambda>s. s X), Skip)]
    {\<lambda>s tr. \<exists>d. s = (\<lambda>_. 0)(X := d + a) \<and> (P @\<^sub>t WaitOut\<^sub>t d (\<lambda>t. (\<lambda>_. 0)(X := t + a)) ''ch1'' (\<lambda>s. s X) ({''ch1''}, {})) tr}"
proof -
  have 1: "ODEsolInf (ODE ((\<lambda>_ _. 0)(X := \<lambda>_. 1))) (\<lambda>t. (\<lambda>_. 0)(X := t + a))"
     unfolding ODEsolInf_def solves_ode_def has_vderiv_on_def
     apply auto
     apply (rule exI[where x="1"])
     apply auto
     apply (rule has_vector_derivative_projI)
     apply (auto simp add: state2vec_def)
     apply (rule has_vector_derivative_eq_rhs)
      apply (auto intro!: derivative_intros)[1]
     by simp
  have 2: "local_lipschitz {- 1<..} UNIV (\<lambda>t v. ODE2Vec (ODE ((\<lambda>_ _. 0)(X := \<lambda>_. 1))) (vec2state v))"
  proof -
    have eq: "(\<chi> a. (if a = X then \<lambda>_. 1 else (\<lambda>_. 0)) (($) v)) = (\<chi> a. if a = X then 1 else 0)" for v::vec
      by auto
    show ?thesis
      unfolding fun_upd_def vec2state_def
      apply (auto simp add: state2vec_def eq)
      by (rule local_lipschitz_constI)
  qed
  show ?thesis
    apply (rule Valid_strengthen_post)
     prefer 2 apply (rule Valid_ode_out_unique_solution[OF 1 _ _ 2])
    apply auto
     apply (rule Valid_skip) by auto
qed

text \<open>
  Trace invariant to be satisfied by the left side.
  Here
   - a is the initial value of variable x,
   - ps is a list of pairs (d, v), where d is delay and v is received value.
\<close>
fun ileft_blocks :: "real \<Rightarrow> (real \<times> real) list \<Rightarrow> tassn" where
  "ileft_blocks a [] = emp\<^sub>t"
| "ileft_blocks a ((d, v) # rest) =
   WaitOut\<^sub>t d (\<lambda>t. (\<lambda>_. 0)(X := t + a)) ''ch1'' (\<lambda>s. s X) ({''ch1''}, {}) @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(X := a + d))) ''ch2'' v @\<^sub>t
   ileft_blocks v rest"

fun last_ileft_blocks :: "real \<Rightarrow> (real \<times> real) list \<Rightarrow> real" where
  "last_ileft_blocks a [] = a"
| "last_ileft_blocks a ((d, v) # rest) = last_ileft_blocks v rest"

lemma ileft_blocks_snoc:
  "ileft_blocks a (ps @ [(d, v)]) =
   ileft_blocks a ps @\<^sub>t
     WaitOut\<^sub>t d (\<lambda>t. (\<lambda>_. 0)(X := t + last_ileft_blocks a ps)) ''ch1'' (\<lambda>s. s X) ({''ch1''}, {}) @\<^sub>t
     In\<^sub>t (State ((\<lambda>_. 0)(X := d + last_ileft_blocks a ps))) ''ch2'' v"
  apply (induct ps arbitrary: a)
  by (auto simp add: join_assoc add.commute)

lemma last_ileft_blocks_snoc [simp]:
  "last_ileft_blocks a (ps @ [(d, v)]) = v"
  apply (induct ps arbitrary: a) by auto

lemma testHL14a:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(X := a) \<and> emp\<^sub>t tr}
      Rep (Interrupt (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>_. True) [(''ch1''[!](\<lambda>s. s X), Skip)];
           Cm (''ch2''[?]X))
    {\<lambda>s tr. \<exists>ps. s = (\<lambda>_. 0)(X := last_ileft_blocks a ps) \<and> ileft_blocks a ps tr}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
   apply (rule Valid_ex_pre)
  subgoal for ps
    apply (rule Valid_seq)
     apply (rule testHL14o)
    apply (rule Valid_ex_pre)
    subgoal for d
      apply (rule Valid_strengthen_post)
       prefer 2 apply (rule Valid_receive_sp)
      apply (auto simp add: entails_def)
      subgoal for s tr x v
        apply (rule exI[where x="ps@[(d,v)]"])
        apply (auto simp add: conj_assn_def pure_assn_def ileft_blocks_snoc join_assoc)
        by (metis fun_upd_idem_iff fun_upd_upd)
      done
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by (auto simp add: emp_assn_def)

text \<open>
  Trace invariant to be satisfied by the right side.
  Here
   - a is the initial value of variable y,
   - vs is the list of values received from channel ch1.
\<close>
fun iright_blocks :: "real \<Rightarrow> real list \<Rightarrow> tassn" where
  "iright_blocks a [] = emp\<^sub>t"
| "iright_blocks a (v # rest) =
   Wait\<^sub>t 1 (\<lambda>t. State ((\<lambda>_. 0)(Y := a))) ({}, {}) @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(Y := a))) ''ch1'' v @\<^sub>t
   Out\<^sub>t (State ((\<lambda>_. 0)(Y := v))) ''ch2'' (v - 1) @\<^sub>t iright_blocks v rest"

fun last_iright_blocks :: "real \<Rightarrow> real list \<Rightarrow> real" where
  "last_iright_blocks a [] = a"
| "last_iright_blocks a (v # rest) = last_iright_blocks v rest"

lemma iright_blocks_snoc:
  "iright_blocks a (vs @ [v]) =
   iright_blocks a vs @\<^sub>t Wait\<^sub>t 1 (\<lambda>t. State ((\<lambda>_. 0)(Y := last_iright_blocks a vs))) ({}, {}) @\<^sub>t
   In\<^sub>t (State ((\<lambda>_. 0)(Y := last_iright_blocks a vs))) ''ch1'' v @\<^sub>t
   Out\<^sub>t (State ((\<lambda>_. 0)(Y := v))) ''ch2'' (v - 1)"
  apply (induct vs arbitrary: a)
  by (auto simp add: join_assoc)

lemma last_iright_blocks_snoc [simp]:
  "last_iright_blocks a (vs @ [v]) = v"
  apply (induct vs arbitrary: a) by auto

lemma testHL14b:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(Y := a) \<and> emp\<^sub>t tr}
      Rep (Wait (\<lambda>_. 1); Cm (''ch1''[?]Y); Cm (''ch2''[!](\<lambda>s. s Y - 1)))
    {\<lambda>s tr. \<exists>vs. s = (\<lambda>_. 0)(Y := last_iright_blocks a vs) \<and> iright_blocks a vs tr}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
   apply (rule Valid_ex_pre)
  subgoal for vs
    apply (rule Valid_seq)
    apply (rule Valid_wait_sp) apply simp
    apply (rule Valid_seq)
     apply (rule Valid_receive_sp)
    apply (intro Valid_ex_pre)
    subgoal for x v
      apply (rule Valid_strengthen_post)
       prefer 2 apply (rule Valid_send_sp)
      apply (auto simp add: entails_def)
      apply (rule exI[where x="vs@[v]"])
      apply (auto simp add: conj_assn_def pure_assn_def iright_blocks_snoc join_assoc)
       apply (metis fun_upd_idem fun_upd_upd)
      by (metis fun_upd_triv fun_upd_upd)
    done
  apply (auto simp add: entails_def)
  apply (rule exI[where x="[]"])
  by (auto simp add: emp_assn_def)

text \<open>
  Trace invariant for the overall system.
\<close>
fun tot_blocks2 :: "nat \<Rightarrow> tassn" where
  "tot_blocks2 0 = emp\<^sub>t"
| "tot_blocks2 (Suc n) = (
    Wait\<^sub>t 1 (\<lambda>t. ParState (State ((\<lambda>_. 0)(X := t))) (State ((\<lambda>_. 0)(Y := 1)))) ({''ch1''}, {}) @\<^sub>t
    IO\<^sub>t ''ch1'' 1 @\<^sub>t IO\<^sub>t ''ch2'' 0 @\<^sub>t tot_blocks2 n)"

lemma combineHL14:
  "combine_assn {''ch1'', ''ch2''} (ileft_blocks 0 ps) (iright_blocks 1 ws) \<Longrightarrow>\<^sub>t
   tot_blocks2 (length ps)"
proof (induct ps arbitrary: ws)
  case Nil
  then show ?case
  proof (cases ws)
    case Nil
    then show ?thesis by auto
  next
    case (Cons w ws')
    then show ?thesis
      apply auto
      apply (rule entails_tassn_trans)
      apply (rule combine_assn_emp_wait)
      by (rule false_assn_entails)
  qed
next
  case (Cons p ps')
  note Cons1 = Cons
  then show ?case
  proof (cases p)
    case (Pair d v)
    then show ?thesis
    proof (cases ws)
      case Nil
      then show ?thesis
        apply (auto simp add: Pair)
        apply (rule entails_tassn_trans)
        apply (rule combine_assn_waitout_emp)
        by auto
    next
      case (Cons a list)
      then show ?thesis
        apply (auto simp add: Pair)
        apply (rule entails_tassn_trans)
        apply (rule combine_assn_waitout_wait)
         apply auto
        apply (rule entails_tassn_cancel_left)
        apply (rule entails_tassn_trans)
        apply (rule combine_assn_waitout_in)
        apply auto
        apply (rule entails_tassn_cancel_left)
        apply (rule entails_tassn_trans)
         apply (rule combine_assn_in_out)
         apply auto
        apply (rule entails_tassn_cancel_left)
        by (rule Cons1)
    qed
  qed
qed

lemma testHL14:
  "\<Turnstile>\<^sub>p
    {pair_assn (\<lambda>s. s = ((\<lambda>_. 0)(X := 0))) (\<lambda>s. s = ((\<lambda>_. 0)(Y := 1)))}
     Parallel
      (Single (Rep (Interrupt (ODE ((\<lambda>_ _. 0)(X := (\<lambda>_. 1)))) (\<lambda>_. True) [(''ch1''[!](\<lambda>s. s X), Skip)];
               Cm (''ch2''[?]X)))) {''ch1'', ''ch2''}
      (Single (Rep (Wait (\<lambda>_. 1); Cm (''ch1''[?]Y); Cm (''ch2''[!](\<lambda>s. s Y - 1)))))
    {\<exists>\<^sub>g n. trace_gassn (tot_blocks2 n)}"
  apply (rule ParValid_conseq')
    apply (rule ParValid_Parallel')
     apply (rule testHL14a)
    apply (rule testHL14b)
   apply (auto simp add: sing_gassn_ex sing_gassn_split)
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for ps vs
    unfolding sync_gassn_state_left sync_gassn_state_right
    apply (rule entails_ex_gassn)
    apply (rule exI[where x="length ps"])
    apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
    apply (rule entails_tassn_trans)
    prefer 2 apply (rule combineHL14)
    apply (rule combine_assn_mono)
    by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done

end