theory Source_Code
imports "~~/src/HOL/Probability/Information"
begin
(*
AIM: Formalize Shannon's theorems
*)

section{* Basic types *}

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"
type_synonym 'b code = "'b encoder * 'b decoder"

type_synonym 'b prob = "'b \<Rightarrow> real"

section{* First locale, generic to both Shannon's theorems *}
(*
X is the input, Y is the output.
They are not independent (if they are, all of this serves no purpose)
We fix N, N' the measures (TODO: should I? Can we have two different bit measures?)
The input is only correlated to the corresponding output.
From a code, we consider:
_its extension: the code obtained when we encode each
letter and concatenate the result (and fortunately decode it if it has some good
properties).
_its block code, with a natural parameter, that takes mentioned number of
letters, consider it as a single character (of a new alphabet), and encode it.
*)

(* locale generic to both theorems *)
locale source_code = information_space +
(* information source *)
  fixes fi :: "'b \<Rightarrow> real"
  fixes X::"'a \<Rightarrow> 'b"
  assumes distr_i: "simple_distributed M X fi"
(*
According to RAHM, this should be a rat: my impression is that they aim for a code that can achieve
precisely this rate, however the gist is that we can achieve a rate equal OR better than H + \<epsilon>, so
in my mind it is not that important. In the Shannon's original paper it is not clear to me either.
*)
  fixes H::real

(*
The entropy depends on the value of b, which is the cardinal of the set of available
output symbols.
*)
(*
I have tried to use statements that do not use the value of b explicitly, using b_gt_1 whenever
possible. However it is not possible to avoid using this value altogether, since it is encoded in
the output type of the code (which is a bword, a word of bits). This is one of the shortcomings of
Isabelle vs Coq/SSreflect, where dependent parameter types are available.
*)
  assumes b_val: "b = 2"
  assumes entropy_defi: "H = \<H>(X)"

  fixes L :: "'b set"
  assumes fin_L: "finite L"
  assumes emp_L: "L \<noteq> {}"

(*
TLDR: technicality
The assumption boils down to say that for all letter l in L, there is a "omega" such that X(omega) =
l. Even with that, we can still have P(X=l) = 0, if only by modifying X for one value in the
(continuous) probability space but keeping the same distribution.
*)
  assumes bounded_input: "X ` space M = L"

  fixes c::"'b code"
  assumes real_code : "((\<forall>x. snd c (fst c x) = Some x) \<and>
(\<forall>w. (fst c) w = [] \<longleftrightarrow> w = []) \<and>
(\<forall>x. x \<noteq> [] \<longrightarrow> fst c x = (fst c) [(hd x)] @ (fst c) (tl x)))"

(*
TODO: Have some predicates to allow reasonings about codes. Keep the input_block_size that limits
the size of the input, and use it.
*)
(*
We will generalize the type "code" to any input by splitting the input in piece of length below a
constant.
*)
section{* Source coding theorem, direct: the entropy is a lower bound *}
context source_code
begin
subsection{* Codes and words *}

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))

(*
length of the codeword associated with the letter
*)
definition code_word_length :: "'e code \<Rightarrow> 'e \<Rightarrow> nat" where
  "code_word_length co l = length ((fst co) [l])"

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

(*
The code rate is the expectation of the length of the code taken on all inputs (which is a finite
set, the set of letters).
*)
definition code_rate :: "'e code \<Rightarrow> ('a \<Rightarrow> 'e) \<Rightarrow> real" where
  "code_rate co Xo = expectation (\<lambda>a. (code_word_length co ((Xo) a)))"

abbreviation cr :: "real" where
  "cr \<equiv> code_rate c X"

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

(*
Proof by Johannes Hölzl
*)
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]
    by (simp add: lebesgue_integral_count_space_finite[OF simple_distributed_finite[OF X]] ac_simps)

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

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 (fst c 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{* Related to the Kraft theorem *}
definition kraft_sum :: "real" where
  "kraft_sum = (\<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 kraft_sum_nonnull: "0 < kraft_sum"
    using emp_L fin_L pos_cw_len setsum_pos kraft_sum_def
    by metis

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

definition kraft_inequality :: "bool" where
  "kraft_inequality = (kraft_sum \<le> 1)"

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_setsum[where h="(\<lambda>x y. x * y)" and f="f" and g="g"] assms
    by (metis (erased, lifting) setsum.cong split_beta' Groups.ab_semigroup_mult_class.mult.commute)

lemma kraft_sum_power :
shows "kraft_sum ^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 "kraft_sum ^Suc n = kraft_sum ^n * kraft_sum " 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 kraft_sum_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 setsum.reindex_bij_betw by fastforce
    finally show ?case by simp
qed

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

subsection{* Inequality of the kraft sum (source coding theorem, direct) *}
subsubsection{* Sum manipulation lemmas and McMillan theorem *}

lemma real_plus_one:
shows "real ((n::nat) + 1) * r = (n * r + r)"
    by (simp add: semiring_normalization_rules(2))

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))"
  (* focusing of the right hand term *)
    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 setsum_diff1_ring)
    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)"
      using insert real_plus_one by fastforce
    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

(*
5.54
*)
lemma kraft_sum_rewrite :
  "(\<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 :
shows "inj_on (fst c) ((cw_len_concat)-`{m})" (is "inj_on ?enc ?s")
proof -
    fix x y
    let ?dec = "snd c"
    have "x \<in> ?s \<and> y \<in> ?s \<and> ?enc x = ?enc y \<longrightarrow> ?dec (?enc x) = ?dec (?enc y)" by auto
    moreover have "(\<forall>x. snd c (fst c x) = Some x)" using real_code by blast
    ultimately show ?thesis using inj_on_def[of "?enc" "?s"] by (metis option.inject)
qed

lemma img_inc:
shows "(fst c)`(cw_len_concat)-`{m} \<subseteq> {bl. length bl = m}"
proof
    fix y
    assume "y \<in>(fst c)`(cw_len_concat)-`{m}"
    then obtain x where "y = fst c x" "x\<in>(cw_len_concat)-`{m}" by auto
    thus "y \<in> {bl. length bl = m}" using cw_len_length by simp
qed

lemma bool_list_fin:
  "finite {bl::bool list. length bl = m}"
proof -
    have "{bl. set bl \<subseteq> {True, False} \<and> length bl = m} = {bl. length bl= m}" by auto
    moreover have "finite {bl. set bl \<subseteq> {True, False} \<and> length bl = m}"
      by (simp add: finite_lists_length_eq)
    ultimately show ?thesis by simp
qed

lemma bool_lists_card:
shows "card {bl::bool list. length bl = m} = b^m"
proof -
    have "card {b. set b \<subseteq> {True,False} \<and> length b = m} = card {True,False}^m"
      using card_lists_length_eq[of "{True,False}"] by simp
    moreover have "card {True, False} = b" using b_val by simp
    moreover have "\<And>d. d \<in> {c::(bool list). True} \<longleftrightarrow> set d \<subseteq> {True, False}" by auto
    ultimately show ?thesis by simp
qed

lemma img_card:
  assumes "real_code c"
shows "card (fst c`cw_len_concat-`{m}) \<le> b^m"
proof -
    have "card ((fst c)` (cw_len_concat)-`{m}) \<le> card {b::(bool list). length b = m}"
      by (metis (mono_tags) bool_list_fin img_inc card_mono)
    thus ?thesis by (metis bool_lists_card of_nat_le_iff)
qed

lemma am_maj_aux2:
shows "finite ((cw_len_concat)-`{m}) \<and> (card ((cw_len_concat)-`{m})) \<le> b^m"
    by (metis (no_types, lifting) am_inj_code bool_list_fin bool_lists_card card.infinite card_0_eq
  card_image card_mono empty_iff finite_subset img_inc inf_img_fin_dom of_nat_le_iff)

lemma am_maj:
shows "card (set_of_k_words_length_m k m)\<le> b^m" (is "?c \<le> ?b")
proof -
    have "set_of_k_words_length_m k m \<subseteq> (cw_len_concat)-`{m}"
      using set_of_k_words_length_m_def by simp
    hence "card (set_of_k_words_length_m k m) \<le> card ((cw_len_concat)-`{m})"
      using assms am_maj_aux2 card_mono by blast
    thus ?thesis using real_code am_maj_aux2[of m] 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 "(fst c) [(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 kraft_sum_rewrite2:
  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 am_maj b_val
    Groups_Big.setsum_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_setsum diff_Suc_Suc real_of_card)
    thus ?thesis using empty_set_k_words assms
      by (simp add: setsum_shift_lb_Suc0_0_upt split: split_if_asm)
qed

lemma kraft_sum_power_bound :
  assumes "0 < k"
shows "kraft_sum^k \<le> (k * max_len)"
    using assms kraft_sum_power kraft_sum_rewrite kraft_sum_rewrite2
    by (simp add: set_of_k_words_length_m_def)

theorem McMillan :
shows "kraft_inequality"
proof -
    have ineq: "\<And>k. 0 < k \<Longrightarrow> (kraft_sum) \<le> root k k * root k (max_len)"
      using kraft_sum_nonnull kraft_sum_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"
      using LIMSEQ_root LIMSEQ_root_const tendsto_mult
      by fastforce
    moreover have "\<forall>n\<ge>1. kraft_sum \<le> root n n * root n (max_len)"
      using ineq by simp
    moreover have "max_len = 0 \<Longrightarrow> kraft_sum \<le> 1" using ineq by fastforce
    ultimately have "kraft_sum \<le> 1" using LIMSEQ_le_const by blast
    thus "kraft_inequality" unfolding kraft_inequality_def by simp
qed

lemma entropy_rewrite: "H = -(\<Sum>i \<in> L. fi i * log b (fi i))"
    using entropy_simple_distributed[OF distr_i] bounded_input
    by (simp add: entropy_defi)

lemma log_mult_ext_not_0:
  "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> 0 < z \<Longrightarrow> x * log b (x*z*y) = x * log b (x*z) + x * log b y"
    using b_gt_1 distrib_left log_mult by simp

lemma log_mult_ext_3:
  " 0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> 0 < z \<Longrightarrow> x * log b (x*z*y) = x * log b (x*z) + x * log b y"
    using log_mult_ext_not_0[of x] mult_zero_left[of "log b (0 * z * y)"] by fastforce

lemma log_mult_ext2: "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> x * log b (x*y) = x * log b (x) + x * log b y"
    by (metis (no_types) log_mult_ext_3 mult.right_neutral zero_less_one)

subsubsection {* KL divergence and properties *}
(*
TODO (eventually): I use a custom definition of the KL_divergence, as it is far simpler for me to
use. It'd be better if in the end I can use the real def definition KL_div.
*)
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" "\<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) divide_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 setsum_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_setsum[
    OF fin,
    OF nemp,OF minus_log_convex[OF b_gt_1],
    OF convex_real_interval(3),
    OF sum_a_one,
    OF a_pos
    ]
    f_pos
      by fastforce
    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))"
      using sum_c_one
      by simp
    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" unfolding KL_div_def by simp

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 setsum.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)"
    (* a pos *)
      have 1: "(\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < a i)" by simp
    (* ?c pos *)
      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) setsum_pos)
    (* sum a equals to 1 *)
      have 3: "setsum a (S \<inter> {i. 0 < a i}) = 1"
        using setsum.cong[of S, of S, of "(\<lambda>x. if x \<in> {i. 0 < a i} then a x else 0)", of a]
      setsum.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 setsum_divide_distrib)
    (* sum ?c equals to 1 *)
      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 < setsum d (S \<inter> {i. 0 < a i})" using non_null(2) False
        by (metis Int_Collect fin finite_Int setsum_pos)
      have "(\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < a i) \<Longrightarrow>
    (\<And>i. i \<in> S \<inter> {i. 0 < a i} \<Longrightarrow> 0 < d i / setsum d (S \<inter> {i. 0 < a i})) \<Longrightarrow>
      setsum a (S \<inter> {i. 0 < a i}) = 1 \<Longrightarrow>
    (\<Sum>i\<in>S \<inter> {i. 0 < a i}. d i / setsum d (S \<inter> {i. 0 < a i})) = 1 \<Longrightarrow>
      0 \<le> KL_div (S \<inter> {i. 0 < a i}) a (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a i}))"
        using KL_div_pos_gen[
      OF finite_Int[OF disjI1, OF fin], of "{i. 0 < a i}", of "a", of "?c"
      ] by simp
      hence 6: "
      0 \<le> KL_div (S \<inter> {i. 0 < a i}) a (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a i}))"
        using 2 3 5
        by simp
      have
      "(\<And>i. i \<in> S \<inter> {j. 0 < a j} \<Longrightarrow> 0 < d i) \<Longrightarrow>
      0 < setsum d (S \<inter> {i. 0 < a i}) \<Longrightarrow>
      setsum d (S \<inter> {i. 0 < a i}) \<le> 1 \<Longrightarrow>
    (\<And>i. i \<in> S \<inter> {j. 0 < a j} \<Longrightarrow> 0 \<le> a i) \<Longrightarrow>
      KL_div (S \<inter> {j. 0 < a j}) a
    (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a i}))
      \<le> KL_div (S \<inter> {j. 0 < a j}) a d"
        using KL_div_mul
        by fastforce
      hence "setsum d (S \<inter> {i. 0 < a i}) \<le> 1 \<Longrightarrow>
    (\<And>i. i \<in> S \<inter> {j. 0 < a j} \<Longrightarrow> 0 \<le> a i) \<Longrightarrow>
      KL_div (S \<inter> {j. 0 < a j}) a
    (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a i}))
      \<le> KL_div (S \<inter> {j. 0 < a j}) a d" using non_null(2) fstdb
        by simp
      hence
      "(\<And>i. i \<in> S \<inter> {j. 0 < a j} \<Longrightarrow> 0 \<le> a i) \<Longrightarrow> KL_div (S \<inter> {j. 0 < a j}) a
    (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a i}))
      \<le> KL_div (S \<inter> {j. 0 < a j}) a d" using setsum.inter_restrict[OF fin, of d, of "{i. 0 < a i}"]
      setsum_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
        by force
      hence
      "KL_div (S \<inter> {j. 0 < a j}) a (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a i})) \<le> KL_div (S \<inter> {j. 0 < a j}) a d"
        using non_null by simp
      moreover have "0 \<le> KL_div (S \<inter> {j. 0 < a j}) a (\<lambda>i. d i / setsum d (S \<inter> {i. 0 < a 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

(* Used in many theorems... *)
lemma sum_div_1:
  fixes f::"'b \<Rightarrow> 'c::field"
  assumes "(\<Sum>i\<in>A. f i) \<noteq> 0"
  defines "S \<equiv> \<Sum>i\<in>A. f i"
shows "(\<Sum>i\<in>A. f i / S) = 1"
    by (metis (no_types) S_def assms right_inverse_eq setsum_divide_distrib)

(*
_Kraft inequality for real codes using the McMillan theorem
*)
theorem rate_lower_bound :
  defines "l \<equiv> (\<lambda>i. cw_len i)"
  defines "LL \<equiv> L - {i. fi i = 0}"
  defines "F \<equiv> (X ` space M)"
shows "H \<le> cr"
proof -
    let ?c = "kraft_sum"
    let ?r = "(\<lambda>i. 1 / ((b powr l i) * ?c))"
    {
    fix i
    assume "i \<in> L"
    hence "0 \<le> fi i" using simple_distributed_nonneg[OF distr_i] bounded_input by blast
    } hence pos_pi: "\<And>i. i \<in> L \<Longrightarrow> 0 \<le> fi i" by simp
    {
    fix i
    assume iL: "i \<in> L"
    hence
    "fi i * (log b (1 / (1 / b powr (l i))) + log b (fi i))
    = fi i * log b (fi i / (1 / b powr (l i)))"
      using log_mult_ext2[OF pos_pi] b_gt_1
      by (simp add:
    `\<And>y i. \<lbrakk>i \<in> L; 0 < y\<rbrakk> \<Longrightarrow> fi i * log b (fi i * y) = fi i * log b (fi i) + fi i * log b y`
    linordered_field_class.sign_simps(36))
    }
    hence eqpi:
    "\<And>i. i\<in> L \<Longrightarrow> fi i * (log b (1 / (1 / b powr (l i))) + log b (fi i))
    = fi i * log b (fi i / (1 / b powr (l i)))"
      by simp
    have sum_one: "(\<Sum> i \<in> F. fi i) = 1"
      using simple_distributed_setsum_space[OF distr_i] F_def by simp
    hence sum_one_L: "(\<Sum> i \<in> L. fi i) = 1" using bounded_input F_def by simp
    {
    fix i
    assume iL: "i \<in> L"
    have
    "fi i * log b (fi i * ?c / (1/b powr l i) * (inverse kraft_sum)) =
    fi i * log b (fi i * ?c / (1/b powr l i)) + fi i * log b (inverse kraft_sum)"
      using log_mult_ext_3[OF pos_pi[OF iL]
    positive_imp_inverse_positive[OF kraft_sum_nonnull],
    of "kraft_sum / (1 / b powr (l i))"] divide_pos_pos[OF kraft_sum_nonnull] powr_gt_zero[of b]
    Orderings.order_class.order.strict_implies_not_eq[
    OF Orderings.order_class.order.strict_trans[OF zero_less_one, OF b_gt_1]
    ]
      by (metis (no_types) divide_1 inverse_divide inverse_positive_iff_positive times_divide_eq_right)
    } hence big_eq:
    "\<And>i. i \<in> L \<Longrightarrow> fi i * log b (fi i * ?c / (1/b powr l i) * (1 / kraft_sum)) =
    fi i * log b (fi i * ?c / (1/b powr l i)) + fi i * log b (1 / kraft_sum)"
      by (simp add: inverse_eq_divide)
    have 1: "cr - H = (\<Sum>i \<in> L. fi i * l i) + (\<Sum>i \<in> L. fi i * log b (fi i))"
      using kraft_sum_def entropy_rewrite cr_rw bounded_input l_def by simp
    also have 2: "(\<Sum>i\<in>L. fi i * l i) = (\<Sum>i \<in> L. fi i * (-log b (1/(b powr (l i)))))"
      using b_gt_1 log_divide by simp
    also have "\<dots> = -1 * (\<Sum>i \<in> L. fi i * (log b (1/(b powr (l i)))))"
      using setsum_right_distrib[of "-1" "(\<lambda>i. fi i * (- 1 * log b (1 / b powr (l i))))" L]
      by simp
    finally have
    "cr - H = -(\<Sum>i \<in> L. fi i * log b (1/b powr l i)) + (\<Sum>i \<in> L. fi i * log b (fi i))"
      by simp
    have "cr - H = (\<Sum>i \<in> L. fi i * ((log b (1/ (1/(b powr (l i))))) +log b (fi i)))"
      using b_gt_1 1
      by (simp add: distrib_left setsum.distrib)
    also have "\<dots> = (\<Sum>i \<in> L. fi i *((log b (fi i / (1/(b powr (l i)))))))"
      using Cartesian_Euclidean_Space.setsum_cong_aux[OF eqpi] by simp
    also from big_eq have
    "\<dots> = (\<Sum>i\<in>L. fi i * (log b (fi i * ?c / (1 / b powr (l i))))) + (\<Sum>i \<in> L. fi i) * log b (1/ ?c)"
      using kraft_sum_nonnull
      by (simp add: setsum_left_distrib setsum.distrib)
    also have "\<dots> = (\<Sum>i\<in>L. fi i * (log b (fi i * ?c / (1 / b powr (l i))))) - log b (?c)"
      using kraft_sum_nonnull
      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 (?c)"
      by (metis (mono_tags, hide_lams) divide_divide_eq_left divide_divide_eq_right)
    also have "\<dots> = KL_div L fi ?r + log b (inverse ?c)"
      using b_gt_1 kraft_sum_nonnull by (simp add: log_inverse KL_div_def)
    finally have code_ent_kl_log: "cr - H = KL_div L fi ?r + log b (inverse ?c)" by simp
    have "setsum ?r L = 1"
      using sum_div_1[of "\<lambda>i. 1 / (b powr (l i))"] kraft_sum_nonnull l_def kraft_sum_powr
      by simp
    moreover have "\<And>i. 0 < ?r i" using b_gt_1 kraft_sum_nonnull 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 (inverse ?c) \<le> cr - H" using code_ent_kl_log by simp
    hence "log b (inverse (kraft_sum)) \<le> cr - H" by simp
    moreover from McMillan assms have "0 \<le> log b (inverse (kraft_sum))"
      using kraft_sum_nonnull unfolding kraft_inequality_def
      by (simp add: b_gt_1 log_inverse_eq)
    ultimately show ?thesis by simp
qed
end
end


(*  Title:      JinjaDCI/Common/Auxiliary.thy

    Author:     David von Oheimb, Tobias Nipkow, Susannah Mansky
    Copyright   1999 TU Muenchen, 2019-20 UIUC

    Based on the Jinja theory Common/Auxiliary.thy by David von Oheimb and Tobias Nipkow
*)

chapter \<open> Jinja Source Language \label{cha:j} \<close>

section \<open> Auxiliary Definitions \<close>

theory Auxiliary imports Main begin
(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j \<le> m) = (n + i \<le> m \<and> n + j \<le> m)"
 (*<*)by arith(*>*)

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j) \<le> m) = (Suc(n + i) \<le> m \<and> Suc(n + j) \<le> m)"
(*<*)by arith(*>*)

notation Some  ("(\<lfloor>_\<rfloor>)")

(*<*)
declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
 Cons_eq_map_conv [iff]
(*>*)

subsection \<open>@{text distinct_fst}\<close>

definition distinct_fst  :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
 (*<*)
by (unfold distinct_fst_def) (simp (no_asm))
(*>*)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
(*<*)
by (unfold distinct_fst_def) (auto simp:image_def)
(*>*)

lemma distinct_fst_appendD:
 "distinct_fst(kxs @ kxs') \<Longrightarrow> distinct_fst kxs \<and> distinct_fst kxs'"
(*<*)by(induct kxs, auto)(*>*)

lemma map_of_SomeI:
  "\<lbrakk> distinct_fst kxs; (k,x) \<in> set kxs \<rbrakk> \<Longrightarrow> map_of kxs k = Some x"
(*<*)by (induct kxs) (auto simp:fun_upd_apply)(*>*)

subsection \<open> Using @{term list_all2} for relations \<close>

definition fun_of :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
where
  "fun_of S \<equiv> \<lambda>x y. (x,y) \<in> S"

text \<open> Convenience lemmas \<close>
(*<*)
declare fun_of_def [simp]
(*>*)
lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) =
   ((x,y) \<in> S \<and> list_all2 (fun_of S) xs ys)"
  (*<*)by simp(*>*)

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys =
  (\<exists>z zs. ys = z#zs \<and> (x,z) \<in> S \<and> list_all2 (fun_of S) xs zs)"
  (*<*)by (cases ys) auto(*>*)

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) =
  (\<exists>z zs. xs = z#zs \<and> (z,y) \<in> S \<and> list_all2 (fun_of S) zs ys)"
  (*<*)by (cases xs) auto(*>*)

lemma rel_list_all2_refl:
  "(\<And>x. (x,x) \<in> S) \<Longrightarrow> list_all2 (fun_of S) xs xs"
  (*<*)by (simp add: list_all2_refl)(*>*)

lemma rel_list_all2_antisym:
  "\<lbrakk> (\<And>x y. \<lbrakk>(x,y) \<in> S; (y,x) \<in> T\<rbrakk> \<Longrightarrow> x = y);
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  (*<*)by (rule list_all2_antisym) auto(*>*)

lemma rel_list_all2_trans:
  "\<lbrakk> \<And>a b c. \<lbrakk>(a,b) \<in> R; (b,c) \<in> S\<rbrakk> \<Longrightarrow> (a,c) \<in> T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs\<rbrakk>
  \<Longrightarrow> list_all2 (fun_of T) as cs"
  (*<*)by (rule list_all2_trans) auto(*>*)

lemma rel_list_all2_update_cong:
  "\<lbrakk> i<size xs; list_all2 (fun_of S) xs ys; (x,y) \<in> S \<rbrakk>
  \<Longrightarrow> list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  (*<*)by (simp add: list_all2_update_cong)(*>*)

lemma rel_list_all2_nthD:
  "\<lbrakk> list_all2 (fun_of S) xs ys; p < size xs \<rbrakk> \<Longrightarrow> (xs!p,ys!p) \<in> S"
  (*<*)by (drule list_all2_nthD) auto(*>*)

lemma rel_list_all2I:
  "\<lbrakk> length a = length b; \<And>n. n < length a \<Longrightarrow> (a!n,b!n) \<in> S \<rbrakk> \<Longrightarrow> list_all2 (fun_of S) a b"
  (*<*)by (erule list_all2_all_nthI) simp(*>*)

(*<*)declare fun_of_def [simp del](*>*)

subsection \<open> Auxiliary properties of @{text "map_of"} function \<close>

lemma map_of_set_pcs_notin: "C \<notin> (\<lambda>t. snd (fst t)) ` set FDTs \<Longrightarrow> map_of FDTs (F, C) = None"
(*<*)by (metis image_eqI image_image map_of_eq_None_iff snd_conv)(*>*)

lemma map_of_insertmap_SomeD':
  "map_of fs F = Some y \<Longrightarrow> map_of (map (\<lambda>(F, y). (F, D, y)) fs) F = Some(D,y)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_reinsert_neq_None:
  "Ca \<noteq> D \<Longrightarrow> map_of (map (\<lambda>(F, y). ((F, Ca), y)) fs) (F, D) = None"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_remap_insertmap:
  "map_of (map ((\<lambda>((F, D), b, T). (F, D, b, T)) \<circ> (\<lambda>(F, y). ((F, D), y))) fs)
    = map_of (map (\<lambda>(F, y). (F, D, y)) fs)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_reinsert_SomeD:
  "map_of (map (\<lambda>(F, y). ((F, D), y)) fs) (F, D) = Some T \<Longrightarrow> map_of fs F = Some T"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_filtered_SomeD:
"map_of fs (F,D) = Some (a, T) \<Longrightarrow> Q ((F,D),a,T) \<Longrightarrow>
       map_of (map (\<lambda>((F,D), b, T). ((F,D), P T)) (filter Q fs))
        (F,D) = Some (P T)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_remove_filtered_SomeD:
"map_of fs (F,C) = Some (a, T) \<Longrightarrow> Q ((F,C),a,T) \<Longrightarrow>
       map_of (map (\<lambda>((F,D), b, T). (F, P T)) [((F, D), b, T)\<leftarrow>fs . Q ((F, D), b, T) \<and> D = C])
        F = Some (P T)"
(*<*)by (induct fs) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma map_of_Some_None_split:
assumes "t = map (\<lambda>(F, y). ((F, C), y)) fs @ t'" "map_of t' (F, C) = None" "map_of t (F, C) = Some y"
shows "map_of (map (\<lambda>((F, D), b, T). (F, D, b, T)) t) F = Some (C, y)"
(*<*)
proof -
  have "map_of (map (\<lambda>(F, y). ((F, C), y)) fs) (F, C) = Some y" using assms by auto
  then have "\<forall>p. map_of fs F = Some p \<or> Some y \<noteq> Some p"
    by (metis map_of_reinsert_SomeD)
  then have "\<forall>f b p pa. ((f ++ map_of (map (\<lambda>(a, p). (a, b::'b, p)) fs)) F = Some p \<or> Some (b, pa) \<noteq> Some p)
     \<or> Some y \<noteq> Some pa"
    by (metis (no_types) map_add_find_right map_of_insertmap_SomeD')
  then have "(map_of (map (\<lambda>((a, b), c, d). (a, b, c, d)) t')
                     ++ map_of (map (\<lambda>(a, p). (a, C, p)) fs)) F = Some (C, y)"
    by blast
  then have "(map_of (map (\<lambda>((a, b), c, d). (a, b, c, d)) t')
      ++ map_of (map ((\<lambda>((a, b), c, d). (a, b, c, d)) \<circ> (\<lambda>(a, y). ((a, C), y))) fs)) F = Some (C, y)"
    by (simp add: map_of_remap_insertmap)
  then show ?thesis using assms by auto
qed
(*>*)

end


(*
  File:     Non_Regular_Languages.thy
  Author:   Manuel Eberl <eberlm@in.tum.de>

  This file provides some tools for showing the non-regularity of a language, either
  via an infinite set of equivalence classes or via the Pumping Lemma.
*)
section \<open>Tools for showing non-regularity of a language\<close>
theory Non_Regular_Languages
  imports Myhill
begin

subsection \<open>Auxiliary material\<close>

lemma bij_betw_image_quotient:
  "bij_betw (\<lambda>y. f -` {y}) (f ` A) (A // {(a,b). f a = f b})"
  by (force simp: bij_betw_def inj_on_def image_image quotient_def)

lemma regular_Derivs_finite:
  fixes r :: "'a :: finite rexp"
  shows "finite (range (\<lambda>w. Derivs w (lang r)))"
proof -
  have "?thesis \<longleftrightarrow> finite (UNIV // \<approx>lang r)"
    unfolding str_eq_conv_Derivs by (rule bij_betw_finite bij_betw_image_quotient)+
  also have "\<dots>" by (subst Myhill_Nerode [symmetric]) auto
  finally show ?thesis .
qed

lemma Nil_in_Derivs_iff: "[] \<in> Derivs w A \<longleftrightarrow> w \<in> A"
  by (auto simp: Derivs_def)

(* TODO: Move to distribution? *)
text \<open>
  The following operation repeats a list $n$ times (usually written as $w ^ n$).
\<close>
primrec repeat :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "repeat 0 xs = []"
| "repeat (Suc n) xs = xs @ repeat n xs"

lemma repeat_Cons_left: "repeat (Suc n) xs = xs @ repeat n xs" by simp

lemma repeat_Cons_right: "repeat (Suc n) xs = repeat n xs @ xs"
  by (induction n) simp_all

(* TODO: Move to distribution? *)
lemma nth_prefixes [simp]: "n \<le> length xs \<Longrightarrow> prefixes xs ! n = take n xs"
  by (induction xs arbitrary: n) (auto simp: nth_Cons split: nat.splits)

lemma nth_suffixes [simp]: "n \<le> length xs \<Longrightarrow> suffixes xs ! n = drop (length xs - n) xs"
  by (subst suffixes_conv_prefixes) (simp_all add: rev_take)

lemma length_take_prefixes:
  assumes "xs \<in> set (take n (prefixes ys))"
  shows   "length xs < n"
proof (cases "n \<le> Suc (length ys)")
  case True
  with assms obtain i where "i < n" "xs = take i ys"
    by (subst (asm) nth_image [symmetric]) auto
  thus ?thesis by simp
next
  case False
  with assms have "prefix xs ys" by simp
  hence "length xs \<le> length ys" by (rule prefix_length_le)
  also from False have "\<dots> < n" by simp
  finally show ?thesis .
qed

subsection \<open>Non-regularity by giving an infinite set of equivalence classes\<close>

text \<open>
  Non-regularity can be shown by giving an infinite set of non-equivalent words (w.r.t. the
  Myhill--Nerode relation).
\<close>
lemma not_regular_langI:
  assumes "infinite B" "\<And>x y. x \<in> B \<Longrightarrow> y \<in> B \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>w. \<not>(x @ w \<in> A \<longleftrightarrow> y @ w \<in> A)"
  shows   "\<not>regular_lang (A :: 'a :: finite list set)"
proof -
  have "(\<lambda>w. Derivs w A) ` B \<subseteq> range (\<lambda>w. Derivs w A)" by blast
  moreover from assms(2) have "inj_on (\<lambda>w. Derivs w A) B"
    by (auto simp: inj_on_def Derivs_def)
  with assms(1) have "infinite ((\<lambda>w. Derivs w A) ` B)"
    by (blast dest: finite_imageD)
  ultimately have "infinite (range (\<lambda>w. Derivs w A))" by (rule infinite_super)
  with regular_Derivs_finite show ?thesis by blast
qed

lemma not_regular_langI':
  assumes "infinite B" "\<And>x y. x \<in> B \<Longrightarrow> y \<in> B \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<exists>w. \<not>(f x @ w \<in> A \<longleftrightarrow> f y @ w \<in> A)"
  shows   "\<not>regular_lang (A :: 'a :: finite list set)"
proof (rule not_regular_langI)
  from assms(2) have "inj_on f B" by (force simp: inj_on_def)
  with \<open>infinite B\<close> show "infinite (f ` B)" by (simp add: finite_image_iff)
qed (insert assms, auto)

subsection \<open>The Pumping Lemma\<close>

text \<open>
  The Pumping lemma can be shown very easily from the Myhill--Nerode theorem: if we have
  a word whose length is more than the (finite) number of equivalence classes, then it must
  have two different prefixes in the same class and the difference between these two
  prefixes can then be ``pumped''.
\<close>
lemma pumping_lemma_aux:
  fixes A :: "'a list set"
  defines "\<delta> \<equiv> \<lambda>w. Derivs w A"
  defines "n \<equiv> card (range \<delta>)"
  assumes "z \<in> A" "finite (range \<delta>)" "length z \<ge> n"
  shows "\<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> A)"
proof -
  define P where "P = set (take (Suc n) (prefixes z))"
  from \<open>length z \<ge> n\<close> have [simp]: "card P = Suc n"
    unfolding P_def by (subst distinct_card) (auto intro!: distinct_take)
  have length_le: "length y \<le> n" if "y \<in> P" for y
    using length_take_prefixes[OF that [unfolded P_def]] by simp

  have "card (\<delta> ` P) \<le> card (range \<delta>)" by (intro card_mono assms) auto
  also from assms have "\<dots> < card P" by simp
  finally have "\<not>inj_on \<delta> P" by (rule pigeonhole)
  then obtain a b where ab: "a \<in> P" "b \<in> P" "a \<noteq> b" "Derivs a A = Derivs b A"
    by (auto simp: inj_on_def \<delta>_def)
  from ab have prefix_ab: "prefix a z" "prefix b z" by (auto simp: P_def dest: in_set_takeD)
  from ab have length_ab: "length a \<le> n" "length b \<le> n"
    by (simp_all add: length_le)

  have *: ?thesis
    if uz': "prefix u z'" "prefix z' z" "length z' \<le> n"
            "u \<noteq> z'" "Derivs z' A = Derivs u A" for u z'
  proof -
    from \<open>prefix u z'\<close> and \<open>u \<noteq> z'\<close>
      obtain v where v [simp]: "z' = u @ v" "v \<noteq> []"
      by (auto simp: prefix_def)
    from \<open>prefix z' z\<close> obtain w where [simp]: "z = u @ v @ w"
      by (auto simp: prefix_def)

    hence [simp]: "Derivs (repeat i v) (Derivs u A) = Derivs u A" for i
      by (induction i) (use uz' in simp_all)
    have "Derivs z A = Derivs (u @ repeat i v @ w) A" for i
      using uz' by simp
    with \<open>z \<in> A\<close> and uz' have "\<forall>i. u @ repeat i v @ w \<in> A"
      by (simp add: Nil_in_Derivs_iff [of _ A, symmetric])
    moreover have "z = u @ v @ w" by simp
    moreover from \<open>length z' \<le> n\<close> have "length (u @ v) \<le> n" by simp
    ultimately show ?thesis using \<open>v \<noteq> []\<close> by blast
  qed

  from prefix_ab have "prefix a b \<or> prefix b a" by (rule prefix_same_cases)
  with *[of a b] and *[of b a] and ab and prefix_ab and length_ab show ?thesis by blast
qed

theorem pumping_lemma:
  fixes r :: "'a :: finite rexp"
  obtains n where
    "\<And>z. z \<in> lang r \<Longrightarrow> length z \<ge> n \<Longrightarrow>
            \<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
proof -
  let ?n = "card (range (\<lambda>w. Derivs w (lang r)))"
  have "\<exists>u v w. z = u @ v @ w \<and> length (u @ v) \<le> ?n \<and> v \<noteq> [] \<and> (\<forall>i. u @ repeat i v @ w \<in> lang r)"
    if "z \<in> lang r" and "length z \<ge> ?n" for z
    by (intro pumping_lemma_aux[of z] that regular_Derivs_finite)
  thus ?thesis by (rule that)
qed

corollary pumping_lemma_not_regular_lang:
  fixes A :: "'a :: finite list set"
  assumes "\<And>n. length (z n) \<ge> n" and "\<And>n. z n \<in> A"
  assumes "\<And>n u v w. z n = u @ v @ w \<Longrightarrow> length (u @ v) \<le> n \<Longrightarrow> v \<noteq> [] \<Longrightarrow>
             u @ repeat (i n u v w) v @ w \<notin> A"
  shows   "\<not>regular_lang A"
proof
  assume "regular_lang A"
  then obtain r where r: "lang r = A" by blast
  from pumping_lemma[of r] guess n .
  from this[of "z n"] and assms[of n] obtain u v w
    where "z n = u @ v @ w" and "length (u @ v) \<le> n" and "v \<noteq> []" and
          "\<And>i. u @ repeat i v @ w \<in> lang r" by (auto simp: r)
  with assms(3)[of n u v w] show False by (auto simp: r)
qed

subsection \<open>Examples\<close>

text \<open>
  The language of all words containing the same number of $a$s and $b$s is not regular.
\<close>
lemma "\<not>regular_lang {w. length (filter id w) = length (filter Not w)}" (is "\<not>regular_lang ?A")
proof (rule not_regular_langI')
  show "infinite (UNIV :: nat set)" by simp
next
  fix m n :: nat assume "m \<noteq> n"
  hence "replicate m True @ replicate m False \<in> ?A" and
        "replicate n True @ replicate m False \<notin> ?A" by simp_all
  thus "\<exists>w. \<not>(replicate m True @ w \<in> ?A \<longleftrightarrow> replicate n True @ w \<in> ?A)" by blast
qed

text \<open>
  The language $\{a^i b^i\ |\ i \in \mathbb{N}\}$ is not regular.
\<close>
lemma eq_replicate_iff:
  "xs = replicate n x \<longleftrightarrow> set xs \<subseteq> {x} \<and> length xs = n"
  using replicate_length_same[of xs x] by (subst eq_commute) auto

lemma replicate_eq_appendE:
  assumes "xs @ ys = replicate n x"
  obtains i j where "n = i + j" "xs = replicate i x" "ys = replicate j x"
proof -
  have "n = length (replicate n x)" by simp
  also note assms [symmetric]
  finally have "n = length xs + length ys" by simp
  moreover have "xs = replicate (length xs) x" and "ys = replicate (length ys) x"
    using assms by (auto simp: eq_replicate_iff)
  ultimately show ?thesis using that[of "length xs" "length ys"] by auto
qed

lemma "\<not>regular_lang (range (\<lambda>i. replicate i True @ replicate i False))" (is "\<not>regular_lang ?A")
proof (rule pumping_lemma_not_regular_lang)
  fix n :: nat
  show "length (replicate n True @ replicate n False) \<ge> n" by simp
  show "replicate n True @ replicate n False \<in> ?A" by simp
next
  fix n :: nat and u v w :: "bool list"
  assume decomp: "replicate n True @ replicate n False = u @ v @ w"
     and length_le: "length (u @ v) \<le> n" and v_ne: "v \<noteq> []"
  define w1 w2 where "w1 = take (n - length (u@v)) w" and "w2 = drop (n - length (u@v)) w"
  have w_decomp: "w = w1 @ w2" by (simp add: w1_def w2_def)

  have "replicate n True = take n (replicate n True @ replicate n False)" by simp
  also note decomp
  also have "take n (u @ v @ w) = u @ v @ w1" using length_le by (simp add: w1_def)
  finally have "u @ v @ w1 = replicate n True" by simp
  then obtain i j k
    where uvw1: "n = i + j + k" "u = replicate i True" "v = replicate j True" "w1 = replicate k True"
    by (elim replicate_eq_appendE) auto

  have "replicate n False = drop n (replicate n True @ replicate n False)" by simp
  also note decomp
  finally have [simp]: "w2 = replicate n False" using length_le by (simp add: w2_def)

  have "u @ repeat (Suc (Suc 0)) v @ w = replicate (n + j) True @ replicate n False"
    by (simp add: uvw1 w_decomp replicate_add [symmetric])
  also have "\<dots> \<notin> ?A"
  proof safe
    fix m assume *: "replicate (n + j) True @ replicate n False =
                       replicate m True @ replicate m False" (is "?lhs = ?rhs")
    have "n = length (filter Not ?lhs)" by simp
    also note *
    also have "length (filter Not ?rhs) = m" by simp
    finally have [simp]: "m = n" by simp
    from * have "v = []" by (simp add: uvw1)
    with \<open>v \<noteq> []\<close> show False by contradiction
  qed
  finally show "u @ repeat (Suc (Suc 0)) v @ w \<notin> ?A" .
qed

end


(*  Title:      HOL/Metis_Examples/Proxies.thy
    Author:     Jasmin Blanchette, TU Muenchen

Example that exercises Metis's and Sledgehammer's logical symbol proxies for
rudimentary higher-order reasoning.
*)

section \<open>
Example that Exercises Metis's and Sledgehammer's Logical Symbol Proxies for
Rudimentary Higher-Order Reasoning.
\<close>

theory Proxies
imports Type_Encodings
begin

sledgehammer_params [prover = spass, fact_filter = mepo, timeout = 30, preplay_timeout = 0,
  dont_minimize]

text \<open>Extensionality and set constants\<close>

lemma plus_1_not_0: "n + (1::nat) \<noteq> 0"
by simp

definition inc :: "nat \<Rightarrow> nat" where
"inc x = x + 1"

lemma "inc \<noteq> (\<lambda>y. 0)"
sledgehammer [expect = some] (inc_def plus_1_not_0)
by (metis_exhaust inc_def plus_1_not_0)

lemma "inc = (\<lambda>y. y + 1)"
sledgehammer [expect = some]
by (metis_exhaust inc_def)

definition add_swap :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add_swap = (\<lambda>x y. y + x)"

lemma "add_swap m n = n + m"
sledgehammer [expect = some] (add_swap_def)
by (metis_exhaust add_swap_def)

definition "A = {xs::'a list. True}"

lemma "xs \<in> A"
(* The "add:" argument is unfortunate. *)
sledgehammer [expect = some] (add: A_def mem_Collect_eq)
by (metis_exhaust A_def mem_Collect_eq)

definition "B (y::int) \<equiv> y \<le> 0"
definition "C (y::int) \<equiv> y \<le> 1"

lemma int_le_0_imp_le_1: "x \<le> (0::int) \<Longrightarrow> x \<le> 1"
by linarith

lemma "B \<le> C"
sledgehammer [expect = some]
by (metis_exhaust B_def C_def int_le_0_imp_le_1 predicate1I)

text \<open>Proxies for logical constants\<close>

lemma "id (op =) x x"
sledgehammer [type_enc = erased, expect = none] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis (full_types) id_apply)

lemma "id True"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "\<not> id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "x = id True \<or> x = id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id x = id True \<or> id x = id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "P True \<Longrightarrow> P False \<Longrightarrow> P x"
sledgehammer [type_enc = erased, expect = none] ()
sledgehammer [type_enc = poly_args, expect = none] ()
sledgehammer [type_enc = poly_tags??, expect = some] ()
sledgehammer [type_enc = poly_tags, expect = some] ()
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] ()
sledgehammer [type_enc = mono_tags??, expect = some] ()
sledgehammer [type_enc = mono_tags, expect = some] ()
sledgehammer [type_enc = mono_guards??, expect = some] ()
sledgehammer [type_enc = mono_guards, expect = some] ()
by (metis (full_types))

lemma "id (\<not> a) \<Longrightarrow> \<not> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> \<not> a) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by metis_exhaust

lemma "id (\<not> (id (\<not> a))) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<and> b) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<and> b) \<Longrightarrow> id b"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id a \<Longrightarrow> id b \<Longrightarrow> id (a \<and> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id a \<Longrightarrow> id (a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id b \<Longrightarrow> id (a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> a) \<Longrightarrow> id (\<not> b) \<Longrightarrow> id (\<not> (a \<or> b))"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> a) \<Longrightarrow> id (a \<longrightarrow> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<longrightarrow> b) \<longleftrightarrow> id (\<not> a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

end


theory Bidirected_Digraph
imports
  Digraph
  "HOL-Library.Permutations"
begin

section \<open>Bidirected Graphs\<close>

locale bidirected_digraph = wf_digraph G for G +
  fixes arev :: "'b \<Rightarrow> 'b"
  assumes arev_dom: "\<And>a. a \<in> arcs G \<longleftrightarrow> arev a \<noteq> a"
  assumes arev_arev_raw: "\<And>a. a \<in> arcs G \<Longrightarrow> arev (arev a) = a"
  assumes tail_arev[simp]: "\<And>a. a \<in> arcs G \<Longrightarrow> tail G (arev a) = head G a"

lemma (in wf_digraph) bidirected_digraphI:
  assumes arev_eq: "\<And>a. a \<notin> arcs G \<Longrightarrow> arev a = a"
  assumes arev_neq: "\<And>a. a \<in> arcs G \<Longrightarrow> arev a \<noteq> a"
  assumes arev_arev_raw: "\<And>a. a \<in> arcs G \<Longrightarrow> arev (arev a) = a"
  assumes tail_arev: "\<And>a. a \<in> arcs G \<Longrightarrow> tail G (arev a) = head G a"
  shows "bidirected_digraph G arev"
  using assms by unfold_locales (auto simp: permutes_def)

context bidirected_digraph begin

  lemma bidirected_digraph[intro!]: "bidirected_digraph G arev"
    by unfold_locales

  lemma arev_arev[simp]: "arev (arev a) = a"
    using arev_dom by (cases "a \<in> arcs G") (auto simp: arev_arev_raw)

  lemma arev_o_arev[simp]: "arev o arev = id"
    by (simp add: fun_eq_iff)

  lemma arev_eq: "a \<notin> arcs G \<Longrightarrow> arev a = a"
    by (simp add: arev_dom)

  lemma arev_neq: "a \<in> arcs G \<Longrightarrow> arev a \<noteq> a"
    by (simp add: arev_dom)

  lemma arev_in_arcs[simp]: "a \<in> arcs G \<Longrightarrow> arev a \<in> arcs G"
    by (metis arev_arev arev_dom)

  lemma head_arev[simp]:
    assumes "a \<in> arcs G" shows "head G (arev a) = tail G a"
  proof -
    from assms have "head G (arev a) = tail G (arev (arev a)) "
      by (simp only: tail_arev arev_in_arcs)
    then show ?thesis by simp
  qed

  lemma ate_arev[simp]:
    assumes "a \<in> arcs G" shows "arc_to_ends G (arev a) = prod.swap (arc_to_ends G a)"
    using assms by (auto simp: arc_to_ends_def)

  lemma bij_arev: "bij arev"
    using arev_arev by (metis bij_betw_imageI inj_on_inverseI surjI)

  lemma arev_eq_iff: "\<And>x y. arev x = arev y \<longleftrightarrow> x = y"
    by (metis arev_arev)

  lemma in_arcs_eq: "in_arcs G w = arev ` out_arcs G w"
    by auto (metis arev_arev arev_in_arcs image_eqI in_out_arcs_conv tail_arev)

  lemma inj_on_arev[intro!]: "inj_on arev S"
    by (metis arev_arev inj_on_inverseI)

  lemma even_card_loops:
    "even (card (in_arcs G w \<inter> out_arcs G w))" (is "even (card ?S)")
  proof -
    { assume "\<not>finite ?S"
      then have ?thesis by simp
    }
    moreover
    { assume A:"finite ?S"
      have "card ?S = card (\<Union>{{a,arev a} | a. a \<in> ?S})" (is "_ = card (\<Union> ?T)")
        by (rule arg_cong[where f=card]) (auto intro!: exI[where x="{x, arev x}" for x])
      also have "\<dots>= sum card ?T"
      proof (rule card_Union_disjoint)
        show "\<And>A. A\<in>{{a, arev a} |a. a \<in> ?S} \<Longrightarrow> finite A" by auto
        show "pairwise disjnt {{a, arev a} |a. a \<in> in_arcs G w \<inter> out_arcs G w}"
          unfolding pairwise_def disjnt_def
           by safe (simp_all add: arev_eq_iff)
      qed
      also have "\<dots> = sum (\<lambda>a. 2) ?T"
        by (intro sum.cong) (auto simp: card_insert_if dest: arev_neq)
      also have "\<dots> = 2 * card ?T" by simp
      finally have ?thesis by simp
    }
    ultimately
    show ?thesis by blast
  qed

end

(*XXX*)
sublocale bidirected_digraph \<subseteq> sym_digraph
proof (unfold_locales, unfold symmetric_def, intro symI)
  fix u v assume "u \<rightarrow>\<^bsub>G\<^esub> v"
  then obtain a where "a \<in> arcs G" "arc_to_ends G a = (u,v)" by (auto simp: arcs_ends_def)
  then have "arev a \<in> arcs G" "arc_to_ends G (arev a) = (v,u)"
    by (auto simp: arc_to_ends_def)
  then show "v \<rightarrow>\<^bsub>G\<^esub> u" by (auto simp: arcs_ends_def intro: rev_image_eqI)
qed

end


(* Version 0.4, last changed 2019-02-01
 * (C) fovefi ltd, www.fovefi.co
 * (author: Manfred Kerber [make@fovefi.co])
 *
 * Dually licenced under
 * Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
 * ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
 * See LICENSE files for details.
 * (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
 *
 * In this file we redefine the example given in openSIMM in Isabelle/HOL.
 *)

(*text \<open>
  See values in
  @{file "../OpenSIMM/src/main/java/com/opengamma/opensimm/src/test/resources/"}
\<close>

*)

theory foveSIMM_Values
  imports  "~~/src/HOL/Library/Complex_Main" "~~/src/HOL/Library/Code_Target_Int"
begin

(* There are three currencies in the example, EUR, USD, and GBP. The reference (main) currency in
 * the example is EUR, that is, the risks are all converted to EUR. *)
definition currencies :: "(string list)"
  where "currencies = [''EUR'', ''USD'', ''GBP'']"

(* The currencies are represented by the 0, 1, and 2 for EUR, USD, and GBP, resp. *)
type_synonym currency = nat

definition EUR :: currency
    where "EUR = 0"
definition USD :: currency
    where "USD = 1"
definition GBP :: currency
    where "GBP = 2"

(* The method returns the currency number of the corresponding string. *)
fun get_currency_number :: "string \<Rightarrow> nat" where
  "get_currency_number x = (if (x = ''EUR'')
                          then 0
                          else (if (x = ''USD'')
                                then 1
                                else 2))"

(* The lemma states that EUR and USD are different currencies. *)

chapter \<open>Declaration of the values in the example\<close>

(* The matrix is used for the conversion of the three currencies, order EUR, USD, GBP. Values
 * taken from fx-rates.csv, completed to a full matrix. *)
definition fx_matrix:: "real list list"
  where "fx_matrix =
         [[1, 7/5, 7/8],
          [5/7, 1, 5/8],
          [8/7, 8/5, 1]]
        "
(* Next we introduce the fx-rate-shocks taken from fx-rate-shocks.csv *)
record fx_rate_shock =
  name :: string
  currency :: nat
  shocks :: "real list"

definition fx_rate_shocks_source :: "fx_rate_shock list"
  where "fx_rate_shocks_source =
      [
        \<lparr> name = ''USD'', currency = EUR, shocks = [1, 1.001, 0.9975, 0.995, 1.0002, 1.01, 0.995, 0.997, 1.001, 1.0002,
1.01, 0.995, 0.997, 1.001, 1.0002, 1.01, 0.995, 0.997, 1.001, 1.0002,
1.01, 0.995, 0.997, 1.001, 1.0002] \<rparr>,

        \<lparr> name = ''GBP'', currency = USD, shocks = [0.9985, 1.002, 1, 0.995, 1.0003, 1.01, 0.994, 0.996, 1.001, 1.0002,
1.01, 1.005, 0.9999, 0.9999, 1.0011, 1.005, 0.996, 0.998, 1.0025, 1.01,
0.995, 0.997, 1.001, 1.0002, 1.0001] \<rparr>
     ]"

chapter \<open>Basic computations\<close>

(* Let a list be given such as [(a,b,c,''d''),...]. The function produces sublist of
 * elements for which the selector on an element is equal to the compare element. For instance,
 * value "filter fx_rate_shocks ''USD'' fx_rate_shock.name" will give the values in the fx_rate_shocks
 * list where the name of the shock is ''USD''. *)
fun filter :: "('a list) \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a list)"
  where "filter [] compare selector = []" |
        "filter (x#xs) compare selector =
         (if (selector x) = compare
             then x # (filter xs compare selector)
             else filter xs compare selector)"

(* Let a non-empty list be given such as [(a,b,c,''d''),...],
 * the lookup function returns the first corresponding element in the list. *)
fun lookup
  where "lookup list compare selector =
      (filter list compare selector)!0"

(* mapfun applies a function fun to a list (x#xs) *)
fun mapfun where
  "mapfun fun [] = []" |
  "mapfun fun (x#xs) = (fun x) # (mapfun fun xs)"

fun mapfun2 where
  "mapfun2 fun [][] = []" |
  "mapfun2 fun (x#xs) (y#ys) = (fun x y) # (mapfun2 fun xs ys)" |
  "mapfun2 fun xs ys = undefined"

value "get_currency_number ''USD''"
value "(fx_rate_shock.shocks (lookup fx_rate_shocks_source ''USD'' fx_rate_shock.name))"

(* The shocks of USD are converted to EUR. *)
definition USD_shocks_in_euros
  where "USD_shocks_in_euros = mapfun (\<lambda> usd. (usd - 1) * (fx_matrix!0!(get_currency_number ''USD'')))
                     (fx_rate_shock.shocks (lookup fx_rate_shocks_source ''USD'' fx_rate_shock.name))"

(* The EUR value of the GBP is calculated via USD. The following definition makes the conversion according to the
 * conversion performed in the openSIMM computation in which the shocks to the GBP are combined
 * with the shocks to USD. *)
definition GBP_shocks_in_euros
  where "GBP_shocks_in_euros = mapfun2
           (\<lambda> usd. \<lambda> gbp. fx_matrix!0!(get_currency_number ''USD'')/
                          fx_matrix!(get_currency_number ''GBP'')!(get_currency_number ''USD'') *
                           (usd/gbp -1))
             (fx_rate_shock.shocks (lookup fx_rate_shocks_source ''USD'' fx_rate_shock.name))
             (fx_rate_shock.shocks (lookup fx_rate_shocks_source ''GBP'' fx_rate_shock.name))"

(* The shocks for the three currencies used in the example. *)
definition fx_rate_shocks :: "fx_rate_shock list"
  where "fx_rate_shocks =
      [ \<lparr> name = ''USD'', currency = 0, shocks = USD_shocks_in_euros\<rparr>,
        \<lparr> name = ''GBP'', currency = 0, shocks = GBP_shocks_in_euros \<rparr>,
        \<lparr> name = ''EUR'', currency = 0, shocks = [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]  \<rparr>
      ]"

(* portfolio-derivatives from portfolio-derivatives.csv
 * RiskFactorName, Amount,   Currency *)
record portfolio_derivative =
  name :: string
  amount :: int
  currency :: currency

definition portfolio_derivatives :: "portfolio_derivative list"
  where "portfolio_derivatives =
         [
            \<lparr> name = ''EUR_OIS_2Y'',   amount =   100000,   currency = EUR \<rparr>,
            \<lparr> name = ''EUR_OIS_5Y'',   amount =   -20000,   currency = EUR \<rparr>,
            \<lparr> name = ''USD_IRSL3M_2Y'',amount =    20000,   currency = EUR \<rparr>,
            \<lparr> name = ''IBM'',          amount =    30300,   currency = EUR \<rparr>,
            \<lparr> name = ''SP500'',        amount =   100000,   currency = USD \<rparr>,
            \<lparr> name = ''XAU'',          amount =  -123456,   currency = USD \<rparr>,
            \<lparr> name = ''EUR'',          amount =  1000000,   currency = EUR \<rparr>,
            \<lparr> name = ''USD'',          amount = -1400000,   currency = GBP \<rparr>,
            \<lparr> name = ''GBP'',          amount =   200000,   currency = USD \<rparr>
         ]"

(* portfolio-initial-margin from portfolio-initial-margin.csv
 * RiskFactorName, Amount,   Currency*)
record portfolio_initial_margin =
  name :: string
  amount :: int
  currency :: currency

definition portfolio_initial_margins :: "portfolio_initial_margin list"
  where "portfolio_initial_margins =
     [
       \<lparr> name = ''USD_IRSL3M_2Y'', amount =     2000, currency = EUR \<rparr>,
       \<lparr> name =''USD'',            amount = -1300000, currency = GBP \<rparr>
     ]"

(* portfolio-initial-margin from portfolio-initial-margin.csv
 * RiskFactorName, Amount,   Currency *)
record portfolio_variation_margin =
  name :: string
  amount :: int
  currency :: currency

definition portfolio_variation_margins :: "portfolio_variation_margin list"
  where "portfolio_variation_margins =
     [
       \<lparr> name =''GBP'',            amount = 150000, currency = USD \<rparr>
     ]"

(* risk-factor-base-levels from risk-factor-base-levels.csv
 * RiskFactorName, BaseLevel *)
record risk_factor_base_level =
   name :: string
   base_level :: real

definition risk_factor_base_levels :: "risk_factor_base_level list"
   where "risk_factor_base_levels =
             [
                     \<lparr> name = ''EUR_OIS_2Y'',    base_level =    -0.0005 \<rparr>,
                     \<lparr> name = ''EUR_OIS_5Y'',    base_level =     0.0025 \<rparr>,
                     \<lparr> name = ''USD_IRSL3M_2Y'', base_level =     0.01 \<rparr>,
                     \<lparr> name = ''IBM'',           base_level =     0.012 \<rparr>,
                     \<lparr> name = ''SP500'',         base_level =  1000 \<rparr>,
                     \<lparr> name = ''XAU'',           base_level =  1200 \<rparr>
             ]"
(* risk-factor-definitions from risk-factor-definitions.csv
 * RiskFactorName, AssetClass, RiskType,    ShockType, Shift *)
record risk_factor =
  name :: string
  asset_class :: string
  risk_type :: string
  shock_type :: string
  shift :: real

definition risk_factors :: "risk_factor list"
  where "risk_factors =
         [
           \<lparr> name = ''EUR_OIS_2Y'',       asset_class = ''IR'',
             risk_type = ''SENSITIVITY'', shock_type = ''AB'', shift = 0.0\<rparr>,
           \<lparr> name = ''EUR_OIS_5Y'',       asset_class = ''IR'',
             risk_type = ''SENSITIVITY'', shock_type = ''AB'', shift = 0.0\<rparr>,
           \<lparr> name = ''USD_IRSL3M_2Y'',    asset_class = ''IR'',
             risk_type = ''SENSITIVITY'', shock_type = ''RE'', shift = 0.04\<rparr>,
           \<lparr> name = ''IBM'',              asset_class = ''CR'',
             risk_type = ''SENSITIVITY'', shock_type = ''AB'', shift = 0.0\<rparr>,
           \<lparr> name = ''SP500'',            asset_class = ''EQ'',
             risk_type = ''EXPOSURE'',    shock_type = ''RE'', shift = 0.0\<rparr>,
           \<lparr> name = ''XAU'',              asset_class = ''CO'',
             risk_type = ''EXPOSURE'',    shock_type = ''RE'', shift = 0.0\<rparr>
         ]"

(* risk-factor-shocks from risk-factor-shocks.csv
 * RiskFactorName, Shocks *)

record risk_factor_shock =
  name :: string
  shocks :: "(real list)"

definition risk_factor_shocks :: "risk_factor_shock list"
   where "risk_factor_shocks =
             [
               \<lparr> name = ''EUR_OIS_2Y'',  shocks = [0.0001, -0.0005, -0.005, 0, 0.0002, 0.0001, -0.0005,
                                 -0.005, 0.0001, -0.0005, -0.005, 0, 0, 0.0002, 0.0001,
                                 -0.0005, -0.005, 0, 0.0002, 0.0002, 0.0001, -0.0005,
                                 -0.005, 0, 0.0002]\<rparr>,
               \<lparr> name = ''EUR_OIS_5Y'', shocks = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
                                 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]\<rparr>,
               \<lparr> name = ''USD_IRSL3M_2Y'', shocks = [1.0025, 1.0025, 0.9975, 0.9975, 1, 1, 1.0025, 0.9975, 1,
                                    1, 1, 1, 1, 1, 1.0025, 0.9975, 1, 1, 1, 1, 1.0025,
                                    0.9975, 1, 1, 1]\<rparr>,
               \<lparr> name = ''IBM'', shocks = [0.0001, -0.0005, -0.005, 0.0002, -0.0006, -0.0051, 0.0003,
                          -0.0007, -0.0052, 0, 0.0004, -0.0001, 0.0011, 0.0008, 0.0012]\<rparr>,
               \<lparr> name = ''SP500'', shocks = [1.011, 0.995, 0.997, 1.001, 1.0002, 1.01, 0.9955, 0.9975,
                            1.0012, 1.0003, 1.0101, 0.9951]\<rparr>,
               \<lparr> name = ''XAU'',   shocks = [1.01, 0.995, 0.997, 1.001, 0.9955, 1.0002, 1.011, 0.994,
                          0.9975, 1.003, 0.99, 1.0004, 1.012, 0.9945]\<rparr>
             ]"

(* The risk level, i.e., the var level, in the example is 0.9. *)
definition "var_level = 0.9"

value "simulated_profit_loss ''GBP''"
end