(*
    File:      Multiplicative_Function.thy
    Author:    Manuel Eberl, TU München
*)
section \<open>Multiplicative arithmetic functions\<close>
theory Multiplicative_Function
  imports
    "HOL-Number_Theory.Number_Theory"
    Dirichlet_Misc
begin

subsection \<open>Definition\<close>

locale multiplicative_function =
  fixes f :: "nat \<Rightarrow> 'a :: comm_semiring_1"
  assumes zero [simp]: "f 0 = 0"
  assumes one [simp]: "f 1 = 1"
  assumes mult_coprime_aux: "a > 1 \<Longrightarrow> b > 1 \<Longrightarrow> coprime a b \<Longrightarrow> f (a * b) = f a * f b"
begin

lemma Suc_0 [simp]: "f (Suc 0) = 1"
  using one by (simp del: one)

lemma mult_coprime:
  assumes "coprime a b"
  shows   "f (a * b) = f a * f b"
proof -
  {fix n :: nat consider "n = 0" | "n = 1" | "n > 1" by force} note P = this
  show ?thesis by (cases a rule: P; cases b rule: P) (simp_all add: mult_coprime_aux assms)
qed

lemma prod_coprime:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> coprime (g x) (g y)"
  shows   "f (prod g A) = (\<Prod>x\<in>A. f (g x))"
  using assms
proof (induction rule: infinite_finite_induct)
  case (insert x A)
  from insert have "f (prod g (insert x A)) = f (g x * prod g A)" by simp
  also have "\<dots> = f (g x) * f (prod g A)" using insert.prems insert.hyps
    by (auto intro: mult_coprime prod_coprime_right)
  also have "\<dots> = (\<Prod>x\<in>insert x A. f (g x))" using insert by simp
  finally show ?case .
qed auto

lemma prod_prime_factors:
  assumes "n > 0"
  shows   "f n = (\<Prod>p\<in>prime_factors n. f (p ^ multiplicity p n))"
proof -
  have "n = (\<Prod>p\<in>prime_factors n. p ^ multiplicity p n)"
    using Primes.prime_factorization_nat assms by blast
  also have "f \<dots> = (\<Prod>p\<in>prime_factors n. f (p ^ multiplicity p n))"
    by (rule prod_coprime) (auto simp add: in_prime_factors_imp_prime primes_coprime)
  finally show ?thesis .
qed

lemma multiplicative_sum_divisors: "multiplicative_function (\<lambda>n. \<Sum>d | d dvd n. f d)"
proof
  fix a b :: nat assume ab: "a > 1" "b > 1" "coprime a b"
  hence "(\<Sum>d | d dvd a * b. f d) = (\<Sum>r | r dvd a. \<Sum>s | s dvd b. f (r * s))"
    by (intro sum_divisors_coprime_mult)
  also have "\<dots> = (\<Sum>r | r dvd a. \<Sum>s | s dvd b. f r * f s)"
    using ab(3)
    by (auto intro!: sum.cong intro: mult_coprime coprime_imp_coprime dvd_trans)
  also have "\<dots> = (\<Sum>r | r dvd a. f r) * (\<Sum>s | s dvd b. f s)"
    by (subst sum_distrib_right, subst sum_distrib_left) simp_all
  finally show "(\<Sum>d | d dvd a * b. f d) = (\<Sum>r | r dvd a. f r) * (\<Sum>s | s dvd b. f s)" .
qed auto

end

locale multiplicative_function' = multiplicative_function f for f :: "nat \<Rightarrow> 'a :: comm_semiring_1" +
  fixes f_prime_power :: "nat \<Rightarrow> nat \<Rightarrow> 'a" and f_prime :: "nat \<Rightarrow> 'a"
  assumes prime_power: "prime p \<Longrightarrow> k > 0 \<Longrightarrow> f (p ^ k) = f_prime_power p k"
  assumes prime_aux: "prime p \<Longrightarrow> f_prime_power p 1 = f_prime p"
begin

lemma prime: "prime p \<Longrightarrow> f p = f_prime p"
  using prime_power[of p 1] prime_aux[of p] by simp

lemma prod_prime_factors':
  assumes "n > 0"
  shows   "f n = (\<Prod>p\<in>prime_factors n. f_prime_power p (multiplicity p n))"
  by (subst prod_prime_factors[OF assms(1)])
     (intro prod.cong refl prime_power, auto simp: prime_factors_multiplicity)

lemma efficient_code_aux:
  assumes "n > 0" "set ps = (\<lambda>p. (p, multiplicity p n - 1)) ` prime_factors n" "distinct ps"
  shows   "f n = (\<Prod>(p,d) \<leftarrow> ps. f_prime_power p (Suc d))"
proof -
  from assms have
    "(\<Prod>(p,d) \<leftarrow> ps. f_prime_power p (Suc d)) =
       (\<Prod>(p,d)\<in>(\<lambda>p. (p, multiplicity p n - 1)) ` prime_factors n. f_prime_power p (Suc d))"
    by (subst prod.distinct_set_conv_list [symmetric]) simp_all
  also have "\<dots> = (\<Prod>x\<in>prime_factors n. f_prime_power x (multiplicity x n))"
    by (subst prod.reindex) (auto simp: inj_on_def prime_factors_multiplicity intro!: prod.cong)
  also have "\<dots> = f n" by (rule prod_prime_factors' [symmetric]) fact+
  finally show ?thesis ..
qed

lemma efficient_code:
  assumes "set (ps ()) = (\<lambda>p. (p, multiplicity p n - 1)) ` prime_factors n" "distinct (ps ())"
  shows   "f n = (if n = 0 then 0 else (\<Prod>(p,d) \<leftarrow> ps (). f_prime_power p (Suc d)))"
  using efficient_code_aux[of n "ps ()"] assms by simp

end

locale completely_multiplicative_function =
  fixes f :: "nat \<Rightarrow> 'a :: comm_semiring_1"
  assumes zero_aux: "f 0 = 0"
  assumes one_aux:  "f (Suc 0) = 1"
  assumes mult_aux: "a > 1 \<Longrightarrow> b > 1 \<Longrightarrow> f (a * b) = f a * f b"
begin

lemma mult: "f (a * b) = f a * f b"
proof -
  {fix n :: nat consider "n = 0" | "n = 1" | "n > 1" by force} note P = this
  show ?thesis by (cases a rule: P; cases b rule: P) (simp_all add: zero_aux one_aux mult_aux)
qed

sublocale multiplicative_function f
  by standard (simp_all add: zero_aux one_aux mult)

lemma prod: "f (prod g A) = (\<Prod>x\<in>A. f (g x))"
  by (induction A rule: infinite_finite_induct) (simp_all add: mult)

lemma power: "f (n ^ m) = f n ^ m"
  by (induction m) (simp_all add: mult)

lemma prod_prime_factors': "n > 0 \<Longrightarrow> f n = (\<Prod>p\<in>prime_factors n. f p ^ multiplicity p n)"
  by (subst prime_factorization_nat) (simp_all add: prod power)

end

locale completely_multiplicative_function' =
  completely_multiplicative_function f for f :: "nat \<Rightarrow> 'a :: comm_semiring_1" +
  fixes f_prime :: "nat \<Rightarrow> 'a"
  assumes f_prime: "prime p \<Longrightarrow> f p = f_prime p"
begin

lemma prod_prime_factors'': "n > 0 \<Longrightarrow> f n = (\<Prod>p\<in>prime_factors n. f_prime p ^ multiplicity p n)"
  by (subst prod_prime_factors') (auto simp: f_prime prime_factors_multiplicity intro!: prod.cong)

lemma efficient_code_aux:
  assumes "n > 0" "set ps = (\<lambda>p. (p, multiplicity p n - 1)) ` prime_factors n" "distinct ps"
  shows   "f n = (\<Prod>(p,d) \<leftarrow> ps. f_prime p ^ Suc d)"
proof -
  from assms have
    "(\<Prod>(p,d) \<leftarrow> ps. f_prime p ^ Suc d) =
       (\<Prod>(p,d)\<in>(\<lambda>p. (p, multiplicity p n - 1)) ` prime_factors n. f_prime p ^ Suc d)"
    by (subst prod.distinct_set_conv_list [symmetric]) simp_all
  also have "\<dots> = (\<Prod>x\<in>prime_factors n. f_prime x ^ multiplicity x n)"
    by (subst prod.reindex) (auto simp: inj_on_def prime_factors_multiplicity
                                  simp del: power_Suc intro!: prod.cong)
  also have "\<dots> = f n" by (rule prod_prime_factors'' [symmetric]) fact+
  finally show ?thesis ..
qed

lemma efficient_code:
  assumes "set (ps ()) = (\<lambda>p. (p, multiplicity p n - 1)) ` prime_factors n" "distinct (ps ())"
  shows   "f n = (if n = 0 then 0 else (\<Prod>(p,d) \<leftarrow> ps (). f_prime p ^ Suc d))"
  using efficient_code_aux[of n "ps ()"] assms by simp

end

lemma multiplicative_function_eqI:
  assumes "multiplicative_function f" "multiplicative_function g"
  assumes "\<And>p k. prime p \<Longrightarrow> k > 0 \<Longrightarrow> f (p ^ k) = g (p ^ k)"
  shows   "f n = g n"
proof -
  interpret f: multiplicative_function f by fact
  interpret g: multiplicative_function g by fact
  show ?thesis
  proof (cases "n > 0")
    case True
    thus ?thesis
      using f.prod_prime_factors[OF True] g.prod_prime_factors[OF True]
      by (auto intro!: prod.cong assms simp: prime_factors_multiplicity)
  qed simp_all
qed

lemma multiplicative_function_of_natI:
  "multiplicative_function f \<Longrightarrow> multiplicative_function (\<lambda>n. of_nat (f n))"
  unfolding multiplicative_function_def by auto

lemma multiplicative_function_of_natD:
  "multiplicative_function (\<lambda>n. of_nat (f n) :: 'a :: {ring_char_0, comm_semiring_1}) \<Longrightarrow>
     multiplicative_function f"
  unfolding multiplicative_function_def
  by (auto simp: of_nat_mult [symmetric] of_nat_eq_1_iff simp del: of_nat_mult)

lemma multiplicative_function_mult:
  assumes "multiplicative_function f"  "multiplicative_function g"
  shows   "multiplicative_function (\<lambda>n. f n * g n)"
proof
  interpret f: multiplicative_function f by fact
  interpret g: multiplicative_function g by fact
  show "f 0 * g 0 = 0" "f 1 * g 1 = 1" by simp_all
  fix a b :: nat assume "a > 1" "b > 1" "coprime a b"
  thus "f (a * b) * g (a * b) = (f a * g a) * (f b * g b)"
    by (simp_all add: f.mult_coprime g.mult_coprime mult_ac)
qed

lemma multiplicative_function_inverse:
  fixes f :: "nat \<Rightarrow> 'a :: field"
  assumes "multiplicative_function f"
  shows   "multiplicative_function (\<lambda>n. inverse (f n))"
proof
  interpret f: multiplicative_function f by fact
  show "inverse (f 0) = 0" "inverse (f 1) = 1" by simp_all
  fix a b :: nat assume "a > 1" "b > 1" "coprime a b"
  thus "inverse (f (a * b)) = inverse (f a) * inverse (f b)"
    by (simp_all add: f.mult_coprime field_simps)
qed

lemma multiplicative_function_divide:
  fixes f :: "nat \<Rightarrow> 'a :: field"
  assumes "multiplicative_function f"  "multiplicative_function g"
  shows   "multiplicative_function (\<lambda>n. f n / g n)"
proof -
  have "multiplicative_function (\<lambda>n. f n * inverse (g n))"
    by (intro multiplicative_function_mult multiplicative_function_inverse assms)
  also have "(\<lambda>n. f n * inverse (g n)) = (\<lambda>n. f n / g n)"
    by (simp add: field_simps)
  finally show ?thesis .
qed

lemma completely_multiplicative_function_mult:
  assumes "completely_multiplicative_function f" "completely_multiplicative_function g"
  shows   "completely_multiplicative_function (\<lambda>n. f n * g n)"
proof
  interpret f: completely_multiplicative_function f by fact
  interpret g: completely_multiplicative_function g by fact
  show "f 0 * g 0 = 0" "f (Suc 0) * g (Suc 0) = 1" by simp_all
  fix a b :: nat assume "a > 1" "b > 1"
  thus "f (a * b) * g (a * b) = (f a * g a) * (f b * g b)"
    by (simp_all add: f.mult g.mult mult_ac)
qed

lemma completely_multiplicative_function_inverse:
  fixes f :: "nat \<Rightarrow> 'a :: field"
  assumes "completely_multiplicative_function f"
  shows   "completely_multiplicative_function (\<lambda>n. inverse (f n))"
proof
  interpret f: completely_multiplicative_function f by fact
  show "inverse (f 0) = 0" "inverse (f (Suc 0)) = 1" by simp_all
  fix a b :: nat assume "a > 1" "b > 1"
  thus "inverse (f (a * b)) = inverse (f a) * inverse (f b)"
    by (simp_all add: f.mult field_simps)
qed

lemma completely_multiplicative_function_divide:
  fixes f :: "nat \<Rightarrow> 'a :: field"
  assumes "completely_multiplicative_function f"  "completely_multiplicative_function g"
  shows   "completely_multiplicative_function (\<lambda>n. f n / g n)"
proof -
  have "completely_multiplicative_function (\<lambda>n. f n * inverse (g n))"
    by (intro completely_multiplicative_function_mult
              completely_multiplicative_function_inverse assms)
  also have "(\<lambda>n. f n * inverse (g n)) = (\<lambda>n. f n / g n)"
    by (simp add: field_simps)
  finally show ?thesis .
qed

lemma (in multiplicative_function) completely_multiplicativeI:
  assumes "\<And>p k. prime p \<Longrightarrow> k > 0 \<Longrightarrow> f (p ^ k) = f p ^ k"
  shows   "completely_multiplicative_function f"
proof
  fix m n :: nat assume mn: "m > 1" "n > 1"
  define P where "P = prime_factors (m * n)"
  have "f (m * n) = (\<Prod>p\<in>P. f (p ^ multiplicity p (m * n)))"
    using mn by (subst prod_prime_factors) (auto simp: P_def)
  also have "\<dots> = (\<Prod>p\<in>P. f p ^ multiplicity p (m * n))"
    by (intro prod.cong) (auto simp: assms prime_factors_multiplicity P_def)
  also have "\<dots> = (\<Prod>p\<in>P. f p ^ multiplicity p m * f p ^ multiplicity p n)"
    by (intro prod.cong refl, subst prime_elem_multiplicity_mult_distrib)
       (use mn in \<open>auto simp: P_def prime_factors_multiplicity power_add\<close>)
  also have "\<dots> = (\<Prod>p\<in>P. f p ^ multiplicity p m) * (\<Prod>p\<in>P. f p ^ multiplicity p n)"
    by (rule prod.distrib)
  also have "(\<Prod>p\<in>P. f p ^ multiplicity p m) = (\<Prod>p\<in>prime_factors m. f p ^ multiplicity p m)"
    unfolding P_def by (intro prod.mono_neutral_right dvd_prime_factors finite_set_mset)
                       (use mn in \<open>auto simp: prime_factors_multiplicity\<close>)
  also have "\<dots> = (\<Prod>p\<in>prime_factors m. f (p ^ multiplicity p m))"
    by (intro prod.cong) (auto simp: assms prime_factors_multiplicity)
  also have "\<dots> = f m"
    using mn by (intro prod_prime_factors [symmetric]) auto
  also have "(\<Prod>p\<in>P. f p ^ multiplicity p n) = (\<Prod>p\<in>prime_factors n. f p ^ multiplicity p n)"
    unfolding P_def by (intro prod.mono_neutral_right dvd_prime_factors finite_set_mset)
                       (use mn in \<open>auto simp: prime_factors_multiplicity\<close>)
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. f (p ^ multiplicity p n))"
    by (intro prod.cong) (auto simp: assms prime_factors_multiplicity)
  also have "\<dots> = f n"
    using mn by (intro prod_prime_factors [symmetric]) auto
  finally show "f (m * n) = f m * f n" .
qed auto

subsection \<open>Indicator function\<close>

definition ind :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a :: semiring_1" where
  "ind P n = (if n > 0 \<and> P n then 1 else 0)"

lemma ind_0 [simp]: "ind P 0 = 0" by (simp add: ind_def)

lemma ind_nonzero: "n > 0 \<Longrightarrow> ind P n = (if P n then 1 else 0)"
  by (simp add: ind_def)

lemma ind_True [simp]: "P n \<Longrightarrow> n > 0 \<Longrightarrow> ind P n = 1"
  by (simp add: ind_nonzero)

lemma ind_False [simp]: "\<not>P n \<Longrightarrow> n > 0 \<Longrightarrow> ind P n = 0"
  by (simp add: ind_nonzero)

lemma ind_eq_1_iff: "ind P n = 1 \<longleftrightarrow> n > 0 \<and> P n"
  by (simp add: ind_def)

lemma ind_eq_0_iff: "ind P n = 0 \<longleftrightarrow> n = 0 \<or> \<not>P n"
  by (simp add: ind_def)

lemma multiplicative_function_ind [intro?]:
  assumes "P 1" "\<And>a b. a > 1 \<Longrightarrow> b > 1 \<Longrightarrow> coprime a b \<Longrightarrow> P (a * b) \<longleftrightarrow> P a \<and> P b"
  shows   "multiplicative_function (ind P)"
  by standard (insert assms, auto simp: ind_nonzero)

end


theory ex4_05 imports Main "~~/src/HOL/IMP/Star" begin

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
s1: "S []"  |
s2: "S w \<Longrightarrow> S (a # w @ [b])" |
s3: "\<lbrakk> S w1; S w2 \<rbrakk> \<Longrightarrow> S (w1 @ w2)"

inductive T :: "alpha list \<Rightarrow> bool" where
t1: "T []"  |
t2: "\<lbrakk> T x; T y \<rbrakk> \<Longrightarrow> T (x @ a # y @ [b])"

lemma lem1:"T w \<Longrightarrow> T (a # w @ [b])"
using t1 t2 by force

lemma t2':"\<lbrakk> T w2; T w1 \<rbrakk> \<Longrightarrow> T (a # w1 @ b # w2)"
apply(induction rule: T.induct)
apply(auto simp add: t1 t2)
using t1 t2 apply force
using t2 by fastforce

theorem s2t: "S w \<Longrightarrow> T w"
apply(induction rule: S.induct)
apply(auto simp add: t1 lem1)
done

theorem t2s: "T w \<Longrightarrow> S w"
apply(induction rule: T.induct)
apply(auto simp add: s1 s2 s3)
done

end


section \<open> Protocol parameters \<close>

theory Protocol_Parameters
imports Complex_Main
begin

text \<open>
  The protocol depends on a number of parameters, among others are the following:

  \<^item> \<open>k\<close>: Establishes how deep in the chain (in terms of number of blocks) a transaction needs to be
    in order to be declared as stable.
  \<^item> \<open>f\<close>: The `active slot coefficient'. Establishes the probability that at least one stakeholder
    is elected as a slot leader in each slot, that is, the probability that a slot is not empty.
    Must be a strictly positive probability.
\<close>

locale protocol_parameters =
  fixes k :: nat
    and f :: real
  assumes f_non_zero_probability: "f \<in> {0<..1}"
begin

text \<open>
  According to Definition 21.3 in @{cite "cardano-consensus-tr"} (which is based on the analysis in
  Section 4 of @{cite "genesis-praos-parametrization"}), the default value for the Genesis window
  size is set to \<open>3k/f\<close>:
\<close>

abbreviation default_window_size :: nat where
  "default_window_size \<equiv> nat \<lceil>3 * k / f\<rceil>"

text \<open>
  We can show that the default value is at least \<open>k\<close>:
\<close>

lemma default_window_greater_or_equal_than_k:
  shows "default_window_size \<ge> k"
proof -
  have "default_window_size \<ge> 3 * k"
    using f_non_zero_probability
    by (smt divide_numeral_1 frac_le greaterThanAtMost_iff nat_le_0 of_nat_ceiling of_nat_le_iff
        zero_less_ceiling)
  then show ?thesis
    by linarith
qed

end

end


theory Reg_Exp
imports "../NonFreeInput"
begin

(* Regular expressions as the freely generated Kleene algebra: *)
nonfree_datatype 'a exp = Let 'a | Zero | One | Plus "'a exp" "'a exp" |
                     Times "'a exp" "'a exp" | Star "'a exp"
where
   Plus_Assoc: "Plus (Plus e1 e2) e3 = Plus e1 (Plus e2 e3)"
 | Plus_Comm: "Plus e1 e2 = Plus e2 e1"
 | Plus_Zero: "Plus Zero e = e"
 | Plus_Idem: "Plus e e = e"
 | Times_Assoc: "Times (Times e1 e2) e3 = Times e1 (Times e2 e3)"
 | Times_One: "Times One e = e"
 | Times_Zero: "Times Zero e = Zero"
 | Times_Plus: "Times e1 (Plus e2 e3) = Plus (Times e1 e2) (Times e1 e3)"
 | Star_Left: "Plus (Plus One (Times (Star e) e)) (Star e) = Star e"
 | Star_Right: "Plus (Plus One (Times e (Star e))) (Star e) = Star e"
 | Star_Left_Min: "Plus (Times e e1) e1 = e1 \<Longrightarrow> Plus (Times (Star e) e1) e1 = e1"
 | Star_Right_Min: "Plus (Times e1 e) e1 = e1 \<Longrightarrow> Plus e1 (Times e1 (Star e)) = e1"

(* Interpretation as abstract relation algebra, on the powerset of a monoid: *)
definition Mult :: "('a::monoid_mult) set \<Rightarrow> 'a set \<Rightarrow> 'a set"
where
"Mult P Q \<equiv> {p * q | p q. p \<in> P \<and> q \<in> Q}"

declare algebra_simps[simp]

lemma Mult_Assoc: "Mult (Mult L1 L2) L3 = Mult L1 (Mult L2 L3)"
unfolding Mult_def apply auto apply blast
unfolding mult_assoc[symmetric] by blast

lemma Mult_Singl_One: "Mult {1} L = L"
unfolding Mult_def by auto

lemma Mult_emp: "Mult {} L = {}"
unfolding Mult_def by auto

lemma Mult_Un: "Mult L (L1 \<union> L2) = Mult L L1 \<union> Mult L L2"
unfolding Mult_def by auto

inductive_set Mstar for L :: "('a::monoid_mult) set" where
One: "1 \<in> Mstar L"
|
Times: "\<lbrakk>w \<in> L; w1 \<in> Mstar L\<rbrakk> \<Longrightarrow> w * w1 \<in> Mstar L"

lemma incl_Mstar[simp]: "w \<in> L \<Longrightarrow> w \<in> Mstar L"
using Mstar.intros by (metis mult_1_right)

lemma append_Mstar: "\<lbrakk>w \<in> Mstar L; w1 \<in> L\<rbrakk> \<Longrightarrow> w * w1 \<in> Mstar L"
apply(induction rule: Mstar.induct) by (auto intro: Mstar.intros)

lemma Mult_Mstar_R: "Mult L (Mstar L) \<subseteq> Mstar L"
unfolding Mult_def by (auto intro: Mstar.intros)

lemma Mult_Mstar_L: "Mult (Mstar L) L \<subseteq> Mstar L"
unfolding Mult_def by (auto intro: append_Mstar)

lemma Mult_Mstar_Min_L:
assumes "Mult L1 L \<subseteq> L"  shows "Mult (Mstar L1) L \<subseteq> L"
unfolding Mult_def proof safe
  fix x w1 w2 assume "w1 \<in> Mstar L1" and "w2 \<in> L"
  thus "w1 * w2 \<in> L"
  using assms unfolding Mult_def by (induction rule: Mstar.induct) auto
qed

lemma Mult_Mstar_Min_R:
assumes "Mult L L1 \<subseteq> L"  shows "Mult L (Mstar L1) \<subseteq> L"
unfolding Mult_def proof safe
  fix x w1 w2 assume "w2 \<in> Mstar L1" and "w1 \<in> L"
  thus "w1 * w2 \<in> L"
  proof (induction arbitrary: w1 rule: Mstar.induct)
    case (Times w w1 w1a)
    hence "w1a * w \<in> L" using assms unfolding Mult_def by auto
    from Times.IH[OF this] show ?case by simp
  qed auto
qed

nonfree_primrec kinter :: "('a \<Rightarrow> 'b::monoid_mult) \<Rightarrow> 'a exp \<Rightarrow> 'b set"
where
  "kinter f (Let a) = {f a}"
| "kinter f Zero = {}"
| "kinter f One = {1}"
| "kinter f (Plus e1 e2) = kinter f e1 \<union> kinter f e2"
| "kinter f (Times e1 e2) = Mult (kinter f e1) (kinter f e2)"
| "kinter f (Star e) = Mstar (kinter f e)"
apply (metis sup.commute)
apply (metis Sup_fin.idem)
apply (metis sup_bot_left)
apply auto[]
apply (metis Mstar.One)
apply (metis Mult_Mstar_L subsetD)
apply (metis Mult_Singl_One)
apply (metis Un_left_commute sup.commute)
apply auto[]
apply (metis Mstar.One)
apply (metis Mult_Mstar_R subsetD)
apply (metis Mult_Un)
apply (metis Mult_emp)
apply (metis Mult_Assoc)
apply (metis Mult_Mstar_Min_L Un_commute sup_absorb1 sup_ge1)
by (metis Mult_Mstar_Min_R Un_upper2 sup.commute sup_absorb1)

(* Instantiation to regular languages: *)
instantiation list :: (type)monoid_mult begin
  definition times_list where "xs * ys = xs @ ys"
  definition one_list where "1 = []"
  instance apply default unfolding times_list_def one_list_def by auto
end

definition "lang \<equiv> kinter (\<lambda> a. [a])"
abbreviation "Append \<equiv> Mult :: 'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set"
abbreviation "Lstar \<equiv> Mstar :: 'a list set \<Rightarrow> 'a list set"

lemma lang_simps:
  "lang (Let a) = {[a]}"
  "lang Zero = {}"
  "lang One = {[]}"
  "lang (Plus e1 e2) = lang e1 \<union> lang e2"
  "lang (Times e1 e2) = Append (lang e1) (lang e2)"
  "lang (Star e) = Lstar (lang e)"
unfolding lang_def by (auto simp: times_list_def one_list_def)

(* Interpretation in the algebra of relations: *)
nonfree_primrec rinter :: "('a \<Rightarrow> ('b \<times> 'b) set) \<Rightarrow> 'a exp \<Rightarrow> ('b \<times> 'b) set"
where
  "rinter f (Let a) = f a"
| "rinter f Zero = {}"
| "rinter f One = Id"
| "rinter f (Plus e1 e2) = rinter f e1 \<union> rinter f e2"
| "rinter f (Times e1 e2) = (rinter f e1) O (rinter f e2)"
| "rinter f (Star e) = (rinter f e) ^*"
apply auto
proof-
  fix x' x'a x y z assume "(x, y) \<in> x'\<^sup>*" "(y, z) \<in> x'a" "x' O x'a \<union> x'a = x'a"
  thus "(x, z) \<in> x'a" by (induction rule: rtrancl_induct) auto
next
  fix x' x'a x y z assume "(y, z) \<in> x'a\<^sup>*" "(x, y) \<in> x'" "x' O x'a \<union> x' = x'"
  thus "(x, z) \<in> x'" by (induction rule: rtrancl_induct) auto
qed

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_HSort2Permutes
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "Nat => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "Nat list => Nat list" where
  "hsort2 x = toList (toHeap2 x)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (hsort2 xs) xs"
  oops

end


theory Homework4_2
imports Main
begin

  (*
    ISSUED: Wednesday, October 11
    DUE: Wednesday, October 18, 11:59pm
    POINTS: 5
  *)

  (*
    In a directed graph, we have a path of length n from u to v,
    if we can go from u to v using exactly n edges.

    Specify an inductive predicate pol E x n y, which is true if and only
    if there is a path of length n from x to y.
  *)

  inductive pol :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
    (* Add inductive specification here! *)

  (* Show that two paths can be appended. Their length is the sum of the two lengths.
    Hint: Make sure the premises are in the right order,
      as rule induction will pick the first matching premise.
      If not, use rotate_tac.
  *)
  lemma pol_append: "\<lbrakk>pol E x k y; pol E y l z\<rbrakk> \<Longrightarrow> pol E x (k+l) z"
    sorry

  (*
    Write a recursive function that checks whether there is a path of length n.
    Hint: Recursion over n. Use an \<exists>-quantifier to obtain a next state.
  *)

  fun fpol :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
    where
    "fpol _ _ _ _ = undefined"

  (* Show that the function is equivalent to the inductive version!

    You may either show the two directions separately, as indicated in this template.
    Alternatively, you may derive recursive equations for pol, as done in LTS.thy.

    The only lemma that MUST be proved at the end is fpol_eq_pol!
  *)
  lemma fpol_imp_pol: "fpol E x l y \<Longrightarrow> pol E x l y"
    sorry

  lemma pol_imp_fpol: "pol E x l y \<Longrightarrow> fpol E x l y"
    sorry

  lemma fpol_eq_pol: "fpol = pol"
    sorry

  (* Using fpol, show that a path can be split *)
  lemma fpol_split: "fpol E x (l1+l2) z \<Longrightarrow> (\<exists>y. fpol E x l1 y \<and> fpol E y l2 z)"
    sorry

  (* Combine the split and append lemma *)
  lemma pol_append_conv: "pol E x (l1+l2) z \<longleftrightarrow> (\<exists>y. pol E x l1 y \<and> pol E y l2 z)"
    sorry

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Definition of Ordinals\<close>

theory OrdinalDef
imports Main
begin

subsection \<open>Preliminary datatype for ordinals\<close>

datatype ord0 = ord0_Zero | ord0_Lim "nat \<Rightarrow> ord0"

text \<open>subterm ordering on ord0\<close>

definition
  ord0_prec :: "(ord0 \<times> ord0) set" where
  "ord0_prec = (\<Union>f i. {(f i, ord0_Lim f)})"

lemma wf_ord0_prec: "wf ord0_prec"
 apply (unfold ord0_prec_def)
 apply (rule wfUNIVI, induct_tac x)
  apply (drule spec, erule mp, simp)
 apply (drule spec, erule mp, auto)
done

lemmas ord0_prec_induct = wf_induct[OF wf_trancl[OF wf_ord0_prec]]

text \<open>less-than-or-equal ordering on ord0\<close>

inductive_set ord0_leq :: "(ord0 \<times> ord0) set" where
"\<lbrakk>\<forall>a. (a,x) \<in> ord0_prec\<^sup>+ \<longrightarrow> (\<exists>b. (b,y) \<in> ord0_prec\<^sup>+ \<and> (a,b) \<in> ord0_leq)\<rbrakk>
  \<Longrightarrow> (x,y) \<in> ord0_leq"

lemma ord0_leqI:
"\<lbrakk>\<forall>a. (a,x) \<in> ord0_prec\<^sup>+ \<longrightarrow> (a,y) \<in> ord0_leq O ord0_prec\<^sup>+\<rbrakk>
 \<Longrightarrow> (x,y) \<in> ord0_leq"
by (rule ord0_leq.intros, auto)

lemma ord0_leqD:
"\<lbrakk>(x,y) \<in> ord0_leq; (a,x) \<in> ord0_prec\<^sup>+\<rbrakk> \<Longrightarrow> (a,y) \<in> ord0_leq O ord0_prec\<^sup>+"
by (ind_cases "(x,y) \<in> ord0_leq", auto)

lemma ord0_leq_refl: "(x, x) \<in> ord0_leq"
by (rule ord0_prec_induct, rule ord0_leqI, auto)

lemma ord0_leq_trans[rule_format]:
"\<forall>y. (x,y) \<in> ord0_leq \<longrightarrow>
   (\<forall>z. (y,z) \<in> ord0_leq \<longrightarrow> (x,z) \<in> ord0_leq)"
 apply (rule ord0_prec_induct, clarify)
 apply (rule ord0_leqI, clarify)
 apply (drule spec, drule mp, assumption)
 apply (drule ord0_leqD, assumption, clarify)
 apply (drule spec, drule mp, assumption)
 apply (drule ord0_leqD, assumption, clarify)
 apply (drule spec, drule mp, assumption)
 apply auto
done

lemma wf_ord0_leq: "wf (ord0_leq O ord0_prec\<^sup>+)"
 apply (unfold wf_def, clarify)
 apply (subgoal_tac "\<forall>z. (z,x) \<in> ord0_leq \<longrightarrow> P z")
  apply (drule spec, erule mp, rule ord0_leq_refl)
 apply (rule ord0_prec_induct, clarify)
 apply (drule spec, erule mp, clarify)
 apply (drule ord0_leqD, assumption, clarify)
 apply (drule spec, drule mp, assumption)
 apply (drule spec, erule mp)
 apply (erule ord0_leq_trans, assumption)
done

text \<open>ordering on ord0\<close>

instantiation ord0 :: ord
begin

definition
  ord0_less_def: "x < y \<longleftrightarrow> (x,y) \<in> ord0_leq O ord0_prec\<^sup>+"

definition
  ord0_le_def:   "x \<le> y \<longleftrightarrow> (x,y) \<in> ord0_leq"

instance ..

end

lemma ord0_order_refl[simp]: "(x::ord0) \<le> x"
by (unfold ord0_le_def, rule ord0_leq_refl)

lemma ord0_order_trans: "\<lbrakk>(x::ord0) \<le> y; y \<le> z\<rbrakk> \<Longrightarrow> x \<le> z"
by (unfold ord0_le_def, rule ord0_leq_trans)

lemma ord0_wf: "wf {(x,y::ord0). x < y}"
 apply (subgoal_tac "{(x,y). x < y} = ord0_leq O ord0_prec\<^sup>+")
  apply (simp add: wf_ord0_leq)
 apply (auto simp add: ord0_less_def)
done

lemmas ord0_less_induct = wf_induct[OF ord0_wf]

lemma ord0_leI:
"\<lbrakk>\<forall>a::ord0. a < x \<longrightarrow> a < y\<rbrakk> \<Longrightarrow> x \<le> y"
 apply (unfold ord0_less_def ord0_le_def)
 apply (rule ord0_leqI[rule_format])
 apply (drule spec, erule mp)
 apply (erule relcompI[OF ord0_leq_refl])
done

lemma ord0_less_le_trans:
"\<lbrakk>(x::ord0) < y; y \<le> z\<rbrakk> \<Longrightarrow> x < z"
 apply (unfold ord0_le_def ord0_less_def, clarify)
 apply (drule ord0_leqD, assumption, clarify)
by (rule relcompI[OF ord0_leq_trans])

lemma ord0_le_less_trans:
"\<lbrakk>(x::ord0) \<le> y; y < z\<rbrakk> \<Longrightarrow> x < z"
 apply (unfold ord0_le_def ord0_less_def, clarify)
by (rule relcompI[OF ord0_leq_trans])

lemma rev_ord0_le_less_trans:
"\<lbrakk>(y::ord0) < z; x \<le> y\<rbrakk> \<Longrightarrow> x < z"
by (rule ord0_le_less_trans)

lemma ord0_less_trans:
"\<lbrakk>(x::ord0) < y; y < z\<rbrakk> \<Longrightarrow> x < z"
 apply (unfold ord0_less_def, clarify)
 apply (drule ord0_leqD, assumption, clarify)
by (rule relcompI[OF ord0_leq_trans trancl_trans])

lemma ord0_less_imp_le: "(x::ord0) < y \<Longrightarrow> x \<le> y"
by (rule ord0_leI[rule_format], rule ord0_less_trans)

lemma ord0_linear_lemma:
fixes m :: ord0 and n :: ord0
shows "m < n \<or> n < m \<or> (m \<le> n \<and> n \<le> m)"
 apply (rule_tac x=m in spec)
 apply (rule_tac a=n in ord0_less_induct, rename_tac n)
 apply (rule allI, rename_tac m)
 apply (rule_tac a=m in ord0_less_induct, rename_tac m)
 apply (case_tac "\<forall>a. a < n \<longrightarrow> a < m")
  apply (rule disjI2)
  apply (case_tac "\<forall>a. a < m \<longrightarrow> a < n")
   apply (rule disjI2)
   apply (rule conjI, erule ord0_leI, erule ord0_leI)
  apply (rule disjI1, clarsimp)
  apply (drule spec, drule mp, assumption)
  apply (erule rev_ord0_le_less_trans)
  apply (force simp add: ord0_less_imp_le)
 apply (rule disjI1, clarsimp)
 apply (drule spec, drule mp, assumption)
 apply (drule_tac x=m in spec, simp)
 apply (erule rev_ord0_le_less_trans)
 apply (force simp add: ord0_less_imp_le)
done

lemma ord0_linear: "(x::ord0) \<le> y \<or> y \<le> x"
 apply (cut_tac ord0_linear_lemma[of x y])
 apply (auto dest: ord0_less_imp_le)
done

lemma ord0_order_less_le: "(x::ord0) < y = (x \<le> y \<and> \<not> y \<le> x)"
 apply (rule iffI)
  apply (clarsimp simp add: ord0_less_imp_le)
  apply (drule ord0_less_le_trans, assumption)
  apply (cut_tac a=x in wf_not_refl[OF ord0_wf], simp)
 apply (cut_tac ord0_linear_lemma[of x y], simp)
 apply (auto dest: ord0_less_imp_le)
done

subsection \<open>Ordinal type\<close>

definition
  ord0rel :: "(ord0 \<times> ord0) set" where
  "ord0rel = {(x,y). x \<le> y \<and> y \<le> x}"

typedef ordinal = "(UNIV::ord0 set) // ord0rel"
by (unfold quotient_def, auto)

theorem Abs_ordinal_cases2 [case_names Abs_ordinal, cases type: ordinal]:
"(\<And>z. x = Abs_ordinal (ord0rel `` {z}) \<Longrightarrow> P) \<Longrightarrow> P"
by (cases x, auto simp add: quotient_def)

instantiation ordinal :: ord
begin

definition
  ordinal_less_def: "x < y \<longleftrightarrow> (\<forall>a\<in>Rep_ordinal x. \<forall>b\<in>Rep_ordinal y. a < b)"

definition
  ordinal_le_def: "x \<le> y \<longleftrightarrow> (\<forall>a\<in>Rep_ordinal x. \<forall>b\<in>Rep_ordinal y. a \<le> b)"

instance ..

end

lemma Rep_Abs_ord0rel [simp]:
"Rep_ordinal (Abs_ordinal (ord0rel `` {x})) = (ord0rel `` {x})"
by (simp add: Abs_ordinal_inverse quotientI)

lemma mem_ord0rel_Image [simp, intro!]: "x \<in> ord0rel `` {x}"
by (simp add: ord0rel_def)

lemma equiv_ord0rel: "equiv UNIV ord0rel"
 apply (unfold equiv_def refl_on_def sym_def trans_def ord0rel_def)
 apply (auto elim: ord0_order_trans)
done

lemma Abs_ordinal_eq[simp]:
"(Abs_ordinal (ord0rel `` {x}) = Abs_ordinal (ord0rel `` {y}))
  = (x \<le> y \<and> y \<le> x)"
 apply (simp add: Abs_ordinal_inject quotientI)
 apply (simp add: eq_equiv_class_iff[OF equiv_ord0rel])
 apply (simp add: ord0rel_def)
done

lemma Abs_ordinal_le[simp]:
"Abs_ordinal (ord0rel `` {x}) \<le> Abs_ordinal (ord0rel `` {y}) = (x \<le> y)"
 apply (auto simp add: ordinal_le_def)
 apply (unfold ord0rel_def)
 apply (auto elim: ord0_order_trans)
done

lemma Abs_ordinal_less[simp]:
"Abs_ordinal (ord0rel `` {x}) < Abs_ordinal (ord0rel `` {y}) = (x < y)"
 apply (auto simp add: ordinal_less_def)
 apply (unfold ord0rel_def)
 apply (auto elim: ord0_less_le_trans[OF rev_ord0_le_less_trans])
done

lemma ordinal_order_refl: "(x::ordinal) \<le> x"
by (cases x, simp)

lemma ordinal_order_trans: "(x::ordinal) \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
by (cases x, cases y, cases z, auto elim: ord0_order_trans)

lemma ordinal_order_antisym: "(x::ordinal) \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
by (cases x, cases y, simp)

lemma ordinal_linear: "(x::ordinal) \<le> y \<or> y \<le> x"
by (cases x, cases y, simp add: ord0_linear)

lemma ordinal_wf: "wf {(x,y::ordinal). x < y}"
 apply (rule wfUNIVI)
 apply (rule_tac x=x in Abs_ordinal_cases2, clarify)
 apply (rule ord0_less_induct, rename_tac a)
 apply (drule spec, erule mp, clarify)
 apply (rule_tac x=y in Abs_ordinal_cases2, simp)
done

instance ordinal :: wellorder
 apply (rule wf_wellorderI)
 apply (rule ordinal_wf)
 apply (intro_classes)
       apply (rule ordinal_order_less_le_not_le)
      apply (rule ordinal_order_refl)
     apply (rule ordinal_order_trans, assumption+)
    apply (rule ordinal_order_antisym, assumption+)
  apply (rule ordinal_linear)
done

subsection \<open>Induction over ordinals\<close>

text "zero and strict limits"

definition
  oZero :: "ordinal" where
    "oZero = Abs_ordinal (ord0rel `` {ord0_Zero})"

definition
  oStrictLimit :: "(nat \<Rightarrow> ordinal) \<Rightarrow> ordinal" where
    "oStrictLimit f = Abs_ordinal
      (ord0rel `` {ord0_Lim (\<lambda>n. SOME x. x \<in> Rep_ordinal (f n))})"

text "induction over ordinals"

lemma ord0relD: "(x,y) \<in> ord0rel \<Longrightarrow> x \<le> y \<and> y \<le> x"
by (simp add: ord0rel_def)

lemma ord0_precD: "(x,y) \<in> ord0_prec \<Longrightarrow> \<exists>f n. x = f n \<and> y = ord0_Lim f"
by (simp add: ord0_prec_def)

lemma less_ord0_LimI: "f n < ord0_Lim f"
 apply (simp add: ord0_less_def)
 apply (rule relcompI[OF ord0_leq_refl])
 apply (rule r_into_trancl)
 apply (auto simp add: ord0_prec_def)
done

lemma less_ord0_LimD: "x < ord0_Lim f \<Longrightarrow> \<exists>n. x \<le> f n"
 apply (simp add: ord0_less_def, clarify)
 apply (erule tranclE)
  apply (drule ord0_precD, clarify)
  apply (force simp add: ord0_le_def)
 apply (drule ord0_precD, clarify)
 apply (rule_tac x=n in exI)
 apply (rule ord0_less_imp_le)
 apply (auto simp add: ord0_less_def)
done

lemma some_ord0rel: "(x, SOME y. (x,y) \<in> ord0rel) \<in> ord0rel"
by (rule_tac x=x in someI, simp add: ord0rel_def)

lemma ord0_Lim_le:
"\<forall>n. f n \<le> g n \<Longrightarrow> ord0_Lim f \<le> ord0_Lim g"
 apply (rule ord0_leI[rule_format])
 apply (drule less_ord0_LimD, clarify)
 apply (erule ord0_le_less_trans)
 apply (drule_tac x=n in spec)
 apply (erule ord0_le_less_trans)
 apply (rule less_ord0_LimI)
done

lemma ord0_Lim_ord0rel:
"\<forall>n. (f n, g n) \<in> ord0rel \<Longrightarrow> (ord0_Lim f, ord0_Lim g) \<in> ord0rel"
by (simp add: ord0rel_def ord0_Lim_le)

lemma Abs_ordinal_oStrictLimit:
"Abs_ordinal (ord0rel `` {ord0_Lim f})
  = oStrictLimit (\<lambda>n. Abs_ordinal (ord0rel `` {f n}))"
 apply (simp add: oStrictLimit_def)
 apply (rule ord0relD)
 apply (rule ord0_Lim_ord0rel)
 apply (simp add: some_ord0rel)
done

lemma oStrictLimit_induct:
assumes base: "P oZero"
assumes step: "\<And>f. \<forall>n. P (f n) \<Longrightarrow> P (oStrictLimit f)"
shows "P a"
 apply (cases a, clarsimp)
 apply (induct_tac z)
  apply (rule base[unfolded oZero_def])
 apply (simp add: Abs_ordinal_oStrictLimit step)
done

text "order properties of 0 and strict limits"

lemma oZero_least: "oZero \<le> x"
 apply (unfold oZero_def, cases x, clarsimp)
 apply (induct_tac z, simp, atomize)
 apply (rule ord0_less_imp_le)
 apply (rule ord0_le_less_trans)
 apply (auto simp: less_ord0_LimI)
done

lemma oStrictLimit_ub: "f n < oStrictLimit f"
 apply (cases "f n", simp add: oStrictLimit_def)
 apply (rule_tac y="SOME x. x \<in> Rep_ordinal (f n)" in ord0_le_less_trans)
  apply (simp, rule ord0relD[THEN conjunct1])
  apply (rule some_ord0rel)
 apply (rule less_ord0_LimI)
done

lemma oStrictLimit_lub: "\<forall>n. f n < x \<Longrightarrow> oStrictLimit f \<le> x"
 apply (erule contrapos_pp, simp add: linorder_not_less linorder_not_le)
 apply (cases x, simp add: oStrictLimit_def)
 apply (drule less_ord0_LimD, clarify)
 apply (rule_tac x=n in exI)
 apply (rule_tac x="f n" in Abs_ordinal_cases2, simp, rename_tac y)
 apply (erule ord0_order_trans)
 apply (rule ord0relD[THEN conjunct2])
 apply (rule some_ord0rel)
done

lemma less_oStrictLimitD: "x < oStrictLimit f \<Longrightarrow> \<exists>n. x \<le> f n"
 apply (erule contrapos_pp)
 apply (simp add: linorder_not_less linorder_not_le)
 apply (erule oStrictLimit_lub)
done

end


theory Chapter03
  imports Main
begin

declare [[names_short]]

section "Chapter 3"

datatype t =
  TTrue
  | FFalse
  | Zero
  | Succ t
  | Pred t
  | IsZero t
  | IfElse t t t ("If _ Then _ Else _" [85,85,85] 80)

(* 3.2.5 *)
fun terms :: "nat \<Rightarrow> t set" where
"terms 0 = {}" |
"terms (Suc n) =
  {TTrue,FFalse,Zero}
  \<union> {Succ t | t. t \<in> terms n} \<union> {Pred t | t. t \<in> terms n} \<union> {IsZero t | t. t \<in> terms n}
  \<union> {IfElse t1 t2 t3 | t1 t2 t3. let termsn = terms n in t1 \<in> termsn \<and> t2 \<in> termsn \<and> t3 \<in> termsn}"

lemma succ: "Succ t \<in> terms (Suc n) \<longleftrightarrow> t \<in> terms n"
  by (induction n) auto

lemma pred: "Pred t \<in> terms (Suc n) \<longleftrightarrow> t \<in> terms n"
  by (induction n) auto

lemma iszero: "IsZero t \<in> terms (Suc n) \<longleftrightarrow> t \<in> terms n"
  by (induction n) auto

lemma ifelse: "IfElse t1 t2 t3 \<in> terms (Suc n) \<longleftrightarrow> t1 \<in> terms n \<and> t2 \<in> terms n \<and> t3 \<in> terms n"
  by (induction n) auto
thm terms.simps
lemma "terms n \<subseteq> terms (Suc n)"
proof (induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  have "t \<in> terms (Suc n) \<Longrightarrow> t \<in> terms (Suc (Suc n))" for t
  proof (induction t)
    case (Succ t)
    then show ?case
      using Suc.IH
      by (meson in_mono succ)
  next
    case (Pred t)
    then show ?case
      using Suc.IH
      by (meson in_mono pred)
  next
    case (IsZero t)
    then show ?case
      using Suc.IH
      by (meson in_mono iszero)
  next
    case (IfElse t1 t2 t3)
    then show ?case
      using Suc.IH
      by (meson in_mono ifelse)
  qed auto
  then show ?case
    by blast
qed

(* 3.3.1 *)
fun Consts :: "t \<Rightarrow> t set" where
"Consts TTrue = {TTrue}" |
"Consts FFalse = {FFalse}" |
"Consts Zero = {Zero}" |
"Consts (Succ t1) = Consts t1" |
"Consts (Pred t1) = Consts t1" |
"Consts (IsZero t1) = Consts t1" |
"Consts (IfElse t1 t2 t3) = Consts t1 \<union> Consts t2 \<union> Consts t3"

(* 3.3.2 *)
fun size :: "t \<Rightarrow> nat" where
"size TTrue = 1" |
"size FFalse = 1" |
"size Zero = 1" |
"size (Succ t1) = 1 + size t1" |
"size (Pred t1) = 1 + size t1" |
"size (IsZero t1) = 1 + size t1" |
"size (IfElse t1 t2 t3) = 1 + size t1 + size t2 + size t3"

lemma size_not_zero: "size t > 0"
  by (cases t) auto

fun depth :: "t \<Rightarrow> nat" where
"depth TTrue = 1" |
"depth FFalse = 1" |
"depth Zero = 1" |
"depth (Succ t1) = 1 + depth t1" |
"depth (Pred t1) = 1 + depth t1" |
"depth (IsZero t1) = 1 + depth t1" |
"depth (IfElse t1 t2 t3) = Max {depth t1, depth t2, depth t3}"

lemma depth_not_zero: "depth t > 0"
  by (induction t) auto

(* 3.3.3 *)
lemma "card (Consts t) \<le> size t"
proof (induction t)
  case (IfElse t1 t2 t3)
  have "card (Consts (IfElse t1 t2 t3)) = card (Consts t1 \<union> Consts t2 \<union> Consts t3)"
    by simp
  also have "\<dots> \<le> card (Consts t1) + card (Consts t2) + card (Consts t3)"
    by (metis add_mono_thms_linordered_semiring(3) card_Un_le order_trans)
  also have "\<dots> \<le> size t1 + size t2 + size t3"
    using IfElse.IH by (simp add: add_mono)
  also have "\<dots> \<le> size (IfElse t1 t2 t3)"
    by simp
  finally show ?case .
qed auto

(* 3.3.4 *)
lemma raw_induct[case_names TTrue FFalse Zero Succ Pred IsZero IfElse]:
  assumes "P TTrue"
    and "P FFalse"
    and "P Zero"
    and "\<And>t. P (Succ t)"
    and "\<And>t. P (Pred t)"
    and "\<And>t. P (IsZero t)"
    and "\<And>t1 t2 t3. P (IfElse t1 t2 t3)"
  shows "P t"
  using assms
  by (cases t) auto

lemma depth_induct:
  "(\<And>r::t. depth r < depth s \<Longrightarrow> P r) \<Longrightarrow> P s"
  sorry

lemma size_induct:
  "(\<And>r::t. size r < size s \<Longrightarrow> P r) \<Longrightarrow> P s"
  sorry

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_mod_same
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

(*fun did not finish the proof*)
function mod2 :: "Nat => Nat => Nat" where
"mod2 x (Z) = Z"
| "mod2 x (S z) =
     (if lt x (S z) then x else mod2 (minus x (S z)) (S z))"
by pat_completeness auto

fun go :: "Nat => Nat => Nat => Nat" where
"go x y (Z) = Z"
| "go (Z) (Z) (S x2) = Z"
| "go (Z) (S x5) (S x2) = minus (S x2) (S x5)"
| "go (S x3) (Z) (S x2) = go x3 x2 (S x2)"
| "go (S x3) (S x4) (S x2) = go x3 x4 (S x2)"

fun modstructural :: "Nat => Nat => Nat" where
"modstructural x y = go x Z y"

theorem property0 :
  "((mod2 m n) = (modstructural m n))"
  oops

end


(*  Title:       Graph.thy
    Author:      Filip Smola, 2019
*)

section\<open>Graphs\<close>
text\<open>The graph theory required to define bigraphs and their constituents.
Focused on forests (for place graphs) and hypergraphs (for link graphs).

Heavily inspired by Tom Ridge's 2005 paper "Graphs and Trees in Isabelle/HOL".\<close>

theory Graph
  imports
    Main
begin

subsection\<open>Paths and Edges\<close>

text\<open>A path is a list of nodes with some extra conditions. The extra conditions are introduced in a
later subsection.\<close>
type_synonym 'a prepath = "'a list"

text\<open>An edge is a set of one or more connected nodes.\<close>
type_synonym 'a edge = "'a set"

text\<open>A pre-path gives rise to a list of edges.\<close>
primrec edge_list :: "'a prepath \<Rightarrow> 'a edge list"
  where
    "edge_list [] = []"
  | "edge_list (x#xs) = (case xs of
        [] \<Rightarrow> []
      | (y#ys) \<Rightarrow> ({x,y}#(edge_list xs)))"

text\<open>A path is loop-free if its generated edge list contains no loops (i.e. edges \<open>{x,x}\<close>).\<close>
definition is_loop_free :: "'a prepath \<Rightarrow> bool"
  where "is_loop_free p = (\<forall>x . {x,x} \<notin> set (edge_list p))"

subsection\<open>Graphs and Subgraphs\<close>

text\<open>A graph is a record with a set of vertices and a set of edges.\<close>
record 'a pregraph =
  Verts :: "'a set"
  Edges :: "'a edge set"

(*TODO paper suggests defining the next two on pregraph instead of pregraph_scheme*)
text\<open>A graph is well-formed iff its edge set is a subset of the powerset of the vertices and
contains no loops.\<close>
definition is_graph :: "('a,'b) pregraph_scheme \<Rightarrow> bool"
  where "is_graph g = (Edges g \<subseteq> Pow (Verts g) \<and> (\<forall>x. {x,x} \<notin> (Edges g)))"

text\<open>A graph G is a subgraph of a graph H iff the vertex and edge sets of G are subsets of those of
H.\<close>
definition is_subgraph :: "('a,'b) pregraph_scheme \<Rightarrow> ('a,'c) pregraph_scheme \<Rightarrow> bool"
  where "is_subgraph G H = (Verts G \<subseteq> Verts H \<and> Edges G \<subseteq> Edges H)"

subsection\<open>Paths Continued\<close>

text\<open>A path consists of a set of vertices and gives rise to a set of edges, therefore it represents
a graph.\<close>
definition graph_of :: "'a prepath \<Rightarrow> 'a pregraph"
  where "graph_of p = \<lparr> Verts = set p, Edges = set (edge_list p) \<rparr>"

text\<open>A path lies in a graph G if its graph is a subgraph of G. Therefore we do not require a special
predicate for that.\<close>

text\<open>We constrain the type of prepaths with the following properties:
  * The empty list does not represent a valid path,
  * A path should be loop-free (which respects the restriction placed on graphs)
This most general form of a path is called a walk.\<close>
definition is_walk :: "'a prepath \<Rightarrow> bool"
  where "is_walk p = (p \<noteq> [] \<and> is_loop_free p)"

text\<open>A trail is a walk whose all edges are distinct.\<close>
definition is_trail :: "'a prepath \<Rightarrow> bool"
  where "is_trail p = (is_walk p \<and> distinct (edge_list p))"

(* Deviation from source: I note length constraints of circuits as lemmas instead of including them
in the circuit definition. *)
text\<open>A circuit is a trail whose start and end vertices are the same and which contains at least one
edge.\<close>
definition is_circuit :: "'a prepath \<Rightarrow> bool"
  where "is_circuit p = (is_trail p \<and> hd p = last p \<and> length (edge_list p) > 0)"

text\<open>A circuit can't be of length 0 because walks can't be empty.
It can't be of length 1 because it has to contain an edge.
It can't be of length 2 because walks are loop-free.
It can't be of length 3 because edges have to be distinct (i.e. not \<open>{x,y}\<close> and \<open>{y,x}\<close>).\<close>
lemma circuit_length:
  assumes circ: "is_circuit p"
  shows "length p > 3"
proof -
  have l0: "length p \<noteq> 0"
    using circ is_circuit_def is_trail_def is_walk_def by blast

  moreover have "length p \<noteq> 1"
  proof (rule ccontr)
    assume "\<not>length p \<noteq> 1"
    then have "length p = 1"
      by simp
    then have "\<exists>x. p = [x]"
      using length_0_conv length_Suc_conv One_nat_def by metis
    then obtain x where "p = [x]"
      by auto
    then have "edge_list p = []"
      by simp
    then have "length (edge_list p) = 0"
      by simp
    then show "False"
      using circ is_circuit_def by blast
  qed

  moreover have "length p \<noteq> 2"
  proof (rule ccontr)
    assume "\<not>length p \<noteq> 2"
    then have "length p = 2"
      by simp
    then have "\<exists>x y. p = [x,y]"
      using length_0_conv length_Suc_conv One_nat_def Suc_1 by metis
    then obtain x y where cont_p: "p = [x,y]" and "hd p = x" and "last p = y"
      by auto
    then have "x = y"
      using is_circuit_def circ by metis
    moreover have "edge_list p = [{x,y}]"
      using cont_p by simp
    ultimately have "\<not>is_loop_free p"
      by (simp add: is_loop_free_def)
    then show "False"
      using circ is_circuit_def is_trail_def is_walk_def by blast
  qed

  moreover have "length p \<noteq> 3"
  proof (rule ccontr)
    assume "\<not>length p \<noteq> 3"
    then have "length p = 3"
      by simp
    then have "\<exists>x y z. p = [x,y,z]"
      using length_0_conv length_Suc_conv numeral_3_eq_3 by smt
    then obtain x y z where cont_p: "p = [x,y,z]" and "hd p = x" and "last p = z"
      by auto
    then have "x = z"
      using is_circuit_def circ by metis
    then have "{x,y} = {y,z}"
      by (simp add: insert_commute)
    moreover have "edge_list p = [{x,y},{y,z}]"
      using cont_p by simp
    ultimately have "\<not>distinct (edge_list p)"
      by simp
    then show "False"
      using circ is_circuit_def is_trail_def by blast
  qed

  moreover have "length p \<ge> 0"
    by simp

  ultimately show "length p > 3"
    by (simp add: Suc_lessI numeral_3_eq_3)
qed

text\<open>A path is a trail whose vertices are distinct.\<close>
definition is_path :: "'a prepath \<Rightarrow> bool"
  where "is_path p = (is_trail p \<and> distinct p)"

text\<open>If the vertices are distinct, then the edge list is also distinct.\<close>
lemma vertices_distinct_then_edges:
  assumes "distinct (p :: 'a prepath)"
  shows "distinct (edge_list p)"
proof (cases "length p < 2")
  (* Trivial for zero, one vertices *)
  case True
  then have "length p = 0 \<or> length p = 1"
    by (simp add: less_Suc_eq numeral_2_eq_2)
  then have "p = [] \<or> (\<exists>x. p = [x])"
      using length_0_conv length_Suc_conv One_nat_def Suc_1 by metis
  then have "edge_list p = []"
    by auto
  then show ?thesis
    by simp
next
  case geq: False
  then show ?thesis
  proof (cases "length p = 2")
    (* Still simple with two vertices giving rise to one edge. *)
    case True
    then have "\<exists>x y. p = [x,y]"
      using length_0_conv length_Suc_conv One_nat_def Suc_1 by metis
    then obtain x y where cont_p: "p = [x, y]"
      by auto
    then have "edge_list p = [{x,y}]"
      by simp
    then show "distinct (edge_list p)"
      by simp
  next
    (* If edge list wasn't distinct, there would be two edges {a,b} in it and those can only arise by
having two sequences of a followed by b in the vertex list. *)
    case False
    then have ge: "length p > 2"
      using geq by simp
    show ?thesis
    proof (rule ccontr)
      assume "\<not>distinct (edge_list p)"
      then have "\<exists>a b l r. edge_list p = l@{a,b}#r \<and> distinct l \<and> {a,b} \<in> set r"
        sorry
      show "False" sorry
    qed
  qed
qed

text\<open>We can then derive an alternative definition of a path as a non-empty distinct list.\<close>
lemma is_path_def_2: "is_path p = (p \<noteq> [] \<and> distinct p)"
  sorry

text\<open>We define a cycle as a circuit whose vertices are distinct, except for the first and last.\<close>
definition is_cycle :: "'a prepath \<Rightarrow> bool"
  where "is_cycle p = (is_circuit p \<and> is_path (tl p))"

text\<open>We can also derive a cycle definition removing some redundancy.\<close>
lemma is_cycle_def_2: "is_cycle p = (hd p = last p \<and> distinct (tl p) \<and> length (edge_list p) > 0)"
  sorry
end


theory Binary_operations
 imports Bij_betw_simplicial_complex_bool_func
begin

section\<open>Binary operations over Boolean functions and simplicial complexes\<close>

text\<open>In this theory some results on binary operations over Boolean functions and
  their relationship to operations over the induced simplicial complexes are
  presented. We follow the presentation by Chastain and Scoville~\cite[Sect. 1.1]{CHSC}.\<close>

definition bool_fun_or :: "nat \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool)"
  where "(bool_fun_or n f g) \<equiv> (\<lambda>x. f x \<or> g x)"

definition bool_fun_and :: "nat \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool) \<Rightarrow> (bool vec \<Rightarrow> bool)"
  where "(bool_fun_and n f g) \<equiv> (\<lambda>x. f x \<and> g x)"

lemma eq_union_or:
  "simplicial_complex_induced_by_monotone_boolean_function n (bool_fun_or n f g)
  = simplicial_complex_induced_by_monotone_boolean_function n f
    \<union> simplicial_complex_induced_by_monotone_boolean_function n g"
  (is "?sc n (?bf_or n f g) = ?sc n f \<union> ?sc n g")
proof
  show "?sc n f \<union> ?sc n g \<subseteq> ?sc n (?bf_or n f g)"
  proof
    fix \<sigma> :: "nat set"
    assume "\<sigma> \<in> (?sc n f \<union> ?sc n g)"
    hence sigma: "\<sigma> \<in> ?sc n f \<or> \<sigma> \<in> ?sc n g" by auto
    have "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<or> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
    proof (cases "\<sigma> \<in> ?sc n f")
      case True
      from simplicial_complex.simplicial_complex_implies_true [OF True]
      show "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<or> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)" by fast
    next
      case False
      hence sigmain: "\<sigma> \<in> ?sc n g" using sigma by fast
      from simplicial_complex.simplicial_complex_implies_true [OF sigmain]
      show "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<or> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)" by fast
    qed
    thus "\<sigma> \<in> ?sc n (?bf_or n f g)"
      using simplicial_complex_induced_by_monotone_boolean_function_def
      using bool_fun_or_def sigma by auto
  qed
next
  show "?sc n (?bf_or n f g) \<subseteq> ?sc n f \<union> ?sc n g"
  proof
    fix \<sigma>::"nat set"
    assume sigma: "\<sigma> \<in> ?sc n (?bf_or n f g)"
    hence "bool_fun_or n f g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
      unfolding simplicial_complex.bool_vec_from_simplice_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding ceros_of_boolean_input_def
      by auto (smt (verit) dim_vec eq_vecI index_vec)+
    hence "(f (simplicial_complex.bool_vec_from_simplice n \<sigma>))
            \<or> (g (simplicial_complex.bool_vec_from_simplice n \<sigma>))"
      unfolding bool_fun_or_def
      by auto
    hence "\<sigma> \<in> ?sc n f \<or> \<sigma> \<in> ?sc n g"
      by (smt (z3) sigma bool_fun_or_def mem_Collect_eq
            simplicial_complex_induced_by_monotone_boolean_function_def)
    thus "\<sigma> \<in> simplicial_complex_induced_by_monotone_boolean_function n f
          \<union> simplicial_complex_induced_by_monotone_boolean_function n g"
      by auto
  qed
qed

lemma eq_inter_and:
  "simplicial_complex_induced_by_monotone_boolean_function n (bool_fun_and n f g)
  = simplicial_complex_induced_by_monotone_boolean_function n f
    \<inter> simplicial_complex_induced_by_monotone_boolean_function n g"
  (is "?sc n (?bf_and n f g) = ?sc n f \<inter> ?sc n g")
proof
  show "?sc n f \<inter> ?sc n g \<subseteq> ?sc n (?bf_and n f g)"
  proof
    fix \<sigma> :: "nat set"
    assume "\<sigma> \<in> (?sc n f \<inter> ?sc n g)"
    hence sigma: "\<sigma> \<in> ?sc n f \<and> \<sigma> \<in> ?sc n g" by auto
    have "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)
           \<and> g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
    proof -
      from sigma have sigmaf: "\<sigma> \<in> ?sc n f" and sigmag: "\<sigma> \<in> ?sc n g"
        by auto
      have "f (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
        using simplicial_complex.simplicial_complex_implies_true [OF sigmaf] .
      moreover have "g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
        using simplicial_complex.simplicial_complex_implies_true [OF sigmag] .
      ultimately show ?thesis by fast
    qed
    thus "\<sigma> \<in> ?sc n (?bf_and n f g)"
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding bool_fun_and_def
      using sigma apply auto
      by (smt (z3) Collect_cong ceros_of_boolean_input_def dim_vec index_vec mem_Collect_eq
          simplicial_complex.bool_vec_from_simplice_def
          simplicial_complex_induced_by_monotone_boolean_function_def)
  qed
next
  show "?sc n (?bf_and n f g) \<subseteq> ?sc n f \<inter> ?sc n g"
  proof
    fix \<sigma> :: "nat set"
    assume sigma: "\<sigma> \<in> ?sc n (?bf_and n f g)"
    hence "bool_fun_and n f g (simplicial_complex.bool_vec_from_simplice n \<sigma>)"
      unfolding simplicial_complex.bool_vec_from_simplice_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding ceros_of_boolean_input_def
      by auto (smt (verit) dim_vec eq_vecI index_vec)+
    hence "(f (simplicial_complex.bool_vec_from_simplice n \<sigma>))
          \<and> (g (simplicial_complex.bool_vec_from_simplice n \<sigma>))"
      unfolding bool_fun_and_def
      by auto
    hence "\<sigma> \<in> ?sc n f \<and> \<sigma> \<in> ?sc n g"
      using bool_fun_and_def sigma simplicial_complex_induced_by_monotone_boolean_function_def by auto
    thus "\<sigma> \<in> simplicial_complex_induced_by_monotone_boolean_function n f
          \<inter> simplicial_complex_induced_by_monotone_boolean_function n g"
      by auto
  qed
qed

definition bool_fun_ast :: "(nat \<times> nat) \<Rightarrow> (bool vec \<Rightarrow> bool) \<times> (bool vec \<Rightarrow> bool)
    \<Rightarrow> (bool vec \<times> bool vec \<Rightarrow> bool)"
  where "(bool_fun_ast n f) \<equiv> (\<lambda> (x,y). (fst f x) \<and> (snd f y))"

definition
  simplicial_complex_induced_by_monotone_boolean_function_ast
    :: "(nat \<times> nat) \<Rightarrow> ((bool vec \<times> bool vec \<Rightarrow> bool)) \<Rightarrow> (nat set * nat set) set"
  where "simplicial_complex_induced_by_monotone_boolean_function_ast n f =
        {z. \<exists>x y. dim_vec x = fst n \<and> dim_vec y = snd n \<and> f (x, y)
          \<and> ((ceros_of_boolean_input x), (ceros_of_boolean_input y)) = z}"

lemma fst_es_simplice:
  "a \<in> simplicial_complex_induced_by_monotone_boolean_function_ast n f
    \<Longrightarrow> (\<exists>x y. f (x, y) \<and> (ceros_of_boolean_input x) = fst(a))"
  by (smt (verit) fst_conv mem_Collect_eq
        simplicial_complex_induced_by_monotone_boolean_function_ast_def)

lemma snd_es_simplice:
  "a \<in> simplicial_complex_induced_by_monotone_boolean_function_ast n f
    \<Longrightarrow> (\<exists>x y. f (x, y) \<and> (ceros_of_boolean_input y) = snd(a))"
  by (smt (verit) snd_conv mem_Collect_eq
      simplicial_complex_induced_by_monotone_boolean_function_ast_def)

definition set_ast :: "(nat set) set \<Rightarrow> (nat set) set \<Rightarrow> ((nat set*nat set) set)"
  where "set_ast A B \<equiv> {c. \<exists>a\<in>A. \<exists>b\<in>B. c = (a,b)}"

definition set_fst :: "(nat*nat) set \<Rightarrow> nat set"
  where "set_fst AB = {a. \<exists>ab\<in>AB. a = fst ab}"

lemma set_fst_simp [simp]:
  assumes "y \<noteq> {}"
  shows "set_fst (x \<times> y) = x"
proof
  show "set_fst (x \<times> y) \<subseteq> x"
    by (smt (verit) SigmaE mem_Collect_eq prod.sel(1) set_fst_def subsetI)
  show "x \<subseteq> set_fst (x \<times> y)"
  proof
    fix a::"nat"
    assume "a \<in> x"
    then obtain b where "b \<in> y" and "(a,b) \<in> (x\<times>y)"
      using assms by blast
    then show "a \<in> set_fst (x \<times> y)"
      using set_fst_def by fastforce
  qed
qed

definition set_snd :: "(nat*nat) set \<Rightarrow> nat set"
  where "set_snd AB = {b. \<exists>ab\<in>AB. b = snd(ab)}"

lemma
  simplicial_complex_ast_implies_fst_true:
  assumes "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast nn
     (bool_fun_ast nn f)"
  shows "fst f (simplicial_complex.bool_vec_from_simplice (fst nn) (fst \<gamma>))"
  using assms
  unfolding simplicial_complex.bool_vec_from_simplice_def
  unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
  unfolding bool_fun_ast_def
  unfolding ceros_of_boolean_input_def
  apply auto
  by (smt (verit, ccfv_threshold) bool_fun_ast_def case_prod_conv dim_vec index_vec vec_eq_iff)

lemma
  simplicial_complex_ast_implies_snd_true:
  assumes "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast nn
     (bool_fun_ast nn f)"
  shows "snd f (simplicial_complex.bool_vec_from_simplice (snd nn) (snd \<gamma>))"
  using assms
  unfolding simplicial_complex.bool_vec_from_simplice_def
  unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
  unfolding bool_fun_ast_def
  unfolding ceros_of_boolean_input_def
  by auto (smt (verit, ccfv_threshold) bool_fun_ast_def
        case_prod_conv dim_vec index_vec vec_eq_iff)

lemma eq_ast:
"simplicial_complex_induced_by_monotone_boolean_function_ast (n, m) (bool_fun_ast (n, m) f)
= set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
          (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
proof
  show "set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
     (simplicial_complex_induced_by_monotone_boolean_function m (snd f))
    \<subseteq> simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
        (bool_fun_ast (n, m) f)"
  proof
    fix \<gamma>::"nat set*nat set"
    assume pert: "\<gamma> \<in> set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
     (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
    hence f: "(fst \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function n (fst f)"
      unfolding set_ast_def
      by auto
    have sigma: "fst f (simplicial_complex.bool_vec_from_simplice n (fst \<gamma>))"
      using simplicial_complex.simplicial_complex_implies_true [OF f] .
    from pert have g: "(snd \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function m (snd f)"
      unfolding set_ast_def by auto
    have tau: "(snd f) (simplicial_complex.bool_vec_from_simplice m (snd \<gamma>))"
      using simplicial_complex.simplicial_complex_implies_true [OF g] .
    from sigma and tau have sigtau: "bool_fun_ast (n, m) f
        ((simplicial_complex.bool_vec_from_simplice n (fst \<gamma>)),
         (simplicial_complex.bool_vec_from_simplice m (snd \<gamma>)))"
      unfolding bool_fun_ast_def
      by auto
    from sigtau
    show "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
              (bool_fun_ast (n, m) f)"
      unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
      unfolding bool_fun_ast_def
      using sigma apply auto
      using f g simplicial_complex_induced_by_monotone_boolean_function_def by fastforce
  qed
next
  show "simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
     (bool_fun_ast (n, m) f)
    \<subseteq> set_ast (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
        (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
    proof
    fix \<gamma> :: "nat set*nat set"
    assume pert: "\<gamma> \<in> simplicial_complex_induced_by_monotone_boolean_function_ast (n, m)
     (bool_fun_ast (n, m) f)"
    have sigma: "(fst \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function n (fst f)"
      unfolding bool_fun_ast_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
      apply auto
      apply (rule exI [of _ "simplicial_complex.bool_vec_from_simplice n (fst \<gamma>)"], safe)
      using simplicial_complex.bool_vec_from_simplice_def apply auto[1]
        apply (metis fst_conv pert simplicial_complex_ast_implies_fst_true)
      using ceros_of_boolean_input_def simplicial_complex.bool_vec_from_simplice_def
        apply fastforce
      using ceros_of_boolean_input_def pert
          simplicial_complex.bool_vec_from_simplice_def
          simplicial_complex_induced_by_monotone_boolean_function_ast_def by force
   have tau: "(snd \<gamma>) \<in> simplicial_complex_induced_by_monotone_boolean_function m (snd f)"
      unfolding bool_fun_ast_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_def
      unfolding simplicial_complex_induced_by_monotone_boolean_function_ast_def
      apply auto
      apply (rule exI [of _ "simplicial_complex.bool_vec_from_simplice m (snd \<gamma>)"], safe)
      using simplicial_complex.bool_vec_from_simplice_def apply auto[1]
        apply (metis snd_conv pert simplicial_complex_ast_implies_snd_true)
      using ceros_of_boolean_input_def simplicial_complex.bool_vec_from_simplice_def
       apply fastforce
      using ceros_of_boolean_input_def pert
        simplicial_complex.bool_vec_from_simplice_def
        simplicial_complex_induced_by_monotone_boolean_function_ast_def by force
    from sigma and tau
    show "\<gamma> \<in> set_ast
        (simplicial_complex_induced_by_monotone_boolean_function n (fst f))
        (simplicial_complex_induced_by_monotone_boolean_function m (snd f))"
      using set_ast_def
      by force
  qed
qed

end


(*
  File:     Solovay_Strassen.thy
  Authors:  Daniel Stüwe, Manuel Eberl

  The Solovay--Strassen primality test.
*)
section \<open>The Solovay--Strassen Test\<close>
theory Solovay_Strassen_Test
imports
  Generalized_Primality_Test
  Euler_Witness
begin

definition solovay_strassen_witness :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "solovay_strassen_witness n a =
     (let x = Jacobi (int a) (int n) in x \<noteq> 0 \<and> [x = int a ^ ((n - 1) div 2)] (mod n))"

definition solovay_strassen :: "nat \<Rightarrow> bool pmf" where
  "solovay_strassen = primality_test solovay_strassen_witness"

lemma prime_imp_solovay_strassen_witness:
  assumes "prime p" "odd p" "a \<in> {2..<p}"
  shows   "solovay_strassen_witness p a"
proof -
  have eq: "Jacobi a p = Legendre a p"
    using prime_p_Jacobi_eq_Legendre assms by simp
  from \<open>prime p\<close> have "coprime p a"
    by (rule prime_imp_coprime) (use assms in auto)

  show ?thesis unfolding solovay_strassen_witness_def Let_def eq
  proof
    from \<open>coprime p a\<close> and \<open>prime p\<close> show "Legendre (int a) (int p) \<noteq> 0"
      by (auto simp: coprime_commute)
  next
    show "[Legendre (int a) (int p) = int a ^ ((p - 1) div 2)] (mod int p)"
      using assms by (intro euler_criterion) auto
  qed
qed

lemma card_solovay_strassen_liars_composite:
  fixes n :: nat
  assumes "\<not>prime n" "n > 2" "odd n"
  shows   "card {a \<in> {2..<n}. solovay_strassen_witness n a} < (n - 2) div 2"
    (is "card ?A < _")
proof -
  interpret euler_witness_context n
    using assms unfolding euler_witness_context_def by simp
  have "card H < (n - 1) div 2"
    by (intro card_euler_liars_cosets_limit(2) assms)
  also from assms have "H = insert 1 ?A"
    by (auto simp: solovay_strassen_witness_def Let_def
                   euler_witness_def H_def Jacobi_eq_0_iff_not_coprime)
  also have "card \<dots> = card ?A + 1"
    by (subst card.insert) auto
  finally show "card ?A < (n - 2) div 2"
    by linarith
qed

interpretation solovay_strassen: good_prob_primality_test solovay_strassen_witness n "1 / 2"
  rewrites "primality_test solovay_strassen_witness = solovay_strassen"
proof -
  show "good_prob_primality_test solovay_strassen_witness n (1 / 2)"
  proof
    fix n :: nat assume "\<not>prime n" "n > 2" "odd n"
    thus "real (card {a. 2 \<le> a \<and> a < n \<and> solovay_strassen_witness n a}) < (1 / 2) * real (n - 2)"
      using card_solovay_strassen_liars_composite[of n] by auto
  qed (use prime_imp_solovay_strassen_witness in auto)
qed (simp_all add: solovay_strassen_def)

end


(*  Title:      HOL/Statespace/DistinctTreeProver.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section {* Distinctness of Names in a Binary Tree \label{sec:DistinctTreeProver}*}

theory DistinctTreeProver
imports Main
begin

text {* A state space manages a set of (abstract) names and assumes
that the names are distinct. The names are stored as parameters of a
locale and distinctness as an assumption. The most common request is
to proof distinctness of two given names. We maintain the names in a
balanced binary tree and formulate a predicate that all nodes in the
tree have distinct names. This setup leads to logarithmic certificates.
*}

subsection {* The Binary Tree *}

datatype 'a tree = Node "'a tree" 'a bool "'a tree" | Tip

text {* The boolean flag in the node marks the content of the node as
deleted, without having to build a new tree. We prefer the boolean
flag to an option type, so that the ML-layer can still use the node
content to facilitate binary search in the tree. The ML code keeps the
nodes sorted using the term order. We do not have to push ordering to
the HOL level. *}

subsection {* Distinctness of Nodes *}

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
  "set_of Tip = {}"
| "set_of (Node l x d r) = (if d then {} else {x}) \<union> set_of l \<union> set_of r"

primrec all_distinct :: "'a tree \<Rightarrow> bool"
where
  "all_distinct Tip = True"
| "all_distinct (Node l x d r) =
    ((d \<or> (x \<notin> set_of l \<and> x \<notin> set_of r)) \<and>
      set_of l \<inter> set_of r = {} \<and>
      all_distinct l \<and> all_distinct r)"

text {* Given a binary tree @{term "t"} for which
@{const all_distinct} holds, given two different nodes contained in the tree,
we want to write a ML function that generates a logarithmic
certificate that the content of the nodes is distinct. We use the
following lemmas to achieve this.  *}

lemma all_distinct_left: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct l"
  by simp

lemma all_distinct_right: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct r"
  by simp

lemma distinct_left: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of l \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_right: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_left_right:
    "all_distinct (Node l z b r) \<Longrightarrow> x \<in> set_of l \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma in_set_root: "x \<in> set_of (Node l x False r)"
  by simp

lemma in_set_left: "y \<in> set_of l \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma in_set_right: "y \<in> set_of r \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma swap_neq: "x \<noteq> y \<Longrightarrow> y \<noteq> x"
  by blast

lemma neq_to_eq_False: "x\<noteq>y \<Longrightarrow> (x=y)\<equiv>False"
  by simp

subsection {* Containment of Trees *}

text {* When deriving a state space from other ones, we create a new
name tree which contains all the names of the parent state spaces and
assume the predicate @{const all_distinct}. We then prove that the new
locale interprets all parent locales. Hence we have to show that the
new distinctness assumption on all names implies the distinctness
assumptions of the parent locales. This proof is implemented in ML. We
do this efficiently by defining a kind of containment check of trees
by ``subtraction''.  We subtract the parent tree from the new tree. If
this succeeds we know that @{const all_distinct} of the new tree
implies @{const all_distinct} of the parent tree.  The resulting
certificate is of the order @{term "n * log(m)"} where @{term "n"} is
the size of the (smaller) parent tree and @{term "m"} the size of the
(bigger) new tree.  *}

primrec delete :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "delete x Tip = None"
| "delete x (Node l y d r) = (case delete x l of
                                Some l' \<Rightarrow>
                                 (case delete x r of
                                    Some r' \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r')
                                  | None \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r))
                               | None \<Rightarrow>
                                  (case delete x r of
                                     Some r' \<Rightarrow> Some (Node l y (d \<or> (x=y)) r')
                                   | None \<Rightarrow> if x=y \<and> \<not>d then Some (Node l y True r)
                                             else None))"

lemma delete_Some_set_of: "delete x t = Some t' \<Longrightarrow> set_of t' \<subseteq> set_of t"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    with Node.hyps
    have l'_l: "set_of l' \<subseteq> set_of l"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with l'_l Some x_l_Some del
      show ?thesis
        by (auto split: split_if_asm)
    next
      case None
      with l'_l Some x_l_Some del
      show ?thesis
        by (fastforce split: split_if_asm)
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with Some x_l_None del
      show ?thesis
        by (fastforce split: split_if_asm)
    next
      case None
      with x_l_None del
      show ?thesis
        by (fastforce split: split_if_asm)
    qed
  qed
qed

lemma delete_Some_all_distinct:
  "delete x t = Some t' \<Longrightarrow> all_distinct t \<Longrightarrow> all_distinct t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  have "all_distinct (Node l y d r)" by fact
  then obtain
    dist_l: "all_distinct l" and
    dist_r: "all_distinct r" and
    d: "d \<or> (y \<notin> set_of l \<and> y \<notin> set_of r)" and
    dist_l_r: "set_of l \<inter> set_of r = {}"
    by auto
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some dist_l]
    have dist_l': "all_distinct l'"
      by simp
    from delete_Some_set_of [OF x_l_Some]
    have l'_l: "set_of l' \<subseteq> set_of l".
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".

      with dist_l' dist_r' l'_l Some x_l_Some del d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with l'_l dist_l'  x_l_Some del d dist_l_r dist_r
      show ?thesis
        by fastforce
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".
      with Some dist_r' x_l_None del dist_l d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with x_l_None del dist_l dist_r d dist_l_r
      show ?thesis
        by (fastforce split: split_if_asm)
    qed
  qed
qed

lemma delete_None_set_of_conv: "delete x t = None = (x \<notin> set_of t)"
proof (induct t)
  case Tip thus ?case by simp
next
  case (Node l y d r)
  thus ?case
    by (auto split: option.splits)
qed

lemma delete_Some_x_set_of:
  "delete x t = Some t' \<Longrightarrow> x \<in> set_of t \<and> x \<notin> set_of t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some]
    obtain x_l: "x \<in> set_of l" "x \<notin> set_of l'"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_l Some x_l_Some del
      show ?thesis
        by (clarsimp split: split_if_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with x_l None x_l_Some del
      show ?thesis
        by (clarsimp split: split_if_asm)
    qed
  next
    case None
    note x_l_None = this
    then have x_notin_l: "x \<notin> set_of l"
      by (simp add: delete_None_set_of_conv)
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_notin_l Some x_l_None del
      show ?thesis
        by (clarsimp split: split_if_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with None x_l_None x_notin_l del
      show ?thesis
        by (clarsimp split: split_if_asm)
    qed
  qed
qed

primrec subtract :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "subtract Tip t = Some t"
| "subtract (Node l x b r) t =
     (case delete x t of
        Some t' \<Rightarrow> (case subtract l t' of
                     Some t'' \<Rightarrow> subtract r t''
                    | None \<Rightarrow> None)
       | None \<Rightarrow> None)"

lemma subtract_Some_set_of_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x b r)
  have sub: "subtract (Node l x b r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''" .
        with Some sub_l_Some del_x_Some sub t2''_t2' t2'_t2
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_set_of:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_None_set_of_conv [of x t\<^sub>2] Some
    have x_t2: "x \<in> set_of t\<^sub>2"
      by simp
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have r_t\<^sub>2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from Some sub_l_Some del_x_Some sub r_t\<^sub>2'' l_t2' t2'_t2 t2''_t2' x_t2
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2]
    have dist_t2': "all_distinct t\<^sub>2'" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_t2''': "all_distinct t\<^sub>2'''" .
        from Some sub_l_Some del_x_Some sub
             dist_t2'''
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_dist_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<inter> set_of t = {}"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some ]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}" .
        from subtract_Some_set_of_res [OF Some]
        have t2'''_t2'': "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''".

        from Some sub_l_Some del_x_Some sub t2'''_t2'' dist_l_t2'' dist_r_t2'''
             t2''_t2' t2'_t2 x_not_t2'
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t\<^sub>1"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2 ]
    have dist_t2': "all_distinct t\<^sub>2'" .
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp

    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2' ]
      have dist_l: "all_distinct l" .
      from subtract_Some_all_distinct_res [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      from subtract_Some_set_of [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_dist_res [OF Some]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_r: "all_distinct r" .
        from subtract_Some_set_of [OF Some]
        have r_t2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from subtract_Some_dist_res [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}".

        from dist_l dist_r Some sub_l_Some del_x_Some r_t2'' l_t2' x_t2 x_not_t2'
             t2''_t2' dist_l_t2'' dist_r_t2'''
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma delete_left:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_l: "delete x l = Some l'"
  shows "delete x (Node l y d r) = Some (Node l' y d r)"
proof -
  from delete_Some_x_set_of [OF del_l]
  obtain x: "x \<in> set_of l"
    by simp
  with dist
  have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_l dist
    by (auto split: option.splits)
qed

lemma delete_right:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_r: "delete x r = Some r'"
  shows "delete x (Node l y d r) = Some (Node l y d r')"
proof -
  from delete_Some_x_set_of [OF del_r]
  obtain x: "x \<in> set_of r"
    by simp
  with dist
  have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_r dist
    by (auto split: option.splits)
qed

lemma delete_root:
  assumes dist: "all_distinct (Node l x False r)"
  shows "delete x (Node l x False r) = Some (Node l x True r)"
proof -
  from dist have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)
  moreover
  from dist have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)
  ultimately show ?thesis
    using dist
       by (auto split: option.splits)
qed

lemma subtract_Node:
 assumes del: "delete x t = Some t'"
 assumes sub_l: "subtract l t' = Some t''"
 assumes sub_r: "subtract r t'' = Some t'''"
 shows "subtract (Node l x False r) t = Some t'''"
using del sub_l sub_r
by simp

lemma subtract_Tip: "subtract Tip t = Some t"
  by simp

text {* Now we have all the theorems in place that are needed for the
certificate generating ML functions. *}

ML_file "distinct_tree_prover.ML"

end


(* Title: List_Bits.thy
  Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Exclusive or on lists\<close>

theory List_Bits imports Misc_CryptHOL begin

definition xor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a :: {uminus,inf,sup}" (infixr "\<oplus>" 67)
where "x \<oplus> y = inf (sup x y) (- (inf x y))"

lemma xor_commute:
  fixes x y :: "'a :: {semilattice_sup,semilattice_inf,uminus}"
  shows "x \<oplus> y = y \<oplus> x"
by(simp add: xor_def sup.commute inf.commute)

lemma xor_assoc:
  fixes x y :: "'a :: boolean_algebra"
  shows "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
by(simp add: xor_def inf_sup_aci inf_sup_distrib1 inf_sup_distrib2)

lemma xor_left_commute:
  fixes x y :: "'a :: boolean_algebra"
  shows "x \<oplus> (y \<oplus> z) = y \<oplus> (x \<oplus> z)"
by (metis xor_assoc xor_commute)

lemma xor_inverse [simp]:
  fixes x :: "'a :: boolean_algebra"
  shows "x \<oplus> x = bot"
by(simp add: xor_def)

lemma xor_left_inverse [simp]:
  fixes x :: "'a :: boolean_algebra"
  shows "x \<oplus> x \<oplus> y = y"
by(metis xor_left_commute xor_inverse xor_bot)

lemmas xor_ac = xor_assoc xor_commute xor_left_commute

definition xor_list :: "'a :: {uminus,inf,sup} list \<Rightarrow> 'a list \<Rightarrow> 'a list"  (infixr "[\<oplus>]" 67)
where "xor_list xs ys = map (case_prod (\<oplus>)) (zip xs ys)"

lemma xor_list_unfold:
  "xs [\<oplus>] ys = (case xs of [] \<Rightarrow> [] | x # xs' \<Rightarrow> (case ys of [] \<Rightarrow> [] | y # ys' \<Rightarrow> x \<oplus> y # xs' [\<oplus>] ys'))"
by(simp add: xor_list_def split: list.split)

lemma xor_list_commute: fixes xs ys :: "'a :: {semilattice_sup,semilattice_inf,uminus} list"
  shows "xs [\<oplus>] ys = ys [\<oplus>] xs"
unfolding xor_list_def by(subst zip_commute)(auto simp add: split_def xor_commute)

lemma xor_list_assoc [simp]:
  fixes xs ys :: "'a :: boolean_algebra list"
  shows "(xs [\<oplus>] ys) [\<oplus>] zs = xs [\<oplus>] (ys [\<oplus>] zs)"
unfolding xor_list_def zip_map1 zip_map2
apply(subst (2) zip_commute)
apply(subst zip_left_commute)
apply(subst (2) zip_commute)
apply(auto simp add: zip_map2 split_def xor_assoc)
done

lemma xor_list_left_commute:
  fixes xs ys zs :: "'a :: boolean_algebra list"
  shows "xs [\<oplus>] (ys [\<oplus>] zs) = ys [\<oplus>] (xs [\<oplus>] zs)"
by(metis xor_list_assoc xor_list_commute)

lemmas xor_list_ac = xor_list_assoc xor_list_commute xor_list_left_commute

lemma xor_list_inverse [simp]:
  fixes xs :: "'a :: boolean_algebra list"
  shows "xs [\<oplus>] xs = replicate (length xs) bot"
by(simp add: xor_list_def zip_same_conv_map o_def map_replicate_const)

lemma xor_replicate_bot_right [simp]:
  fixes xs :: "'a :: boolean_algebra list"
  shows "\<lbrakk> length xs \<le> n; x = bot \<rbrakk> \<Longrightarrow> xs [\<oplus>] replicate n x = xs"
by(simp add: xor_list_def zip_replicate2 o_def)

lemma xor_replicate_bot_left [simp]:
  fixes xs :: "'a :: boolean_algebra list"
  shows "\<lbrakk> length xs \<le> n; x = bot \<rbrakk> \<Longrightarrow> replicate n x [\<oplus>] xs = xs"
by(simp add: xor_list_commute)

lemma xor_list_left_inverse [simp]:
  fixes xs :: "'a :: boolean_algebra list"
  shows "length ys \<le> length xs \<Longrightarrow> xs [\<oplus>] (xs [\<oplus>] ys) = ys"
by(subst xor_list_assoc[symmetric])(simp)

lemma length_xor_list [simp]: "length (xor_list xs ys) = min (length xs) (length ys)"
by(simp add: xor_list_def)

lemma inj_on_xor_list_nlists [simp]:
  fixes xs :: "'a :: boolean_algebra list"
  shows "n \<le> length xs \<Longrightarrow> inj_on (xor_list xs) (nlists UNIV n)"
apply(clarsimp simp add: inj_on_def in_nlists_UNIV)
using xor_list_left_inverse by fastforce

lemma one_time_pad:
  fixes xs :: "_ :: boolean_algebra list"
  shows "length xs \<ge> n \<Longrightarrow> map_spmf (xor_list xs) (spmf_of_set (nlists UNIV n)) = spmf_of_set (nlists UNIV n)"
by(auto 4 3 simp add: in_nlists_UNIV intro: xor_list_left_inverse[symmetric] rev_image_eqI intro!: arg_cong[where f=spmf_of_set])

end


(*  Title:       Metric and semimetric spaces
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

section "Metric and semimetric spaces"

theory Metric
imports "HOL-Analysis.Multivariate_Analysis"
begin

locale semimetric =
  fixes dist :: "'p \<Rightarrow> 'p \<Rightarrow> real"
  assumes nonneg [simp]: "dist x y \<ge> 0"
  and eq_0 [simp]: "dist x y = 0 \<longleftrightarrow> x = y"
  and symm: "dist x y = dist y x"
begin
  lemma refl [simp]: "dist x x = 0"
    by simp
end

locale metric =
  fixes dist :: "'p \<Rightarrow> 'p \<Rightarrow> real"
  assumes [simp]: "dist x y = 0 \<longleftrightarrow> x = y"
  and triangle: "dist x z \<le> dist y x + dist y z"

sublocale metric < semimetric
proof
  { fix w
    have "dist w w = 0" by simp }
  note [simp] = this
  fix x y
  show "0 \<le> dist x y"
  proof -
    from triangle [of y y x] show "0 \<le> dist x y" by simp
  qed
  show "dist x y = 0 \<longleftrightarrow> x = y" by simp
  show "dist x y = dist y x"
  proof -
    { fix w z
      have "dist w z \<le> dist z w"
      proof -
        from triangle [of w z z] show "dist w z \<le> dist z w" by simp
      qed }
    hence "dist x y \<le> dist y x" and "dist y x \<le> dist x y" by simp+
    thus "dist x y = dist y x" by simp
  qed
qed

definition norm_dist :: "('a::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> real" where
[simp]: "norm_dist x y \<equiv> norm (x - y)"

interpretation norm_metric: metric norm_dist
proof
  fix x y
  show "norm_dist x y = 0 \<longleftrightarrow> x = y" by simp
  fix z
  from norm_triangle_ineq [of "x - y" "y - z"] have
    "norm (x - z) \<le> norm (x - y) + norm (y - z)" by simp
  with norm_minus_commute [of x y] show
    "norm_dist x z \<le> norm_dist y x + norm_dist y z" by simp
qed

end


theory Scratch
  imports Main
begin

(*
  Add
*)

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n" |
  "add (Suc m) n = Suc (add m n)"

lemma [simp]: "add x (Suc y) = Suc (add x y)"
  apply(induction x)
   apply(auto)
  done

lemma add_commut: "add x y = add y x"
  apply(induction x)
   apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
  "double 0 = 0" |
  "double (Suc n) = Suc (Suc (double n))"

lemma double_to_add: "double n = add n n"
  apply(induction n)
  apply(auto)
  done

(*
  Count
*)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count el [] = 0" |
  "count el (x#xs) = (if el = x then Suc (count el xs) else count el xs)"

lemma count_le_length: "count el xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

(*
  Snoc
*)

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] el = [el]" |
  "snoc (x#xs) el = x#(snoc xs el)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []" |
  "reverse (x#xs) = snoc (reverse xs) x"

lemma [simp]: "reverse (snoc xs el) = el # (reverse xs)"
  apply(induction xs)
   apply(auto)
  done

lemma reverse_reverse: "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto)
  done

(*
  Sum up to
*)

fun sum_upto :: "nat \<Rightarrow> nat" where
  "sum_upto 0 = 0" |
  "sum_upto (Suc n) = add (Suc n) (sum_upto n)"

lemma [simp]: "add x y = x + y"
  apply(induction x)
  apply(auto)
  done

lemma sum_upto_formula: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
  apply(auto)
  done

end