(* Title:       One Part of Shannon's Source Coding Theorem
   Author:      Quentin Hibon <qh225@cl.cam.ac.uk>, Lawrence Paulson <lp15@cam.ac.uk>, 2014
   Maintainer:  Quentin Hibon <qh225@cl.cam.ac.uk>
*)

theory Source_Coding_Theorem
imports "HOL-Probability.Information"
begin
section\<open>Basic types\<close>

type_synonym bit = bool
type_synonym bword = "bit list"
type_synonym letter = nat
type_synonym 'b word = "'b list"

type_synonym 'b encoder = "'b word \<Rightarrow> bword"
type_synonym 'b decoder = "bword \<Rightarrow> 'b word option"

section\<open>Locale for the source coding theorem\<close>
locale source_code = information_space +
  fixes fi :: "'b \<Rightarrow> real"
  fixes X :: "'a \<Rightarrow> 'b"

  assumes distr_i: "simple_distributed M X fi"
  assumes b_val: "b = 2"

  fixes enc::"'b encoder"
  fixes dec::"'b decoder"
  assumes real_code:
  "dec (enc x) = Some x"
  "enc w = [] \<longleftrightarrow> w = []"
  "x \<noteq> [] \<longrightarrow> enc x = enc [hd x] @ enc (tl x)"

section\<open>Source coding theorem, direct: the entropy is a lower bound of the code rate\<close>
context source_code
begin
subsection\<open>The letter set\<close>

definition L :: "'b set" where
  "L \<equiv> X ` space M"

lemma fin_L: "finite L"
    using L_def distr_i
    by auto

lemma emp_L: "L \<noteq> {}"
    using L_def subprob_not_empty
    by auto

subsection\<open>Codes and words\<close>

abbreviation real_word :: "'b word \<Rightarrow> bool" where
  "real_word w \<equiv> (set w \<subseteq> L)"

abbreviation k_words :: "nat \<Rightarrow> ('b word) set" where
  "k_words k \<equiv> {w. length w = k \<and> real_word w}"

lemma rw_tail:
  assumes "real_word w"
shows "w = [] \<or> real_word (tl w)"
    by (meson assms list.set_sel(2) subset_code(1))

definition code_word_length :: "'e encoder \<Rightarrow> 'e \<Rightarrow> nat" where
  "code_word_length e l = length (e [l])"

abbreviation cw_len :: "'b \<Rightarrow> nat" where
  "cw_len l \<equiv> code_word_length enc l"

definition code_rate :: "'e encoder \<Rightarrow> ('a \<Rightarrow> 'e) \<Rightarrow> real" where
  "code_rate e Xo = expectation (\<lambda>a. (code_word_length e ((Xo) a)))"

lemma fi_pos: "i\<in> L \<Longrightarrow> 0 \<le> fi i"
    using simple_distributed_nonneg[OF distr_i] L_def by auto

lemma (in prob_space) simp_exp_composed:
  assumes X: "simple_distributed M X Px"
shows "expectation (\<lambda>a. f (X a)) = (\<Sum>x \<in> X`space M. f x * Px x)"
  using distributed_integral[OF simple_distributed[OF X], of f]
    simple_distributed_nonneg[OF X]
    lebesgue_integral_count_space_finite[OF simple_distributed_finite[OF X], of "\<lambda>x. f x * Px x"]
  by (simp add:  ac_simps)

lemma cr_rw:
  "code_rate enc X = (\<Sum>i \<in> X ` space M. fi i * cw_len i)"
    using simp_exp_composed[OF distr_i, of "cw_len"]
    by (simp add: mult.commute code_rate_def)

abbreviation cw_len_concat :: "'b word \<Rightarrow> nat" where
  "cw_len_concat w \<equiv> foldr (\<lambda>x s. (cw_len x) + s) w 0"

lemma cw_len_length: "cw_len_concat w = length (enc w)"
proof (induction w)
    case Nil
    show ?case using real_code by simp
    case (Cons a w)
    have "cw_len_concat (a # w) = cw_len a + cw_len_concat w" by simp
    thus ?case using code_word_length_def real_code Cons
      by (metis length_append list.distinct(1) list.sel(1) list.sel(3))
qed

lemma maj_fold:
  assumes "\<And>l. l\<in>L \<Longrightarrow> f l \<le> bound"
  assumes "real_word w"
shows "foldr (\<lambda>x s. f x + s) w 0 \<le> length w * bound"
    using assms
    by(induction w) (simp,fastforce)

definition max_len :: "nat" where
  "max_len = Max ((\<lambda>x. cw_len x) ` L)"

lemma max_cw:
  "l \<in> L \<Longrightarrow> cw_len l \<le> max_len"
    by (simp add: max_len_def fin_L)

subsection\<open>Related to the Kraft theorem\<close>
definition \<K> :: "real" where
  "\<K> = (\<Sum>i\<in>L. 1 / b ^ (cw_len i))"

lemma pos_cw_len: "0 < 1 / b ^ cw_len i" using b_gt_1 by simp

lemma \<K>_pos: "0 < \<K>"
    using emp_L fin_L pos_cw_len sum_pos \<K>_def
    by metis

lemma \<K>_pow: "\<K> = (\<Sum>i\<in>L. 1 / b powr cw_len i)"
    using powr_realpow b_gt_1
    by (simp add: \<K>_def)

lemma k_words_rel:
  "k_words (Suc k) = {w. (hd w \<in> L \<and> tl w \<in> k_words k \<and> w \<noteq> [])}"
proof
    fix k
    show "k_words (Suc k) \<subseteq> {w. (hd w \<in> L \<and> tl w \<in> k_words k \<and> w \<noteq> [] )}" (is "?l \<subseteq> ?r")
  proof
      fix w
      assume w_kw: "w \<in> k_words (Suc k)"
      hence "real_word w" by simp
      hence "hd w \<in> L"
        by (metis (mono_tags) w_kw hd_in_set list.size(3) mem_Collect_eq nat.distinct(1) subset_code(1))
      moreover have "length w = Suc k" using w_kw by simp
      moreover hence "w \<noteq> []" by auto
      moreover have "real_word (tl w)" using \<open>real_word w\<close> calculation(3) rw_tail by auto
      ultimately show "w \<in> ?r" using w_kw by simp
  qed
next
    fix k
    show "k_words (Suc k) \<supseteq> {w. (hd w \<in> L \<and> tl w \<in> k_words k \<and> w \<noteq> [])}"
  proof
      fix w
      assume asm: "w \<in> {w. hd w \<in> L \<and> tl w \<in> {w. length w = k \<and> real_word w} \<and> w \<noteq> []}"
      hence "hd w \<in> L \<and> length (tl w) = k \<and> real_word (tl w)" by simp
      hence "real_word w"
        by (metis empty_iff insert_subset list.collapse list.set(1) set_simps(2) subsetI)
      moreover hence "length w = Suc k" using asm by auto
      ultimately show "w \<in> k_words (Suc k)" by simp
  qed
qed

lemma bij_k_words:
shows "bij_betw (\<lambda>wi. Cons (fst wi) (snd wi)) (L \<times> k_words k) (k_words (Suc k))"
    unfolding bij_betw_def
proof
    fix k
    let ?f = "(\<lambda>wi. Cons (fst wi) (snd wi))"
    let ?S = "L \<times> (k_words k)"
    let ?T = "k_words (Suc k)"
    show "inj_on ?f ?S" by (simp add: inj_on_def)
    show "?f`?S = ?T"
  proof (rule ccontr)
      assume "?f ` ?S \<noteq> ?T"
      hence "\<exists>w. w\<in> ?T \<and> w \<notin> ?f`?S" by auto
      then obtain w where asm: "w\<in> ?T \<and> w \<notin> ?f`?S" by blast
      hence "w = ?f (hd w,tl w)" using k_words_rel by simp
      moreover have "(hd w,tl w) \<in> ?S" using k_words_rel asm by simp
      ultimately have "w \<in> ?f`?S" by blast
      thus "False" using asm by simp
  qed
qed

lemma finite_k_words: "finite (k_words k)"
proof (induct k)
    case 0
    show ?case by simp
    case (Suc n)
    thus ?case using bij_k_words bij_betw_finite fin_L by blast
qed

lemma cartesian_product:
  fixes f::"('c \<Rightarrow> real)"
  fixes g::"('d \<Rightarrow> real)"
  assumes "finite A"
  assumes "finite B"
shows "(\<Sum>b\<in>B. g b) * (\<Sum>a\<in>A. f a) = (\<Sum>ab\<in>A\<times>B. f (fst ab) * g (snd ab))"
    using bilinear_times bilinear_sum[where h="(\<lambda>x y. x * y)" and f="f" and g="g"] assms
    by (metis (erased, lifting) sum.cong split_beta' Groups.ab_semigroup_mult_class.mult.commute)

lemma \<K>_power:
shows "\<K>^k = (\<Sum>w \<in> (k_words k). 1 / b^(cw_len_concat w))"
proof (induct k)
    case 0
    have "k_words 0 = {[]}" by auto
    thus ?case by simp
next
    case (Suc n)
    have " \<K> ^Suc n = \<K> ^n * \<K> " by simp
    also have "\<dots> = (\<Sum>w \<in> k_words n. 1 / b^cw_len_concat w) * (\<Sum>i\<in>L. 1 / b^cw_len i)"
      using Suc.hyps \<K>_def by auto
    also have "\<dots> = (\<Sum>wi \<in> L \<times> k_words n. 1/b^cw_len (fst wi) * (1 / b^cw_len_concat (snd wi)))"
      using fin_L finite_k_words cartesian_product
      by blast
    also have "\<dots> = (\<Sum>wi \<in> L \<times> k_words n. 1 / b^(cw_len_concat (snd wi) + cw_len (fst wi)))"
      by (metis (no_types, lifting) power_add add.commute power_one_over)
    also have "\<dots> = (\<Sum>wi \<in> L \<times> k_words n. 1 / b^cw_len_concat (fst wi # snd wi))"
      by (metis (erased, lifting) add.commute comp_apply foldr.simps(2))
    also have "\<dots> = (\<Sum>w \<in> (k_words (Suc n)). 1 / b^(cw_len_concat w))"
      using bij_k_words sum.reindex_bij_betw by fastforce
    finally show ?case by simp
qed

lemma bound_len_concat:
shows "w \<in> k_words k \<Longrightarrow> cw_len_concat w \<le> k * max_len"
    using max_cw maj_fold by blast

subsection\<open>Inequality of the kraft sum (source coding theorem, direct)\<close>
subsubsection\<open>Sum manipulation lemmas and McMillan theorem\<close>

lemma sum_vimage_proof:
  fixes g::"nat \<Rightarrow> real"
  assumes "\<And>w. f w < bd"
shows "finite S \<Longrightarrow> (\<Sum>w\<in>S. g (f w)) = (\<Sum> m=0..<bd. (card ((f-`{m}) \<inter> S) )* g m)"
(is "_ \<Longrightarrow> _ = (\<Sum> m=0..<bd. ?ff m S)")
proof (induct S rule: finite_induct)
    case empty
    show ?case by simp
next
    case (insert x F)
    let ?rr = "(\<Sum>m = 0..<bd. ?ff m (insert x F))"
    have "(f x) \<in> {0..<bd}" using assms by simp
    hence "\<And>h::(nat \<Rightarrow> real). (\<Sum>m=0..<bd. h m) = (\<Sum>y\<in>({0..<bd} - {f x}).h y) + h (f x)"
      by (metis diff_add_cancel finite_atLeastLessThan sum_diff1)
    moreover hence
    "(\<Sum>m = 0..<bd. ?ff m (insert x F))
    = (\<Sum>m\<in>{0..<bd} - {f x}. ?ff m (insert x F)) + card (f -` {f x} \<inter> F) * g (f x) + g (f x)"
      by (simp add: semiring_normalization_rules(2), simp add: insert)
    ultimately have "(\<Sum>m = 0..<bd. ?ff m (insert x F)) = (\<Sum>m\<in>{0..<bd}. ?ff m F) + g (f x)"
      by fastforce
    thus ?case using insert by simp
qed

lemma sum_vimage:
  fixes g::"nat \<Rightarrow> real"
  assumes bounded: "\<And>w. w \<in> S \<Longrightarrow> f w < bd" and "0 < bd"
  assumes finite: "finite S"
shows "(\<Sum>w\<in>S. g (f w)) = (\<Sum> m=0..<bd. (card ((f-`{m}) \<inter> S) ) * g m)"
(is "?s1 = ?s2")
proof -
    let ?ff = "(\<lambda>x. if x\<in>S then f x else 0)"
    let ?ss1 = "(\<Sum>w\<in>S. g (?ff w))"
    let ?ss2 = "(\<Sum> m=0..<bd. (card ((?ff-`{m}) \<inter> S) ) * g m)"
    have "?s1 =?ss1" by simp
    moreover have"\<And>m. ?ff -`{m} \<inter> S = f-`{m} \<inter> S" by auto
    moreover hence "?s2 = ?ss2" by simp
    moreover have "\<And>w . ?ff w < bd" using assms by simp
    moreover hence "?ss1 = ?ss2" using sum_vimage_proof[of "?ff"] finite by blast
    ultimately show "?s1 = ?s2" by metis
qed

lemma \<K>_rw:
  "(\<Sum>w \<in> (k_words k). 1 / b^(cw_len_concat w)) = (\<Sum>m=0..<Suc (k*max_len). card (k_words k \<inter>
((cw_len_concat) -` {m})) * (1 / b^m))" (is "?L = ?R")
proof -
    have "\<And>w. w \<in> k_words k \<Longrightarrow> cw_len_concat w < Suc ( k * max_len)"
      by (simp add: bound_len_concat le_imp_less_Suc)
    moreover have
    "?R = (\<Sum>m = 0..<Suc (k * max_len).
  (card (cw_len_concat -` {m} \<inter> k_words k)) * (1 / b ^ m))"
      by (metis Int_commute)
    moreover have "0 < Suc (k*max_len)" by simp
    ultimately show ?thesis
      using finite_k_words
    sum_vimage[where f="cw_len_concat" and g = "\<lambda>i. 1/ (b^i)"]
      by fastforce
qed

definition set_of_k_words_length_m :: "nat \<Rightarrow> nat \<Rightarrow> 'b word set" where
  "set_of_k_words_length_m k m = {xk. xk \<in> k_words k} \<inter> (cw_len_concat)-`{m}"

lemma am_inj_code: "inj_on enc ((cw_len_concat)-`{m})" (is "inj_on _ ?s")
  using inj_on_def[of enc "?s"] real_code
  by (metis option.inject)

lemma img_inc: "enc`cw_len_concat-`{m} \<subseteq> {bl. length bl = m}" using cw_len_length by auto

lemma bool_lists_card: "card {bl::bool list. length bl = m} = b^m"
 using card_lists_length_eq[of "UNIV::bool set"]
  by (simp add: b_val)

lemma bool_list_fin: "finite {bl::bool list. length bl = m}"
  using finite_lists_length_eq[of "UNIV::bool set"]
  by (simp add: b_val)

lemma set_of_k_words_bound:
shows "card (set_of_k_words_length_m k m) \<le> b^m" (is "?c \<le> ?b")
proof -
    have card_w_len_m_bound: "card (cw_len_concat-`{m}) \<le> b^m"
      by (metis (no_types, lifting) am_inj_code bool_list_fin bool_lists_card card_image card_mono
    img_inc of_nat_le_iff)
    have "set_of_k_words_length_m k m \<subseteq> (cw_len_concat)-`{m}"
      by (simp add: set_of_k_words_length_m_def)
    hence "card (set_of_k_words_length_m k m) \<le> card ((cw_len_concat)-`{m})"
      by (metis (no_types, lifting) am_inj_code bool_list_fin card.infinite card_0_eq
    card_image card_mono empty_iff finite_subset img_inc inf_img_fin_dom)
    thus ?thesis using card_w_len_m_bound by simp
qed

lemma empty_set_k_words:
  assumes "0 < k"
shows "set_of_k_words_length_m k 0 = {}"
proof(rule ccontr)
    assume "\<not> set_of_k_words_length_m k 0 = {}"
    hence "\<exists>x. x \<in> set_of_k_words_length_m k 0" by auto
    then obtain x where x_def: "x \<in> set_of_k_words_length_m k 0" by auto
    hence "x \<noteq> []" unfolding set_of_k_words_length_m_def using assms by auto
    moreover have "cw_len_concat (hd x#tl x) = cw_len_concat (tl x) + cw_len (hd x)"
      by (metis add.commute comp_apply foldr.simps(2))
    moreover have "enc [(hd x)] \<noteq> []" using assms real_code by blast
    moreover hence "0 < cw_len (hd x)" unfolding code_word_length_def by simp
    ultimately have "x \<notin> set_of_k_words_length_m k 0" by (simp add:set_of_k_words_length_m_def)
    thus "False" using x_def by simp
qed

lemma \<K>_rw2:
  assumes "0 < k"
shows "(\<Sum>m=0..<Suc (k * max_len). card (set_of_k_words_length_m k m)/ b^m) \<le> (k * max_len)"
proof -
    have
    "(\<Sum>m=1..<Suc (k * max_len). card (set_of_k_words_length_m k m) / b^m)
    \<le> (\<Sum>m=1..<Suc(k * max_len). b^m / b^m)"
      using set_of_k_words_bound b_val
    Groups_Big.sum_mono[of "{1..<Suc(k * max_len)}"
    "(\<lambda>m. (card (set_of_k_words_length_m k m))/b^m)" "\<lambda>m. b^m /b^m"]
      by simp
    moreover have"(\<Sum>m=1..<Suc(k * max_len). b^m / b^m) = (\<Sum>m=1..<Suc(k *max_len). 1)"
      using b_gt_1 by simp
    moreover have "(\<Sum>m=1..<Suc(k * max_len). 1) = (k * max_len)"
      by simp
    ultimately have
    "(\<Sum>m = 1..<Suc (k * max_len). card (set_of_k_words_length_m k m) / b ^ m) \<le> k * max_len"
      by (metis One_nat_def card_atLeastLessThan card_eq_sum diff_Suc_Suc real_of_card)
    thus ?thesis using empty_set_k_words assms
      by (simp add: sum_shift_lb_Suc0_0_upt split: if_split_asm)
qed

lemma \<K>_power_bound :
  assumes "0 < k"
shows " \<K>^k \<le> k * max_len"
    using assms \<K>_power \<K>_rw \<K>_rw2
    by (simp add: set_of_k_words_length_m_def)

theorem McMillan :
shows "\<K> \<le> 1"
proof -
    have ineq: "\<And>k. 0 < k \<Longrightarrow> \<K> \<le> root k k * root k max_len"
      using \<K>_pos \<K>_power_bound
      by (metis (no_types, hide_lams) not_less of_nat_0_le_iff of_nat_mult power_strict_mono real_root_mult real_root_pos_pos_le real_root_pos_unique real_root_power)
    hence "0 < max_len \<Longrightarrow> (\<lambda>k. root k k * root k max_len) \<longlonglongrightarrow> 1"
      by (auto intro!: tendsto_eq_intros LIMSEQ_root LIMSEQ_root_const)
    moreover have "\<forall>n\<ge>1. \<K> \<le> root n n * root n max_len"
      using ineq by simp
    moreover have "max_len = 0 \<Longrightarrow> \<K> \<le> 1" using ineq by fastforce
    ultimately show " \<K> \<le> 1" using LIMSEQ_le_const by blast
qed

subsubsection\<open>Technical lemmas about the logarithm\<close>
lemma log_mult_ext3:
  "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> 0 < z \<Longrightarrow> x * log b (x*y*z) = x * log b (x*y) + x * log b z"
    by(cases "x=0")(simp add: log_mult_eq abs_of_pos distrib_left less_eq_real_def)+

lemma log_mult_ext2:
  "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> x * log b (x*y) = x * log b x + x * log b y"
    using log_mult_ext3[where y=1] by simp

subsubsection \<open>KL divergence and properties\<close>
definition KL_div ::"'b set \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> real" where
  "KL_div S a d = (\<Sum> i \<in> S. a i * log b (a i / d i))"

lemma KL_div_mul:
  assumes "0 < d" "d \<le> 1"
  assumes "\<And>i. i\<in>S \<Longrightarrow> 0 \<le> a i"
  assumes "\<And>i. i\<in>S \<Longrightarrow> 0 < e i"
shows "KL_div S a e \<ge> KL_div S a (\<lambda>i. e i / d)"
    unfolding KL_div_def
proof -
    {
    fix i
    assume "i\<in>S"
    hence "a i / (e i / d) \<le> a i / e i" using assms
      by (metis (no_types) div_by_1 frac_le less_imp_triv not_less)
    hence "log b (a i / (e i / d)) \<le> log b (a i / e i)" using assms(1)
      by (metis (full_types) b_gt_1 divide_divide_eq_left inverse_divide le_less_linear log_le
    log_neg_const order_refl times_divide_eq_right zero_less_mult_iff)
    }
    thus "(\<Sum>i\<in>S. a i * log b (a i / (e i / d))) \<le> (\<Sum>i\<in>S. a i * log b (a i / e i))"
      by (meson mult_left_mono assms sum_mono)
qed

lemma KL_div_pos:
  fixes a e::"'b \<Rightarrow> real"
  assumes fin: "finite S"
  assumes nemp: "S \<noteq> {}"
  assumes non_null: "\<And>i. i\<in>S \<Longrightarrow> 0 < a i" "\<And>i. i\<in> S \<Longrightarrow> 0 < e i"
  assumes sum_a_one: "(\<Sum> i \<in> S. a i) = 1"
  assumes sum_c_one: "(\<Sum> i \<in> S. e i) = 1"
shows "0 \<le> KL_div S a e"
    unfolding KL_div_def
proof -
    let ?f = "\<lambda>i. e i / a i"
    have f_pos: "\<And>i. i\<in>S \<Longrightarrow> 0 < ?f i"
      using non_null
      by simp
    have a_pos: "\<And>i. i\<in> S \<Longrightarrow> 0 \<le> a i"
      using non_null
      by (simp add: order.strict_implies_order)
    have "- log b (\<Sum>i\<in>S. a i * e i / a i) \<le> (\<Sum>i\<in>S. a i * - log b (e i / a i))"
      using convex_on_sum[OF fin nemp  minus_log_convex[OF b_gt_1] convex_real_interval(3)
                             sum_a_one a_pos, of "\<lambda>i. e i / a i"] f_pos by simp
    also have "-log b (\<Sum>i\<in>S. a i * e i / a i) = -log b (\<Sum>i\<in>S. e i)"
  proof -
      from non_null(1) have "\<And>i. i \<in> S \<Longrightarrow> a i * e i / a i = e i" by force
      thus ?thesis by simp
  qed
    finally have "0 \<le> (\<Sum>i\<in>S. a i * - log b (e i / a i))"
      by (simp add: sum_c_one)
    thus "0 \<le> (\<Sum>i\<in>S. a i * log b (a i / e i))"
      using b_gt_1 log_divide non_null
      by simp
qed

lemma KL_div_pos_emp:
  "0 \<le> KL_div {} a e" by (simp add: KL_div_def)

lemma KL_div_pos_gen:
  fixes a d::"'b \<Rightarrow> real"
  assumes fin: "finite S"
  assumes non_null: "\<And>i. i\<in>S \<Longrightarrow> 0 < a i" "\<And>i. i\<in> S \<Longrightarrow> 0 < d i"
  assumes sum_a_one: "(\<Sum> i \<in> S. a i) = 1"
  assumes sum_d_one: "(\<Sum> i \<in> S. d i) = 1"
shows "0 \<le> KL_div S a d"
    using KL_div_pos KL_div_pos_emp assms by metis

theorem KL_div_pos2:
  fixes a d::"'b \<Rightarrow> real"
  assumes fin: "finite S"
  assumes non_null: "\<And>i. i\<in>S \<Longrightarrow> 0 \<le> a i" "\<And>i. i\<in> S \<Longrightarrow> 0 < d i"
  assumes sum_a_one: "(\<Sum> i \<in> S. a i) = 1"
  assumes sum_c_one: "(\<Sum> i \<in> S. d i) = 1"
shows "0 \<le> KL_div S a d"
proof -
    have "S = (S \<inter> {i. 0 < a i}) \<union> (S \<inter> {i. 0 = a i})" using non_null(1) by fastforce
    moreover have "(S \<inter> {i. 0 < a i}) \<inter> (S \<inter> {i. 0 = a i}) = {}" by auto
    ultimately have
    eq: "KL_div S a d = KL_div (S \<inter> {i. 0 < a i}) a d + KL_div (S \<inter> {i. 0 = a i}) a d"
      unfolding KL_div_def
      by (metis (mono_tags, lifting) fin finite_Un sum.union_disjoint)
    have "KL_div (S \<inter> {i. 0 = a i}) a d = 0" unfolding KL_div_def by simp
    hence "KL_div S a d = KL_div (S \<inter> {i. 0 < a i}) a d" using eq by simp
    moreover have "0 \<le> KL_div (S \<inter> {i. 0 < a i}) a d"
  proof(cases "(S \<inter> {i. 0 < a i}) = {}")
      case True
      thus ?thesis unfolding KL_div_def by simp
  next
      case False
      let ?c = "\<lambda>i. d i / (\<Sum>j \<in>(S \<inter> {i. 0 < a i}). d j)"
      have 1: "(\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < a i)" by simp
      have 2: "(\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < ?c i)"
        by (metis False IntD1 divide_pos_pos fin finite_Int non_null(2) sum_pos)
      have 3: "(\<Sum>i\<in> (S \<inter> {i. 0 < a i}). a i) = 1"
        using sum.cong[of S, of S, of "(\<lambda>x. if x \<in> {i. 0 < a i} then a x else 0)", of a]
      sum.inter_restrict[OF fin, of a] non_null(1) sum_a_one
        by fastforce
      have "(\<Sum>i\<in>S \<inter> {j. 0 < a j}. ?c i) = (\<Sum>i\<in>S \<inter> {j. 0 < a j}. d i) / (\<Sum>i\<in>S \<inter> {j. 0 < a j}. d i)"
        by (metis sum_divide_distrib)
      hence 5: "(\<Sum>i\<in>S \<inter> {j. 0 < a j}. ?c i) = 1" using 2 False by force
      hence "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a ?c"
        using KL_div_pos_gen[
      OF finite_Int[OF disjI1, of S, of "{j. 0 < a j}"], of a, of ?c
      ] 1 2 3
        by (metis fin)
      have fstdb: "0 < (\<Sum>i\<in>S \<inter> {i. 0 < a i}. d i)" using non_null(2) False
        by (metis Int_Collect fin finite_Int sum_pos)
      have 6: "0 \<le> KL_div (S \<inter> {i. 0 < a i}) a (\<lambda>i. d i / (\<Sum>i\<in>(S \<inter> {i. 0 < a i}). d i))"
        using 2 3 5
        KL_div_pos_gen[
      OF finite_Int[OF disjI1, OF fin], of "{i. 0 < a i}", of "a", of "?c"
      ]
        by simp
      hence
      "KL_div (S \<inter> {j. 0 < a j}) a (\<lambda>i. d i / (\<Sum>i\<in>(S \<inter> {i. 0 < a i}). d i)) \<le> KL_div (S \<inter> {j. 0 < a j}) a d"
        using non_null sum.inter_restrict[OF fin, of d, of "{i. 0 < a i}"]
        sum_mono[of S, of "(\<lambda>x. if x \<in> {i. 0 < a i} then d x else 0)", of d] non_null(2) sum_c_one
        non_null(2) fstdb KL_div_mul
        by force
      moreover have "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a (\<lambda>i. d i / (\<Sum>i\<in>(S \<inter> {i. 0 < a i}). d i))"
        using KL_div_pos_gen[ OF finite_Int[OF disjI1, OF fin]] using 2 3 5 by fastforce
      ultimately show "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a d" by simp
  qed
    ultimately show ?thesis by simp
qed

lemma sum_div_1:
  fixes f::"'b \<Rightarrow> 'c::field"
  assumes "(\<Sum>i\<in>A. f i) \<noteq> 0"
shows "(\<Sum>i\<in>A. f i / (\<Sum>j\<in>A. f j)) = 1"
    by (metis (no_types) assms right_inverse_eq sum_divide_distrib)

theorem rate_lower_bound:
shows "\<H>(X) \<le> code_rate enc X"
proof -
    let ?cr = "code_rate enc X"
    let ?r = "(\<lambda>i. 1 / ((b powr cw_len i) * \<K>))"
    have pos_pi: "\<And>i. i \<in> L \<Longrightarrow> 0 \<le> fi i" using fi_pos by simp
    {
    fix i
    assume "i \<in> L"
    hence
    "fi i * (log b (1 / (1 / b powr (cw_len i))) + log b (fi i))
    = fi i * log b (fi i / (1 / b powr (cw_len i)))"
      using log_mult_ext2 [OF pos_pi, of i] b_gt_1
      by simp (simp add: algebra_simps)
    }
    hence eqpi:
    "\<And>i. i\<in> L \<Longrightarrow> fi i * (log b (1 / (1 / b powr (cw_len i))) + log b (fi i))
    = fi i * log b (fi i / (1 / b powr (cw_len i)))"
      by simp
    have sum_one_L: "(\<Sum> i \<in> L. fi i) = 1"
      using simple_distributed_sum_space[OF distr_i] by (simp add: L_def)
    {
    fix i
    assume "i \<in> L"
    hence h1: "0 \<le> fi i" using pos_pi by blast
    have h2: "0 < \<K> / (1/b powr cw_len i)" using b_gt_1 \<K>_pos by auto
    have h3: "0 < 1 / \<K>" using \<K>_pos by simp
    have
    "fi i * log b (fi i * \<K> / (1/b powr cw_len i) * (1/ \<K>)) =
    fi i * log b (fi i * \<K> / (1/b powr cw_len i)) + fi i * log b (1/ \<K>)"
      using log_mult_ext3[OF h1 h2 h3]
      by (metis times_divide_eq_right)
    } hence big_eq:
    "\<And>i. i \<in> L \<Longrightarrow> fi i * log b (fi i * \<K> / (1/b powr cw_len i) * (1 / \<K>)) =
    fi i * log b (fi i * \<K> / (1/b powr cw_len i)) + fi i * log b (1 / \<K>)"
      by (simp add: inverse_eq_divide)
    have 1: "?cr - \<H>(X) = (\<Sum>i \<in> L. fi i * cw_len i) + (\<Sum>i \<in> L. fi i * log b (fi i))"
      using \<K>_def entropy_rw cr_rw L_def by simp
    also have 2: "(\<Sum>i\<in>L. fi i * cw_len i) = (\<Sum>i \<in> L. fi i * (-log b (1/(b powr (cw_len i)))))"
      using b_gt_1 log_divide by simp
    also have "\<dots> = -1 * (\<Sum>i \<in> L. fi i * (log b (1/(b powr (cw_len i)))))"
      using sum_distrib_left[of "-1" "(\<lambda>i. fi i * (- 1 * log b (1 / b powr (cw_len i))))" L]
      by simp
    finally have
    "?cr - \<H>(X) = -(\<Sum>i \<in> L. fi i * log b (1/b powr cw_len i)) + (\<Sum>i \<in> L. fi i * log b (fi i))"
      by simp
    have "?cr - \<H>(X) = (\<Sum>i \<in> L. fi i * ((log b (1/ (1/(b powr (cw_len i))))) + log b (fi i)))"
      using b_gt_1 1
      by (simp add: distrib_left sum.distrib)
    also have "\<dots> = (\<Sum>i \<in> L. fi i *((log b (fi i / (1/(b powr (cw_len i)))))))"
      using Finite_Cartesian_Product.sum_cong_aux[OF eqpi] by simp
    also from big_eq have
    "\<dots> = (\<Sum>i\<in>L. fi i * (log b (fi i * \<K> / (1 / b powr (cw_len i))))) + (\<Sum>i \<in> L. fi i) * log b (1/ \<K>)"
      using \<K>_pos
      by (simp add: sum_distrib_right sum.distrib)
    also have "\<dots> = (\<Sum>i\<in>L. fi i * (log b (fi i * \<K> / (1 / b powr (cw_len i))))) - log b (\<K>)"
      using \<K>_pos
      by (simp add: log_inverse_eq divide_inverse sum_one_L)
    also have "\<dots> = (\<Sum> i \<in> L. fi i * log b (fi i / ?r i)) - log b (\<K>)"
      by (metis (mono_tags, hide_lams) divide_divide_eq_left divide_divide_eq_right)
    also have "\<dots> = KL_div L fi ?r - log b ( \<K>)"
      using b_gt_1 \<K>_pos log_inverse KL_div_def
      by simp
    also have "\<dots> = KL_div L fi ?r + log b (1 / \<K>)"
      using log_inverse b_val \<K>_pos
      by (simp add: inverse_eq_divide)
    finally have code_ent_kl_log: "?cr - \<H>(X) = KL_div L fi ?r + log b (1 / \<K>)" by simp
    have "(\<Sum>i\<in>L. ?r i) = 1"
      using sum_div_1[of "\<lambda>i. 1 / (b powr (cw_len i))"] \<K>_pos \<K>_pow
      by simp
    moreover have "\<And>i. 0 < ?r i" using b_gt_1 \<K>_pos by simp
    moreover have "(\<Sum>i\<in>L. fi i) = 1" using sum_one_L by simp
    ultimately have "0 \<le> KL_div L fi ?r"
      using KL_div_pos2[OF fin_L fi_pos] by simp
    hence "log b (1 / \<K>) \<le> ?cr - \<H>(X)" using code_ent_kl_log by simp
    moreover from McMillan have "0 \<le> log b (1 / \<K>)"
      using \<K>_pos
      by (simp add: b_gt_1)
    ultimately show ?thesis by simp
qed

end

end


(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
recently described verification components. Notice that this is an exact copy of
the file @{text HS_VC_MKA_Examples}, meaning our components are truly modular and
we can choose either a relational or predicate transformer semantics.\<close>

theory HS_VC_MKA_Examples_ndfun
  imports HS_VC_MKA_ndfun

begin

subsubsection\<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t
  else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified by providing dynamics. \<close>

lemma pendulum_dyn:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (EVOL \<phi> G T) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by simp

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (simp add: local_flow.wp_g_ode[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection\<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assigntment that
flips the velocity, thus it is a completely elastic collision with the ground. We use @{text "s$1"}
to ball's height and @{text "s$2"} for its velocity. We prove that the ball remains above ground
and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma bouncing_ball_inv:
  fixes h::real
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow> \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le>
  wp
    (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)
  ) \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all, force simp: bb_real_arith)
  by (rule wp_g_odei) (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified by providing dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags, hide_lams) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types, hide_lams) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
    by (simp add: monoid_mult_class.power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v))" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((EVOL (\<phi> g) (\<lambda>s. 0 \<le> s$1) T);
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  by (rule wp_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0));
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all add: local_flow.wp_g_ode[OF local_flow_ball])
  by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection\<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp_all add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.fbox_g_ode_ivl[OF local_flow_temp _ UNIV_I]

lemma thermostat:
  assumes "a > 0" and "0 \<le> t" and "0 < Tmin" and "Tmax < L"
  shows "\<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0\<rceil> \<le> wp
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>=(f a 0) & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a) on {0..t} UNIV @ 0)
    ELSE (x\<acute>=(f a L) & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a) on {0..t} UNIV @ 0)) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1)))
  \<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax\<rceil>"
  apply(rule wp_loopI, simp_all add: fbox_temp_dyn[OF assms(1,2)])
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

end


theory Aexp
imports Main
begin

section\<open>Arithmetic Expressions\<close>

text \<open>In this section, we model arithmetic expressions as total functions from valuations of
program variables to values. This modeling does not take into consideration the syntactic aspects
of arithmetic expressions. Thus, our modeling holds for any operator. However, some classical
notions, like the set of variables occurring in a given expression for example, must be rethought
and defined accordingly.\<close>

subsection\<open>Variables and their domain\<close>

text \<open>\textbf{Note}: in the following theories, we distinguish the set of \emph{program variables}
and the set
of \emph{symbolic variables}. A number of types we define are parameterized by a type of variables.
For example, we make a distinction between expressions (arithmetic or boolean) over program
variables and expressions over symbolic variables. This distinction eases some parts of the following
formalization.\<close>

paragraph \<open>Symbolic variables.\<close>

text \<open>A \emph{symbolic variable} is an indexed version of a program variable. In the following
type-synonym, we consider that the abstract type \<open>'v\<close> represent the set of program
variables. By set
of program variables, we do not mean \emph{the set of variables of a given program}, but
\emph{the set of variables of all possible programs}. This distinction justifies some of the
modeling choices done later. Within Isabelle/HOL, nothing is known about this set. The set of
program variables is infinite, though it is not needed to make this assumption. On the other hand,
the set of symbolic variables is infinite, independently of the fact that the set of program
variables is finite or not.\<close>

type_synonym 'v symvar = "'v \<times> nat"

lemma
  "\<not> finite (UNIV::'v symvar set)"
by (simp add : finite_prod)

text \<open>The previous lemma has no name and thus cannot be referenced in the following. Indeed, it is
of no use for proving the properties we are interested in. In the following, we will give other
unnamed lemmas when we think they might help the reader to understand the ideas behind our modeling
choices.\<close>

paragraph \<open>Domain of variables.\<close>

text \<open>We call @{term "D"} the domain of program and symbolic variables. In the following, we
suppose that @{term "D"} is the set of integers.\<close>

subsection\<open>Program and symbolic states\<close>

text \<open>A state is a total function giving values in @{term "D"} to variables. The latter are
represented by elements of type \<open>'v\<close>. Unlike in the \<open>'v symvar\<close> type-synonym, here
the type \<open>'v\<close> can stand for program variables as well as symbolic variables. States over
program variables are called \emph{program states}, and states over symbolic variables are called
\emph{symbolic states}.\<close>
type_synonym ('v,'d) state = "'v \<Rightarrow> 'd"

subsection\<open>The \emph{aexp} type-synonym\<close>

text \<open>Arithmetic (and boolean, see \verb?Bexp.thy?) expressions are represented by their
semantics, i.e.\
total functions giving values in @{term "D"} to states. This way of representing expressions has
the benefit that it is not necessary to define the syntax of terms (and formulae) appearing
in program statements and path predicates.\<close>

type_synonym ('v,'d) aexp =  "('v,'d) state \<Rightarrow> 'd"

text \<open>In order to represent expressions over program variables as well as symbolic variables,
the type synonym @{type "aexp"} is parameterized by the type of variables. Arithmetic and boolean
expressions over program variables are used to express program statements. Arithmetic and boolean
expressions over symbolic variables are used to represent the constraints occurring in path
predicates during symbolic execution.\<close>

subsection\<open>Variables of an arithmetic expression\<close>

text\<open>Expressions being represented by total functions, one can not say that a given variable is
occurring in a given expression. We define the set of variables of an expression as the set of
variables that can actually have an influence on the value associated by an expression to a state.
For example, the set of variables of the expression @{term "\<lambda> \<sigma>. \<sigma> x - \<sigma> y"} is @{term "{x,y}"},
provided that @{term "x"} and @{term "y"} are distinct variables, and the empty set otherwise. In
the second case, this expression would evaluate to $0$ for any state @{term
"\<sigma>"}. Similarly, an expression like
 @{term "\<lambda> \<sigma>.  \<sigma> x * (0::nat)"} is considered as having no
 variable as if a static evaluation of the multiplication had occurred.
\<close>

definition vars ::
  "('v,'d) aexp \<Rightarrow> 'v set"
where
  "vars e = {v. \<exists> \<sigma> val. e (\<sigma>(v := val)) \<noteq> e \<sigma>}"

lemma vars_example_1 :
  fixes e::"('v,integer) aexp"
  assumes "e = (\<lambda> \<sigma>. \<sigma> x - \<sigma> y)"
  assumes "x \<noteq> y"
  shows   "vars e = {x,y}"
unfolding set_eq_iff
proof (intro allI iffI)
  fix v assume "v \<in> vars e"

  then obtain \<sigma> val
  where "e (\<sigma>(v := val)) \<noteq> e \<sigma>"
  unfolding vars_def by blast

  thus "v \<in> {x, y}"
  using assms by (case_tac "v = x", simp, (case_tac "v = y", simp+))
next
  fix v assume "v \<in> {x,y}"

  thus "v \<in> vars e"
  using assms
  by (auto simp add : vars_def)
     (rule_tac ?x="\<lambda> v. 0" in exI, rule_tac ?x="1" in exI, simp)+
qed

lemma vars_example_2 :
  fixes e::"('v,integer) aexp"
  assumes "e = (\<lambda> \<sigma>. \<sigma> x - \<sigma> y)"
  assumes "x = y"
  shows   "vars e = {}"
using assms by (auto simp add : vars_def)

subsection\<open>Fresh variables\<close>

text \<open>Our notion of symbolic execution suppose \emph{static single assignment
form}. In order to symbolically execute an assignment, we require the existence of a fresh
symbolic variable for the configuration from which symbolic execution is performed. We define here
the notion of \emph{freshness} of a variable for an arithmetic expression.\<close>

text \<open>A variable is fresh for an expression if does not belong to its set of variables.\<close>

abbreviation fresh ::
  "'v \<Rightarrow> ('v,'d) aexp \<Rightarrow> bool"
where
  "fresh v e \<equiv> v \<notin> vars e"

end


section "Classes with Laws"

subsection "Equality"

theory Derive_Eq_Laws
  imports Main "../Derive" Derive_Datatypes
begin

class eq =
  fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes refl: "eq x x" and
          sym: "eq x y \<Longrightarrow> eq y x" and
          trans: "eq x y \<Longrightarrow> eq y z \<Longrightarrow> eq x z"

derive_generic_setup eq
  unfolding eq_class_law_def
  by blast

lemma eq_law_eq: "eq_class_law eq"
  unfolding eq_class_law_def
  using eq_class.axioms unfolding class.eq_def .

(* Manual instances for nat, unit, prod, and sum *)
instantiation nat and unit :: eq
begin
  definition eq_nat_def : "eq (x::nat) y \<longleftrightarrow> x = y"
  definition eq_unit_def: "eq (x::unit) y \<longleftrightarrow> True"
instance proof
  fix x y z :: nat
  show "eq x x" unfolding eq_nat_def by simp
  show "eq x y \<Longrightarrow> eq y x" unfolding eq_nat_def by simp
  show "eq x y \<Longrightarrow> eq y z \<Longrightarrow> eq x z" unfolding eq_nat_def by simp
next
  fix x y z :: unit
  show "eq x x" unfolding eq_unit_def by simp
  show "eq x y \<Longrightarrow> eq y x" unfolding eq_unit_def by simp
  show "eq x y \<Longrightarrow> eq y z \<Longrightarrow> eq x z" unfolding eq_unit_def by simp
qed
end

instantiation prod and sum :: (eq, eq) eq
begin
  definition eq_prod_def: "eq x y \<longleftrightarrow> (eq (fst x) (fst y)) \<and> (eq (snd x) (snd y))"
  definition eq_sum_def: "eq x y = (case x of Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> eq a b | Inr b \<Rightarrow> False)
                                            | Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> eq a b))"
instance proof
  fix x y z :: "('a::eq) \<times> ('b::eq)"
  show "eq x x" unfolding eq_prod_def by (simp add: eq_class.refl)
  show "eq x y \<Longrightarrow> eq y x" unfolding eq_prod_def by (simp add: eq_class.sym)
  show "eq x y \<Longrightarrow> eq y z \<Longrightarrow> eq x z" unfolding eq_prod_def by (meson eq_class.trans)
next
  fix x y z :: "('a::eq) + ('b::eq)"
  show "eq x x" unfolding eq_sum_def by (simp add: sum.case_eq_if eq_class.refl)
  show "eq x y \<Longrightarrow> eq y x" unfolding eq_sum_def by (metis eq_class.sym sum.case_eq_if)
  show "eq x y \<Longrightarrow> eq y z \<Longrightarrow> eq x z"
    unfolding eq_sum_def
    apply (simp only: sum.case_eq_if)
    apply (cases "isl x"; cases "isl y"; cases "isl z")
    by (auto simp add: eq_class.trans)
qed
end

(* nonrecursive test *)
derive_generic eq simple .

(* some tests *)
lemma "eq (A 4) (A 4)" by eval
lemma "eq (A 6) (A 4) \<longleftrightarrow> False" by eval
lemma "eq C C" by eval
lemma "eq (B 4 5) (B 4 5)" by eval
lemma "eq (B 4 4) (A 3) \<longleftrightarrow> False" by eval
lemma "eq C (A 4) \<longleftrightarrow> False" by eval

(* type with parameter *)

derive_generic eq either .

lemma "eq (L (3::nat)) (R 3) \<longleftrightarrow> False" by code_simp
lemma "eq (L (3::nat)) (L 3)" by code_simp
lemma "eq (L (3::nat)) (L 4) \<longleftrightarrow> False" by code_simp

(* recursive types *)
derive_generic eq list
proof goal_cases
  case (1 x)
  then show ?case
  proof (induction x)
    case (In y)
    then show ?case
      apply(cases y)
      by (auto simp add: Derive_Eq_Laws.eq_mulistF.simps eq_unit_def eq_class.refl)
  qed
next
  case (2 x y)
  then show ?case
  proof (induction y arbitrary: x)
    case (In y)
    then show ?case
      apply(cases x; cases y; hypsubst_thin)
       apply (simp add: Derive_Eq_Laws.eq_mulistF.simps sum.case_eq_if eq_unit_def)
       apply(metis old.sum.simps(5))
      unfolding sum_set_defs prod_set_defs
      apply (simp add: Derive_Eq_Laws.eq_mulistF.simps sum.case_eq_if)
      using eq_class.sym by fastforce
  qed
next
  case (3 x y z)
  then show ?case
  proof (induction x arbitrary: y z)
    case (In x')
    then show ?case
      apply(cases x')
      apply (cases y; cases z; hypsubst_thin)
       apply (simp add: Derive_Eq_Laws.eq_mulistF.simps sum.case_eq_if eq_unit_def)
       apply (metis sum.case_eq_if)
      apply(cases y; cases z; hypsubst_thin)
      unfolding sum_set_defs prod_set_defs
      apply (simp add: Derive_Eq_Laws.eq_mulistF.simps eq_unit_def snds.intros)
      apply (simp only: sum.case_eq_if)
      by (meson eq_class.trans)
  qed
qed

lemma "eq ([]::(nat list)) []" by eval
lemma "eq ([1,2,3]:: (nat list)) [1,2,3]" by eval
lemma "eq [(1::nat)] [1,2] \<longleftrightarrow> False" by eval

derive_generic eq tree
proof goal_cases
  case (1 x)
  then show ?case
  proof (induction x)
    case (In y)
    then show ?case
      apply(cases y)
      by (auto simp add: Derive_Eq_Laws.eq_mutreeF.simps eq_unit_def eq_class.refl)
  qed
next
  case (2 x y)
  then show ?case
  proof (induction y arbitrary: x)
    case (In y)
    then show ?case
      apply(cases x; cases y; hypsubst_thin)
       apply (simp add: Derive_Eq_Laws.eq_mutreeF.simps sum.case_eq_if eq_unit_def)
       apply(metis old.sum.simps(5))
      unfolding sum_set_defs prod_set_defs
      apply (simp add: Derive_Eq_Laws.eq_mutreeF.simps sum.case_eq_if)
      using eq_class.sym by fastforce
  qed
next
  case (3 x y z)
  then show ?case
  proof (induction x arbitrary: y z)
    case (In x')
    then show ?case
      apply(cases x')
      apply (cases y; cases z; hypsubst_thin)
       apply (simp add: Derive_Eq_Laws.eq_mutreeF.simps sum.case_eq_if eq_unit_def)
       apply (metis sum.case_eq_if)
      apply(cases y; cases z; hypsubst_thin)
      unfolding sum_set_defs prod_set_defs
      apply (simp add: Derive_Eq_Laws.eq_mutreeF.simps eq_unit_def snds.intros)
      apply (simp only: sum.case_eq_if)
      by (meson eq_class.trans)
  qed
qed

lemma "eq Leaf Leaf" by code_simp
lemma "eq (Node (1::nat) Leaf Leaf) Leaf \<longleftrightarrow> False" by eval
lemma "eq (Node (1::nat) Leaf Leaf) (Node (1::nat) Leaf Leaf)" by eval
lemma "eq (Node (1::nat) (Node 2 Leaf Leaf) (Node 3 Leaf Leaf)) (Node (1::nat) (Node 2 Leaf Leaf) (Node 4 Leaf Leaf))
    \<longleftrightarrow> False" by eval
end


theory ex3_12
imports AExp BExp begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"
type_synonym reg = nat

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

fun exec0 :: "instr0 \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"exec0 (LDI0 n) s rs = rs(0:= n)" |
"exec0 (LD0 x ) s rs = rs(0:= s x)" |
"exec0 (ADD0 r) s rs = rs(0:= (rs 0) + (rs r))" |
"exec0 (MV0 r ) s rs = rs(r:= (rs 0)) "

fun exec :: "instr0 list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> (reg \<Rightarrow> int)" where
"exec [] _ rs = rs" |
"exec (i#is) s rs = exec is s (exec0 i s rs)"

fun comp0 ::  "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp0 (N n) r = [LDI0 n] @ [MV0 r]" |
"comp0 (V x) r = [LD0 x] @ [MV0 r]" |
"comp0 (Plus e1 e2) r = comp0 e1 r @ [MV0 (r+1)] @ comp0 e2 (r+2) @ [ADD0 (r+1)] @ [MV0 r]"

lemma [simp]:"0 < r & r < k \<Longrightarrow> exec (comp0 a k) s rs r = rs r"
  apply (induction a arbitrary:rs r k)
  apply (auto)
  done

theorem "exec (comp0 a r) s rs 0 = aval a s"
  apply(induction a arbitrary:rs r)
  apply(auto)
  done

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_15
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

lemma t2_succ: "S (t2 n m) = t2 n (S m)"
  by(induct n, auto)

theorem property0 :
  "((t2 x (S x)) = (S (t2 x x)))"
  apply(induction x, auto)
  apply(simp add:t2_succ)
  done

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Reflexive Transitive Closure\<close>

theory Relation_Algebra_RTC
  imports Relation_Algebra
begin

text \<open>We impose the Kleene algebra axioms for the star on relation algebras.
This gives us a reflexive transitive closure operation.\<close>

class relation_algebra_rtc = relation_algebra + star_op +
  assumes rtc_unfoldl: "1' +  x ; x\<^sup>\<star> \<le> x\<^sup>\<star>"
    and rtc_inductl: "z + x ; y \<le> y \<longrightarrow> x\<^sup>\<star> ; z \<le> y"
    and rtc_inductr: "z + y ; x \<le> y \<longrightarrow> z ; x\<^sup>\<star> \<le> y"

sublocale relation_algebra_rtc \<subseteq> kleene_algebra "(+)" "(;)" "1'" 0 "(\<le>)" "(<)" star
apply (unfold_locales)
  apply (rule rtc_unfoldl)
 apply (simp add: local.rtc_inductl)
apply (simp add: rtc_inductr)
done

context relation_algebra_rtc
begin

text \<open>First, we prove that the obvious interaction between the star and
converse is captured by the axioms.\<close>

lemma star_conv: "(x\<^sup>\<star>)\<^sup>\<smile> = (x\<^sup>\<smile>)\<^sup>\<star>"
proof (rule antisym)
  show "(x\<^sup>\<smile>)\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<smile>"
    by (metis local.conv_add local.conv_contrav local.conv_e local.conv_iso local.star_rtc1 local.star_rtc_least)
  show "(x\<^sup>\<star>)\<^sup>\<smile> \<le> (x\<^sup>\<smile>)\<^sup>\<star>"
    by (metis boffa_var conv_add conv_contrav conv_e conv_invol conv_iso star_denest star_ext star_iso star_plus_one sup.idem)
qed

text \<open>Next we provide an example to show how facts from Kleene algebra are
picked up in relation algebra.\<close>

lemma rel_church_rosser: "(x\<^sup>\<smile>)\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<star> ; (x\<^sup>\<smile>)\<^sup>\<star> \<Longrightarrow> (x + x\<^sup>\<smile>)\<^sup>\<star> = x\<^sup>\<star> ; (x\<^sup>\<smile>)\<^sup>\<star>"
by (fact church_rosser)

end (* relation_algebra_rtc *)

end


theory Simplificacion3
imports Main
begin

section {* Reescritura con definiciones *}

text {* Ejemplo de definición: (cuadrado x) es el cuadrado de x. Por
  ejemplo,
     cuadrado (Suc (Suc 0)) = Suc (Suc (Suc (Suc 0)))
*}
definition cuadrado :: "nat \<Rightarrow> nat"
where
  "cuadrado n = n*n"

value "cuadrado (Suc (Suc 0))"

text {* Ejemplo de lema con reescritura usando definición: *}
lemma "cuadrado (Suc (Suc 0)) = Suc (Suc (Suc (Suc 0)))"
apply (simp add: cuadrado_def)
done

text {* Ejemplo de lema con reescritura usando definición: *}
lemma "cuadrado(n*n) = cuadrado(n)*cuadrado(n)"
apply (simp add: cuadrado_def)
done

end


(*  Title:      ZF/Fixedpt.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section\<open>Least and Greatest Fixed Points; the Knaster-Tarski Theorem\<close>

theory Fixedpt imports equalities begin

definition
  (*monotone operator from Pow(D) to itself*)
  bnd_mono :: "[i,i=>i]=>o"  where
     "bnd_mono(D,h) == h(D)<=D & (\<forall>W X. W<=X \<longrightarrow> X<=D \<longrightarrow> h(W) \<subseteq> h(X))"

definition
  lfp      :: "[i,i=>i]=>i"  where
     "lfp(D,h) == \<Inter>({X: Pow(D). h(X) \<subseteq> X})"

definition
  gfp      :: "[i,i=>i]=>i"  where
     "gfp(D,h) == \<Union>({X: Pow(D). X \<subseteq> h(X)})"

text\<open>The theorem is proved in the lattice of subsets of @{term D},
      namely @{term "Pow(D)"}, with Inter as the greatest lower bound.\<close>

subsection\<open>Monotone Operators\<close>

lemma bnd_monoI:
    "[| h(D)<=D;
        !!W X. [| W<=D;  X<=D;  W<=X |] ==> h(W) \<subseteq> h(X)
     |] ==> bnd_mono(D,h)"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_monoD1: "bnd_mono(D,h) ==> h(D) \<subseteq> D"
apply (unfold bnd_mono_def)
apply (erule conjunct1)
done

lemma bnd_monoD2: "[| bnd_mono(D,h);  W<=X;  X<=D |] ==> h(W) \<subseteq> h(X)"
by (unfold bnd_mono_def, blast)

lemma bnd_mono_subset:
    "[| bnd_mono(D,h);  X<=D |] ==> h(X) \<subseteq> D"
by (unfold bnd_mono_def, clarify, blast)

lemma bnd_mono_Un:
     "[| bnd_mono(D,h);  A \<subseteq> D;  B \<subseteq> D |] ==> h(A) \<union> h(B) \<subseteq> h(A \<union> B)"
apply (unfold bnd_mono_def)
apply (rule Un_least, blast+)
done

(*unused*)
lemma bnd_mono_UN:
     "[| bnd_mono(D,h);  \<forall>i\<in>I. A(i) \<subseteq> D |]
      ==> (\<Union>i\<in>I. h(A(i))) \<subseteq> h((\<Union>i\<in>I. A(i)))"
apply (unfold bnd_mono_def)
apply (rule UN_least)
apply (elim conjE)
apply (drule_tac x="A(i)" in spec)
apply (drule_tac x="(\<Union>i\<in>I. A(i))" in spec)
apply blast
done

(*Useful??*)
lemma bnd_mono_Int:
     "[| bnd_mono(D,h);  A \<subseteq> D;  B \<subseteq> D |] ==> h(A \<inter> B) \<subseteq> h(A) \<inter> h(B)"
apply (rule Int_greatest)
apply (erule bnd_monoD2, rule Int_lower1, assumption)
apply (erule bnd_monoD2, rule Int_lower2, assumption)
done

subsection\<open>Proof of Knaster-Tarski Theorem using @{term lfp}\<close>

(*lfp is contained in each pre-fixedpoint*)
lemma lfp_lowerbound:
    "[| h(A) \<subseteq> A;  A<=D |] ==> lfp(D,h) \<subseteq> A"
by (unfold lfp_def, blast)

(*Unfolding the defn of Inter dispenses with the premise bnd_mono(D,h)!*)
lemma lfp_subset: "lfp(D,h) \<subseteq> D"
by (unfold lfp_def Inter_def, blast)

(*Used in datatype package*)
lemma def_lfp_subset:  "A == lfp(D,h) ==> A \<subseteq> D"
apply simp
apply (rule lfp_subset)
done

lemma lfp_greatest:
    "[| h(D) \<subseteq> D;  !!X. [| h(X) \<subseteq> X;  X<=D |] ==> A<=X |] ==> A \<subseteq> lfp(D,h)"
by (unfold lfp_def, blast)

lemma lfp_lemma1:
    "[| bnd_mono(D,h);  h(A)<=A;  A<=D |] ==> h(lfp(D,h)) \<subseteq> A"
apply (erule bnd_monoD2 [THEN subset_trans])
apply (rule lfp_lowerbound, assumption+)
done

lemma lfp_lemma2: "bnd_mono(D,h) ==> h(lfp(D,h)) \<subseteq> lfp(D,h)"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule_tac [2] lfp_lemma1)
apply (assumption+)
done

lemma lfp_lemma3:
    "bnd_mono(D,h) ==> lfp(D,h) \<subseteq> h(lfp(D,h))"
apply (rule lfp_lowerbound)
apply (rule bnd_monoD2, assumption)
apply (rule lfp_lemma2, assumption)
apply (erule_tac [2] bnd_mono_subset)
apply (rule lfp_subset)+
done

(*Definition form, to control unfolding*)
lemma def_lfp_unfold:
    "[| A==lfp(D,h);  bnd_mono(D,h) |] ==> A = h(A)"
apply simp
apply (erule lfp_unfold)
done

subsection\<open>General Induction Rule for Least Fixedpoints\<close>

lemma Collect_is_pre_fixedpt:
    "[| bnd_mono(D,h);  !!x. x \<in> h(Collect(lfp(D,h),P)) ==> P(x) |]
     ==> h(Collect(lfp(D,h),P)) \<subseteq> Collect(lfp(D,h),P)"
by (blast intro: lfp_lemma2 [THEN subsetD] bnd_monoD2 [THEN subsetD]
                 lfp_subset [THEN subsetD])

(*This rule yields an induction hypothesis in which the components of a
  data structure may be assumed to be elements of lfp(D,h)*)
lemma induct:
    "[| bnd_mono(D,h);  a \<in> lfp(D,h);
        !!x. x \<in> h(Collect(lfp(D,h),P)) ==> P(x)
     |] ==> P(a)"
apply (rule Collect_is_pre_fixedpt
              [THEN lfp_lowerbound, THEN subsetD, THEN CollectD2])
apply (rule_tac [3] lfp_subset [THEN Collect_subset [THEN subset_trans]],
       blast+)
done

(*Definition form, to control unfolding*)
lemma def_induct:
    "[| A == lfp(D,h);  bnd_mono(D,h);  a:A;
        !!x. x \<in> h(Collect(A,P)) ==> P(x)
     |] ==> P(a)"
by (rule induct, blast+)

(*This version is useful when "A" is not a subset of D
  second premise could simply be h(D \<inter> A) \<subseteq> D or !!X. X<=D ==> h(X)<=D *)
lemma lfp_Int_lowerbound:
    "[| h(D \<inter> A) \<subseteq> A;  bnd_mono(D,h) |] ==> lfp(D,h) \<subseteq> A"
apply (rule lfp_lowerbound [THEN subset_trans])
apply (erule bnd_mono_subset [THEN Int_greatest], blast+)
done

(*Monotonicity of lfp, where h precedes i under a domain-like partial order
  monotonicity of h is not strictly necessary; h must be bounded by D*)
lemma lfp_mono:
  assumes hmono: "bnd_mono(D,h)"
      and imono: "bnd_mono(E,i)"
      and subhi: "!!X. X<=D ==> h(X) \<subseteq> i(X)"
    shows "lfp(D,h) \<subseteq> lfp(E,i)"
apply (rule bnd_monoD1 [THEN lfp_greatest])
apply (rule imono)
apply (rule hmono [THEN [2] lfp_Int_lowerbound])
apply (rule Int_lower1 [THEN subhi, THEN subset_trans])
apply (rule imono [THEN bnd_monoD2, THEN subset_trans], auto)
done

(*This (unused) version illustrates that monotonicity is not really needed,
  but both lfp's must be over the SAME set D;  Inter is anti-monotonic!*)
lemma lfp_mono2:
    "[| i(D) \<subseteq> D;  !!X. X<=D ==> h(X) \<subseteq> i(X)  |] ==> lfp(D,h) \<subseteq> lfp(D,i)"
apply (rule lfp_greatest, assumption)
apply (rule lfp_lowerbound, blast, assumption)
done

lemma lfp_cong:
     "[|D=D'; !!X. X \<subseteq> D' ==> h(X) = h'(X)|] ==> lfp(D,h) = lfp(D',h')"
apply (simp add: lfp_def)
apply (rule_tac t=Inter in subst_context)
apply (rule Collect_cong, simp_all)
done

subsection\<open>Proof of Knaster-Tarski Theorem using @{term gfp}\<close>

(*gfp contains each post-fixedpoint that is contained in D*)
lemma gfp_upperbound: "[| A \<subseteq> h(A);  A<=D |] ==> A \<subseteq> gfp(D,h)"
apply (unfold gfp_def)
apply (rule PowI [THEN CollectI, THEN Union_upper])
apply (assumption+)
done

lemma gfp_subset: "gfp(D,h) \<subseteq> D"
by (unfold gfp_def, blast)

(*Used in datatype package*)
lemma def_gfp_subset: "A==gfp(D,h) ==> A \<subseteq> D"
apply simp
apply (rule gfp_subset)
done

lemma gfp_least:
    "[| bnd_mono(D,h);  !!X. [| X \<subseteq> h(X);  X<=D |] ==> X<=A |] ==>
     gfp(D,h) \<subseteq> A"
apply (unfold gfp_def)
apply (blast dest: bnd_monoD1)
done

lemma gfp_lemma1:
    "[| bnd_mono(D,h);  A<=h(A);  A<=D |] ==> A \<subseteq> h(gfp(D,h))"
apply (rule subset_trans, assumption)
apply (erule bnd_monoD2)
apply (rule_tac [2] gfp_subset)
apply (simp add: gfp_upperbound)
done

lemma gfp_lemma2: "bnd_mono(D,h) ==> gfp(D,h) \<subseteq> h(gfp(D,h))"
apply (rule gfp_least)
apply (rule_tac [2] gfp_lemma1)
apply (assumption+)
done

lemma gfp_lemma3:
    "bnd_mono(D,h) ==> h(gfp(D,h)) \<subseteq> gfp(D,h)"
apply (rule gfp_upperbound)
apply (rule bnd_monoD2, assumption)
apply (rule gfp_lemma2, assumption)
apply (erule bnd_mono_subset, rule gfp_subset)+
done

lemma gfp_unfold: "bnd_mono(D,h) ==> gfp(D,h) = h(gfp(D,h))"
apply (rule equalityI)
apply (erule gfp_lemma2)
apply (erule gfp_lemma3)
done

(*Definition form, to control unfolding*)
lemma def_gfp_unfold:
    "[| A==gfp(D,h);  bnd_mono(D,h) |] ==> A = h(A)"
apply simp
apply (erule gfp_unfold)
done

subsection\<open>Coinduction Rules for Greatest Fixed Points\<close>

(*weak version*)
lemma weak_coinduct: "[| a: X;  X \<subseteq> h(X);  X \<subseteq> D |] ==> a \<in> gfp(D,h)"
by (blast intro: gfp_upperbound [THEN subsetD])

lemma coinduct_lemma:
    "[| X \<subseteq> h(X \<union> gfp(D,h));  X \<subseteq> D;  bnd_mono(D,h) |] ==>
     X \<union> gfp(D,h) \<subseteq> h(X \<union> gfp(D,h))"
apply (erule Un_least)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (rule Un_upper2 [THEN subset_trans])
apply (rule bnd_mono_Un, assumption+)
apply (rule gfp_subset)
done

(*strong version*)
lemma coinduct:
     "[| bnd_mono(D,h);  a: X;  X \<subseteq> h(X \<union> gfp(D,h));  X \<subseteq> D |]
      ==> a \<in> gfp(D,h)"
apply (rule weak_coinduct)
apply (erule_tac [2] coinduct_lemma)
apply (simp_all add: gfp_subset Un_subset_iff)
done

(*Definition form, to control unfolding*)
lemma def_coinduct:
    "[| A == gfp(D,h);  bnd_mono(D,h);  a: X;  X \<subseteq> h(X \<union> A);  X \<subseteq> D |] ==>
     a \<in> A"
apply simp
apply (rule coinduct, assumption+)
done

(*The version used in the induction/coinduction package*)
lemma def_Collect_coinduct:
    "[| A == gfp(D, %w. Collect(D,P(w)));  bnd_mono(D, %w. Collect(D,P(w)));
        a: X;  X \<subseteq> D;  !!z. z: X ==> P(X \<union> A, z) |] ==>
     a \<in> A"
apply (rule def_coinduct, assumption+, blast+)
done

(*Monotonicity of gfp!*)
lemma gfp_mono:
    "[| bnd_mono(D,h);  D \<subseteq> E;
        !!X. X<=D ==> h(X) \<subseteq> i(X)  |] ==> gfp(D,h) \<subseteq> gfp(E,i)"
apply (rule gfp_upperbound)
apply (rule gfp_lemma2 [THEN subset_trans], assumption)
apply (blast del: subsetI intro: gfp_subset)
apply (blast del: subsetI intro: subset_trans gfp_subset)
done

end


(*  Title:      ZF/AC/HH.thy
    Author:     Krzysztof Grabczewski

Some properties of the recursive definition of HH used in the proofs of
  AC17 \<Longrightarrow> AC1
  AC1 \<Longrightarrow> WO2
  AC15 \<Longrightarrow> WO6
*)

theory HH
imports AC_Equiv Hartog
begin

definition
  HH :: "[i, i, i] \<Rightarrow> i"  where
    "HH(f,x,a) \<equiv> transrec(a, \<lambda>b r. let z = x - (\<Union>c \<in> b. r`c)
                                    in  if f`z \<in> Pow(z)-{0} then f`z else {x})"

subsection\<open>Lemmas useful in each of the three proofs\<close>

lemma HH_def_satisfies_eq:
     "HH(f,x,a) = (let z = x - (\<Union>b \<in> a. HH(f,x,b))
                   in  if f`z \<in> Pow(z)-{0} then f`z else {x})"
by (rule HH_def [THEN def_transrec, THEN trans], simp)

lemma HH_values: "HH(f,x,a) \<in> Pow(x)-{0} | HH(f,x,a)={x}"
apply (rule HH_def_satisfies_eq [THEN ssubst])
apply (simp add: Let_def Diff_subset [THEN PowI], fast)
done

lemma subset_imp_Diff_eq:
     "B \<subseteq> A \<Longrightarrow> X-(\<Union>a \<in> A. P(a)) = X-(\<Union>a \<in> A-B. P(a))-(\<Union>b \<in> B. P(b))"
by fast

lemma Ord_DiffE: "\<lbrakk>c \<in> a-b; b<a\<rbrakk> \<Longrightarrow> c=b | b<c \<and> c<a"
apply (erule ltE)
apply (drule Ord_linear [of _ c])
apply (fast elim: Ord_in_Ord)
apply (fast intro!: ltI intro: Ord_in_Ord)
done

lemma Diff_UN_eq_self: "(\<And>y. y\<in>A \<Longrightarrow> P(y) = {x}) \<Longrightarrow> x - (\<Union>y \<in> A. P(y)) = x"
by (simp, fast elim!: mem_irrefl)

lemma HH_eq: "x - (\<Union>b \<in> a. HH(f,x,b)) = x - (\<Union>b \<in> a1. HH(f,x,b))
              \<Longrightarrow> HH(f,x,a) = HH(f,x,a1)"
apply (subst HH_def_satisfies_eq [of _ _ a1])
apply (rule HH_def_satisfies_eq [THEN trans], simp)
done

lemma HH_is_x_gt_too: "\<lbrakk>HH(f,x,b)={x}; b<a\<rbrakk> \<Longrightarrow> HH(f,x,a)={x}"
apply (rule_tac P = "b<a" in impE)
prefer 2 apply assumption+
apply (erule lt_Ord2 [THEN trans_induct])
apply (rule impI)
apply (rule HH_eq [THEN trans])
prefer 2 apply assumption+
apply (rule leI [THEN le_imp_subset, THEN subset_imp_Diff_eq, THEN ssubst],
       assumption)
apply (rule_tac t = "\<lambda>z. z-X" for X in subst_context)
apply (rule Diff_UN_eq_self)
apply (drule Ord_DiffE, assumption)
apply (fast elim: ltE, auto)
done

lemma HH_subset_x_lt_too:
     "\<lbrakk>HH(f,x,a) \<in> Pow(x)-{0}; b<a\<rbrakk> \<Longrightarrow> HH(f,x,b) \<in> Pow(x)-{0}"
apply (rule HH_values [THEN disjE], assumption)
apply (drule HH_is_x_gt_too, assumption)
apply (drule subst, assumption)
apply (fast elim!: mem_irrefl)
done

lemma HH_subset_x_imp_subset_Diff_UN:
    "HH(f,x,a) \<in> Pow(x)-{0} \<Longrightarrow> HH(f,x,a) \<in> Pow(x - (\<Union>b \<in> a. HH(f,x,b)))-{0}"
apply (drule HH_def_satisfies_eq [THEN subst])
apply (rule HH_def_satisfies_eq [THEN ssubst])
apply (simp add: Let_def Diff_subset [THEN PowI])
apply (drule split_if [THEN iffD1])
apply (fast elim!: mem_irrefl)
done

lemma HH_eq_arg_lt:
     "\<lbrakk>HH(f,x,v)=HH(f,x,w); HH(f,x,v) \<in> Pow(x)-{0}; v \<in> w\<rbrakk> \<Longrightarrow> P"
apply (frule_tac P = "\<lambda>y. y \<in> Pow (x) -{0}" in subst, assumption)
apply (drule_tac a = w in HH_subset_x_imp_subset_Diff_UN)
apply (drule subst_elem, assumption)
apply (fast intro!: singleton_iff [THEN iffD2] equals0I)
done

lemma HH_eq_imp_arg_eq:
  "\<lbrakk>HH(f,x,v)=HH(f,x,w); HH(f,x,w) \<in> Pow(x)-{0}; Ord(v); Ord(w)\<rbrakk> \<Longrightarrow> v=w"
apply (rule_tac j = w in Ord_linear_lt)
apply (simp_all (no_asm_simp))
 apply (drule subst_elem, assumption)
 apply (blast dest: ltD HH_eq_arg_lt)
apply (blast dest: HH_eq_arg_lt [OF sym] ltD)
done

lemma HH_subset_x_imp_lepoll:
     "\<lbrakk>HH(f, x, i) \<in> Pow(x)-{0}; Ord(i)\<rbrakk> \<Longrightarrow> i \<lesssim> Pow(x)-{0}"
  unfolding lepoll_def inj_def
apply (rule_tac x = "\<lambda>j \<in> i. HH (f, x, j) " in exI)
apply (simp (no_asm_simp))
apply (fast del: DiffE
            elim!: HH_eq_imp_arg_eq Ord_in_Ord HH_subset_x_lt_too
            intro!: lam_type ballI ltI intro: bexI)
done

lemma HH_Hartog_is_x: "HH(f, x, Hartog(Pow(x)-{0})) = {x}"
apply (rule HH_values [THEN disjE])
prefer 2 apply assumption
apply (fast del: DiffE
            intro!: Ord_Hartog
            dest!: HH_subset_x_imp_lepoll
            elim!: Hartog_lepoll_selfE)
done

lemma HH_Least_eq_x: "HH(f, x, \<mu> i. HH(f, x, i) = {x}) = {x}"
by (fast intro!: Ord_Hartog HH_Hartog_is_x LeastI)

lemma less_Least_subset_x:
     "a \<in> (\<mu> i. HH(f,x,i)={x}) \<Longrightarrow> HH(f,x,a) \<in> Pow(x)-{0}"
apply (rule HH_values [THEN disjE], assumption)
apply (rule less_LeastE)
apply (erule_tac [2] ltI [OF _ Ord_Least], assumption)
done

subsection\<open>Lemmas used in the proofs of @{term "AC1 \<Longrightarrow> WO2"} and @{term "AC17 \<Longrightarrow> AC1"}\<close>

lemma lam_Least_HH_inj_Pow:
        "(\<lambda>a \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,a))
         \<in> inj(\<mu> i. HH(f,x,i)={x}, Pow(x)-{0})"
apply (unfold inj_def, simp)
apply (fast intro!: lam_type dest: less_Least_subset_x
            elim!: HH_eq_imp_arg_eq Ord_Least [THEN Ord_in_Ord])
done

lemma lam_Least_HH_inj:
     "\<forall>a \<in> (\<mu> i. HH(f,x,i)={x}). \<exists>z \<in> x. HH(f,x,a) = {z}
      \<Longrightarrow> (\<lambda>a \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,a))
          \<in> inj(\<mu> i. HH(f,x,i)={x}, {{y}. y \<in> x})"
by (rule lam_Least_HH_inj_Pow [THEN inj_strengthen_type], simp)

lemma lam_surj_sing:
        "\<lbrakk>x - (\<Union>a \<in> A. F(a)) = 0;  \<forall>a \<in> A. \<exists>z \<in> x. F(a) = {z}\<rbrakk>
         \<Longrightarrow> (\<lambda>a \<in> A. F(a)) \<in> surj(A, {{y}. y \<in> x})"
apply (simp add: surj_def lam_type Diff_eq_0_iff)
apply (blast elim: equalityE)
done

lemma not_emptyI2: "y \<in> Pow(x)-{0} \<Longrightarrow> x \<noteq> 0"
by auto

lemma f_subset_imp_HH_subset:
     "f`(x - (\<Union>j \<in> i. HH(f,x,j))) \<in> Pow(x - (\<Union>j \<in> i. HH(f,x,j)))-{0}
      \<Longrightarrow> HH(f, x, i) \<in> Pow(x) - {0}"
apply (rule HH_def_satisfies_eq [THEN ssubst])
apply (simp add: Let_def Diff_subset [THEN PowI] not_emptyI2 [THEN if_P], fast)
done

lemma f_subsets_imp_UN_HH_eq_x:
     "\<forall>z \<in> Pow(x)-{0}. f`z \<in> Pow(z)-{0}
      \<Longrightarrow> x - (\<Union>j \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,j)) = 0"
apply (case_tac "P \<in> {0}" for P, fast)
apply (drule Diff_subset [THEN PowI, THEN DiffI])
apply (drule bspec, assumption)
apply (drule f_subset_imp_HH_subset)
apply (blast dest!: subst_elem [OF _ HH_Least_eq_x [symmetric]]
             elim!: mem_irrefl)
done

lemma HH_values2: "HH(f,x,i) = f`(x - (\<Union>j \<in> i. HH(f,x,j))) | HH(f,x,i)={x}"
apply (rule HH_def_satisfies_eq [THEN ssubst])
apply (simp add: Let_def Diff_subset [THEN PowI])
done

lemma HH_subset_imp_eq:
     "HH(f,x,i): Pow(x)-{0} \<Longrightarrow> HH(f,x,i)=f`(x - (\<Union>j \<in> i. HH(f,x,j)))"
apply (rule HH_values2 [THEN disjE], assumption)
apply (fast elim!: equalityE mem_irrefl dest!: singleton_subsetD)
done

lemma f_sing_imp_HH_sing:
     "\<lbrakk>f \<in> (Pow(x)-{0}) -> {{z}. z \<in> x};
         a \<in> (\<mu> i. HH(f,x,i)={x})\<rbrakk> \<Longrightarrow> \<exists>z \<in> x. HH(f,x,a) = {z}"
apply (drule less_Least_subset_x)
apply (frule HH_subset_imp_eq)
apply (drule apply_type)
apply (rule Diff_subset [THEN PowI, THEN DiffI])
apply (fast dest!: HH_subset_x_imp_subset_Diff_UN [THEN not_emptyI2], force)
done

lemma f_sing_lam_bij:
     "\<lbrakk>x - (\<Union>j \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,j)) = 0;
         f \<in> (Pow(x)-{0}) -> {{z}. z \<in> x}\<rbrakk>
      \<Longrightarrow> (\<lambda>a \<in> (\<mu> i. HH(f,x,i)={x}). HH(f,x,a))
          \<in> bij(\<mu> i. HH(f,x,i)={x}, {{y}. y \<in> x})"
  unfolding bij_def
apply (fast intro!: lam_Least_HH_inj lam_surj_sing f_sing_imp_HH_sing)
done

lemma lam_singI:
     "f \<in> (\<Prod>X \<in> Pow(x)-{0}. F(X))
      \<Longrightarrow> (\<lambda>X \<in> Pow(x)-{0}. {f`X}) \<in> (\<Prod>X \<in> Pow(x)-{0}. {{z}. z \<in> F(X)})"
by (fast del: DiffI DiffE
            intro!: lam_type singleton_eq_iff [THEN iffD2] dest: apply_type)

(*FIXME: both uses have the form ...[THEN bij_converse_bij], so
  simplification is needed!*)
lemmas bij_Least_HH_x =
    comp_bij [OF f_sing_lam_bij [OF _ lam_singI]
              lam_sing_bij [THEN bij_converse_bij]]

subsection\<open>The proof of @{term "AC1 \<Longrightarrow> WO2"}\<close>

(*Establishing the existence of a bijection, namely
converse
 (converse(\<lambda>x\<in>x. {x}) O
  Lambda
   (\<mu> i. HH(\<lambda>X\<in>Pow(x) - {0}. {f ` X}, x, i) = {x},
    HH(\<lambda>X\<in>Pow(x) - {0}. {f ` X}, x)))
Perhaps it could be simplified. *)

lemma bijection:
     "f \<in> (\<Prod>X \<in> Pow(x) - {0}. X)
      \<Longrightarrow> \<exists>g. g \<in> bij(x, \<mu> i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, i) = {x})"
apply (rule exI)
apply (rule bij_Least_HH_x [THEN bij_converse_bij])
apply (rule f_subsets_imp_UN_HH_eq_x)
apply (intro ballI apply_type)
apply (fast intro: lam_type apply_type del: DiffE, assumption)
apply (fast intro: Pi_weaken_type)
done

lemma AC1_WO2: "AC1 \<Longrightarrow> WO2"
  unfolding AC1_def WO2_def eqpoll_def
  apply (intro allI)
  apply (drule_tac x = "Pow(A) - {0}" in spec)
  apply (blast dest: bijection)
  done

end


(*  Title:      HOL/ex/Transfer_Int_Nat.thy
    Author:     Brian Huffman, TU Muenchen
*)

section \<open>Using the transfer method between nat and int\<close>

theory Transfer_Int_Nat
imports MainRLT
begin

subsection \<open>Correspondence relation\<close>

definition ZN :: "int \<Rightarrow> nat \<Rightarrow> bool"
  where "ZN = (\<lambda>z n. z = of_nat n)"

subsection \<open>Transfer domain rules\<close>

lemma Domainp_ZN [transfer_domain_rule]: "Domainp ZN = (\<lambda>x. x \<ge> 0)"
  unfolding ZN_def Domainp_iff[abs_def] by (auto intro: zero_le_imp_eq_int)

subsection \<open>Transfer rules\<close>

context includes lifting_syntax
begin

lemma bi_unique_ZN [transfer_rule]: "bi_unique ZN"
  unfolding ZN_def bi_unique_def by simp

lemma right_total_ZN [transfer_rule]: "right_total ZN"
  unfolding ZN_def right_total_def by simp

lemma ZN_0 [transfer_rule]: "ZN 0 0"
  unfolding ZN_def by simp

lemma ZN_1 [transfer_rule]: "ZN 1 1"
  unfolding ZN_def by simp

lemma ZN_add [transfer_rule]: "(ZN ===> ZN ===> ZN) (+) (+)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_mult [transfer_rule]: "(ZN ===> ZN ===> ZN) ((*)) ((*))"
  unfolding rel_fun_def ZN_def by simp

definition tsub :: "int \<Rightarrow> int \<Rightarrow> int"
  where "tsub k l = max 0 (k - l)"

lemma ZN_diff [transfer_rule]: "(ZN ===> ZN ===> ZN) tsub (-)"
  unfolding rel_fun_def ZN_def by (auto simp add: of_nat_diff tsub_def)

lemma ZN_power [transfer_rule]: "(ZN ===> (=) ===> ZN) (^) (^)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_nat_id [transfer_rule]: "(ZN ===> (=)) nat id"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_id_int [transfer_rule]: "(ZN ===> (=)) id int"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_All [transfer_rule]:
  "((ZN ===> (=)) ===> (=)) (Ball {0..}) All"
  unfolding rel_fun_def ZN_def by (auto dest: zero_le_imp_eq_int)

lemma ZN_transfer_forall [transfer_rule]:
  "((ZN ===> (=)) ===> (=)) (transfer_bforall (\<lambda>x. 0 \<le> x)) transfer_forall"
  unfolding transfer_forall_def transfer_bforall_def
  unfolding rel_fun_def ZN_def by (auto dest: zero_le_imp_eq_int)

lemma ZN_Ex [transfer_rule]: "((ZN ===> (=)) ===> (=)) (Bex {0..}) Ex"
  unfolding rel_fun_def ZN_def Bex_def atLeast_iff
  by (metis zero_le_imp_eq_int of_nat_0_le_iff)

lemma ZN_le [transfer_rule]: "(ZN ===> ZN ===> (=)) (\<le>) (\<le>)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_less [transfer_rule]: "(ZN ===> ZN ===> (=)) (<) (<)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_eq [transfer_rule]: "(ZN ===> ZN ===> (=)) (=) (=)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_Suc [transfer_rule]: "(ZN ===> ZN) (\<lambda>x. x + 1) Suc"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_numeral [transfer_rule]:
  "((=) ===> ZN) numeral numeral"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_dvd [transfer_rule]: "(ZN ===> ZN ===> (=)) (dvd) (dvd)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_div [transfer_rule]: "(ZN ===> ZN ===> ZN) (div) (div)"
  unfolding rel_fun_def ZN_def by (simp add: zdiv_int)

lemma ZN_mod [transfer_rule]: "(ZN ===> ZN ===> ZN) (mod) (mod)"
  unfolding rel_fun_def ZN_def by (simp add: zmod_int)

lemma ZN_gcd [transfer_rule]: "(ZN ===> ZN ===> ZN) gcd gcd"
  unfolding rel_fun_def ZN_def by (simp add: gcd_int_def)

lemma ZN_atMost [transfer_rule]:
  "(ZN ===> rel_set ZN) (atLeastAtMost 0) atMost"
  unfolding rel_fun_def ZN_def rel_set_def
  by (clarsimp simp add: Bex_def, arith)

lemma ZN_atLeastAtMost [transfer_rule]:
  "(ZN ===> ZN ===> rel_set ZN) atLeastAtMost atLeastAtMost"
  unfolding rel_fun_def ZN_def rel_set_def
  by (clarsimp simp add: Bex_def, arith)

lemma ZN_sum [transfer_rule]:
  "bi_unique A \<Longrightarrow> ((A ===> ZN) ===> rel_set A ===> ZN) sum sum"
  apply (intro rel_funI)
  apply (erule (1) bi_unique_rel_set_lemma)
  apply (simp add: sum.reindex int_sum ZN_def rel_fun_def)
  apply (rule sum.cong)
  apply simp_all
  done

text \<open>For derived operations, we can use the \<open>transfer_prover\<close>
  method to help generate transfer rules.\<close>

lemma ZN_sum_list [transfer_rule]: "(list_all2 ZN ===> ZN) sum_list sum_list"
  by transfer_prover

end

subsection \<open>Transfer examples\<close>

lemma
  assumes "\<And>i::int. 0 \<le> i \<Longrightarrow> i + 0 = i"
  shows "\<And>i::nat. i + 0 = i"
apply transfer
apply fact
done

lemma
  assumes "\<And>i k::int. \<lbrakk>0 \<le> i; 0 \<le> k; i < k\<rbrakk> \<Longrightarrow> \<exists>j\<in>{0..}. i + j = k"
  shows "\<And>i k::nat. i < k \<Longrightarrow> \<exists>j. i + j = k"
apply transfer
apply fact
done

lemma
  assumes "\<forall>x\<in>{0::int..}. \<forall>y\<in>{0..}. x * y div y = x"
  shows "\<forall>x y :: nat. x * y div y = x"
apply transfer
apply fact
done

lemma
  assumes "\<And>m n::int. \<lbrakk>0 \<le> m; 0 \<le> n; m * n = 0\<rbrakk> \<Longrightarrow> m = 0 \<or> n = 0"
  shows "m * n = (0::nat) \<Longrightarrow> m = 0 \<or> n = 0"
apply transfer
apply fact
done

lemma
  assumes "\<forall>x\<in>{0::int..}. \<exists>y\<in>{0..}. \<exists>z\<in>{0..}. x + 3 * y = 5 * z"
  shows "\<forall>x::nat. \<exists>y z. x + 3 * y = 5 * z"
apply transfer
apply fact
done

text \<open>The \<open>fixing\<close> option prevents generalization over the free
  variable \<open>n\<close>, allowing the local transfer rule to be used.\<close>

lemma
  assumes [transfer_rule]: "ZN x n"
  assumes "\<forall>i\<in>{0..}. i < x \<longrightarrow> 2 * i < 3 * x"
  shows "\<forall>i. i < n \<longrightarrow> 2 * i < 3 * n"
apply (transfer fixing: n)
apply fact
done

lemma
  assumes "gcd (2^i) (3^j) = (1::int)"
  shows "gcd (2^i) (3^j) = (1::nat)"
apply (transfer fixing: i j)
apply fact
done

lemma
  assumes "\<And>x y z::int. \<lbrakk>0 \<le> x; 0 \<le> y; 0 \<le> z\<rbrakk> \<Longrightarrow>
    sum_list [x, y, z] = 0 \<longleftrightarrow> list_all (\<lambda>x. x = 0) [x, y, z]"
  shows "sum_list [x, y, z] = (0::nat) \<longleftrightarrow> list_all (\<lambda>x. x = 0) [x, y, z]"
apply transfer
apply fact
done

text \<open>Quantifiers over higher types (e.g. \<open>nat list\<close>) are
  transferred to a readable formula thanks to the transfer domain rule @{thm Domainp_ZN}\<close>

lemma
  assumes "\<And>xs::int list. list_all (\<lambda>x. x \<ge> 0) xs \<Longrightarrow>
    (sum_list xs = 0) = list_all (\<lambda>x. x = 0) xs"
  shows "sum_list xs = (0::nat) \<longleftrightarrow> list_all (\<lambda>x. x = 0) xs"
apply transfer
apply fact
done

text \<open>Equality on a higher type can be transferred if the relations
  involved are bi-unique.\<close>

lemma
  assumes "\<And>xs::int list. \<lbrakk>list_all (\<lambda>x. x \<ge> 0) xs; xs \<noteq> []\<rbrakk> \<Longrightarrow>
    sum_list xs < sum_list (map (\<lambda>x. x + 1) xs)"
  shows "xs \<noteq> [] \<Longrightarrow> sum_list xs < sum_list (map Suc xs)"
apply transfer
apply fact
done

end