(*  Author:  Florian Haftmann, TUM
*)

section \<open>Proof of concept for algebraically founded bit word types\<close>

theory Word_Type
  imports
    Main
    "~~/src/HOL/Library/Type_Length"
begin

subsection \<open>Truncating bit representations of numeric types\<close>

class semiring_bits = semiring_div_parity +
  assumes semiring_bits: "(1 + 2 * a) mod of_nat (2 * n) = 1 + 2 * (a mod of_nat n)"
begin

definition bitrunc :: "nat \<Rightarrow> 'a \<Rightarrow> 'a"
  where bitrunc_eq_mod: "bitrunc n a = a mod of_nat (2 ^ n)"

lemma bitrunc_bitrunc [simp]:
  "bitrunc n (bitrunc n a) = bitrunc n a"
  by (simp add: bitrunc_eq_mod)

lemma bitrunc_0 [simp]:
  "bitrunc 0 a = 0"
  by (simp add: bitrunc_eq_mod)

lemma bitrunc_Suc [simp]:
  "bitrunc (Suc n) a = bitrunc n (a div 2) * 2 + a mod 2"
proof -
  define b and c
    where "b = a div 2" and "c = a mod 2"
  then have a: "a = b * 2 + c"
    and "c = 0 \<or> c = 1"
    by (simp_all add: div_mult_mod_eq parity)
  from \<open>c = 0 \<or> c = 1\<close>
  have "bitrunc (Suc n) (b * 2 + c) = bitrunc n b * 2 + c"
  proof
    assume "c = 0"
    moreover have "(2 * b) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n)"
      by (simp add: mod_mult_mult1)
    ultimately show ?thesis
      by (simp add: bitrunc_eq_mod ac_simps)
  next
    assume "c = 1"
    with semiring_bits [of b "2 ^ n"] show ?thesis
      by (simp add: bitrunc_eq_mod ac_simps)
  qed
  with a show ?thesis
    by (simp add: b_def c_def)
qed

lemma bitrunc_of_0 [simp]:
  "bitrunc n 0 = 0"
  by (simp add: bitrunc_eq_mod)

lemma bitrunc_plus:
  "bitrunc n (bitrunc n a + bitrunc n b) = bitrunc n (a + b)"
  by (simp add: bitrunc_eq_mod mod_add_eq [symmetric])

lemma bitrunc_of_1_eq_0_iff [simp]:
  "bitrunc n 1 = 0 \<longleftrightarrow> n = 0"
  by (induct n) simp_all

end

instance nat :: semiring_bits
  by standard (simp add: mod_Suc Suc_double_not_eq_double)

instance int :: semiring_bits
  by standard (simp add: pos_zmod_mult_2)

lemma bitrunc_uminus:
  fixes k :: int
  shows "bitrunc n (- (bitrunc n k)) = bitrunc n (- k)"
  by (simp add: bitrunc_eq_mod mod_minus_eq [symmetric])

lemma bitrunc_minus:
  fixes k l :: int
  shows "bitrunc n (bitrunc n k - bitrunc n l) = bitrunc n (k - l)"
  by (simp add: bitrunc_eq_mod mod_diff_eq [symmetric])

lemma bitrunc_nonnegative [simp]:
  fixes k :: int
  shows "bitrunc n k \<ge> 0"
  by (simp add: bitrunc_eq_mod)

definition signed_bitrunc :: "nat \<Rightarrow> int \<Rightarrow> int"
  where signed_bitrunc_eq_bitrunc:
    "signed_bitrunc n k = bitrunc (Suc n) (k + 2 ^ n) - 2 ^ n"

lemma signed_bitrunc_eq_bitrunc':
  assumes "n > 0"
  shows "signed_bitrunc (n - Suc 0) k = bitrunc n (k + 2 ^ (n - 1)) - 2 ^ (n - 1)"
  using assms by (simp add: signed_bitrunc_eq_bitrunc)

lemma signed_bitrunc_0 [simp]:
  "signed_bitrunc 0 k = - (k mod 2)"
proof (cases "even k")
  case True
  then have "odd (k + 1)"
    by simp
  then have "(k + 1) mod 2 = 1"
    by (simp add: even_iff_mod_2_eq_zero)
  with True show ?thesis
    by (simp add: signed_bitrunc_eq_bitrunc)
next
  case False
  then show ?thesis
    by (simp add: signed_bitrunc_eq_bitrunc odd_iff_mod_2_eq_one)
qed

lemma signed_bitrunc_Suc [simp]:
  "signed_bitrunc (Suc n) k = signed_bitrunc n (k div 2) * 2 + k mod 2"
  using zero_not_eq_two by (simp add: signed_bitrunc_eq_bitrunc algebra_simps)

lemma signed_bitrunc_of_0 [simp]:
  "signed_bitrunc n 0 = 0"
  by (simp add: signed_bitrunc_eq_bitrunc bitrunc_eq_mod)

lemma signed_bitrunc_of_minus_1 [simp]:
  "signed_bitrunc n (- 1) = - 1"
  by (induct n) simp_all

lemma signed_bitrunc_eq_iff_bitrunc_eq:
  assumes "n > 0"
  shows "signed_bitrunc (n - Suc 0) k = signed_bitrunc (n - Suc 0) l \<longleftrightarrow> bitrunc n k = bitrunc n l" (is "?P \<longleftrightarrow> ?Q")
proof -
  from assms obtain m where m: "n = Suc m"
    by (cases n) auto
  show ?thesis
  proof
    assume ?Q
    have "bitrunc (Suc m) (k + 2 ^ m) =
      bitrunc (Suc m) (bitrunc (Suc m) k + bitrunc (Suc m) (2 ^ m))"
      by (simp only: bitrunc_plus)
    also have "\<dots> =
      bitrunc (Suc m) (bitrunc (Suc m) l + bitrunc (Suc m) (2 ^ m))"
      by (simp only: \<open>?Q\<close> m [symmetric])
    also have "\<dots> = bitrunc (Suc m) (l + 2 ^ m)"
      by (simp only: bitrunc_plus)
    finally show ?P
      by (simp only: signed_bitrunc_eq_bitrunc m) simp
  next
    assume ?P
    with assms have "(k + 2 ^ (n - Suc 0)) mod 2 ^ n = (l + 2 ^ (n - Suc 0)) mod 2 ^ n"
      by (simp add: signed_bitrunc_eq_bitrunc' bitrunc_eq_mod)
    then have "(i + (k + 2 ^ (n - Suc 0))) mod 2 ^ n = (i + (l + 2 ^ (n - Suc 0))) mod 2 ^ n" for i
      by (metis mod_add_eq)
    then have "k mod 2 ^ n = l mod 2 ^ n"
      by (metis add_diff_cancel_right' uminus_add_conv_diff)
    then show ?Q
      by (simp add: bitrunc_eq_mod)
  qed
qed

subsection \<open>Bit strings as quotient type\<close>

subsubsection \<open>Basic properties\<close>

quotient_type (overloaded) 'a word = int / "\<lambda>k l. bitrunc LENGTH('a) k = bitrunc LENGTH('a::len0) l"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation word :: (len0) "{semiring_numeral, comm_semiring_0, comm_ring}"
begin

lift_definition zero_word :: "'a word"
  is 0
  .

lift_definition one_word :: "'a word"
  is 1
  .

lift_definition plus_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is plus
  by (subst bitrunc_plus [symmetric]) (simp add: bitrunc_plus)

lift_definition uminus_word :: "'a word \<Rightarrow> 'a word"
  is uminus
  by (subst bitrunc_uminus [symmetric]) (simp add: bitrunc_uminus)

lift_definition minus_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is minus
  by (subst bitrunc_minus [symmetric]) (simp add: bitrunc_minus)

lift_definition times_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is times
  by (auto simp add: bitrunc_eq_mod intro: mod_mult_cong)

instance
  by standard (transfer; simp add: algebra_simps)+

end

instance word :: (len) comm_ring_1
  by standard (transfer; simp)+

subsubsection \<open>Conversions\<close>

context semiring_1
begin

lift_definition unsigned :: "'b::len0 word \<Rightarrow> 'a"
  is "of_nat \<circ> nat \<circ> bitrunc LENGTH('b)"
  by simp

lemma unsigned_0 [simp]:
  "unsigned 0 = 0"
  by transfer simp

end

context semiring_char_0
begin

lemma word_eq_iff_unsigned:
  "a = b \<longleftrightarrow> unsigned a = unsigned b"
  by safe (transfer; simp add: eq_nat_nat_iff)

end

context ring_1
begin

lift_definition signed :: "'b::len word \<Rightarrow> 'a"
  is "of_int \<circ> signed_bitrunc (LENGTH('b) - 1)"
  by (simp add: signed_bitrunc_eq_iff_bitrunc_eq [symmetric])

lemma signed_0 [simp]:
  "signed 0 = 0"
  by transfer simp

end

lemma unsigned_of_nat [simp]:
  "unsigned (of_nat n :: 'a word) = bitrunc LENGTH('a::len) n"
  by transfer (simp add: nat_eq_iff bitrunc_eq_mod zmod_int)

lemma of_nat_unsigned [simp]:
  "of_nat (unsigned a) = a"
  by transfer simp

lemma of_int_unsigned [simp]:
  "of_int (unsigned a) = a"
  by transfer simp

context ring_char_0
begin

lemma word_eq_iff_signed:
  "a = b \<longleftrightarrow> signed a = signed b"
  by safe (transfer; auto simp add: signed_bitrunc_eq_iff_bitrunc_eq)

end

lemma signed_of_int [simp]:
  "signed (of_int k :: 'a word) = signed_bitrunc (LENGTH('a::len) - 1) k"
  by transfer simp

lemma of_int_signed [simp]:
  "of_int (signed a) = a"
  by transfer (simp add: signed_bitrunc_eq_bitrunc bitrunc_eq_mod zdiff_zmod_left)

subsubsection \<open>Properties\<close>

subsubsection \<open>Division\<close>

instantiation word :: (len0) modulo
begin

lift_definition divide_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda>a b. bitrunc LENGTH('a) a div bitrunc LENGTH('a) b"
  by simp

lift_definition modulo_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda>a b. bitrunc LENGTH('a) a mod bitrunc LENGTH('a) b"
  by simp

instance ..

end

subsubsection \<open>Orderings\<close>

instantiation word :: (len0) linorder
begin

lift_definition less_eq_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  is "\<lambda>a b. bitrunc LENGTH('a) a \<le> bitrunc LENGTH('a) b"
  by simp

lift_definition less_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  is "\<lambda>a b. bitrunc LENGTH('a) a < bitrunc LENGTH('a) b"
  by simp

instance
  by standard (transfer; auto)+

end

context linordered_semidom
begin

lemma word_less_eq_iff_unsigned:
  "a \<le> b \<longleftrightarrow> unsigned a \<le> unsigned b"
  by (transfer fixing: less_eq) (simp add: nat_le_eq_zle)

lemma word_less_iff_unsigned:
  "a < b \<longleftrightarrow> unsigned a < unsigned b"
  by (transfer fixing: less) (auto dest: preorder_class.le_less_trans [OF bitrunc_nonnegative])

end

end


(* Author: Tobias Nipkow *)

theory Abs_State
imports Abs_Int0
begin

type_synonym 'a st_rep = "(vname * 'a) list"

fun fun_rep :: "('a::top) st_rep \<Rightarrow> vname \<Rightarrow> 'a" where
"fun_rep [] = (\<lambda>x. \<top>)" |
"fun_rep ((x,a)#ps) = (fun_rep ps) (x := a)"

lemma fun_rep_map_of[code]: --"original def is too slow"
  "fun_rep ps = (%x. case map_of ps x of None \<Rightarrow> \<top> | Some a \<Rightarrow> a)"
by(induction ps rule: fun_rep.induct) auto

definition eq_st :: "('a::top) st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
"eq_st S1 S2 = (fun_rep S1 = fun_rep S2)"

hide_type st  --"hide previous def to avoid long names"
declare [[typedef_overloaded]] --"allow quotient types to depend on classes"

quotient_type 'a st = "('a::top) st_rep" / eq_st
morphisms rep_st St
by (metis eq_st_def equivpI reflpI sympI transpI)

lift_definition update :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a \<Rightarrow> 'a st"
  is "\<lambda>ps x a. (x,a)#ps"
by(auto simp: eq_st_def)

lift_definition "fun" :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a" is fun_rep
by(simp add: eq_st_def)

definition show_st :: "vname set \<Rightarrow> ('a::top) st \<Rightarrow> (vname * 'a)set" where
"show_st X S = (\<lambda>x. (x, fun S x)) ` X"

definition "show_acom C = map_acom (map_option (show_st (vars(strip C)))) C"
definition "show_acom_opt = map_option show_acom"

lemma fun_update[simp]: "fun (update S x y) = (fun S)(x:=y)"
by transfer auto

definition \<gamma>_st :: "(('a::top) \<Rightarrow> 'b set) \<Rightarrow> 'a st \<Rightarrow> (vname \<Rightarrow> 'b) set" where
"\<gamma>_st \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(fun F x)}"

instantiation st :: (order_top) order
begin

definition less_eq_st_rep :: "'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
"less_eq_st_rep ps1 ps2 =
  ((\<forall>x \<in> set(map fst ps1) \<union> set(map fst ps2). fun_rep ps1 x \<le> fun_rep ps2 x))"

lemma less_eq_st_rep_iff:
  "less_eq_st_rep r1 r2 = (\<forall>x. fun_rep r1 x \<le> fun_rep r2 x)"
apply(auto simp: less_eq_st_rep_def fun_rep_map_of split: option.split)
apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
done

corollary less_eq_st_rep_iff_fun:
  "less_eq_st_rep r1 r2 = (fun_rep r1 \<le> fun_rep r2)"
by (metis less_eq_st_rep_iff le_fun_def)

lift_definition less_eq_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> bool" is less_eq_st_rep
by(auto simp add: eq_st_def less_eq_st_rep_iff)

definition less_st where "F < (G::'a st) = (F \<le> G \<and> \<not> G \<le> F)"

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_st_def)
next
  case 2 show ?case by transfer (auto simp: less_eq_st_rep_def)
next
  case 3 thus ?case by transfer (metis less_eq_st_rep_iff order_trans)
next
  case 4 thus ?case
    by transfer (metis less_eq_st_rep_iff eq_st_def fun_eq_iff antisym)
qed

end

lemma le_st_iff: "(F \<le> G) = (\<forall>x. fun F x \<le> fun G x)"
by transfer (rule less_eq_st_rep_iff)

fun map2_st_rep :: "('a::top \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep" where
"map2_st_rep f [] ps2 = map (%(x,y). (x, f \<top> y)) ps2" |
"map2_st_rep f ((x,y)#ps1) ps2 =
  (let y2 = fun_rep ps2 x
   in (x,f y y2) # map2_st_rep f ps1 ps2)"

lemma fun_rep_map2_rep[simp]: "f \<top> \<top> = \<top> \<Longrightarrow>
  fun_rep (map2_st_rep f ps1 ps2) = (\<lambda>x. f (fun_rep ps1 x) (fun_rep ps2 x))"
apply(induction f ps1 ps2 rule: map2_st_rep.induct)
apply(simp add: fun_rep_map_of map_of_map fun_eq_iff split: option.split)
apply(fastforce simp: fun_rep_map_of fun_eq_iff split:option.splits)
done

instantiation st :: (semilattice_sup_top) semilattice_sup_top
begin

lift_definition sup_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (op \<squnion>)"
by (simp add: eq_st_def)

lift_definition top_st :: "'a st" is "[]" .

instance
proof (standard, goal_cases)
  case 1 show ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 2 show ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 3 thus ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 4 show ?case by transfer (simp add:less_eq_st_rep_iff fun_rep_map_of)
qed

end

lemma fun_top: "fun \<top> = (\<lambda>x. \<top>)"
by transfer simp

lemma mono_update[simp]:
  "a1 \<le> a2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> update S1 x a1 \<le> update S2 x a2"
by transfer (auto simp add: less_eq_st_rep_def)

lemma mono_fun: "S1 \<le> S2 \<Longrightarrow> fun S1 x \<le> fun S2 x"
by transfer (simp add: less_eq_st_rep_iff)

locale Gamma_semilattice = Val_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>s == \<gamma>_st \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_s_top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
by(auto simp: \<gamma>_st_def fun_top)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
by (simp add: top_option_def)

lemma mono_gamma_s: "f \<le> g \<Longrightarrow> \<gamma>\<^sub>s f \<subseteq> \<gamma>\<^sub>s g"
by(simp add:\<gamma>_st_def le_st_iff subset_iff) (metis mono_gamma subsetD)

lemma mono_gamma_o:
  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)

lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])

lemma in_gamma_option_iff:
  "x : \<gamma>_option r u \<longleftrightarrow> (\<exists>u'. u = Some u' \<and> x : r u')"
by (cases u) auto

end

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
chapter \<open>Quantitative Separation Logic for expectations\<close>
theory QSL_For_Expectations
imports
 Assertions_With_State
begin

paragraph \<open>Summary\<close>

text \<open>This theory instantiates the Quantitative Separation Logic language with the
        quantale for expectations (ennreal,<=,*,/).

      It is the instance \<open>E\<close> described in the paper by Batz et al. @{cite batzPOPL19}.
    \<close>

section \<open>Misc\<close>

subsection \<open>Stuff about ennreal\<close>

lemma ennreal_mult_divide: "b > 0 \<Longrightarrow> b < (\<infinity>::ennreal) \<Longrightarrow> b * (a / b) = a"
  apply(cases a; cases b) apply (auto simp: divide_ennreal ennreal_mult[symmetric])
   by (simp add: ennreal_divide_eq_top_iff ennreal_mult_eq_top_iff)

lemma ennreal_div_one: "x / 1 = (x::ennreal)"
  by (metis ennreal_top_neq_one mult.right_neutral mult_divide_eq_ennreal one_neq_zero)

lemma SUP_plus_subdistrib2:
  "(SUP (h1,h2)\<in>A.  f h1 h2 + g h1 h2 :: ennreal) \<le> (SUP (h1,h2)\<in>A.  f h1 h2) + (SUP (h1,h2)\<in>A.  g h1 h2)"
  apply(rule Sup_least) apply auto
  apply(rule add_mono) by(auto intro: SUP_upper2)

lemma SUP_plus_subdistrib_ennreal: "\<And>S. \<And>f g::_\<Rightarrow>ennreal. (SUP x\<in>S. f x + g x) \<le> (SUP x\<in>S. f x) + (SUP x\<in>S. g x)"
      by (simp add: SUP_least SUP_upper add_mono)

subsubsection \<open>some experiments\<close>

experiment
begin

thm ereal_mult_divide

lemma "(P::_\<Rightarrow>ennreal) h' * (Y (h + h') / P h') = FF \<Longrightarrow> G"
  apply(subst (asm) ennreal_mult_divide) oops

lemma "\<infinity> / (\<infinity>::ennreal) = 0"
  by simp

lemma "x / (\<infinity>::ennreal) = 0"
  by simp

lemma "x>0 \<Longrightarrow> x * (\<infinity>::ennreal) = \<infinity>"
  using ennreal_mult_eq_top_iff by auto

lemma "0 * (\<infinity>::ennreal) = 0"
  by auto

thm ennreal_mult_divide

thm mult_left_mono

(* for bool
    "(bot < A \<or> bot < B )" and 2: "(A < top \<or> B < top)"
  is
    A \<or> B and ~A \<or> ~B
  equiv with
    (A\<and>~B) or (~A\<and>B)
*)

lemma "x>0 \<Longrightarrow> x / 0 = (\<infinity>::ennreal)" by simp
lemma "x=0 \<Longrightarrow> x / 0 = (0::ennreal)" by simp

lemma "x / \<infinity> = (0::ennreal)" by simp

lemma "x = \<infinity> \<Longrightarrow>  \<infinity> / x = (0::ennreal)" using ennreal_top_divide by simp (* AAAHHHH *)
lemma "x < \<infinity> \<Longrightarrow>  \<infinity> / x = (\<infinity>::ennreal)" using ennreal_top_divide by simp

lemma "x=\<infinity> \<Longrightarrow> x - \<infinity> = (\<infinity>::ennreal)" by simp
lemma "x<\<infinity> \<Longrightarrow> x - \<infinity> = (0::ennreal)" apply simp
  by (simp add: diff_eq_0_iff_ennreal)

lemma "x - 0 = (x::ennreal)" by simp

lemma "x = 0 \<Longrightarrow> 0 - x = (0::ennreal)" by simp   (* AAAHHHH *)
lemma "x > 0 \<Longrightarrow> 0 - x = (0::ennreal)" by simp

end

section \<open>Instantiating the general theory for specific Domains\<close>

subsection \<open>Ennreal with multiplication\<close>

subsubsection \<open>Interpretation of locale quant_sep_con\<close>

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 blast

lemma ennreal_div_antimono:
  "(a::ennreal) \<le> b \<Longrightarrow> c / b \<le> c / a"
  unfolding divide_ennreal_def apply(rule mult_mono)
     apply simp
    apply(rule ennreal_inverse_antimono)
  apply simp apply simp by simp

lemma eq79_ennreal: fixes A B C :: ennreal
  shows "(bot < C \<or> bot < B )  \<Longrightarrow> (C < top \<or> B < top) \<Longrightarrow> ( A \<le> B / C) \<longleftrightarrow> A * C \<le> B "
  subgoal
    apply(cases "C < top")
    subgoal
      by (metis bot.extremum bot_ennreal divide_less_ennreal
          ennreal_divide_eq_0_iff ennreal_divide_eq_top_iff
          ennreal_times_divide leD le_less_linear top_greatest)
    subgoal
      by (metis bot.extremum_strict bot_ennreal ennreal_divide_top
          ennreal_mult_eq_top_iff mult_eq_0_iff nn nn_bot not_le)
    done
  done

interpretation Exp: quant_sep_con Inf Sup inf "(\<le>)" "(<)" sup bot top "(*)" "1::ennreal"  "(/)"
  apply standard
  subgoal using SUP_mult_left_ennreal[where f=id] by simp
  subgoal by (simp add: ennreal_div_one)
  subgoal by (simp add: divide_right_mono_ennreal)
  subgoal using ennreal_div_antimono by simp
  subgoal apply(rule eq79_ennreal) by auto
  subgoal by (simp add: bot_ennreal)
  done

subsubsection \<open>Star and Magic Wand\<close>

definition sep_conj_e (infixr "**\<^sub>e" 35) where "sep_conj_e == Exp.sep_conj_q"
definition sep_impl_e (infixr "-*\<^sub>e" 35) where "sep_impl_e == Exp.sep_impl_qq"
definition "sep_empty\<^sub>e \<equiv> Exp.sep_empty_q"
definition "emb\<^sub>e \<equiv> Exp.emb"

lemma sep_conj_e_alt:
  "(P **\<^sub>e Q) = (\<lambda>h. Sup { P x * Q y | x y. h=x+y \<and> x ## y})"
  by (simp add: sep_conj_e_def Exp.sep_conj_q_def)

lemma sep_impl_e_alt:
  "(P -*\<^sub>e Q) = (\<lambda>h. INF h'\<in> { h'. h ## h' \<and> (bot < P h' \<or> bot < Q (h+h') )
                                \<and> (P h' < top \<or> Q (h+h') < top)}.
                                    (Q (h + h')) / (P h'))"
  by (simp add: Exp.sep_impl_qq_def sep_impl_e_def)

lemma emb\<^sub>e_alt: "emb\<^sub>e P = (\<lambda>h. if P h then 1 else 0)" unfolding emb\<^sub>e_def Exp.emb_def
  by (auto simp: bot_ennreal)

lemma quant_wand_conservative:
  "(P  \<longrightarrow>* Q) h  \<longleftrightarrow> inf 1 (((emb\<^sub>e P) -*\<^sub>e (emb\<^sub>e Q)) h) = 1"
  using Exp.quant_wand_conservative unfolding emb\<^sub>e_def sep_impl_e_def by blast

lemma sep_impl_q_alt_general:
  "inf 1 ((emb\<^sub>e P -*\<^sub>e Q) h) = inf 1 (INF h'\<in> { h'. h ## h' \<and> P h'}. Q (h + h'))"
  using Exp.sep_impl_q_alt_general unfolding emb\<^sub>e_def sep_impl_e_def by blast

subsubsection \<open>Star is Commutative Monoid\<close>

lemma sep_conj_e_assoc:
  fixes x y z :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows
   "(x **\<^sub>e (y **\<^sub>e z))  = ((x **\<^sub>e y) **\<^sub>e z)"
  using Exp.star_assoc[folded  sep_conj_e_def] by blast

lemma sep_conj_e_comm:
  fixes X Y :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows  "(X **\<^sub>e Y) = (Y **\<^sub>e X)"
  using Exp.star_comm[folded  sep_conj_e_def] by blast

lemma sep_conj_e_emp_neutral:
  fixes X   :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows "(X **\<^sub>e sep_empty\<^sub>e) = X"
        "(sep_empty\<^sub>e **\<^sub>e X) = X"
  using Exp.emp_neutral[folded  sep_conj_e_def sep_empty\<^sub>e_def] by auto

lemma sep_conj_e_left_commute:
  fixes P Q R :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows  "(P **\<^sub>e Q **\<^sub>e R) = (Q **\<^sub>e P **\<^sub>e R)"
  using Exp.sep_conj_q_left_commute[folded  sep_conj_e_def sep_empty\<^sub>e_def] by auto

lemmas sep_conj_e_c = sep_conj_e_comm sep_conj_e_left_commute

subsubsection \<open>monotonicity of @{term "(**\<^sub>e)"} and  @{term "(-*\<^sub>e)"}\<close>

lemma sep_conj_e_mono:
  fixes X X' :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows
   "X \<le> X' \<Longrightarrow> Y \<le> Y' \<Longrightarrow> (X **\<^sub>e Y) \<le> (X' **\<^sub>e Y')"
  using Exp.sep_conj_q_mono[folded  sep_conj_e_def]
  unfolding le_fun_def by blast

lemma sep_impl_e_mono:
  fixes P' P Y' Y :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows "P' \<le> P \<Longrightarrow> Y \<le> Y' \<Longrightarrow> (P -*\<^sub>e Y) \<le> (P' -*\<^sub>e Y')"
  using Exp.sep_impl_q_mono[folded  sep_impl_e_def sep_empty\<^sub>e_def]
  unfolding le_fun_def by blast

subsubsection \<open>adjointness of @{term "(**\<^sub>e)"} and  @{term "(-*\<^sub>e)"}\<close>

lemma sep_conj_sep_impl_e_adjoint:
  fixes X Y Z :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows "(X **\<^sub>e Y) \<le> Z \<longleftrightarrow> X \<le> (Y -*\<^sub>e Z)"
  using Exp.adjoint_general[folded  sep_conj_e_def sep_impl_e_def]
  unfolding le_fun_def by blast

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

lemma quant_modus_ponens_general:
  shows "( P **\<^sub>e (P -*\<^sub>e X)) \<le> X"
  using Exp.quant_modus_ponens_general[folded  sep_conj_e_def sep_impl_e_def]
  unfolding le_fun_def by blast

subsubsection \<open>Theorem 3.6\<close>

lemma times_fun': "f * g = (\<lambda>h. f h * g h)"
  apply(rule ext) by simp

lemma theorem_3_6:
  fixes
      Q :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows
  "(P **\<^sub>e (sup Q R)) = sup (P **\<^sub>e Q) (P **\<^sub>e R)"
  "( (emb\<^sub>e \<phi>) **\<^sub>e (Q * R)) \<le> ((emb\<^sub>e \<phi>) **\<^sub>e Q) * ((emb\<^sub>e \<phi>) **\<^sub>e R)"
  subgoal using Exp.theorem_3_6(1)[folded  sep_conj_e_def sep_impl_e_def]
    unfolding  sup_fun_def by blast
  subgoal
    apply(subst (1) times_fun')
    apply(subst (1) times_fun')
    using Exp.theorem_3_6(2)[folded  sep_conj_e_def emb\<^sub>e_def]
    unfolding le_fun_def  sup_fun_def by blast
  done

subsubsection \<open>Intuitionistic Expectations\<close>

abbreviation "intuitionistic\<^sub>e \<equiv> Exp.intuitionistic_q"
abbreviation sep_true_q ("1\<^sub>e")  where "1\<^sub>e \<equiv> (emb\<^sub>e sep_true)"

lemma intuitionistic_e_emb_intuitionistic_iff:
  "intuitionistic\<^sub>e (emb\<^sub>e P) \<longleftrightarrow> intuitionistic P"
  using Exp.intuitionistic_q_emb_intuitionistic_iff[folded emb\<^sub>e_def] by auto

theorem tightest_intuitionistic_expectations_star:
  fixes X :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows
    "intuitionistic\<^sub>e (X **\<^sub>e 1\<^sub>e)"
    "X \<le> (X **\<^sub>e 1\<^sub>e)"
    "\<And>X'. intuitionistic\<^sub>e X' \<Longrightarrow> X \<le> X' \<Longrightarrow> (X **\<^sub>e 1\<^sub>e) \<le> X'"
  using Exp.tightest_intuitionistic_expectations_star[folded emb\<^sub>e_def sep_conj_e_def]
    unfolding le_fun_def by(blast)+

lemma tightest_intuitionistic_expectations_wand:
  fixes X :: "'a::{sep_algebra} \<Rightarrow> ennreal"
  shows
    "intuitionistic\<^sub>e (1\<^sub>e -*\<^sub>e X)"
    "(1\<^sub>e -*\<^sub>e X) \<le> X"
    "\<And>X'. intuitionistic\<^sub>e X' \<Longrightarrow> X' \<le> X \<Longrightarrow>  X' \<le> (1\<^sub>e -*\<^sub>e X)"
  using Exp.tightest_intuitionistic_expectations_wand[folded emb\<^sub>e_def sep_impl_e_def]
    unfolding le_fun_def by blast+

subsubsection \<open>Star and Magic Wand with State\<close>

definition sep_conj_es (infixr "\<star>\<^sub>e" 35) where "sep_conj_es == Exp.sep_conj_s_q"
definition sep_impl_es (infixr "-\<star>\<^sub>e" 35) where "sep_impl_es == Exp.sep_impl_s_q"
definition "sep_empty_s\<^sub>e \<equiv> Exp.sep_empty_s_q"

lemma sep_conj_es_alt:
  fixes P :: "(_ \<times> 'a::{sep_algebra} \<Rightarrow> ennreal)"
  shows "(P \<star>\<^sub>e Q) = (\<lambda>(s,h). Sup { P(s,x) * Q(s,y) | x y. h=x+y \<and> x ## y})"
  by (simp add: Exp.sep_conj_s_q_def Exp.sep_conj_q_def sep_conj_es_def)

lemma sep_impl_es_alt:
  "(P -\<star>\<^sub>e Q) = (\<lambda>(s,h). INF h'\<in> { h'. h ## h' \<and> (bot < P(s,h') \<or> bot < Q(s,h+h') )
                                \<and> ( P(s,h') < top \<or> Q(s,h+h') < top)}.
                                    (Q (s,h + h')) / P (s,h') )"
  by (simp add: Exp.sep_impl_qq_def Exp.sep_impl_s_q_def sep_impl_es_def)

lemma sep_empty_s\<^sub>e_alt: "sep_empty_s\<^sub>e = (\<lambda>(s, y). emb\<^sub>e (\<lambda>h. h = 0) y)"
  by (auto simp: Exp.sep_empty_s_q_def emb\<^sub>e_def Exp.sep_empty_q_def sep_empty_s\<^sub>e_def )

lemmas sep_conj_es_commute =  Exp.sep_conj_s_q_commute[folded sep_conj_es_def]
lemmas sep_conj_es_neutral = Exp.sep_conj_s_q_neutral[folded sep_conj_es_def sep_empty_s\<^sub>e_def]
lemmas sep_conj_es_assoc = Exp.sep_conj_s_q_assoc[folded sep_conj_es_def]
lemmas sep_conj_es_left_commute_s = Exp.sep_conj_q_left_commute_s[folded sep_conj_es_def]

lemmas sep_conj_es_c = Exp.sep_conj_q_s_c[folded sep_conj_es_def]

lemma theorem_3_6_s:
  fixes P Q R :: "(_ \<times> 'a::{sep_algebra} \<Rightarrow> ennreal)"
  shows
  "(P \<star>\<^sub>e sup Q R) = (\<lambda>s. sup ((P \<star>\<^sub>e Q) s) ((P \<star>\<^sub>e R) s))"
  (*  "(P \<star> (\<lambda>s. Q s + R s)) \<le> (\<lambda>s. (P \<star> Q) s + (P \<star> R) s)" *)
  "( (emb\<^sub>e \<phi>) \<star>\<^sub>e (Q * R)) \<le> ((emb\<^sub>e \<phi>) \<star>\<^sub>e Q) * ((emb\<^sub>e \<phi>) \<star>\<^sub>e R)"
  subgoal using Exp.theorem_3_6_s(1)[folded sep_conj_es_def]
    unfolding sup_fun_def .
  subgoal
    apply(subst (1) times_fun')
    using Exp.theorem_3_6_s(2)[folded sep_conj_es_def emb\<^sub>e_def]
    by (auto simp: le_fun_def)
  done

lemmas sep_conj_es_mono = Exp.sep_impl_s_q_mono [folded sep_impl_es_def emb\<^sub>e_def]

lemma adjoint_general_s:
  shows "(X \<star>\<^sub>e P) \<le> Y \<longleftrightarrow> X \<le> (P -\<star>\<^sub>e Y)"
  using Exp.adjoint_general_s [folded sep_impl_es_def sep_conj_es_def]
    unfolding le_fun_def by blast

lemma quant_modus_ponens_general_s:
  shows "( P \<star>\<^sub>e (P -\<star>\<^sub>e X)) \<le> X"
  using Exp.quant_modus_ponens_general_s [folded sep_impl_es_def sep_conj_es_def]
    unfolding le_fun_def by blast

definition "pure\<^sub>e \<equiv> Exp.pure_q"

lemma pure\<^sub>e_alt: "pure\<^sub>e X \<longleftrightarrow> (\<forall>s h1 h2. X (s,h1) = X (s,h2))"
  using Exp.pure_q_def unfolding pure\<^sub>e_def .

lemma  theorem_3_11_1: "pure\<^sub>e X \<Longrightarrow> X * Y \<le> (X \<star>\<^sub>e Y)"
    apply(subst (1) times_fun')
  using Exp.theorem_3_11_1[folded pure\<^sub>e_def sep_conj_es_def]
    unfolding le_fun_def by auto

lemma theorem_3_11_3:
  "pure\<^sub>e X \<Longrightarrow> ((X * Y) \<star>\<^sub>e Z) = X * (Y \<star>\<^sub>e Z)"
    apply(subst times_fun')+
  using Exp.theorem_3_11_3[folded pure\<^sub>e_def sep_conj_es_def]
    unfolding le_fun_def by auto

end


(*  Author:  Tobias Nipkow  *)

header "Properties of Tame Graph Enumeration (1)"

theory GeneratorProps
imports Plane1Props Generator TameProps LowerBound
begin

lemma genPolyTame_spec:
 "generatePolygonTame n v f g = [g' \<leftarrow> generatePolygon n v f g . \<not> notame g']"
by(simp add:generatePolygonTame_def generatePolygon_def enum_enumerator)

lemma genPolyTame_subset_genPoly:
 "g' \<in> set(generatePolygonTame i v f g) \<Longrightarrow>
  g' \<in> set(generatePolygon i v f g)"
by(auto simp add:generatePolygon_def generatePolygonTame_def enum_enumerator)

lemma next_tame0_subset_plane:
 "set(next_tame0 p g) \<subseteq> set(next_plane p g)"
by(auto simp add:next_tame0_def next_plane_def polysizes_def
           elim!:genPolyTame_subset_genPoly simp del:upt_Suc)

lemma genPoly_new_face:
 "\<lbrakk>g' \<in> set (generatePolygon n v f g); minGraphProps g; f \<in> set (nonFinals g);
   v \<in> \<V> f; n \<ge> 3 \<rbrakk> \<Longrightarrow>
  \<exists>f \<in> set(finals g') - set(finals g). |vertices f| = n"
apply(auto simp add:generatePolygon_def image_def)
apply(rename_tac "is")
apply(frule enumerator_length2)
 apply arith
apply(frule (4) pre_subdivFace_indexToVertexList)
 apply(arith)
apply(subgoal_tac "indexToVertexList f v is \<noteq> []")
 prefer 2 apply(subst length_0_conv[symmetric]) apply simp
apply(simp add: subdivFace_subdivFace'_eq)
apply(clarsimp simp:neq_Nil_conv)
apply(rename_tac "ovs")
apply(subgoal_tac "|indexToVertexList f v is| = |ovs| + 1")
 prefer 2 apply(simp)
apply(drule (1) pre_subdivFace_pre_subdivFace')
apply(drule (1) final_subdivFace')
  apply(simp add:nonFinals_def)
 apply(simp add:pre_subdivFace'_def)
apply (simp (no_asm_use))
apply(simp)
apply blast
done

(* Could prove = instead of >=, but who needs it? *)
lemma genPoly_incr_facesquander_lb:
assumes "g' \<in> set (generatePolygon n v f g)" "inv g"
        "f \<in> set(nonFinals g)" "v \<in> \<V> f" "3 \<le> n"
shows "faceSquanderLowerBound g' \<ge> faceSquanderLowerBound g + \<d> n"
proof -
  from genPoly_new_face[OF assms(1) inv_mgp[OF assms(2)] assms(3-5)] obtain f
    where f: "f \<in> set (finals g') - set(finals g)"
    and size: "|vertices f| = n" by auto
  have g': "g' \<in> set(next_plane0 (n - 3) g)" using assms(5)
    by(rule_tac in_next_plane0I[OF assms(1,3-5)]) simp
  note dist = minGraphProps11'[OF inv_mgp[OF assms(2)]]
  note inv' = invariantE[OF inv_inv_next_plane0, OF g' assms(2)]
  note dist' = minGraphProps11'[OF inv_mgp[OF inv']]
  note subset = next_plane0_finals_subset[OF g']
  have "faceSquanderLowerBound g' \<ge>
        faceSquanderLowerBound g + \<d> |vertices f|"
  proof(unfold faceSquanderLowerBound_def)
    have "(\<Sum>\<^bsub>f\<in>finals g\<^esub> \<d> |vertices f| ) + \<d> |vertices f| =
          (\<Sum>f\<in>set(finals g). \<d> |vertices f| ) + \<d> |vertices f|"
      using dist by(simp add:finals_def ListSum_conv_setsum)
    also have "\<dots> = (\<Sum>f\<in>set(finals g) \<union> {f}. \<d> |vertices f| )"
      using f by simp
    also have "\<dots> \<le> (\<Sum>f\<in>set(finals g'). \<d> |vertices f| )"
      using f subset by(fastforce intro!: setsum_mono3)
    also have "\<dots> = (\<Sum>\<^bsub>f\<in>finals g'\<^esub> \<d> |vertices f| )"
      using dist' by(simp add:finals_def ListSum_conv_setsum)
    finally show "(\<Sum>\<^bsub>f\<in>finals g\<^esub> \<d> |vertices f| ) + \<d> |vertices f|
          \<le> (\<Sum>\<^bsub>f\<in>finals g'\<^esub> \<d> |vertices f| )" .
  qed
  with size show ?thesis by blast
qed

definition close :: "graph \<Rightarrow> vertex \<Rightarrow> vertex \<Rightarrow> bool" where
"close g u v \<equiv>
 \<exists>f \<in> set(facesAt g u). if |vertices f| = 4 then v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u)
                        else v = f \<bullet> u"

(* FIXME This should be the def of delAround *)
lemma delAround_def: "deleteAround g u ps = [p \<leftarrow> ps. \<not> close g u (fst p)]"
by (induct ps) (auto simp: deleteAroundCons close_def)

lemma close_sym: assumes mgp: "minGraphProps g" and ug: "u : \<V> g" and cl: "close g u v"
shows "close g v u"
proof -
  obtain f where f: "f \<in> set(facesAt g u)" and
    "if": "if |vertices f| = 4 then v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u) else v = f \<bullet> u"
    using cl by (unfold close_def) blast
  note uf = minGraphProps6[OF mgp ug f]
  note distf = minGraphProps3[OF mgp minGraphProps5[OF mgp ug f]]
  show ?thesis
  proof cases
    assume 4: "|vertices f| = 4"
    hence "v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u)" using "if" by simp
    thus ?thesis
    proof
      assume "v = f \<bullet> u"
      then obtain f' where "f' \<in> set(facesAt g v)" "f' \<bullet> v = u"
        using mgp_nextVertex_face_ex2[OF mgp ug f] by blast
      thus ?thesis by(auto simp:close_def)
    next
      assume v: "v = f \<bullet> (f \<bullet> u)"
      hence "f \<bullet> (f \<bullet> v) = u" using quad_next4_id[OF 4 distf uf] by simp
      moreover have "f \<in> set(facesAt g v)" using v uf
        by(simp add: minGraphProps7[OF mgp minGraphProps5[OF mgp ug f]])
      ultimately show ?thesis using 4 by(auto simp:close_def)
    qed
  next
    assume "|vertices f| \<noteq> 4"
    hence "v = f \<bullet> u" using "if" by simp
    then obtain f' where "f' \<in> set(facesAt g v)" "f' \<bullet> v = u"
      using mgp_nextVertex_face_ex2[OF mgp ug f] by blast
    thus ?thesis by(auto simp:close_def)
  qed
qed

lemma sep_conv:
assumes mgp: "minGraphProps g" and "V <= \<V> g"
shows "separated g V = (\<forall>u\<in>V.\<forall>v\<in>V. u \<noteq> v \<longrightarrow> \<not> close g u v)" (is "?P = ?Q")
proof
  assume sep: ?P
  show ?Q
  proof(clarify)
    fix u v assume uv: "u \<in> V" "v \<in> V" "u \<noteq> v" and cl: "close g u v"
    from cl obtain f where f: "f \<in> set(facesAt g u)" and
      "if": "if |vertices f| = 4 then (v = f \<bullet> u) \<or> (v = f \<bullet> (f \<bullet> u))
                               else (v = f \<bullet> u)"
      by (unfold close_def) blast
    have "u : \<V> g" using `u : V` `V <= \<V> g` by blast
    note uf = minGraphProps6[OF mgp `u : \<V> g` f]
    show False
    proof cases
      assume 4: "|vertices f| = 4"
      hence "v = f \<bullet> u \<or> v = f \<bullet> (f \<bullet> u)" using "if" by simp
      thus False
      proof
        assume "v = f \<bullet> u"
        thus False using sep f uv
          by(simp add:separated_def separated\<^sub>2_def separated\<^sub>3_def)
      next
        assume "v = f \<bullet> (f \<bullet> u)"
        moreover hence "v \<in> \<V> f" using `u \<in> \<V> f` by simp
        moreover have "|vertices f| \<le> 4" using 4 by arith
        ultimately show False using sep f uv `u \<in> \<V> f`
          apply(unfold separated_def separated\<^sub>2_def separated\<^sub>3_def)
(* why does blast get stuck? *)
          apply(subgoal_tac "f \<bullet> (f \<bullet> u) \<in> \<V> f \<inter> V")
          prefer 2 apply blast
          by simp
      qed
    next
      assume 4: "|vertices f| \<noteq> 4"
      hence "v = f \<bullet> u" using "if" by simp
      thus False using sep f uv
        by(simp add:separated_def separated\<^sub>2_def separated\<^sub>3_def)
    qed
  qed
next
  assume not_cl: ?Q
  show ?P
  proof(simp add:separated_def, rule conjI)
    show "separated\<^sub>2 g V"
    proof (clarsimp simp:separated\<^sub>2_def)
      fix v f assume a: "v \<in> V" "f \<in> set (facesAt g v)" "f \<bullet> v \<in> V"
      have "v : \<V> g" using a(1) `V <= \<V> g` by blast
      show False using a not_cl mgp_facesAt_no_loop[OF mgp `v : \<V> g` a(2)]
        by(fastforce simp: close_def split:split_if_asm)
    qed
    show "separated\<^sub>3 g V"
    proof (clarsimp simp:separated\<^sub>3_def)
      fix v f
      assume "v \<in> V" and f: "f \<in> set (facesAt g v)" and len: "|vertices f| \<le> 4"
      have vg: "v : \<V> g" using `v : V` `V <= \<V> g` by blast
      note distf = minGraphProps3[OF mgp minGraphProps5[OF mgp vg f]]
      note vf = minGraphProps6[OF mgp vg f]
      { fix u assume "u \<in> \<V> f" and "u \<in> V"
        have "u = v"
        proof cases
          assume 3: "|vertices f| = 3"
          hence "\<V> f = {v, f \<bullet> v, f \<bullet> (f \<bullet> v)}"
            using vertices_triangle[OF _ vf distf] by simp
          moreover
          { assume "u = f \<bullet> v"
            hence "u = v"
              using not_cl f `u \<in> V` `v \<in> V` 3
              by(force simp:close_def split:split_if_asm)
          }
          moreover
          { assume "u = f \<bullet> (f \<bullet> v)"
            hence fu: "f \<bullet> u = v"
              by(simp add: tri_next3_id[OF 3 distf `v \<in> \<V> f`])
            hence "(u,v) \<in> \<E> f" using nextVertex_in_edges[OF `u \<in> \<V> f`]
              by(simp add:fu)
            then obtain f' where "f' \<in> set(facesAt g v)" "(v,u) \<in>  \<E> f'"
              using mgp_edge_face_ex[OF mgp vg f] by blast
            hence "u = v" using not_cl `u \<in> V` `v \<in> V` 3
              by(force simp:close_def edges_face_eq split:split_if_asm)
          }
          ultimately show "u=v" using `u \<in> \<V> f` by blast
        next
          assume 3: "|vertices f| \<noteq> 3"
          hence 4: "|vertices f| = 4"
            using len mgp_vertices3[OF mgp minGraphProps5[OF mgp vg f]] by arith
          hence "\<V> f = {v, f \<bullet> v, f \<bullet> (f \<bullet> v), f \<bullet> (f \<bullet> (f \<bullet> v))}"
            using vertices_quad[OF _ vf distf] by simp
          moreover
          { assume "u = f \<bullet> v"
            hence "u = v"
              using not_cl f `u \<in> V` `v \<in> V` 4
              by(force simp:close_def split:split_if_asm)
          }
          moreover
          { assume "u = f \<bullet> (f \<bullet> v)"
            hence "u = v"
              using not_cl f `u \<in> V` `v \<in> V` 4
              by(force simp:close_def split:split_if_asm)
          }
          moreover
          { assume "u = f \<bullet> (f \<bullet> (f \<bullet> v))"
            hence fu: "f \<bullet> u = v"
              by(simp add: quad_next4_id[OF 4 distf `v \<in> \<V> f`])
            hence "(u,v) \<in> \<E> f" using nextVertex_in_edges[OF `u \<in> \<V> f`]
              by(simp add:fu)
            then obtain f' where "f' \<in> set(facesAt g v)" "(v,u) \<in>  \<E> f'"
              using mgp_edge_face_ex[OF mgp vg f] by blast
            hence "u = v" using not_cl `u \<in> V` `v \<in> V` 4
              by(force simp:close_def edges_face_eq split:split_if_asm)
          }
          ultimately show "u=v" using `u \<in> \<V> f` by blast
        qed
      }
      thus "\<V> f \<inter> V = {v}" using `v \<in> V` vf by blast
    qed
  qed
qed

lemma fin_aux: "finite B \<Longrightarrow> finite{f A|A. A \<subseteq> B \<and> P A}"
apply(rule finite_subset[where B = "f ` Pow B"])
 apply blast
apply simp
done

lemma sep_ne: "\<exists>P \<subseteq> M. separated g (fst ` P)"
by(unfold separated_def separated\<^sub>2_def separated\<^sub>3_def) blast

lemma ExcessNotAtRec_conv_Max:
assumes mgp: "minGraphProps g"
shows "set(map fst ps) <= \<V> g \<Longrightarrow> distinct(map fst ps) \<Longrightarrow>
  ExcessNotAtRec ps g =
  Max{ \<Sum>p\<in>P. snd p |P. P \<subseteq> set ps \<and> separated g (fst ` P)}"
  (is "_ \<Longrightarrow> _ \<Longrightarrow> _ = Max(?M ps)" is "_ \<Longrightarrow> _ \<Longrightarrow> _ = Max{_ |P. ?S ps P}")
proof(induct ps rule: length_induct)
  case (1 ps0)
  note IH = 1(1) and subset = 1(2) and dist = 1(3)
  show ?case
  proof (cases ps0)
    case Nil thus ?thesis by simp
  next
    case (Cons p ps)
    let ?ps = "deleteAround g (fst p) ps"
    have le: "|?ps| \<le> |ps|" by(simp add:delAround_def)
    have dist': "distinct(map fst ?ps)" using dist Cons
      apply (clarsimp simp:delAround_def)
      apply(drule distinct_filter[where P = "Not o close g (fst p)"])
      apply(simp add: filter_map o_def)
      done
    have "fst p : \<V> g" and "fst ` set ps <= \<V> g"
      using subset Cons by auto
    have sub1: "!!P Q. P <= {x : set ps. Q x} \<Longrightarrow> fst ` P <= \<V> g"
      using subset Cons by auto
    have sub2: "!!P Q. P <= insert p {x : set ps. Q x} \<Longrightarrow> fst ` P <= \<V> g"
      using subset Cons by auto
    have sub3: "!!P. P <= insert p (set ps) \<Longrightarrow> fst ` P <= \<V> g"
      using subset Cons by auto
    have "!!a. set (map fst (deleteAround g a ps)) \<subseteq> \<V> g"
      using deleteAround_subset[of g _ ps] subset Cons
      by auto
    hence "ExcessNotAtRec ps0 g = max (Max(?M ps)) (snd p + Max(?M ?ps))"
      using Cons IH subset le dist dist' by (cases p) simp
    also have "snd p + Max (?M ?ps) =
      Max {snd p + (\<Sum>p\<in>P. snd p) | P. ?S ?ps P}"
      by (auto simp add:add_Max_commute fin_aux sep_ne intro!: arg_cong [where f=Max])
    also have "{snd p + (\<Sum>p\<in>P. snd p) |P. ?S ?ps P} =
      {setsum snd (insert p P) |P. ?S ?ps P}"
      using dist Cons
      apply (auto simp:delAround_def)
      apply(rule_tac x=P in exI)
      apply(fastforce intro!: setsum.insert[THEN trans,symmetric] elim: finite_subset)
      apply(rule_tac x=P in exI)
      apply(fastforce intro!: setsum.insert[THEN trans] elim: finite_subset)
      done
    also have "\<dots> = {setsum snd P |P.
            P \<subseteq> insert p (set ?ps) \<and> p \<in> P \<and> separated g (fst ` P)}"
      apply(auto simp add:sep_conv[OF mgp] sub1 sub2 delAround_def cong: conj_cong)
      apply(rule_tac x = "insert p P" in exI)
      apply simp
      apply(rule conjI) apply blast
      using `image fst (set ps) <= \<V> g` `fst p : \<V> g`
      apply (blast intro:close_sym[OF mgp])
      apply(rule_tac x = "P-{p}" in exI)
      apply (simp add:insert_absorb)
      apply blast
      done
    also have "\<dots> = {setsum snd P |P.
            P \<subseteq> insert p (set ps) \<and> p \<in> P \<and> separated g (fst ` P)}"
      using Cons dist
      apply(auto simp add:sep_conv[OF mgp] sub2 sub3 delAround_def cong: conj_cong)
      apply(rule_tac x = "P" in exI)
      apply simp
      apply auto
      done
    also have "max (Max(?M ps)) (Max \<dots>) = Max(?M ps \<union> {setsum snd P |P.
            P \<subseteq> insert p (set ps) \<and> p \<in> P \<and> separated g (fst ` P)})"
      (is "_ = Max ?U")
    proof -
      have "{setsum snd P |P.
            P \<subseteq> insert p (set ps) \<and> p \<in> P \<and> separated g (fst ` P)} \<noteq> {}"
        apply simp
        apply(rule_tac x="{p}" in exI)
        using `fst p : \<V> g` by(simp add:sep_conv[OF mgp])
      thus ?thesis by(simp add: Max_Un fin_aux sep_ne)
    qed
    also have "?U = ?M ps0" using Cons by simp blast
    finally show ?thesis .
  qed
qed

lemma dist_ExcessTab: "distinct (map fst (ExcessTable g (vertices g)))"
by(simp add:ExcessTable_def vertices_graph o_def)

lemma mono_ExcessTab: "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g \<rbrakk> \<Longrightarrow>
  set(ExcessTable g (vertices g)) \<subseteq> set(ExcessTable g' (vertices g'))"
apply(clarsimp simp:ExcessTable_def image_def)
apply(rule conjI)
 apply(blast dest:next_plane0_vertices_subset inv_mgp)
apply (clarsimp simp:ExcessAt_def split:split_if_asm)
apply(frule (3) next_plane0_finalVertex_mono)
apply(simp add: next_plane0_len_filter_eq tri_def quad_def except_def)
done

lemma close_antimono:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g; u \<in> \<V> g; finalVertex g u \<rbrakk> \<Longrightarrow>
  close g' u v \<Longrightarrow> close g u v"
by(simp add:close_def next_plane0_finalVertex_facesAt_eq)

lemma ExcessTab_final:
 "p \<in> set(ExcessTable g (vertices g)) \<Longrightarrow> finalVertex g (fst p)"
by(clarsimp simp:ExcessTable_def image_def ExcessAt_def split:split_if_asm)

lemma ExcessTab_vertex:
 "p \<in> set(ExcessTable g (vertices g)) \<Longrightarrow> fst p \<in> \<V> g"
by(clarsimp simp:ExcessTable_def image_def ExcessAt_def split:split_if_asm)

lemma fst_set_ExcessTable_subset:
 "fst ` set (ExcessTable g (vertices g)) \<subseteq> \<V> g"
by(clarsimp simp:ExcessTable_def image_def ExcessAt_def split:split_if_asm)

lemma next_plane0_incr_ExcessNotAt:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g \<rbrakk> \<Longrightarrow>
  ExcessNotAt g None \<le> ExcessNotAt g' None"
apply(frule (1) invariantE[OF inv_inv_next_plane0])
apply(frule (1) mono_ExcessTab)
apply(simp add: ExcessNotAt_def ExcessNotAtRec_conv_Max[OF _ _ dist_ExcessTab]
  fst_set_ExcessTable_subset)
apply(rule Max_mono)
  prefer 2 apply (simp add: sep_ne)
 prefer 2 apply (simp add: fin_aux)
apply auto
apply(rule_tac x=P in exI)
apply auto
apply(subgoal_tac "fst ` P <= \<V> g'")
 prefer 2 apply (blast dest: ExcessTab_vertex)
apply(subgoal_tac "fst ` P <= \<V> g")
 prefer 2 apply (blast dest: ExcessTab_vertex)
apply(simp add:sep_conv)
apply (blast intro:close_antimono ExcessTab_final ExcessTab_vertex)
done
(* close -> in neibhood ?? *)

lemma next_plane0_incr_squander_lb:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g \<rbrakk> \<Longrightarrow>
  squanderLowerBound g \<le> squanderLowerBound g'"
apply(simp add:squanderLowerBound_def)
apply(frule (1) next_plane0_incr_ExcessNotAt)
apply(clarsimp simp add:next_plane0_def split:split_if_asm)
apply(drule (4) genPoly_incr_facesquander_lb)
apply arith
done

lemma inv_notame:
 "\<lbrakk>g' \<in> set (next_plane0\<^bsub>p\<^esub> g); inv g; notame7 g\<rbrakk>
  \<Longrightarrow> notame7 g'"
apply(simp add:notame_def notame7_def tame11b_def is_tame13a_def tame10ub_def del:disj_not1)
apply(frule inv_mgp)
apply(frule (1) next_plane0_vertices_subset)
apply(erule disjE)
 apply(simp add:vertices_graph)
apply(rule disjI2)
apply(erule disjE)
 apply clarify
 apply(frule (2) next_plane0_incr_degree)
 apply(frule (2) next_plane0_incr_except)
 apply (force split:split_if_asm)
apply(frule (1) next_plane0_incr_squander_lb)
apply(arith)
done

lemma inv_inv_notame:
 "invariant(\<lambda>g. inv g \<and> notame7 g) next_plane\<^bsub>p\<^esub>"
apply(simp add:invariant_def)
apply(blast intro: inv_notame mgp_next_plane0_if_next_plane[OF inv_mgp]
       invariantE[OF inv_inv_next_plane])
done

lemma untame_notame:
 "untame (\<lambda>g. inv g \<and> notame7 g)"
proof(clarsimp simp add: notame_def notame7_def untame_def tame11b_def is_tame13a_def tame10ub_def
                         linorder_not_le linorder_not_less)
  fix g assume "final g" "inv g" "tame g"
    and cases: "15 < countVertices g \<or>
                (\<exists>v\<in>\<V> g. (except g v = 0 \<longrightarrow> 7 < degree g v) \<and>
                            (0 < except g v \<longrightarrow> 6 < degree g v))
                \<or> squanderTarget \<le> squanderLowerBound g"
                (is "?A \<or> ?B \<or> ?C" is "_ \<or> (\<exists>v\<in>\<V> g. ?B' v) \<or> _")
  from cases show False
  proof(elim disjE)
    assume ?B
    then obtain v where v: "v \<in>\<V> g" "?B' v" by auto
    show False
    proof cases
      assume "except g v = 0"
      thus False using `tame g` v by(auto simp: tame_def tame11b_def)
    next
      assume "except g v \<noteq> 0"
      thus False using `tame g` v
        by(auto simp: except_def filter_empty_conv tame_def tame11b_def
          minGraphProps_facesAt_eq[OF inv_mgp[OF `inv g`]] split:split_if_asm)
    qed
  next
    assume ?A
    thus False using `tame g`  by(simp add:tame_def tame10_def)
  next
    assume ?C
    thus False using total_weight_lowerbound[OF `inv g` `final g` `tame g`]
      `tame g`  by(force simp add:tame_def tame13a_def)
  qed
qed

lemma polysizes_tame:
 "\<lbrakk> g' \<in> set (generatePolygon n v f g); inv g; f \<in> set(nonFinals g);
   v \<in> \<V> f; 3 \<le> n; n < 4+p; n \<notin> set(polysizes p g) \<rbrakk>
 \<Longrightarrow> notame7 g'"
apply(frule (4) in_next_plane0I)
apply(frule (4) genPoly_incr_facesquander_lb)
apply(frule (1) next_plane0_incr_ExcessNotAt)
apply(simp add: notame_def notame7_def is_tame13a_def faceSquanderLowerBound_def
           polysizes_def squanderLowerBound_def)
done

lemma genPolyTame_notame:
 "\<lbrakk> g' \<in> set (generatePolygon n v f g); g' \<notin> set (generatePolygonTame n v f g);
    inv g; 3 \<le> n \<rbrakk>
  \<Longrightarrow> notame7 g'"
by(fastforce simp:generatePolygon_def generatePolygonTame_def enum_enumerator
                 notame_def notame7_def)

declare upt_Suc[simp del] (* FIXME global? *)
lemma excess_notame:
 "\<lbrakk> inv g; g' \<in> set (next_plane\<^bsub>p\<^esub> g); g' \<notin> set (next_tame0 p g) \<rbrakk>
       \<Longrightarrow> notame7 g'"
apply(frule (1) mgp_next_plane0_if_next_plane[OF inv_mgp])
apply(auto simp add:next_tame0_def next_plane_def split:split_if_asm)
apply(rename_tac n)
apply(case_tac "n \<in> set(polysizes p g)")
 apply(drule bspec) apply assumption
 apply(simp add:genPolyTame_notame)
apply(subgoal_tac "minimalFace (nonFinals g) \<in> set(nonFinals g)")
 prefer 2 apply(simp add:minimalFace_def)
apply(subgoal_tac "minimalVertex g (minimalFace (nonFinals g)) \<in> \<V>(minimalFace (nonFinals g))")
 apply(blast intro:polysizes_tame)
apply(simp add:minimalVertex_def)
apply(rule minimal_in_set)
apply(erule mgp_vertices_nonempty[OF inv_mgp])
apply(simp add:nonFinals_def)
done
declare upt_Suc[simp]

lemma next_tame0_comp: "\<lbrakk> Seed\<^bsub>p\<^esub> [next_plane p]\<rightarrow>* g; final g; tame g \<rbrakk>
 \<Longrightarrow> Seed\<^bsub>p\<^esub> [next_tame0 p]\<rightarrow>* g"
apply(rule filterout_untame_succs[OF inv_inv_next_plane inv_inv_notame
  untame_notame])
    apply(blast intro:excess_notame)
   apply assumption
  apply(rule inv_Seed)
 apply assumption
apply assumption
done

lemma inv_inv_next_tame0: "invariant inv (next_tame0 p)"
by(rule inv_subset[OF inv_inv_next_plane next_tame0_subset_plane])

lemma inv_inv_next_tame: "invariant inv next_tame\<^bsub>p\<^esub>"
apply(simp add:next_tame_def)
apply(rule inv_subset[OF inv_inv_next_tame0])
apply auto
done

lemma mgp_TameEnum: "g \<in> TameEnum\<^bsub>p\<^esub> \<Longrightarrow> minGraphProps g"
by (unfold TameEnumP_def)
   (blast intro: RTranCl_inv[OF inv_inv_next_tame] inv_Seed inv_mgp)

end


theory IHT_Binary_Search
  imports
    "../Functional/BinarySearch"
    "../SepLogicTime/SLTC_Main"
    "../Asymptotics/Asymptotics_1D"
begin

partial_function (heap_time)  binarysearch :: "nat \<Rightarrow> nat \<Rightarrow> 'a::{heap,linorder} \<Rightarrow> 'a array \<Rightarrow> bool Heap" where
  "binarysearch l r x a = (
    if l \<ge> r then return False
    else if l + 1 \<ge> r then do {
      v \<leftarrow> Array_Time.nth a l;
      return (v = x) }
    else let m = avg l r in do {
      v \<leftarrow> Array_Time.nth a m;
      (if v = x then return True
       else if v < x then binarysearch (m + 1) r x a
       else binarysearch l m x a)
    })" (* apply pat_completeness by auto
termination by (relation "Wellfounded.measure (\<lambda>(l,r,a,f). r-l)") auto
*)
  print_theorems

function binarysearch_time :: "nat \<Rightarrow> nat" where
  "n < 2 \<Longrightarrow> binarysearch_time n = 2"
| "n \<ge> 2 \<Longrightarrow> binarysearch_time n = 2 + binarysearch_time (n div 2)"
by force simp_all
termination by (relation "Wellfounded.measure (\<lambda>n. n)") auto

definition binarysearch_time' :: "nat \<Rightarrow> real" where
  "binarysearch_time' n = real (binarysearch_time n)"

lemma div_2_to_rounding:
  "n - n div 2 = nat \<lceil>n / 2\<rceil>" "n div 2 = nat \<lfloor>n / 2\<rfloor>" by linarith+

lemma binarysearch_time'_Theta: "(\<lambda>n. binarysearch_time' n) \<in> \<Theta>(\<lambda>n. ln (real n))"
  apply (master_theorem2 2.3 recursion: binarysearch_time.simps(2) rew: binarysearch_time'_def div_2_to_rounding)
  prefer 2 apply auto2
  by (auto simp: binarysearch_time'_def)

setup \<open>fold add_rewrite_rule @{thms binarysearch_time.simps}\<close>

lemma binarysearch_mono [backward]:
  "m \<le> n \<Longrightarrow> binarysearch_time m \<le> binarysearch_time n"
proof (induction n arbitrary: m rule: less_induct)
  case (less n)
  show ?case
  proof (cases "m<2")
    case True
    then show ?thesis apply (cases "n<2") by auto
  next
    case False
    then show ?thesis using less(2) by (auto intro: less(1))
  qed
qed

lemma avg_diff1 [resolve]: "(l::nat) \<le> r \<Longrightarrow> r - (avg l r + 1) \<le> (r - l) div 2" by simp
lemma avg_diff2 [resolve]: "(l::nat) \<le> r \<Longrightarrow> avg l r - l \<le> (r - l) div 2" by simp

lemma binarysearch_correct [hoare_triple]:
  "r \<le> length xs \<Longrightarrow> l \<le> r \<Longrightarrow>
   <a \<mapsto>\<^sub>a xs * $(binarysearch_time (r - l))>
   binarysearch l r x a
   <\<lambda>res. a \<mapsto>\<^sub>a xs * \<up>(res \<longleftrightarrow> binarysearch_fun l r x xs)>\<^sub>t"
@proof @fun_induct "binarysearch_fun l r x xs"
  @unfold "binarysearch_fun l r x xs"
  @case "l \<ge> r" @case "l + 1 \<ge> r"
  @let "m = avg l r"
  @have "r - l \<ge> 2" @with
    @have "l + 2 = 2 + l" @have "r \<ge> 2 + l"  (* TODO: simplify *)
  @end
  @case "xs ! m < x" @with
    @have "binarysearch_time ((r - l) div 2) \<ge>\<^sub>t binarysearch_time (r - (m + 1))"
  @end
  @case "xs ! m > x" @with
    @have "binarysearch_time ((r - l) div 2) \<ge>\<^sub>t binarysearch_time (m - l)"
  @end
@qed

lemma binarysearch_correct' [hoare_triple]:
  "sorted xs \<Longrightarrow> r \<le> length xs \<Longrightarrow> l \<le> r \<Longrightarrow>
   <a \<mapsto>\<^sub>a xs * $(binarysearch_time (r - l))>
   binarysearch l r x a
   <\<lambda>res. a \<mapsto>\<^sub>a xs * \<up>(res \<longleftrightarrow> (\<exists>i. l \<le> i \<and> i < r \<and> xs ! i = x))>\<^sub>t"
  by auto2

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_61
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

fun lastOfTwo :: "Nat list => Nat list => Nat" where
  "lastOfTwo y (nil2) = last y"
| "lastOfTwo y (cons2 z2 x2) = last (cons2 z2 x2)"

theorem property0 :
  "((last (x xs ys)) = (lastOfTwo xs ys))"
  oops

end