theory Chapter12_2
imports "HOL-IMP.Hoare_Examples"
begin

text\<open>
\section*{Chapter 12}

\setcounter{exercise}{1}
\<close>

lemma "\<not>(\<forall>P x a. \<Turnstile> {P} x ::= a {\<lambda>s. P (s[a/x])})"
proof (intro notI)
  assume "\<forall>P x a. \<Turnstile> {P} x ::= a {\<lambda>s. P (s[a/x])}"
  then have h: "\<And>P x a s t. \<lbrakk>P s; (x ::= a, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P (t[a/x])" unfolding hoare_valid_def by blast
  let ?x = "''x''"
  let ?a = "Plus (N 1) (V ?x)"
  let ?P = "(\<lambda>s. s ''x'' = 0) :: assn"
  let ?s = "<> :: state"
  let ?t = "<''x'' := 1> :: state"
  let ?tt = "<''x'' := 2> :: state"
  let ?c = "?x ::= ?a"
  have h1: "?P ?s" unfolding null_state_def by simp
  moreover from big_step.Assign [of ?x ?a ?s] have h2: "(''x'' ::= ?a, <>) \<Rightarrow> ?t" unfolding null_state_def by simp
  from h [of ?P ?s, OF h1 h2] show False by simp
qed

text\<open>
\exercise
Define @{text bsubst} and prove the Substitution Lemma:
\<close>

fun asubst :: "aexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> aexp" where
  "asubst (N n) _ _ = N n" |
  "asubst (V v) a x = (if v = x then a else (V v))" |
  "asubst (Plus a\<^sub>1 a\<^sub>2) a x = Plus (asubst a\<^sub>1 a x) (asubst a\<^sub>2 a x)"

fun bsubst :: "bexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> bexp" where
  "bsubst (Bc v) _ _ = Bc v" |
  "bsubst (Not b) a x = Not (bsubst b a x)" |
  "bsubst (And b\<^sub>1 b\<^sub>2) a x = And (bsubst b\<^sub>1 a x) (bsubst b\<^sub>2 a x)" |
  "bsubst (Less a\<^sub>1 a\<^sub>2) a x = Less (asubst a\<^sub>1 a x) (asubst a\<^sub>2 a x)"

lemma asubstitution: "aval (asubst a a' x) s = aval a (s[a'/x])"
  by (induct a) simp_all

lemma bsubstitution: "bval (bsubst b a x) s = bval b (s[a/x])"
proof (induct b)
  case (Less x1a x2a)
  have "bval (bsubst (Less x1a x2a) a x) s \<longleftrightarrow> aval (asubst x1a a x) s < aval (asubst x2a a x) s" by simp
  also from asubstitution have "\<dots> \<longleftrightarrow> aval x1a (s[a/x]) < aval x2a (s[a/x])" by simp
  also have "\<dots> = bval (Less x1a x2a) (s[a/x])" by simp
  finally show ?case .
qed simp_all

text\<open>
This may require a similar definition and proof for @{typ aexp}.
\endexercise

\exercise
Define a command @{text cmax} that stores the maximum of the values of the IMP variables
@{text "x"} and @{text "y"} in the IMP variable @{text "z"} and prove that
@{text cmax} satisfies its specification:
\<close>

abbreviation cmax :: com where
  "cmax \<equiv> IF Less (V ''x'') (V ''y'') THEN ''z'' ::= V ''y'' ELSE ''z'' ::= V ''x''"

lemma "\<turnstile> {\<lambda>s. True} cmax {\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')}"
proof (rule If; rule Assign'; intro allI impI; elim conjE)
  fix s
  have "(s[V ''y''/''z'']) ''z'' = s ''y''" by simp
  also assume "bval (Less (V ''x'') (V ''y'')) s"
  then have "s ''x'' < s ''y''" by simp
  then have "s ''y'' = max (s ''x'') (s ''y'')" by simp
  also have "\<dots> = max ((s[V ''y''/''z'']) ''x'') ((s[V ''y''/''z'']) ''y'')" by simp
  finally show "(s[V ''y''/''z'']) ''z'' = max ((s[V ''y''/''z'']) ''x'') ((s[V ''y''/''z'']) ''y'')" .
next
  fix s
  have "(s[V ''x''/''z'']) ''z'' = s ''x''" by simp
  also assume "\<not>bval (Less (V ''x'') (V ''y'')) s"
  then have "\<not>s ''x'' < s ''y''" by simp
  then have "s ''x'' = max (s ''x'') (s ''y'')" by simp
  also have "\<dots> = max ((s[V ''x''/''z'']) ''x'') ((s[V ''x''/''z'']) ''y'')" by simp
  finally show "(s[V ''x''/''z'']) ''z'' = max ((s[V ''x''/''z'']) ''x'') ((s[V ''x''/''z'']) ''y'')" .
qed

text\<open>
Function @{const max} is the predefined maximum function.
Proofs about @{const max} are often automatic when simplifying with @{thm[source] max_def}.
\endexercise

\exercise\label{exe:Hoare:sumeq}
Define an equality operation for arithmetic expressions
\<close>

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = (And (Not (Less a1 a2)) (Not (Less a2 a1)))"

text\<open> such that \<close>

lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  unfolding Eq_def by auto

text\<open> Prove the following variant of the summation command correct: \<close>

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''y'' ::= N 0;;
     WHILE Not(Eq (V ''x'') (N 0))
     DO (''y'' ::= Plus (V ''y'') (V ''x'');;
           ''x'' ::= Plus (V ''x'') (N (-1)))
     {\<lambda>s. s ''y'' = sum i}"
proof (intro Seq While' allI impI; (elim conjE)?)
  let ?ax = "Plus (V ''x'') (N (- 1))"
  let ?cx = "''x'' ::= ?ax"
  let ?ay = "Plus (V ''y'') (V ''x'')"
  let ?cy = "''y'' ::= ?ay"
  let ?bx = "(bexp.Not (Eq (V ''x'') (N 0)))"
  let ?P = "\<lambda>s. s ''y'' = sum i - sum (s ''x'') \<and> 0 \<le> s ''x''"
  let ?PS = "\<lambda>s. ?P (s[?ax/''x''])"
  let ?Q = "\<lambda>s. s ''y'' = sum i - sum (s ''x'' - 1) \<and> 0 \<le> s ''x'' - 1"
  let ?Pw = "\<lambda>s. ?P s \<and> bval ?bx s"
  let ?HI = "\<lambda>s. s ''x'' = i \<and> 0 \<le> i"
  let ?yi = "N 0"
  let ?cyi = "''y'' ::= ?yi"
  {
    fix s
    assume HP: "?P s"
    assume "\<not>bval ?bx s"
    then have "s ''x'' = 0" by simp
    with HP show "s ''y'' = sum i" by simp
  next
    have "\<turnstile> {?PS} ?cx {?P}" by (rule Assign)
    then show "\<turnstile> {?Q} ?cx {?P}" by simp
  next
    have "\<forall>s. ?Pw s \<longrightarrow> ?Q (s[?ay/''y''])"
    proof (intro allI impI, elim conjE)
      fix s
      assume "bval (bexp.Not (Eq (V ''x'') (N 0))) s"
      then have Hx0: "s ''x'' \<noteq> 0" by simp
      have "(s[?ay/''y'']) ''y'' = s ''y'' + s ''x''" by simp
      also assume "s ''y'' = sum i - sum (s ''x'')"
      then have "s ''y'' + s ''x'' = sum i - sum (s ''x'') + s ''x''" by simp
      also assume Hxp: "0 \<le> s ''x''"
      with Hx0 have "sum i - sum (s ''x'') + s ''x'' = sum i - sum (s ''x'' - 1)" by auto
      also have "\<dots> = sum i - sum ((s[?ay/''y'']) ''x'' - 1)" by simp
      finally have "(s[?ay/''y'']) ''y'' = sum i - sum ((s[?ay/''y'']) ''x'' - 1)" (is ?H1) .
      moreover from Hxp Hx0 have "0 \<le> (s[?ay/''y'']) ''x'' - 1" (is ?H2) by simp
      ultimately show "?H1 \<and> ?H2" by blast
    qed
    from Assign' [OF this] show "\<turnstile> {?Pw} ?cy {?Q}" .
  next
    have "\<forall>s. ?HI s \<longrightarrow> ?P (s[?yi/''y''])"
    proof (intro allI impI, elim conjE)
      fix s
      assume Hxi: "s ''x'' = i"
      then have "(s[N 0/''y'']) ''y'' = sum i - sum ((s[?yi/''y'']) ''x'')" (is ?H1) by simp
      moreover assume Hi: "0 \<le> i"
      with Hxi have "0 \<le> (s[N 0/''y'']) ''x''" (is ?H2) by simp
      ultimately show "?H1 \<and> ?H2" by blast
    qed
    from Assign' [OF this] show "\<turnstile> {?HI} ?cyi {?P}" .
  }
qed

text\<open>
\endexercise

\exercise
Prove that the following command computes @{prop"y - x"} if @{prop"(0::nat) \<le> x"}:
\<close>

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
     WHILE Less (N 0) (V ''x'')
     DO (''x'' ::= Plus (V ''x'') (N (-1));; ''y'' ::= Plus (V ''y'') (N (-1)))
     {\<lambda>t. t ''y'' = y - x}"
proof (rule strengthen_pre; intro While' Seq allI impI; (elim conjE)?)
  let ?P = "\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x''"
  let ?Q = "\<lambda>s. s ''y'' - 1 - s ''x'' = y - x \<and> 0 \<le> s ''x''"
  let ?b = "Less (N 0) (V ''x'')"
  let ?Pw = "\<lambda>s. ?P s \<and> bval ?b s"
  let ?ay = "Plus (V ''y'') (N (- 1))"
  let ?ax = "Plus (V ''x'') (N (- 1))"
  let ?cy = "''y'' ::= ?ay"
  let ?cx = "''x'' ::= ?ax"
  {
    fix s
    assume "\<not> bval (Less (N 0) (V ''x'')) s"
    then have "s ''x'' \<le> 0" by simp
    moreover assume "?P s"
    ultimately show "s ''y'' = y - x" by simp
  next
    have "\<turnstile> {\<lambda>s. ?P (s[?ay/''y''])} ?cy {?P}" by (rule Assign)
    then show "\<turnstile> {?Q} ?cy {?P}" by simp
  next
    have Hsle: "\<And>s::state. 0 \<le> s ''x'' - 1 \<longleftrightarrow> 0 \<le> s ''x'' \<and> bval ?b s" by auto
    have "\<turnstile> {\<lambda>s. ?Q (s[?ax/''x''])} ?cx {?Q}" by (rule Assign)
    then have "\<turnstile> {\<lambda>s. s ''y'' - s ''x'' = y - x \<and> 0 \<le> s ''x'' - 1} ?cx {?Q}" by simp
    with Hsle show "\<turnstile> {\<lambda>s. ?P s \<and> bval ?b s} ?cx {?Q}" by simp
  next
    fix s
    assume "s ''x'' = x" "s ''y'' = y" "0 \<le> x"
    then show "?P s" by simp
  }
qed

text\<open>
\endexercise

\exercise\label{exe:Hoare:mult}
Define and verify a command @{text cmult} that stores the product of
@{text "x"} and @{text "y"} in @{text "z"} assuming @{prop"(0::int)\<le>y"}:
\<close>

abbreviation cmult :: com where
  "cmult \<equiv> ''z'' ::= N 0;;
    WHILE Less (N 0) (V ''y'') DO (''y'' ::= (Plus (V ''y'') (N (-1)));; ''z'' ::= (Plus (V ''z'') (V ''x'')))"

lemma
  "\<turnstile> {\<lambda>s.  s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} cmult {\<lambda>t. t ''z'' = x*y}"
proof (intro Seq While' allI impI; (elim conjE)?)
  let ?I = "\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y"
  let ?P = "\<lambda>s. s ''x'' = x \<and> s ''z'' = s ''x'' * (y - s ''y'') \<and> 0 \<le> s ''y''"
  let ?Q = "\<lambda>s. s ''x'' = x \<and> s ''z'' = s ''x'' * (y - s ''y'' - 1) \<and> 0 \<le> s ''y''"
  let ?b = "Less (N 0) (V ''y'')"
  let ?az = "Plus (V ''z'') (V ''x'')"
  let ?cz = "''z'' ::= ?az"
  let ?ay = "Plus (V ''y'') (N (- 1))"
  let ?cy = "''y'' ::= ?ay"
  {
    show "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} ''z'' ::= N 0 {?P}" by (auto simp add: Assign')
  next
    fix s
    assume "?P s" "\<not>bval ?b s"
    then show "s ''z'' = x * y" by auto
  next
    have Heq: "\<And>s. s ''z'' + s ''x'' = s ''x'' * (y - s ''y'') \<longleftrightarrow> s ''z'' = s ''x'' * (y - s ''y'' - 1)" by (auto simp add: int_distrib(4))
    have "\<turnstile> {\<lambda>s. ?P (s[?az/''z''])} ?cz {?P}" by (rule Assign)
    with Heq show "\<turnstile> {?Q} ?cz {?P}" by simp
  next
    have Hsle: "\<And>s::state. 0 \<le> s ''y'' - 1 \<longleftrightarrow> 0 \<le> s ''y'' \<and> bval ?b s" by auto
    have "\<turnstile> {\<lambda>s. ?Q (s[?ay/''y''])} ?cy {?Q}" by (rule Assign)
    with Hsle show "\<turnstile> {\<lambda>s. ?P s \<and> bval ?b s} ?cy {?Q}" by simp
  }
qed

text\<open>
You may have to simplify with @{thm[source] algebra_simps} to deal with ``@{text"*"}''.
\endexercise

\exercise\label{exe:Hoare:sqrt}
The following command computes an integer approximation @{text r} of the square root
of @{text "i \<ge> 0"}, i.e.\ @{text"r\<^sup>2 \<le> i < (r+1)\<^sup>2"}. Prove
\<close>

lemma
  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''r'' ::= N 0;; ''r2'' ::= N 1;;
     WHILE (Not (Less (V ''x'') (V ''r2'')))
     DO (''r'' ::= Plus (V ''r'') (N 1);;
            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
proof (intro Seq While' allI impI conjI; (elim conjE)?)
  let ?I = "\<lambda>s. s ''x'' = i \<and> 0 \<le> i"
  let ?II = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> 1 = (s ''r'' + 1)\<^sup>2"
  let ?P = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'' + 1)\<^sup>2"
  let ?Q = "\<lambda>s. s ''x'' = i \<and> (s ''r'')\<^sup>2 \<le> s ''x'' \<and> s ''r2'' = (s ''r'')\<^sup>2"
  let ?b = "Not (Less (V ''x'') (V ''r2''))"
  let ?ar = "Plus (V ''r'') (N 1)"
  let ?ar2 = "Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1))"
  {
    have "\<turnstile> {\<lambda>s. ?P (s[N 1/''r2''])} ''r2'' ::= N 1 {?P}" by (rule Assign)
    then show "\<turnstile> {?II} ''r2'' ::= N 1 {?P}" by simp
  next
    have "\<forall>s. ?I s \<longrightarrow> ?II (s[N 0/''r''])" by auto
    then show "\<turnstile> {?I} ''r'' ::= N 0 {?II}" by (rule Assign')
  next
    fix s
    assume "?P s"
    then have H: "s ''x'' = i" "(s ''r'')\<^sup>2 \<le> s ''x''" "s ''r2'' = (s ''r'' + 1)\<^sup>2" by blast+
    moreover assume "\<not> bval ?b s"
    then have "s ''x'' < s ''r2''" by auto
    ultimately show "(s ''r'')\<^sup>2 \<le> i" "i < (s ''r'' + 1)\<^sup>2" by auto
  next
    have Heqv: "\<And>x::int. (x + 1)\<^sup>2 = x\<^sup>2 + x + x + 1" by (simp add: power2_sum)
    have "\<turnstile> {\<lambda>s. ?P (s[?ar2/''r2''])} ''r2'' ::= ?ar2 {?P}" by (rule Assign)
    with Heqv show "\<turnstile> {?Q} ''r2'' ::= ?ar2 {?P}" by simp
  next
    have "\<forall>s. (\<lambda>s. ?P s \<and> bval ?b s) s \<longrightarrow> ?Q (s[?ar/''r''])" by auto
    then show "\<turnstile> {\<lambda>s. ?P s \<and> bval ?b s} ''r'' ::= ?ar {?Q}" by (rule Assign')
  }
qed

text\<open>
Figure out how @{text r2} is related to @{text r} before
formulating the invariant.
The proof may require simplification with @{thm[source] algebra_simps}
and @{thm[source] power2_eq_square}.
\endexercise

\exercise
Prove by induction:
\<close>

lemma "\<turnstile> {P} c {\<lambda>s. True}"
proof (induct c arbitrary: P)
  case SKIP
  then show ?case by (rule weaken_post, auto)
next
  case (Assign x1 x2)
  then show ?case by (rule Assign', auto)
next
  case (Seq c1 c2)
  then show ?case by (rule hoare.Seq)
next
  case (If x1 c1 c2)
  then show ?case by (rule hoare.If)
next
  case (While x1 c)
  show ?case by (rule strengthen_pre [of _ "\<lambda>_. True"], simp, rule While', auto simp add: While)
qed

text\<open>
\endexercise

\exercise\label{exe:fwdassign}
Design and prove correct a forward assignment rule of the form
\ \mbox{@{text"\<turnstile> {P} x ::= a {?}"}} \
where @{text"?"} is some suitable postcondition that depends on @{text P},
@{text x} and @{text a}. Hint: @{text"?"} may need @{text"\<exists>"}.
\<close>

lemma "\<turnstile> {P} x ::= a {\<lambda>s. \<exists> x'. P (s(x := x')) \<and> s x = aval a (s(x := x'))}"
proof (rule Assign', intro allI impI)
  fix s :: state
  let ?x' = "s x"
  assume "P s"
  then have "P ((s[a/x])(x := ?x'))" by simp
  moreover have "(s[a/x]) x = aval a ((s[a/x])(x := ?x'))" by simp
  ultimately show "\<exists>x'. P ((s[a/x])(x := x')) \<and> (s[a/x]) x = aval a ((s[a/x])(x := x'))" by blast
qed

text\<open>
(In case you wonder if your @{text Questionmark} is strong enough: see Exercise~\ref{exe:sp})
\endexercise
\<close>
end


(*  Title:      Sequents/LK/Quantifiers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Classical sequent calculus: examples with quantifiers.
*)

theory Quantifiers
imports "../LK"
begin

lemma "\<turnstile> (\<forall>x. P) \<longleftrightarrow> P"
  by fast

lemma "\<turnstile> (\<forall>x y. P(x,y)) \<longleftrightarrow> (\<forall>y x. P(x,y))"
  by fast

lemma "\<forall>u. P(u), \<forall>v. Q(v) \<turnstile> \<forall>u v. P(u) \<and> Q(v)"
  by fast

text "Permutation of existential quantifier."

lemma "\<turnstile> (\<exists>x y. P(x,y)) \<longleftrightarrow> (\<exists>y x. P(x,y))"
  by fast

lemma "\<turnstile> (\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> (\<forall>x. P(x)) \<and> (\<forall>x. Q(x))"
  by fast

(*Converse is invalid*)
lemma "\<turnstile> (\<forall>x. P(x)) \<or> (\<forall>x. Q(x)) \<longrightarrow> (\<forall>x. P(x) \<or> Q(x))"
  by fast

text "Pushing \<forall>into an implication."

lemma "\<turnstile> (\<forall>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x. Q(x)))"
  by fast

lemma "\<turnstile> (\<forall>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> Q)"
  by fast

lemma "\<turnstile> (\<exists>x. P)  \<longleftrightarrow>  P"
  by fast

text "Distribution of \<exists>over disjunction."

lemma "\<turnstile> (\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> (\<exists>x. P(x)) \<or> (\<exists>x. Q(x))"
  by fast

(*Converse is invalid*)
lemma "\<turnstile> (\<exists>x. P(x) \<and> Q(x)) \<longrightarrow> (\<exists>x. P(x)) \<and> (\<exists>x. Q(x))"
  by fast

text "Harder examples: classical theorems."

lemma "\<turnstile> (\<exists>x. P \<longrightarrow> Q(x)) \<longleftrightarrow> (P \<longrightarrow> (\<exists>x. Q(x)))"
  by fast

lemma "\<turnstile> (\<exists>x. P(x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<longrightarrow> Q"
  by fast

lemma "\<turnstile> (\<forall>x. P(x)) \<or> Q \<longleftrightarrow> (\<forall>x. P(x) \<or> Q)"
  by fast

text "Basic test of quantifier reasoning"

lemma "\<turnstile> (\<exists>y. \<forall>x. Q(x,y)) \<longrightarrow> (\<forall>x. \<exists>y. Q(x,y))"
  by fast

lemma "\<turnstile> (\<forall>x. Q(x)) \<longrightarrow> (\<exists>x. Q(x))"
  by fast

text "The following are invalid!"

(*INVALID*)
lemma "\<turnstile> (\<forall>x. \<exists>y. Q(x,y)) \<longrightarrow> (\<exists>y. \<forall>x. Q(x,y))"
  apply fast?
  apply (rule _)
  oops

(*INVALID*)
lemma "\<turnstile> (\<exists>x. Q(x)) \<longrightarrow> (\<forall>x. Q(x))"
  apply fast?
  apply (rule _)
  oops

(*INVALID*)
schematic_goal "\<turnstile> P(?a) \<longrightarrow> (\<forall>x. P(x))"
  apply fast?
  apply (rule _)
  oops

(*INVALID*)
schematic_goal "\<turnstile> (P(?a) \<longrightarrow> (\<forall>x. Q(x))) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> Q(x))"
  apply fast?
  apply (rule _)
  oops

text "Back to things that are provable..."

lemma "\<turnstile> (\<forall>x. P(x) \<longrightarrow> Q(x)) \<and> (\<exists>x. P(x)) \<longrightarrow> (\<exists>x. Q(x))"
  by fast

(*An example of why exR should be delayed as long as possible*)
lemma "\<turnstile> (P \<longrightarrow> (\<exists>x. Q(x))) \<and> P \<longrightarrow> (\<exists>x. Q(x))"
  by fast

text "Solving for a Var"

schematic_goal "\<turnstile> (\<forall>x. P(x) \<longrightarrow> Q(f(x))) \<and> (\<forall>x. Q(x) \<longrightarrow> R(g(x))) \<and> P(d) \<longrightarrow> R(?a)"
  by fast

text "Principia Mathematica *11.53"

lemma "\<turnstile> (\<forall>x y. P(x) \<longrightarrow> Q(y)) \<longleftrightarrow> ((\<exists>x. P(x)) \<longrightarrow> (\<forall>y. Q(y)))"
  by fast

text "Principia Mathematica *11.55"

lemma "\<turnstile> (\<exists>x y. P(x) \<and> Q(x,y)) \<longleftrightarrow> (\<exists>x. P(x) \<and> (\<exists>y. Q(x,y)))"
  by fast

text "Principia Mathematica *11.61"

lemma "\<turnstile> (\<exists>y. \<forall>x. P(x) \<longrightarrow> Q(x,y)) \<longrightarrow> (\<forall>x. P(x) \<longrightarrow> (\<exists>y. Q(x,y)))"
  by fast

(*21 August 88: loaded in 45.7 secs*)
(*18 September 2005: loaded in 0.114 secs*)

end


(*  Title:       Executable Matrix Operations on Matrices of Arbitrary Dimensions
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

(*
Copyright 2013 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
theory Ordered_Semiring
imports
  "HOL-Algebra.Ring"
  "Abstract-Rewriting.SN_Orders"
begin

record 'a ordered_semiring = "'a ring" +
  geq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succeq>\<index>" 50)
  gt :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<succ>\<index>" 50)
  max :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("Max\<index>")

lemmas ordered_semiring_record_simps = ring_record_simps ordered_semiring.simps

locale ordered_semiring = semiring +
  assumes compat: "\<lbrakk>s \<succeq> (t :: 'a); t \<succ> u; s \<in> carrier R; t \<in> carrier R; u \<in> carrier R\<rbrakk> \<Longrightarrow> s \<succ> u"
  and compat2: "\<lbrakk>s \<succ> (t :: 'a); t \<succeq> u; s \<in> carrier R ; t \<in> carrier R; u \<in> carrier R\<rbrakk> \<Longrightarrow> s \<succ> u"
  and plus_left_mono: "\<lbrakk>x \<succeq> y; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<oplus> z \<succeq> y \<oplus> z"
  and times_left_mono: "\<lbrakk>z \<succeq> \<zero>; x \<succeq> y; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> z \<succeq> y \<otimes> z"
  and times_right_mono: "\<lbrakk>x \<succeq> \<zero>; y \<succeq> z; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<otimes> y \<succeq> x \<otimes> z"
  and geq_refl: "x \<in> carrier R \<Longrightarrow> x \<succeq> x"
  and geq_trans[trans]: "\<lbrakk>x \<succeq> y; y \<succeq> z; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<succeq> z"
  and gt_trans[trans]: "\<lbrakk>x \<succ> y; y \<succ> z; x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk> \<Longrightarrow> x \<succ> z"
  and gt_imp_ge: "x \<succ> y \<Longrightarrow> x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> x \<succeq> y"
  and max_comm: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> Max x y = Max y x"
  and max_ge: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> Max x y \<succeq> x"
  and max_id: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> x \<succeq> y \<Longrightarrow> Max x y = x"
  and max_mono: "x \<succeq> y \<Longrightarrow> x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> z \<in> carrier R \<Longrightarrow> Max z x \<succeq> Max z y"
  and wf_max[simp, intro]: "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> Max x y \<in> carrier R"
  and one_geq_zero: "\<one> \<succeq> \<zero>"
begin
lemma max_ge_right: assumes x: "x \<in> carrier R" and y: "y \<in> carrier R" shows "Max x y \<succeq> y"
  by (unfold max_comm[OF x y], rule max_ge[OF y x])

lemma wf_max0: "x \<in> carrier R \<Longrightarrow> Max \<zero> x \<in> carrier R" using wf_max[of \<zero> x] by auto

lemma max0_id_pos: assumes x: "x \<succeq> \<zero>" and wf: "x \<in> carrier R"
  shows "Max \<zero> x = x" unfolding max_comm[OF zero_closed wf] by (rule max_id[OF wf zero_closed x])
end
hide_const (open) gt geq max

subsection \<open>A connection between class based semirings and set based semirings\<close>

definition class_semiring :: "'a itself \<Rightarrow> 'b \<Rightarrow> ('a :: {plus,times,one,zero},'b)ring_scheme" where
  "class_semiring _ b \<equiv> \<lparr> carrier = UNIV, mult = (*), one = 1, zero = 0, add = (+), \<dots> = b\<rparr>"

lemma class_semiring: "semiring (class_semiring (TYPE('a :: ordered_semiring_1)) b)"
  unfolding class_semiring_def
  by (unfold_locales, auto simp: field_simps)

definition class_ordered_semiring :: "'a itself \<Rightarrow> ('a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> ('a,'b) ordered_semiring_scheme" where
  "class_ordered_semiring a gt b \<equiv> class_semiring a \<lparr>
    ordered_semiring.geq = (\<ge>),
    gt = gt,
    max = max,
    \<dots> = b\<rparr>"

lemma class_ordered_semiring: assumes "order_pair (gt :: ('a :: ordered_semiring_1 \<Rightarrow> 'a \<Rightarrow> bool)) d"
  shows "ordered_semiring
    (class_ordered_semiring (TYPE('a)) gt b)"
  (is "ordered_semiring ?R")
proof -
  interpret order_pair gt d by fact
  interpret semiring ?R unfolding class_ordered_semiring_def by (rule class_semiring)
  show ?thesis
    by (unfold_locales, unfold class_ordered_semiring_def class_semiring_def, auto
    intro: compat compat2 gt_imp_ge ge_trans max_comm max_id max_mono ge_refl one_ge_zero
     times_left_mono times_right_mono plus_left_mono)
qed

lemma (in one_mono_ordered_semiring_1) class_ordered_semiring:
  "ordered_semiring
    (class_ordered_semiring (TYPE('a)) (\<succ>) b)"
  by (rule class_ordered_semiring[of _ default], unfold_locales)

lemma (in both_mono_ordered_semiring_1) class_ordered_semiring:
  "ordered_semiring
    (class_ordered_semiring (TYPE('a)) (\<succ>) b)"
  by (rule class_ordered_semiring[of _ default], unfold_locales)

end


(*  Title:      HOL/UNITY/Comp/Handshake.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Handshake Protocol

From Misra, "Asynchronous Compositions of Programs", Section 5.3.2
*)

theory Handshake imports "../UNITY_Main" begin

record state =
  BB :: bool
  NF :: nat
  NG :: nat

definition
  (*F's program*)
  cmdF :: "(state*state) set"
  where "cmdF = {(s,s'). s' = s (|NF:= Suc(NF s), BB:=False|) & BB s}"

definition
  F :: "state program"
  where "F = mk_total_program ({s. NF s = 0 & BB s}, {cmdF}, UNIV)"

definition
  (*G's program*)
  cmdG :: "(state*state) set"
  where "cmdG = {(s,s'). s' = s (|NG:= Suc(NG s), BB:=True|) & ~ BB s}"

definition
  G :: "state program"
  where "G = mk_total_program ({s. NG s = 0 & BB s}, {cmdG}, UNIV)"

definition
  (*the joint invariant*)
  invFG :: "state set"
  where "invFG = {s. NG s <= NF s & NF s <= Suc (NG s) & (BB s = (NF s = NG s))}"

declare F_def [THEN def_prg_Init, simp]
        G_def [THEN def_prg_Init, simp]

        cmdF_def [THEN def_act_simp, simp]
        cmdG_def [THEN def_act_simp, simp]

        invFG_def [THEN def_set_simp, simp]

lemma invFG: "(F Join G) : Always invFG"
apply (rule AlwaysI)
apply force
apply (rule constrains_imp_Constrains [THEN StableI])
apply auto
 apply (unfold F_def, safety)
apply (unfold G_def, safety)
done

lemma lemma2_1: "(F Join G) : ({s. NF s = k} - {s. BB s}) LeadsTo
                              ({s. NF s = k} Int {s. BB s})"
apply (rule stable_Join_ensures1[THEN leadsTo_Basis, THEN leadsTo_imp_LeadsTo])
 apply (unfold F_def, safety)
apply (unfold G_def, ensures_tac "cmdG")
done

lemma lemma2_2: "(F Join G) : ({s. NF s = k} Int {s. BB s}) LeadsTo
                              {s. k < NF s}"
apply (rule stable_Join_ensures2[THEN leadsTo_Basis, THEN leadsTo_imp_LeadsTo])
 apply (unfold F_def, ensures_tac "cmdF")
apply (unfold G_def, safety)
done

lemma progress: "(F Join G) : UNIV LeadsTo {s. m < NF s}"
apply (rule LeadsTo_weaken_R)
apply (rule_tac f = "NF" and l = "Suc m" and B = "{}"
       in GreaterThan_bounded_induct)
(*The inductive step is (F Join G) : {x. NF x = ma} LeadsTo {x. ma < NF x}*)
apply (auto intro!: lemma2_1 lemma2_2
            intro: LeadsTo_Trans LeadsTo_Diff simp add: vimage_def)
done

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section "Conversions between automata"

theory Automata
imports DA NAe
begin

definition
 na2da :: "('a,'s)na \<Rightarrow> ('a,'s set)da" where
"na2da A = ({start A}, \<lambda>a Q. Union(next A a ` Q), \<lambda>Q. \<exists>q\<in>Q. fin A q)"

definition
 nae2da :: "('a,'s)nae \<Rightarrow> ('a,'s set)da" where
"nae2da A = ({start A},
              \<lambda>a Q. Union(next A (Some a) ` ((eps A)\<^sup>* `` Q)),
              \<lambda>Q. \<exists>p \<in> (eps A)\<^sup>* `` Q. fin A p)"

(*** Equivalence of NA and DA ***)

lemma DA_delta_is_lift_NA_delta:
 "\<And>Q. DA.delta (na2da A) w Q = Union(NA.delta A w ` Q)"
by (induct w)(auto simp:na2da_def)

lemma NA_DA_equiv:
  "NA.accepts A w = DA.accepts (na2da A) w"
apply (simp add: DA.accepts_def NA.accepts_def DA_delta_is_lift_NA_delta)
apply (simp add: na2da_def)
done

(*** Direct equivalence of NAe and DA ***)

lemma espclosure_DA_delta_is_steps:
 "\<And>Q. (eps A)\<^sup>* `` (DA.delta (nae2da A) w Q) = steps A w `` Q"
apply (induct w)
 apply(simp)
apply (simp add: step_def nae2da_def)
apply (blast)
done

lemma NAe_DA_equiv:
  "DA.accepts (nae2da A) w = NAe.accepts A w"
proof -
  have "\<And>Q. fin (nae2da A) Q = (\<exists>q \<in> (eps A)\<^sup>* `` Q. fin A q)"
    by(simp add:nae2da_def)
  thus ?thesis
    apply(simp add:espclosure_DA_delta_is_steps NAe.accepts_def DA.accepts_def)
    apply(simp add:nae2da_def)
    apply blast
    done
qed

end


theory Prob
  imports  FMap
begin

definition prob_space :: "(('O:: finite) set)set \<Rightarrow> bool"
  where
"prob_space S \<equiv> {} \<in> S \<and> (UNIV:: 'O set) \<in> S \<and>
                (\<forall> A \<in> S. \<forall> B \<in> S. A \<union> B \<in> S) \<and> (\<forall> A \<in> S. (UNIV :: 'O set) - A \<in> S)"

theorem Pow_prob_space: "prob_space (Pow ((UNIV :: (('O :: finite)) set)))"
  by (simp add: prob_space_def)

definition prob_dist_def
  where
"prob_dist_def \<equiv> {p :: (('O :: finite) set \<Rightarrow> real).
         (\<forall> A:: 'O set. p A \<ge> 0) \<and> p {} = 0 \<and> (p(UNIV :: 'O set) = 1) \<and>
         (\<forall> A:: 'O set. \<forall> B:: 'O set.  p(A \<union> B) = p A + p B - p(A \<inter> B))}"

typedef ('O :: finite)prob_dist = "{p :: ('O set \<Rightarrow> real).
         (\<forall> A:: 'O set. p A \<ge> 0) \<and> p {} = 0 \<and> (p(UNIV :: 'O set) = 1) \<and>
         (\<forall> A:: 'O set. \<forall> B:: 'O set.  p(A \<union> B) = p A + p B - p(A \<inter> B))}"
proof (rule_tac x = "(\<lambda> x :: 'O set. ((card x)::real)/((card (UNIV :: 'O set))::real))" in exI, rule CollectI, rule conjI)
  show " \<forall>A::'O set. (0::real) \<le> real (card A) / real (card UNIV)" by simp
next show "real (card ({}  :: ('O :: finite) set)) / real (card (UNIV  :: ('O :: finite) set)) = (0::real) \<and>
       real (card (UNIV :: ('O :: finite) set)) / real (card (UNIV :: ('O :: finite)set)) = (1::real) \<and>
    (\<forall>(A::('O ::finite) set) B::('O::finite) set.
        real (card (A \<union> B)) / real (card (UNIV :: ('O :: finite)set)) =
        real (card A) / real (card (UNIV :: ('O :: finite)set)) +
        real (card B) / real (card (UNIV :: ('O :: finite)set))
        - (real (card (A \<inter> B)) / real (card (UNIV :: ('O :: finite)set))))"
  proof (rule conjI)
    show "real (card ({}  :: ('O :: finite) set)) / real (card (UNIV  :: ('O :: finite) set)) = (0::real)"
    by simp
  next show "real (card (UNIV :: ('O :: finite) set)) / real (card (UNIV :: ('O :: finite)set)) = (1::real) \<and>
    (\<forall>(A::('O ::finite) set) B::('O::finite) set.
        real (card (A \<union> B)) / real (card (UNIV :: ('O :: finite)set)) =
        real (card A) / real (card (UNIV :: ('O :: finite)set)) +
        real (card B) / real (card (UNIV :: ('O :: finite)set))
        - (real (card (A \<inter> B)) / real (card (UNIV :: ('O :: finite)set))))"
    apply (rule conjI)
     apply simp
    apply clarify
    apply (subgoal_tac "real (card A) / real (card (UNIV :: ('O :: finite) set)) +
                        real (card B) / real (card (UNIV :: ('O :: finite) set)) -
                        real (card (A \<inter> B)) / real (card (UNIV :: ('O :: finite) set)) =
                        (real (card A) + real (card B) - real (card (A \<inter> B))) /
                              real (card (UNIV :: ('O :: finite) set))")
    apply (rotate_tac -1)
     apply (erule ssubst)
     apply (subgoal_tac "real (card (A \<union> B)) = real (card A) + real (card B) - real (card (A \<inter> B))")
      apply (rotate_tac -1)
      apply (erule ssubst)
      apply (rule refl)
     apply (subgoal_tac "card (A \<union> B) = card A + card B - card (A \<inter> B)")
      apply (rotate_tac -1)
      apply (erule ssubst)
    apply (metis add_diff_cancel_right' card_Un_Int finite of_nat_add)
    apply (metis add_diff_cancel_right' card_Un_Int finite)
    by (simp add: add_divide_distrib diff_divide_distrib)
qed
qed

(* lemmas to use prop_space and prob_dist *)
lemma prob_dist_def_Abs_inv: "p \<in> prob_dist_def \<Longrightarrow> Rep_prob_dist (Abs_prob_dist p) = p"
  apply (unfold prob_dist_def_def)
  by (erule Abs_prob_dist_inverse)

lemma prob_dist_def_Rep_inv: "Rep_prob_dist (p :: ('O :: finite)prob_dist) \<in> prob_dist_def"
  apply (unfold prob_dist_def_def)
  by (rule Rep_prob_dist)

lemma prob_dist_defE1: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow> (\<forall> A:: 'O set. p A \<ge> 0)"
proof (simp add: prob_dist_def_def)
qed

lemma prob_dist_defE1a: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow> (p({} :: 'O set) = 0)"
proof (simp add: prob_dist_def_def)
qed

lemma prob_dist_defE2: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow> (p(UNIV :: 'O set) = 1)"
proof (simp add: prob_dist_def_def)
qed

lemma prob_dist_defE3[rule_format]: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow>
                        (\<forall> A:: 'O set. \<forall> B:: 'O set.  p(A \<union> B) = p A + p B - p(A \<inter> B))"
proof (simp add: prob_dist_def_def)
qed

lemma prob_dist_defE3'[rule_format]: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow>
                     (A :: 'O set) \<inter> (B:: 'O set) = {} \<Longrightarrow>   p(A \<union> B) = p A + p B"
proof (simp add: prob_dist_defE3 prob_dist_defE1a)
qed

(* Type error
lemma prob_dist_defE3''[rule_format]: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow>
                     (A :: 'O set) \<inter> (B:: 'O set) = {} \<Longrightarrow>   sum p ({a} \<union> B) = p a + sum p B"
 *)

lemma prob_dist_mono: "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow>
                     (A :: 'O set) \<subseteq> (B:: 'O set) \<Longrightarrow>  p A \<le> p B"
proof (frule_tac A = A and B = "B - A" in prob_dist_defE3', simp)
  show "(p :: (('O :: finite) set \<Rightarrow> real)) \<in> prob_dist_def \<Longrightarrow>
         A \<subseteq> B \<Longrightarrow> p (A \<union> (B - A)) = p A + p (B - A) \<Longrightarrow> p A \<le> p B"
    apply (subgoal_tac "A \<union> (B - A) = B")
     apply (rotate_tac -1)
     apply (erule subst)
     apply (erule ssubst)
    apply simp
     apply (insert prob_dist_defE1)
     apply (drule_tac x = p in meta_spec)
     apply (drule meta_mp)
    apply assumption
     apply (erule spec)
by blast
qed

lemma prob_dist_compl: assumes "p \<in> prob_dist_def"
  shows "p ((UNIV :: (('O :: finite)set)) - A :: (('O :: finite) set)) = 1 - p A"
proof -
  have a: "p (UNIV :: (('O :: finite)set)) = 1"  using assms
    by (rule prob_dist_defE2)
  moreover have b: "p (UNIV :: (('O :: finite)set)) - p A = 1 - p A" using a
    by simp
  moreover have c: "(UNIV :: (('O :: finite)set)) = (UNIV :: (('O :: finite)set)) - A  \<union> A" by simp
  moreover have d: "((UNIV :: (('O :: finite)set)) - A) \<inter> A = {}" by blast
  moreover have e: "p (((UNIV :: (('O :: finite)set)) - A) \<union> A) - p A = 1 - p A"
    by (simp add: prob_dist_defE2 a)
  moreover have f: "p (((UNIV :: (('O :: finite)set)) - A) \<union> A)= p (((UNIV :: (('O :: finite)set)) - A)) + p A"
    apply (rule prob_dist_defE3')
     apply (rule assms)
    by (rule d)
  ultimately show "p ((UNIV :: (('O :: finite)set)) - A :: (('O :: finite) set)) = 1 - p A"
    apply (rule_tac P =  "\<lambda> x. p ((UNIV :: (('O :: finite)set)) - A :: (('O :: finite) set)) = x" in subst)
     apply (rule e)
    apply (subst f)
    by simp
qed

(* simply a generalisation of prob_dist_defE3'*)
lemma prob_dist_sum0[rule_format]:
     "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<longrightarrow> p \<in> prob_dist_def \<longrightarrow>
      p(\<Union> A \<in> \<A>. A) = sum (\<lambda> A. p A) \<A>"
  apply (rule finite_induct)
    apply (rule finite)
  apply (simp add: prob_dist_def_def)+
  by (simp add: insert_partition)

lemma prob_dist_sum: "(\<forall> A \<in> \<A>. \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow> p \<in> prob_dist_def \<Longrightarrow>
      p(\<Union> A \<in> \<A>. A) = sum (\<lambda> A. p A) \<A>"
by (rule prob_dist_sum0, simp+)

lemma lem_one: "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
          (\<forall> A \<in> fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set).
            \<forall> B \<in> fmap (\<lambda> x. C \<inter> x) \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {})"
proof (simp add: fmap_set_rep)
  show "\<forall>A::'O set\<in>\<A>. \<forall>B::('O :: finite) set\<in>\<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {} \<Longrightarrow>
    \<forall>A::'O set.
       (\<exists>y::'O set\<in>\<A>. A = C \<inter> y) \<longrightarrow> (\<forall>B::'O set. (\<exists>y::'O set\<in>\<A>. B = C \<inter> y) \<longrightarrow> A \<noteq> B \<longrightarrow> A \<inter> B = {})"
by blast
qed

lemma lem_one': "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
          (\<forall> A \<in> (\<inter>) C `  (\<A> :: ('O :: finite) set set).
            \<forall> B \<in> (\<inter>) C `  \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {})"
proof -
  show "\<forall>A::'O set\<in>\<A>. \<forall>B::'O set\<in>\<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {} \<Longrightarrow>
    \<forall>A::'O set\<in>(\<inter>) C ` \<A>. \<forall>B::'O set\<in>(\<inter>) C ` \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
by blast
qed

lemma lem_one'': assumes "(\<forall> A \<in> (F :: ('O :: finite) set set). \<forall> B \<in> F. A \<noteq> B \<longrightarrow> A \<inter> B = {})"
                         "x \<in> F"
                         "y \<in> F"
                         "x \<noteq> y"
                       shows "(C \<inter> x) \<inter> (C \<inter> y) = {}"
proof -
  have a: "C \<inter> {} = {}" by simp
  moreover have b: "C \<inter> (x \<inter> y) = {}" using assms by blast
  ultimately show "(C \<inter> x) \<inter> (C \<inter> y) = {}" by blast
qed

lemma lem_two: "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
                 \<forall> C \<in> \<A>. {C} \<inter> (\<A> - {C}) = {}"
by blast

lemma lem_two''[rule_format]: "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
                 \<forall> C \<in> \<A>. {C} \<inter> (\<A> - {C}) = {}"
by blast

lemma lem_two': "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
                 D \<subset> \<A> \<Longrightarrow> {C} \<union> D = \<A> \<Longrightarrow>
                 {C} \<inter> (D) = {}"
  apply (subgoal_tac "D = \<A> - {C}")
   apply (rotate_tac -1)
  apply (erule ssubst)
  apply (rule lem_two'')
    apply simp
  apply blast
  by blast

lemma lem_one''': assumes "(\<forall> A \<in> (F :: ('O :: finite) set set). \<forall> B \<in> F. A \<noteq> B \<longrightarrow> A \<inter> B = {})"
                         "x \<in> F"
                         "C \<inter> x \<noteq> {}"
                       shows "{C \<inter> x} \<inter> ((\<inter>) C ` (F - {x})) = {}"
proof -
  show "{C \<inter> x} \<inter> ((\<inter>) C ` (F - {x})) = {}"
    apply (insert assms(1))
    apply (drule_tac C = C in lem_one')
    apply (drule_tac D = "(\<inter>) C ` F - {(C \<inter> x)}" in lem_two')
      apply (insert assms(2))
      apply (rule psubsetI)
       apply blast
      apply (simp add: image_def)
      apply blast
     apply blast
    apply (insert assms(2))
    apply simp
    apply (simp add: image_def)
    apply (rule ballI)
    apply (subgoal_tac "(C \<inter> x) \<inter> (C \<inter> xa) = {}")
    apply (insert assms(3))
      apply blast
     apply (rule lem_one'')
        apply (rule assms)
       apply assumption
      apply simp
by blast
qed

lemma lem_one'''': "(\<forall> A \<in> (insert x F :: ('O :: finite) set set).
                      \<forall> B \<in> insert x F. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow> C \<inter> x \<noteq> {} \<Longrightarrow>
                     {C \<inter> x} \<inter> ((\<inter>) C ` ((insert x F) - {x})) = {}"
proof (rule lem_one''', assumption, simp)
qed

lemma lem_one''''': "(\<forall> A \<in> (insert x F :: ('O :: finite) set set).
                      \<forall> B \<in> insert x F. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow> x \<notin> F \<Longrightarrow> C \<inter> x \<noteq> {} \<Longrightarrow>
                     {C \<inter> x} \<inter> ((\<inter>) C ` F) = {}"
  apply (drule lem_one'''', assumption)
  by blast

lemma lem_three: "x \<notin> F \<Longrightarrow>
                  ((\<inter>) C ` insert x F - {C \<inter> x}) = ((\<inter>) C ` (insert x F - {y. C \<inter> y = C \<inter> x}))"
  by blast

lemma sum_lem_two: "p \<in> prob_dist_def \<Longrightarrow> {C \<inter> x} \<inter> (\<inter>) C ` (\<A> :: ('O :: finite) set set) = {} \<Longrightarrow>
                    sum p ({C \<inter> x} \<union> (\<inter>) C ` \<A>) = p (C \<inter> x) + sum p ((\<inter>) C ` \<A>)"
  by (simp add: Groups_Big.comm_monoid_add_class.sum.insert)

lemma sum_lem_two': "p \<in> prob_dist_def \<Longrightarrow> C \<inter> x = {} \<Longrightarrow>
                   (\<forall> A \<in> (\<inter>) C ` (insert x F :: ('O :: finite) set set).
            \<forall> B \<in> (\<inter>) C ` (insert x F). A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
                    sum p ({C \<inter> x} \<union> (\<inter>) C ` \<A>) = p (C \<inter> x) + sum p ((\<inter>) C ` \<A>)"
  apply (subgoal_tac "p {} = 0")
  apply (metis Un_insert_left add.left_neutral finite sum.insert_if sup_bot.left_neutral)
  by (erule prob_dist_defE1a)

lemma sum_lem[rule_format]: "p \<in> prob_dist_def \<Longrightarrow>
                (\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<longrightarrow>
               sum p ((\<inter>) C ` (\<A> :: ('O :: finite) set set)) = (\<Sum>A::'O set\<in>\<A>. p (C \<inter> A))"
proof (rule finite_induct, rule finite, simp, rule impI)
  show "\<And>(x::('O :: finite) set) F::'O set set.
       p \<in> prob_dist_def \<Longrightarrow>
       finite F \<Longrightarrow>
       x \<notin> F \<Longrightarrow>
       (\<forall>A::'O set\<in>F. \<forall>B::'O set\<in>F. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<longrightarrow>
       sum p ((\<inter>) C ` F) = (\<Sum>A::'O set\<in>F. p (C \<inter> A)) \<Longrightarrow>
       (\<forall>A::'O set\<in>insert x F. \<forall>B::'O set\<in>insert x F. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<Longrightarrow>
       sum p ((\<inter>) C ` insert x F) = (\<Sum>A::'O set\<in>insert x F. p (C \<inter> A))"
  proof -
    fix F x
    assume pr: "p \<in> prob_dist_def"
    assume IH: "(\<forall>A::('O :: finite) set\<in>F. \<forall>B::'O set\<in>F. A \<noteq> B \<longrightarrow> A \<inter> B = {}) \<longrightarrow>
                 sum p ((\<inter>) C ` F) = (\<Sum>A::'O set\<in>F. p (C \<inter> A))"
    assume xninF: "x \<notin> F"
    assume disj:"(\<forall>A::'O set\<in>insert x F. \<forall>B::'O set\<in>insert x F. A \<noteq> B \<longrightarrow> A \<inter> B = {})"
    have a: "sum p ((\<inter>) C ` insert x F) = p (C \<inter> x) + sum p ((\<inter>) C ` F)"
    proof -
      have x1: "((\<inter>) C ` insert x F) = ({(C \<inter> x)} \<union> ((\<inter>) C ` F))" by blast
      moreover have x0: "(\<forall> A \<in> (\<inter>) C ` (insert x F :: ('O :: finite) set set).
            \<forall> B \<in> (\<inter>) C ` (insert x F). A \<noteq> B \<longrightarrow> A \<inter> B = {})"
        apply (rule lem_one')
        apply (insert disj)
        by assumption
      moreover have x2: "C \<inter> x \<noteq> {} \<Longrightarrow> {(C \<inter> x)} \<inter> ((\<inter>) C ` F) = {}" using xninF x0
        apply (insert lem_one''''')
        apply (drule_tac x = x in meta_spec)
        apply (drule_tac x = F in meta_spec)
        apply (drule_tac x = C in meta_spec)
        apply (drule meta_mp)
         apply (rule disj)
        apply (drule meta_mp)
         apply (rule xninF)
        apply (drule meta_mp)
        by assumption
      ultimately show "sum p ((\<inter>) C ` insert x F) = p (C \<inter> x) + sum p ((\<inter>) C ` F)"
        apply (subst x1)
        apply (case_tac "C \<inter> x = {}")
         apply (rule sum_lem_two')
           apply (rule pr)
          apply assumption
        apply (rule x0)
        apply (rule sum_lem_two)
         apply (rule pr)
      by assumption
    qed
    moreover have b: "(\<Sum>A::'O set\<in>insert x F. p (C \<inter> A)) =  p (C \<inter> x) + (\<Sum>A::'O set\<in> F. p (C \<inter> A))"
      by (simp add: xninF)
    ultimately show "sum p ((\<inter>) C ` insert x F) = (\<Sum>A::'O set\<in>insert x F. p (C \<inter> A))"
      apply (subst a)
      apply (subst b)
      apply simp
      apply (insert IH)
      apply (drule mp)
      apply (insert disj)
       apply force
      by assumption
  qed
qed

lemma prob_dist_sum': assumes "(\<forall> A \<in> (\<A> :: ('O :: finite) set set). \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {})"
                              "p \<in> prob_dist_def"
                            shows "p(\<Union> A \<in> \<A>. C \<inter> A) = sum (\<lambda> A. p (C \<inter> A)) \<A>"
proof -
  have a: "(\<forall> A \<in> fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set).
            \<forall> B \<in> fmap (\<lambda> x. C \<inter> x) \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {})" using assms
    apply (insert lem_one)
    apply (drule_tac x = \<A> in meta_spec)
    apply (drule_tac x = C in meta_spec)
    apply (drule meta_mp, rule assms)
    by assumption
  moreover have b: "p(\<Union> A \<in> fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set). A) =
          sum (\<lambda> A. p A) (fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set))"
    apply (rule prob_dist_sum)
     apply (rule a)
    by (rule assms)
  moreover have c: "(\<Union> A \<in> \<A>. C \<inter> A) = (\<Union> A \<in> fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set). A)"
    apply (simp add: fmap_lem_map finite fmap_lem_one fmap_lem)
    apply (rule equalityI)
     apply (rule subsetI)
    apply (erule IntE)
    apply (erule UnionE)
     apply (rule_tac X = "C \<inter> X" in UnionI)
      apply (rule fmap_lem_map, rule finite, assumption, simp)
    apply (rule subsetI)
    apply (erule UnionE)
    apply (rule IntI)
     apply (subgoal_tac "fmap ((\<inter>) C) \<A> = {x. \<exists> y \<in> \<A>. x = C \<inter> y}")
      apply force
     apply (rule fmap_set_rep, rule finite)
     apply (subgoal_tac "fmap ((\<inter>) C) \<A> = {x. \<exists> y \<in> \<A>. x = C \<inter> y}")
      apply force
     by (rule fmap_set_rep, rule finite)
  moreover have d: "sum (\<lambda> A. p A) (fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set)) =
                   sum (\<lambda> A. p (C \<inter> A)) \<A>"
     apply (subgoal_tac "fmap ((\<inter>) C) \<A> = (\<lambda> x. C \<inter> x) ` \<A>")
     apply (erule ssubst)
     apply (rule sum_lem, rule assms)
     apply (insert assms(1))
    apply simp
    by (rule fmap_set_rep', rule finite)
  moreover have e: "sum (\<lambda> A. p (C \<inter> A)) \<A> =
                    sum (\<lambda> A. p A) (fmap (\<lambda> x. C \<inter> x) (\<A> :: ('O :: finite) set set))"
    apply (rule sym)
    by (rule d)
  ultimately show "p(\<Union> A \<in> \<A>. C \<inter> A) = sum (\<lambda> A. p (C \<inter> A)) \<A>"
    apply (subst c)
    apply (subst e)
    apply (subst b)
    by (rule refl)
qed

(* Canonical construction *)
definition pmap :: "(('O :: finite) \<Rightarrow> real) \<Rightarrow> 'O set \<Rightarrow> real"
  where
"pmap (ops :: ('O :: finite) \<Rightarrow> real) S \<equiv> Finite_Set.fold (\<lambda> x y. ops x + y) 0 S"

lemma pmap_ops_lem1[rule_format]: "finite (A :: ('O :: finite) set)  \<Longrightarrow>
       (\<forall>x::('O :: finite). (0::real) \<le> ops x) \<longrightarrow> (0::real) \<le> Finite_Set.fold (\<lambda>x::'O. (+) (ops x)) (0::real) A"
  apply (erule_tac F = A in finite_induct)
   apply simp
  apply clarify
  apply (drule_tac x = x in spec)
  apply (fold fsumap_def)
  apply (subst fsumap_lem)
    apply (rule finite)
   apply assumption
  by simp

lemma sum_fold_ops: "sum ops (S :: ('O :: finite)set)  = Finite_Set.fold (\<lambda>x::'O. (+) (ops x)) (0::real) S"
proof (rule_tac F = S in finite_induct)
  show "finite S" by (rule finite)
next show "sum ops {} = Finite_Set.fold (\<lambda>x::'O. (+) (ops x)) (0::real) {}" by simp
next show "\<And>(x::'O) F::'O set.
       finite F \<Longrightarrow>
       x \<notin> F \<Longrightarrow>
       sum ops F = Finite_Set.fold (\<lambda>x::'O. (+) (ops x)) (0::real) F \<Longrightarrow>
       sum ops (insert x F) = Finite_Set.fold (\<lambda>x::'O. (+) (ops x)) (0::real) (insert x F)"
  apply (fold fsumap_def)
  apply (subst fsumap_lem)
    apply (rule finite, assumption)
    by simp
qed

theorem pmap_ops: "\<forall> x :: ('O :: finite). ops x \<ge> 0 \<Longrightarrow>
                   sum ops (UNIV :: ('O :: finite) set) = 1 \<Longrightarrow> pmap ops \<in> prob_dist_def"
proof (simp add: prob_dist_def_def, rule conjI)
  show "\<forall>x::'O. (0::real) \<le> ops x \<Longrightarrow> sum ops UNIV = (1::real) \<Longrightarrow> \<forall>A::'O set. (0::real) \<le> pmap ops A"
   apply (simp add: pmap_def)
   apply (rule allI)
   apply (rule pmap_ops_lem1)
    apply (rule finite)
    by (erule spec)
next show " \<forall>x::'O. (0::real) \<le> ops x \<Longrightarrow>
    sum ops (UNIV :: ('O :: finite) set) = (1::real) \<Longrightarrow>
    pmap ops {} = (0::real) \<and>
    pmap ops (UNIV :: ('O :: finite) set) = (1::real) \<and>
    (\<forall>(A::('O :: finite) set) B::'O set. pmap ops (A \<union> B) = pmap ops A + pmap ops B - pmap ops (A \<inter> B))"
    apply (rule conjI)
     apply (simp add: pmap_def)
    apply (rule conjI)
     apply (simp add: pmap_def)
    apply (fold sum_fold_ops, assumption)
(* *)
    apply (rule allI)
    apply (rule finite_induct)
    apply (rule finite)
     apply (simp add: pmap_def)
    apply (simp add: pmap_def)
    by (metis Un_insert_right finite sum_Un sum_fold_ops sup_commute)
qed

definition cond_prob :: "('O :: finite)prob_dist \<Rightarrow> 'O set \<Rightarrow> 'O set \<Rightarrow> real" ("_[_|_]" 50)
  where
"(P :: ('O :: finite)prob_dist)[A|B] \<equiv> (if (Rep_prob_dist P B) = 0 then 0 else Rep_prob_dist P (A \<inter> B)) / (Rep_prob_dist P B)"

lemma cond_prob2: "(Rep_prob_dist P (A \<inter> B)) = ((P :: ('O :: finite)prob_dist)[A|B]) * (Rep_prob_dist P B)"
  apply (subst cond_prob_def)
  apply simp
  apply (insert prob_dist_mono)
  apply (drule_tac x = "Rep_prob_dist P" in meta_spec)
  apply (drule_tac x = "A \<inter> B" in meta_spec)
  apply (drule_tac x = B in meta_spec)
  apply (rule impI)
  apply (subgoal_tac "Rep_prob_dist P (A \<inter> B) \<le> (0 :: real)")
   apply (subgoal_tac "Rep_prob_dist P (A \<inter> B) \<ge> (0 :: real)")
    apply simp
   apply (insert prob_dist_defE1)
   apply (drule_tac x = "Rep_prob_dist P" in meta_spec)
   apply (rotate_tac -1)
   apply (drule meta_mp)
    apply (rule prob_dist_def_Rep_inv)
   apply (erule spec)
  apply (drule meta_mp)
    apply (rule prob_dist_def_Rep_inv)
  apply (erule subst)
  apply (erule meta_mp)
  by blast

theorem law_of_total_probability:
  assumes "\<Union> \<A> = (UNIV :: 'O set)"
          "\<forall> A \<in> \<A>. \<forall> B \<in> \<A>. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
  shows "(Rep_prob_dist(P:: ('O :: finite)prob_dist)(B::'O set)) = sum (\<lambda> A. (P[B|A])*(Rep_prob_dist P A)) \<A>"
proof -
  show "Rep_prob_dist P B = (\<Sum>A::'O set\<in>\<A>. (P[B|A]) * Rep_prob_dist P A)"
  proof -
  have a: "Rep_prob_dist P (B :: 'O set) = Rep_prob_dist P (B \<inter> (UNIV :: 'O set))" by simp
  moreover have b: "Rep_prob_dist P (B \<inter> (UNIV :: 'O set)) = Rep_prob_dist P (B \<inter> \<Union> \<A>)" using assms(1)
    by simp
  moreover have c: "Rep_prob_dist P (B \<inter> \<Union> \<A>) = Rep_prob_dist P (\<Union> A \<in> \<A>. B \<inter> A)" using assms(2)
    by simp
  moreover have d: "Rep_prob_dist P (\<Union> A \<in> \<A>. B \<inter> A) = sum (\<lambda> A. Rep_prob_dist P (B \<inter> A)) \<A>" using assms
    apply (rule_tac p = "Rep_prob_dist P" in prob_dist_sum')
     apply (rule assms(2))
  apply (insert Rep_prob_dist)
  apply (drule_tac x = P in meta_spec)
    by (simp add: prob_dist_def_def)
  moreover have e: "sum (\<lambda> A. Rep_prob_dist P (B \<inter> A)) \<A> = sum (\<lambda> A. (P[B|A])*(Rep_prob_dist P A)) \<A>"
    apply (subst cond_prob2)
    by (rule refl)
  ultimately show "Rep_prob_dist P B = (\<Sum>A::'O set\<in>\<A>. (P[B|A]) * Rep_prob_dist P A)"
    apply (subst a)
    apply (subst b)
    apply (subst c)
    apply (subst d)
    apply (subst e)
    by (rule refl)
qed
qed

definition F:: "('a :: state)set \<Rightarrow> 'a list set"
  where
"F s \<equiv> {l. (\<forall> i < length l - 1. l ! i \<rightarrow>\<^sub>i l ! (Suc i)) \<and> last l \<in> s \<and> l \<noteq> []}"

definition eventually :: "[('a :: state)kripke, 'a set] \<Rightarrow> 'a list set" (infixr "\<turnstile>F" 50)
  where
"M \<turnstile>F s \<equiv> {l. set l \<subseteq> states M \<and> hd l \<in> init M} \<inter> F s"

definition probF :: "[('a :: state)kripke, 'a list set \<Rightarrow> real, real \<Rightarrow> bool, 'a set] \<Rightarrow> bool"
                                ("_ _ \<turnstile>PF\<^sub>_ _")
                                where
"M pdist \<turnstile>PF\<^sub>J s \<equiv> J(pdist (M \<turnstile>F s))"

(* application to QKD in QKD.thy *)
end


section \<open>Integer Polynomial Functions\<close>

theory Poly_Fun
  imports Binomial_Int "HOL-Computational_Algebra.Polynomial"
begin

subsection \<open>Definition and Basic Properties\<close>

definition poly_fun :: "(int \<Rightarrow> int) \<Rightarrow> bool"
  where "poly_fun f \<longleftrightarrow> (\<exists>p::rat poly. \<forall>a. rat_of_int (f a) = poly p (rat_of_int a))"

lemma poly_funI: "(\<And>a. rat_of_int (f a) = poly p (rat_of_int a)) \<Longrightarrow> poly_fun f"
  by (auto simp: poly_fun_def)

lemma poly_funE:
  assumes "poly_fun f"
  obtains p where "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
  using assms by (auto simp: poly_fun_def)

lemma poly_fun_eqI:
  assumes "poly_fun f" and "poly_fun g" and "infinite {a. f a = g a}"
  shows "f = g"
proof (rule ext)
  fix a
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  from assms(2) obtain q where q: "\<And>a. rat_of_int (g a) = poly q (rat_of_int a)"
    by (rule poly_funE, blast)
  have "p = q"
  proof (rule ccontr)
    let ?A = "{a. poly p (rat_of_int a) = poly q (rat_of_int a)}"
    assume "p \<noteq> q"
    hence "p - q \<noteq> 0" by simp
    hence fin: "finite {x. poly (p - q) x = 0}" by (rule poly_roots_finite)
    have "rat_of_int ` ?A \<subseteq> {x. poly (p - q) x = 0}" by (simp add: image_Collect_subsetI)
    hence "finite (rat_of_int ` ?A)" using fin by (rule finite_subset)
    moreover have "inj_on rat_of_int ?A" by (simp add: inj_on_def)
    ultimately have "finite ?A" by (simp only: finite_image_iff)
    also have "?A = {a. f a = g a}" by (simp flip: p q)
    finally show False using assms(3) by simp
  qed
  hence "rat_of_int (f a) = rat_of_int (g a)" by (simp add: p q)
  thus "f a = g a" by simp
qed

corollary poly_fun_eqI_ge:
  assumes "poly_fun f" and "poly_fun g" and "\<And>a. b \<le> a \<Longrightarrow> f a = g a"
  shows "f = g"
  using assms(1, 2)
proof (rule poly_fun_eqI)
  have "{b..} \<subseteq> {a. f a = g a}" by (auto intro: assms(3))
  thus "infinite {a. f a = g a}" using infinite_Ici by (rule infinite_super)
qed

corollary poly_fun_eqI_gr:
  assumes "poly_fun f" and "poly_fun g" and "\<And>a. b < a \<Longrightarrow> f a = g a"
  shows "f = g"
  using assms(1, 2)
proof (rule poly_fun_eqI)
  have "{b<..} \<subseteq> {a. f a = g a}" by (auto intro: assms(3))
  thus "infinite {a. f a = g a}" using infinite_Ioi by (rule infinite_super)
qed

subsection \<open>Closure Properties\<close>

lemma poly_fun_const [simp]: "poly_fun (\<lambda>_. c)"
  by (rule poly_funI[where p="[:rat_of_int c:]"]) simp

lemma poly_fun_id [simp]: "poly_fun (\<lambda>x. x)" "poly_fun id"
proof -
  show "poly_fun (\<lambda>x. x)" by (rule poly_funI[where p="[:0, 1:]"]) simp
  thus "poly_fun id" by (simp only: id_def)
qed

lemma poly_fun_uminus:
  assumes "poly_fun f"
  shows "poly_fun (\<lambda>x. - f x)" and "poly_fun (- f)"
proof -
  from assms obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  show "poly_fun (\<lambda>x. - f x)" by (rule poly_funI[where p="- p"]) (simp add: p)
  thus "poly_fun (- f)" by (simp only: fun_Compl_def)
qed

lemma poly_fun_uminus_iff [simp]:
  "poly_fun (\<lambda>x. - f x) \<longleftrightarrow> poly_fun f" "poly_fun (- f) \<longleftrightarrow> poly_fun f"
proof -
  show "poly_fun (\<lambda>x. - f x) \<longleftrightarrow> poly_fun f"
  proof
    assume "poly_fun (\<lambda>x. - f x)"
    hence "poly_fun (\<lambda>x. - (- f x))" by (rule poly_fun_uminus)
    thus "poly_fun f" by simp
  qed (rule poly_fun_uminus)
  thus "poly_fun (- f) \<longleftrightarrow> poly_fun f" by (simp only: fun_Compl_def)
qed

lemma poly_fun_plus [simp]:
  assumes "poly_fun f" and "poly_fun g"
  shows "poly_fun (\<lambda>x. f x + g x)"
proof -
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  from assms(2) obtain q where q: "\<And>a. rat_of_int (g a) = poly q (rat_of_int a)"
    by (rule poly_funE, blast)
  show ?thesis by (rule poly_funI[where p="p + q"]) (simp add: p q)
qed

lemma poly_fun_minus [simp]:
  assumes "poly_fun f" and "poly_fun g"
  shows "poly_fun (\<lambda>x. f x - g x)"
proof -
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  from assms(2) obtain q where q: "\<And>a. rat_of_int (g a) = poly q (rat_of_int a)"
    by (rule poly_funE, blast)
  show ?thesis by (rule poly_funI[where p="p - q"]) (simp add: p q)
qed

lemma poly_fun_times [simp]:
  assumes "poly_fun f" and "poly_fun g"
  shows "poly_fun (\<lambda>x. f x * g x)"
proof -
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  from assms(2) obtain q where q: "\<And>a. rat_of_int (g a) = poly q (rat_of_int a)"
    by (rule poly_funE, blast)
  show ?thesis by (rule poly_funI[where p="p * q"]) (simp add: p q)
qed

lemma poly_fun_divide:
  assumes "poly_fun f" and "\<And>a. c dvd f a"
  shows "poly_fun (\<lambda>x. f x div c)"
proof -
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  let ?p = "p * [:1 / rat_of_int c:]"
  show ?thesis
  proof (rule poly_funI)
    fix a
    have "c dvd f a" by fact
    hence "rat_of_int (f a div c) = rat_of_int (f a) / rat_of_int c" by auto
    also have "\<dots> = poly ?p (rat_of_int a)" by (simp add: p)
    finally show "rat_of_int (f a div c) = poly ?p (rat_of_int a)" .
  qed
qed

lemma poly_fun_pow [simp]:
  assumes "poly_fun f"
  shows "poly_fun (\<lambda>x. f x ^ k)"
proof -
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  show ?thesis by (rule poly_funI[where p="p ^ k"]) (simp add: p)
qed

lemma poly_fun_comp:
  assumes "poly_fun f" and "poly_fun g"
  shows "poly_fun (\<lambda>x. f (g x))" and "poly_fun (f \<circ> g)"
proof -
  from assms(1) obtain p where p: "\<And>a. rat_of_int (f a) = poly p (rat_of_int a)"
    by (rule poly_funE, blast)
  from assms(2) obtain q where q: "\<And>a. rat_of_int (g a) = poly q (rat_of_int a)"
    by (rule poly_funE, blast)
  show "poly_fun (\<lambda>x. f (g x))" by (rule poly_funI[where p="p \<circ>\<^sub>p q"]) (simp add: p q poly_pcompose)
  thus "poly_fun (f \<circ> g)" by (simp only: comp_def)
qed

lemma poly_fun_prod [simp]: "(\<And>i. i \<in> I \<Longrightarrow> poly_fun (f i)) \<Longrightarrow> poly_fun (\<lambda>x. (\<Prod>i\<in>I. f i x))"
proof (induct I rule: infinite_finite_induct)
  case (infinite I)
  from infinite(1) show ?case by simp
next
  case empty
  show ?case by simp
next
  case (insert i I)
  have "i \<in> insert i I" by simp
  hence "poly_fun (f i)" by (rule insert.prems)
  moreover have "poly_fun (\<lambda>x. \<Prod>i\<in>I. f i x)"
  proof (rule insert.hyps)
    fix j
    assume "j \<in> I"
    hence "j \<in> insert i I" by simp
    thus "poly_fun (f j)" by (rule insert.prems)
  qed
  ultimately have "poly_fun (\<lambda>x. f i x * (\<Prod>i\<in>I. f i x))" by (rule poly_fun_times)
  with insert.hyps(1, 2) show ?case by simp
qed

lemma poly_fun_pochhammer [simp]: "poly_fun f \<Longrightarrow> poly_fun (\<lambda>x. pochhammer (f x) k)"
  by (simp add: pochhammer_prod)

lemma poly_fun_gbinomial [simp]: "poly_fun f \<Longrightarrow> poly_fun (\<lambda>x. f x gchoose k)"
  by (simp add: gbinomial_int_pochhammer' poly_fun_divide fact_dvd_pochhammer)

end (* theory *)


section \<open>Some irrational numbers\<close>
text \<open>From Aigner and Ziegler, \emph{Proofs from THE BOOK} (Springer, 2018), Chapter 8, pp. 50--51.\<close>

theory Irrationals_From_THEBOOK imports "Stirling_Formula.Stirling_Formula"

begin

subsection \<open>Basic definitions and their consequences\<close>

definition hf where "hf \<equiv> \<lambda>n. \<lambda>x::real. (x^n * (1-x)^n) / fact n"

definition cf where "cf \<equiv> \<lambda>n i. if i < n then 0 else (n choose (i-n)) * (-1)^(i-n)"

text \<open>Mere knowledge that the coefficients are integers is not enough later on.\<close>
lemma hf_int_poly:
  fixes x::real
  shows "hf n = (\<lambda>x. (1 / fact n) * (\<Sum>i=0..2*n. real_of_int (cf n i) * x^i))"
proof
  fix x
  have inj: "inj_on ((+)n) {..n}"
    by (auto simp: inj_on_def)
  have [simp]: "((+)n) ` {..n} = {n..2*n}"
    using nat_le_iff_add by fastforce
  have "(x^n * (-x + 1)^n) = x ^ n * (\<Sum>k\<le>n. real (n choose k) * (- x) ^ k)"
    unfolding binomial_ring by simp
  also have "\<dots> = x ^ n * (\<Sum>k\<le>n. real_of_int ((n choose k) * (-1)^k) * x ^ k)"
    by (simp add: mult.assoc flip: power_minus)
  also have "\<dots> = (\<Sum>k\<le>n. real_of_int ((n choose k) * (-1)^k) * x ^ (n+k))"
    by (simp add: sum_distrib_left mult_ac power_add)
  also have "\<dots> = (\<Sum>i=n..2*n. real_of_int (cf n i) * x^i)"
    by (simp add: sum.reindex [OF inj, simplified] cf_def)
  finally have "hf n x = (1 / fact n) * (\<Sum>i = n..2 * n. real_of_int (cf n i) * x^i)"
    by (simp add: hf_def)
  moreover have "(\<Sum>i = 0..<n. real_of_int (cf n i) * x^i) = 0"
    by (simp add: cf_def)
  ultimately show "hf n x = (1 / fact n) * (\<Sum>i = 0..2 * n. real_of_int (cf n i) * x^i)"
    using sum.union_disjoint [of "{0..<n}" "{n..2*n}" "\<lambda>i. real_of_int (cf n i) * x^i"]
    by (simp add: ivl_disj_int_two(7) ivl_disj_un_two(7) mult_2)
qed

text \<open>Lemma (ii) in the text has strict inequalities, but that's more work and is less useful.\<close>
lemma
  assumes "0 \<le> x" "x \<le> 1"
  shows hf_nonneg: "0 \<le> hf n x" and hf_le_inverse_fact: "hf n x \<le> 1/fact n"
  using assms by (auto simp: hf_def divide_simps mult_le_one power_le_one)

lemma hf_differt [iff]: "hf n differentiable at x"
  unfolding hf_int_poly differentiable_def
  by (intro derivative_eq_intros exI | simp)+

lemma deriv_sum_int:
  "deriv (\<lambda>x. \<Sum>i=0..n. real_of_int (c i) * x^i) x
     = (if n=0 then 0 else (\<Sum>i=0..n - Suc 0. real_of_int ((int i + 1) * c (Suc i)) * x^i))"
  (is "deriv ?f x = (if n=0 then 0 else ?g)")
proof -
  have "(?f has_real_derivative ?g) (at x)" if "n > 0"
  proof -
    have "(\<Sum>i = 0..n. i * x ^ (i - Suc 0) * (c i))
        = (\<Sum>i = Suc 0..n. (real (i - Suc 0) + 1) * real_of_int (c i) * x ^ (i - Suc 0))"
      using that by (auto simp add: sum.atLeast_Suc_atMost intro!: sum.cong)
    also have "\<dots> = sum ((\<lambda>i. (real i + 1) * real_of_int (c (Suc i)) * x^i) \<circ> (\<lambda>n. n - Suc 0))
                     {Suc 0..Suc (n - Suc 0)}"
      using that by simp
    also have "\<dots> = ?g"
      by (simp flip: sum.atLeast_atMost_pred_shift [where m=0])
    finally have \<section>: "(\<Sum>a = 0..n. a * x ^ (a - Suc 0) * (c a)) = ?g" .
    show ?thesis
      by (rule derivative_eq_intros \<section> | simp)+
  qed
  then show ?thesis
    by (force intro: DERIV_imp_deriv)
qed

text \<open>We calculate the coefficients of the $k$th derivative precisely.\<close>
lemma hf_deriv_int_poly:
  "(deriv^^k) (hf n) = (\<lambda>x. (1/fact n) * (\<Sum>i=0..2*n-k. of_int (int(\<Prod>{i<..i+k}) * cf n (i+k)) * x^i))"
proof (induction k)
  case 0
  show ?case
    by (simp add: hf_int_poly)
next
  case (Suc k)
  define F where "F \<equiv> \<lambda>x. (\<Sum>i = 0..2*n - k. real_of_int (int(\<Prod>{i<..i+k}) * cf n (i+k)) * x^i)"
  have Fd: "F field_differentiable at x" for x
    unfolding field_differentiable_def F_def
    by (rule derivative_eq_intros exI | force)+
  have [simp]: "prod int {i<..Suc (i + k)} = (1 + int i) * prod int {Suc i<..Suc (i + k)}" for i
    by (metis Suc_le_mono atLeastSucAtMost_greaterThanAtMost le_add1 of_nat_Suc prod.head)
  have "deriv (\<lambda>x. F x / fact n) x
      = (\<Sum>i = 0..2 * n - Suc k. of_int (int(\<Prod>{i<..i+ Suc k}) * cf n (Suc (i+k))) * x^i) / fact n" for x
    unfolding deriv_cdivide_right [OF Fd]
    by (fastforce simp add: F_def deriv_sum_int cf_def simp flip: of_int_mult intro: sum.cong)
  then show ?case
    by (simp add: Suc F_def)
qed

lemma hf_deriv_0: "(deriv^^k) (hf n) 0 \<in> \<int>"
proof (cases "n \<le> k")
  case True
  then obtain j where "(fact k::real) = real_of_int j * fact n"
    by (metis fact_dvd dvd_def mult.commute of_int_fact of_int_mult)
  moreover have "prod real {0<..k} = fact k"
    by (simp add: fact_prod atLeastSucAtMost_greaterThanAtMost)
  ultimately show ?thesis
    by (simp add: hf_deriv_int_poly dvd_def)
next
  case False
  then show ?thesis
    by (simp add: hf_deriv_int_poly cf_def)
qed

lemma deriv_hf_minus: "deriv (hf n) = (\<lambda>x. - deriv (hf n) (1-x))"
proof
  fix x
  have "hf n = hf n \<circ> (\<lambda>x. (1-x))"
    by (simp add: fun_eq_iff hf_def mult.commute)
  then have "deriv (hf n) x = deriv (hf n \<circ> (\<lambda>x. (1-x))) x"
    by fastforce
  also have "\<dots> = deriv (hf n) (1-x) * deriv ((-) 1) x"
    by (intro real_derivative_chain) auto
  finally show "deriv (hf n) x = - deriv (hf n) (1-x)"
    by simp
qed

lemma deriv_n_hf_diffr [iff]: "(deriv^^k) (hf n) field_differentiable at x"
  unfolding field_differentiable_def hf_deriv_int_poly
  by (rule derivative_eq_intros exI | force)+

lemma deriv_n_hf_minus: "(deriv^^k) (hf n) = (\<lambda>x. (-1)^k * (deriv^^k) (hf n) (1-x))"
proof (induction k)
  case 0
  then show ?case
    by (simp add: fun_eq_iff hf_def)
next
  case (Suc k)
  have o: "(\<lambda>x. (deriv ^^ k) (hf n) (1-x)) = (deriv ^^ k) (hf n) \<circ> (-) 1"
    by auto
  show ?case
  proof
    fix x
    have [simp]: "((deriv^^k) (hf n) \<circ> (-) 1) field_differentiable at x"
      by (force intro: field_differentiable_compose)
    have "(deriv ^^ Suc k) (hf n) x = deriv (\<lambda>x. (-1) ^ k * (deriv ^^ k) (hf n) (1-x)) x"
      by simp (metis Suc)
    also have "\<dots> = (-1) ^ k * deriv (\<lambda>x. (deriv ^^ k) (hf n) (1-x)) x"
      using o by fastforce
    also have "\<dots> = (-1) ^ Suc k * (deriv ^^ Suc k) (hf n) (1-x)"
      by (subst o, subst deriv_chain, auto)
    finally show "(deriv ^^ Suc k) (hf n) x = (-1) ^ Suc k * (deriv ^^ Suc k) (hf n) (1-x)" .
  qed
qed

subsection \<open>Towards the main result\<close>

lemma hf_deriv_1: "(deriv^^k) (hf n) 1 \<in> \<int>"
  by (smt (verit, best) Ints_1 Ints_minus Ints_mult Ints_power deriv_n_hf_minus hf_deriv_0)

lemma hf_deriv_eq_0: "k > 2*n \<Longrightarrow> (deriv^^k) (hf n) = (\<lambda>x. 0)"
  by (force simp add: cf_def hf_deriv_int_poly)

text \<open>The case for positive integers\<close>
lemma exp_nat_irrational:
  assumes "s > 0" shows "exp (real_of_int s) \<notin> \<rat>"
proof
  assume "exp (real_of_int s) \<in> \<rat>"
  then obtain a b where ab: "a > 0" "b > 0" "coprime a b" and exp_s: "exp s = of_int a / of_int b"
    by (smt (verit) Rats_cases' divide_nonpos_pos exp_gt_zero of_int_0_less_iff)
  define n where "n \<equiv> nat (max (a^2) (3 * s^3))"
  then have ns3: "s^3 \<le> real n / 3"
    by linarith
  have "n > 0"
    using \<open>a > 0\<close> by (simp add: n_def max.strict_coboundedI1)
  then have "s ^ (2*n+1) \<le> s ^ (3*n)"
    using \<open>a > 0\<close> assms by (intro power_increasing) auto
  also have "\<dots> = real_of_int(s^3) ^ n"
    by (simp add: power_mult)
  also have "\<dots> \<le> (n / 3) ^ n"
    using assms ns3 by (simp add: power_mono)
  also have "\<dots> \<le> (n / exp 1) ^ n"
    using exp_le \<open>n > 0\<close> by (auto simp add: divide_simps)
  finally have s_le: "s ^ (2*n+1) \<le> (n / exp 1) ^ n"
    by presburger
  have a_less: "a < sqrt (2*pi*n)"
  proof -
    have "2*pi > 1"
      using pi_ge_two by linarith
    have "a \<le> sqrt n"
      using \<open>0 < n\<close> n_def of_nat_nat real_le_rsqrt by fastforce
    also have "\<dots> < sqrt (2*pi*n)"
      by (simp add: \<open>0 < n\<close> \<open>1 < 2 * pi\<close>)
    finally show ?thesis .
  qed
  have "sqrt (2*pi*n) * (n / exp 1) ^ n > a * s ^ (2*n+1)"
    using mult_strict_right_mono [OF a_less] mult_left_mono [OF s_le]
    by (smt (verit, best) s_le ab(1) assms of_int_1 of_int_le_iff of_int_mult zero_less_power)
  then have n: "fact n > a * s ^ (2*n+1)"
    using fact_bounds(1) by (smt (verit, best) \<open>0 < n\<close> of_int_fact of_int_less_iff)
  define F where "F \<equiv> \<lambda>x. \<Sum>i\<le>2*n. (-1)^i * s^(2*n-i) * (deriv^^i) (hf n) x"
  have Fder: "(F has_real_derivative -s * F x + s^(2*n+1) * hf n x) (at x)" for x
  proof -
    have *: "sum f {..n+n} = sum f {..<n+n}" if "f (n+n) = 0" for f::"nat \<Rightarrow> real"
      by (smt (verit, best) lessThan_Suc_atMost sum.lessThan_Suc that)
    have [simp]: "(deriv ((deriv ^^ (n+n)) (hf n)) x) = 0"
      using hf_deriv_eq_0 [where k= "Suc(n+n)"] by simp
    have \<section>: "(\<Sum>k\<le>n+n. (-1) ^ k * ((deriv ^^ Suc k) (hf n) x * of_int s ^ (n+n - k)))
           + s * (\<Sum>j=0..n+n. (-1) ^ j * ((deriv ^^ j) (hf n) x * of_int s ^ (n+n - j)))
           = s * (hf n x * of_int s ^ (n+n))"
      using \<open>n>0\<close>
      apply (subst sum_Suc_reindex)
      apply (simp add: algebra_simps atLeast0AtMost)
      apply (force simp add: * mult.left_commute [of "of_int s"] minus_nat.diff_Suc sum_distrib_left
              simp flip: sum.distrib intro: comm_monoid_add_class.sum.neutral split: nat.split_asm)
      done
    show ?thesis
      unfolding F_def
      apply (rule derivative_eq_intros field_differentiable_derivI | simp)+
      using \<section> by (simp add: algebra_simps atLeast0AtMost eval_nat_numeral)
  qed
  have F01_Ints: "F 0 \<in> \<int>" "F 1 \<in> \<int>"
    by (simp_all add: F_def hf_deriv_0 hf_deriv_1 Ints_sum)
  define sF where "sF \<equiv> \<lambda>x. exp (of_int s * x) * F x"
  define sF' where "sF' \<equiv> \<lambda>x. of_int s ^ Suc(2*n) * (exp (of_int s * x) * hf n x)"
  have sF_der: "(sF has_real_derivative sF' x) (at x)" for x
    unfolding sF_def sF'_def
    by (rule refl Fder derivative_eq_intros | force simp: algebra_simps)+
  let ?N = "b * integral {0..1} sF'"
  have sF'_integral: "(sF' has_integral sF 1 - sF 0) {0..1}"
    by (smt (verit) fundamental_theorem_of_calculus has_real_derivative_iff_has_vector_derivative
                    has_vector_derivative_at_within sF_der)
  then have "?N = a * F 1 - b * F 0"
    using \<open>b > 0\<close> by (simp add: integral_unique exp_s sF_def algebra_simps)
  also have "\<dots> \<in> \<int>"
    using hf_deriv_1 by (simp add: F01_Ints)
  finally have N_Ints: "?N \<in> \<int>" .
  have "sF' (1/2) > 0" and ge0: "\<And>x. x \<in> {0..1} \<Longrightarrow> 0 \<le> sF' x"
    using assms by (auto simp add: sF'_def hf_def)
  moreover have "continuous_on {0..1} sF'"
    unfolding sF'_def hf_def by (intro continuous_intros) auto
  ultimately have False if "(sF' has_integral 0) {0..1}"
    using has_integral_0_cbox_imp_0 [of 0 1 sF' "1/2"] that by auto
  then have "integral {0..1} sF' > 0"
    by (metis ge0 has_integral_nonneg integral_unique order_le_less sF'_integral)
  then have "0 < ?N"
    by (simp add: \<open>b > 0\<close>)
  have "integral {0..1} sF' = of_int s ^ Suc(2*n) * integral {0..1} (\<lambda>x. exp (s*x) * hf n x)"
    unfolding sF'_def by force
  also have "\<dots> \<le> of_int s ^ Suc(2*n) * (exp s * (1 / fact n))"
  proof (rule mult_left_mono)
    have "integral {0..1} (\<lambda>x. exp (s*x) * hf n x) \<le> integral {0..1} (\<lambda>x::real. exp s * (1/fact n))"
    proof (intro mult_mono integral_le)
      show "(\<lambda>x. exp (s*x) * hf n x) integrable_on {0..1}"
        using \<open>0 < ?N\<close> not_integrable_integral sF'_def by fastforce
    qed (use assms hf_nonneg hf_le_inverse_fact in auto)
    also have "\<dots> = exp s * (1 / fact n)"
      by simp
    finally show "integral {0..1} (\<lambda>x. exp (s*x) * hf n x) \<le> exp s * (1 / fact n)" .
  qed (use assms in auto)
  finally have "?N \<le> b * of_int s ^ Suc(2*n) * exp s * (1 / fact n)"
    using \<open>b > 0\<close> by (simp add: sF'_def mult_ac divide_simps)
  also have "\<dots> < 1"
    using n apply (simp add: field_simps exp_s)
    by (metis of_int_fact of_int_less_iff of_int_mult of_int_power)
  finally show False
    using \<open>0 < ?N\<close> Ints_cases N_Ints by force
qed

theorem exp_irrational:
  fixes q::real assumes "q \<in> \<rat>" "q \<noteq> 0" shows "exp q \<notin> \<rat>"
proof
  assume q: "exp q \<in> \<rat>"
  obtain s t where "s \<noteq> 0" "t > 0" "q = of_int s / of_int t"
    by (metis Rats_cases' assms div_0 of_int_0)
  then have "(exp q) ^ (nat t) = exp s"
    by (smt (verit, best) exp_divide_power_eq of_nat_nat zero_less_nat_eq)
  moreover have "exp q ^ (nat t) \<in> \<rat>"
    by (simp add: q)
  ultimately show False
    by (smt (verit, del_insts) Rats_inverse \<open>s \<noteq> 0\<close> exp_minus exp_nat_irrational of_int_of_nat)
qed

corollary ln_irrational:
  fixes q::real assumes "q \<in> \<rat>" "q > 0"  "q \<noteq> 1" shows "ln q \<notin> \<rat>"
  using assms exp_irrational [of "ln q"] exp_ln_iff [of q] by force

end


(*
  File:     KD_Tree.thy
  Author:   Martin Rau, TU München
*)

section "Definition of the \<open>k\<close>-d Tree"

theory KD_Tree
imports
  Complex_Main
  "HOL-Analysis.Finite_Cartesian_Product"
  "HOL-Analysis.Topology_Euclidean_Space"
begin

text \<open>
  A \<open>k\<close>-d tree is a space-partitioning data structure for organizing points in a \<open>k\<close>-dimensional space.
  In principle the \<open>k\<close>-d tree is a binary tree. The leafs hold the \<open>k\<close>-dimensional points and the nodes
  contain left and right subtrees as well as a discriminator \<open>v\<close> at a particular axis \<open>k\<close>.
  Every node divides the space into two parts by splitting along a hyperplane.
  Consider a node \<open>n\<close> with associated discriminator \<open>v\<close> at axis \<open>k\<close>.
  All points in the left subtree must have a value at axis \<open>k\<close> that is less than or
  equal to \<open>v\<close> and all points in the right subtree must have a value at axis \<open>k\<close> that is
  greater than \<open>v\<close>.

  Deviations from the papers:

  The chosen tree representation is taken from \<^cite>\<open>"DBLP:journals/toms/FriedmanBF77"\<close> with one minor
  adjustment. Originally the leafs hold buckets of points of size \<open>b\<close>. This representation fixes the
  bucket size to \<open>b = 1\<close>, a single point per Leaf. This is only a minor adjustment since the paper
  proves that \<open>b = 1\<close> is the optimal bucket size for minimizing the running time of the nearest neighbor
  algorithm \<^cite>\<open>"DBLP:journals/toms/FriedmanBF77"\<close>, only simplifies building the optimized
  \<open>k\<close>-d trees \<^cite>\<open>"DBLP:journals/toms/FriedmanBF77"\<close> and has little influence on the
  search algorithm \<^cite>\<open>"DBLP:journals/cacm/Bentley75"\<close>.
\<close>

type_synonym 'k point = "(real, 'k) vec"

lemma dist_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "dist p\<^sub>0 p\<^sub>1 = sqrt (\<Sum>k \<in> UNIV. (p\<^sub>0$k - p\<^sub>1$k)\<^sup>2)"
  unfolding dist_vec_def L2_set_def dist_real_def by simp

datatype 'k kdt =
  Leaf "'k point"
| Node 'k real "'k kdt" "'k kdt"

subsection \<open>Definition of the \<open>k\<close>-d Tree Invariant and Related Functions\<close>

fun set_kdt :: "'k kdt \<Rightarrow> ('k point) set" where
  "set_kdt (Leaf p) = { p }"
| "set_kdt (Node _ _ l r) = set_kdt l \<union> set_kdt r"

definition spread :: "('k::finite) \<Rightarrow> 'k point set \<Rightarrow> real" where
  "spread k P = (if P = {} then 0 else let V = (\<lambda>p. p$k) ` P in Max V - Min V)"

definition widest_spread_axis :: "('k::finite) \<Rightarrow> 'k set \<Rightarrow> 'k point set \<Rightarrow> bool" where
  "widest_spread_axis k K ps \<longleftrightarrow> (\<forall>k' \<in> K. spread k' ps \<le> spread k ps)"

fun invar :: "('k::finite) kdt \<Rightarrow> bool" where
  "invar (Leaf p) \<longleftrightarrow> True"
| "invar (Node k v l r) \<longleftrightarrow> (\<forall>p \<in> set_kdt l. p$k \<le> v) \<and> (\<forall>p \<in> set_kdt r. v < p$k) \<and>
    widest_spread_axis k UNIV (set_kdt l \<union> set_kdt r) \<and> invar l \<and> invar r"

fun size_kdt :: "'k kdt \<Rightarrow> nat" where
  "size_kdt (Leaf _) = 1"
| "size_kdt (Node _ _ l r) = size_kdt l + size_kdt r"

fun height :: "'k kdt \<Rightarrow> nat" where
  "height (Leaf _) = 0"
| "height (Node _ _ l r) = max (height l) (height r) + 1"

fun min_height :: "'k kdt \<Rightarrow> nat" where
  "min_height (Leaf _) = 0"
| "min_height (Node _ _ l r) = min (min_height l) (min_height r) + 1"

definition balanced :: "'k kdt \<Rightarrow> bool" where
  "balanced kdt \<longleftrightarrow> height kdt - min_height kdt \<le> 1"

fun complete :: "'k kdt \<Rightarrow> bool" where
  "complete (Leaf _) = True"
| "complete (Node _ _ l r) \<longleftrightarrow> complete l \<and> complete r \<and> height l = height r"

lemma invar_r:
  "invar (Node k v l r) \<Longrightarrow> invar r"
  by simp

lemma invar_l_le_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt l. p$k \<le> v"
  by simp

lemma invar_r_ge_k:
  "invar (Node k v l r) \<Longrightarrow> \<forall>p \<in> set_kdt r. v < p$k"
  by simp

lemma invar_set:
  "set_kdt (Node k v l r) = set_kdt l \<union> set_kdt r"
  by simp

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree\<close> to \<open>k\<close>-d Tree\<close>

lemma size_ge0[simp]:
  "0 < size_kdt kdt"
  by (induction kdt) auto

lemma eq_size_1[simp]:
  "size_kdt kdt = 1 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  apply (induction kdt)
  apply (auto)
  using size_ge0 nat_less_le apply blast+
  done

lemma eq_1_size[simp]:
  "1 = size_kdt kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  using eq_size_1 by metis

lemma neq_Leaf_iff:
  "(\<nexists>p. kdt = Leaf p) = (\<exists>k v l r. kdt = Node k v l r)"
  by (cases kdt) auto

lemma eq_height_0[simp]:
  "height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_height[simp]:
  "0 = height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_min_height_0[simp]:
  "min_height kdt = 0 \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma eq_0_min_height[simp]:
  "0 = min_height kdt \<longleftrightarrow> (\<exists>p. kdt = Leaf p)"
  by (cases kdt) auto

lemma size_height:
  "size_kdt kdt \<le> 2 ^ height kdt"
proof(induction kdt)
  case (Node k v l r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height r + 2 ^ height r" using True by simp
    also have "\<dots> = 2 ^ height (Node k v l r)"
      using True by (auto simp: max_def mult_2)
    finally show ?thesis .
  next
    case False
    have "size_kdt (Node k v l r) = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r" using Node.IH by arith
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

lemma min_height_le_height:
  "min_height kdt \<le> height kdt"
  by (induction kdt) auto

lemma min_height_size:
  "2 ^ min_height kdt \<le> size_kdt kdt"
proof(induction kdt)
  case (Node k v l r)
  have "(2::nat) ^ min_height (Node k v l r) \<le> 2 ^ min_height l + 2 ^ min_height r"
    by (simp add: min_def)
  also have "\<dots> \<le> size_kdt (Node k v l r)" using Node.IH by simp
  finally show ?case .
qed simp

lemma complete_iff_height:
  "complete kdt \<longleftrightarrow> (min_height kdt = height kdt)"
  apply (induction kdt)
  apply simp
  apply (simp add: min_def max_def)
  by (metis le_antisym le_trans min_height_le_height)

lemma size_if_complete:
  "complete kdt \<Longrightarrow> size_kdt kdt = 2 ^ height kdt"
  by (induction kdt) auto

lemma complete_if_size_height:
  "size_kdt kdt = 2 ^ height kdt \<Longrightarrow> complete kdt"
proof (induction "height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "height l \<le> h" and 2: "height r \<le> h" using Suc(2) by(auto)
  have 3: "\<not> height l < h"
  proof
    assume 0: "height l < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ h + 2 ^ height r" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 2 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  have 4: "\<not> height r < h"
  proof
    assume 0: "height r < h"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also have "\<dots> \<le> 2 ^ height l + 2 ^ height r"
      using size_height[of l] size_height[of r] by arith
    also have " \<dots> < 2 ^ height l + 2 ^ h" using 0 by (simp)
    also have " \<dots> \<le> 2 ^ h + 2 ^ h" using 1 by (simp)
    also have "\<dots> = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally have "size_kdt kdt < size_kdt kdt" .
    thus False by (simp)
  qed
  from 1 2 3 4 have *: "height l = h" "height r = h" by linarith+
  hence "size_kdt l = 2 ^ height l" "size_kdt r = 2 ^ height r"
    using Suc(3) size_height[of l] size_height[of r] by (auto)
  with * Suc(1) show ?case by simp
qed

lemma complete_if_size_min_height:
  "size_kdt kdt = 2 ^ min_height kdt \<Longrightarrow> complete kdt"
proof (induct "min_height kdt" arbitrary: kdt)
  case 0 thus ?case by auto
next
  case (Suc h)
  hence "\<nexists>p. kdt = Leaf p"
    by auto
  then obtain k v l r where [simp]: "kdt = Node k v l r"
    using neq_Leaf_iff by metis
  have 1: "h \<le> min_height l" and 2: "h \<le> min_height r" using Suc(2) by (auto)
  have 3: "\<not> h < min_height l"
  proof
    assume 0: "h < min_height l"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height l > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height r \<ge> 2 ^ h" using 2 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  have 4: "\<not> h < min_height r"
  proof
    assume 0: "h < min_height r"
    have "size_kdt kdt = size_kdt l + size_kdt r" by simp
    also note min_height_size[of l]
    also(xtrans) note min_height_size[of r]
    also(xtrans) have "(2::nat) ^ min_height r > 2 ^ h"
        using 0 by (simp add: diff_less_mono)
    also(xtrans) have "(2::nat) ^ min_height l \<ge> 2 ^ h" using 1 by simp
    also(xtrans) have "(2::nat) ^ h + 2 ^ h = 2 ^ (Suc h)" by (simp)
    also have "\<dots> = size_kdt kdt" using Suc(2,3) by simp
    finally show False by (simp add: diff_le_mono)
  qed
  from 1 2 3 4 have *: "min_height l = h" "min_height r = h" by linarith+
  hence "size_kdt l = 2 ^ min_height l" "size_kdt r = 2 ^ min_height r"
    using Suc(3) min_height_size[of l] min_height_size[of r] by (auto)
  with * Suc(1) show ?case
    by (simp add: complete_iff_height)
qed

lemma complete_iff_size:
  "complete kdt \<longleftrightarrow> size_kdt kdt = 2 ^ height kdt"
  using complete_if_size_height size_if_complete by blast

lemma size_height_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> size_kdt kdt < 2 ^ height kdt"
  by (meson antisym_conv complete_iff_size not_le size_height)

lemma min_height_size_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> 2 ^ min_height kdt < size_kdt kdt"
  by (metis complete_if_size_min_height le_less min_height_size)

lemma balanced_subtreeL:
  "balanced (Node k v l r) \<Longrightarrow> balanced l"
  by (simp add: balanced_def)

lemma balanced_subtreeR:
  "balanced (Node k v l r) \<Longrightarrow> balanced r"
  by (simp add: balanced_def)

lemma balanced_optimal:
  assumes "balanced kdt" "size_kdt kdt \<le> size_kdt kdt'"
  shows "height kdt \<le> height kdt'"
proof (cases "complete kdt")
  case True
  have "(2::nat) ^ height kdt \<le> 2 ^ height kdt'"
  proof -
    have "2 ^ height kdt = size_kdt kdt"
      using True by (simp add: complete_iff_height size_if_complete)
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'" by (rule size_height)
    finally show ?thesis .
  qed
  thus ?thesis by (simp)
next
  case False
  have "(2::nat) ^ min_height kdt < 2 ^ height kdt'"
  proof -
    have "(2::nat) ^ min_height kdt < size_kdt kdt"
      by(rule min_height_size_if_incomplete[OF False])
    also have "\<dots> \<le> size_kdt kdt'" using assms(2) by simp
    also have "\<dots> \<le> 2 ^ height kdt'"  by(rule size_height)
    finally have "(2::nat) ^ min_height kdt < (2::nat) ^ height kdt'" .
    thus ?thesis .
  qed
  hence *: "min_height kdt < height kdt'" by simp
  have "min_height kdt + 1 = height kdt"
    using min_height_le_height[of kdt] assms(1) False
    by (simp add: complete_iff_height balanced_def)
  with * show ?thesis by arith
qed

subsection \<open>Lemmas adapted from \<open>HOL-Library.Tree_Real\<close> to \<open>k\<close>-d Tree\<close>

lemma size_height_log:
  "log 2 (size_kdt kdt) \<le> height kdt"
  by (simp add: log2_of_power_le size_height)

lemma min_height_size_log:
  "min_height kdt \<le> log 2 (size_kdt kdt)"
  by (simp add: le_log2_of_power min_height_size)

lemma size_log_if_complete:
  "complete kdt \<Longrightarrow> height kdt = log 2 (size_kdt kdt)"
  using complete_iff_size log2_of_power_eq by blast

lemma min_height_size_log_if_incomplete:
  "\<not> complete kdt \<Longrightarrow> min_height kdt < log 2 (size_kdt kdt)"
  by (simp add: less_log2_of_power min_height_size_if_incomplete)

lemma min_height_balanced:
  assumes "balanced kdt"
  shows "min_height kdt = nat(floor(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ min_height kdt"
    by (simp add: complete_iff_height size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis by linarith
next
  assume *: "\<not> complete kdt"
  hence "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt < 2 ^ (min_height kdt + 1)"
    by (metis * size_height_if_incomplete)
  hence "log 2 (size_kdt kdt) < min_height kdt + 1"
    using log2_of_power_less size_ge0 by blast
  thus ?thesis using min_height_size_log[of kdt] by linarith
qed

lemma height_balanced:
  assumes "balanced kdt"
  shows "height kdt = nat(ceiling(log 2 (size_kdt kdt)))"
proof cases
  assume *: "complete kdt"
  hence "size_kdt kdt = 2 ^ height kdt"
    by (simp add: size_if_complete)
  from log2_of_power_eq[OF this] show ?thesis
    by linarith
next
  assume *: "\<not> complete kdt"
  hence **: "height kdt = min_height kdt + 1"
    using assms min_height_le_height[of kdt]
    by(auto simp add: balanced_def complete_iff_height)
  hence "size_kdt kdt \<le> 2 ^ (min_height kdt + 1)" by (metis size_height)
  from  log2_of_power_le[OF this size_ge0] min_height_size_log_if_incomplete[OF *] **
  show ?thesis by linarith
qed

lemma balanced_Node_if_wbal1:
  assumes "balanced l" "balanced r" "size_kdt l = size_kdt r + 1"
  shows "balanced (Node k v l r)"
proof -
  from assms(3) have [simp]: "size_kdt l = size_kdt r + 1" by simp
  have "nat \<lceil>log 2 (1 + size_kdt r)\<rceil> \<ge> nat \<lceil>log 2 (size_kdt r)\<rceil>"
    by(rule nat_mono[OF ceiling_mono]) simp
  hence 1: "height(Node k v l r) = nat \<lceil>log 2 (1 + size_kdt r)\<rceil> + 1"
    using height_balanced[OF assms(1)] height_balanced[OF assms(2)]
    by (simp del: nat_ceiling_le_eq add: max_def)
  have "nat \<lfloor>log 2 (1 + size_kdt r)\<rfloor> \<ge> nat \<lfloor>log 2 (size_kdt r)\<rfloor>"
    by(rule nat_mono[OF floor_mono]) simp
  hence 2: "min_height(Node k v l r) = nat \<lfloor>log 2 (size_kdt r)\<rfloor> + 1"
    using min_height_balanced[OF assms(1)] min_height_balanced[OF assms(2)]
    by (simp)
  have "size_kdt r \<ge> 1" by (simp add: Suc_leI)
  then obtain i where i: "2 ^ i \<le> size_kdt r" "size_kdt r < 2 ^ (i + 1)"
    using ex_power_ivl1[of 2 "size_kdt r"] by auto
  hence i1: "2 ^ i < size_kdt r + 1" "size_kdt r + 1 \<le> 2 ^ (i + 1)" by auto
  from 1 2 floor_log_nat_eq_if[OF i] ceiling_log_nat_eq_if[OF i1]
  show ?thesis by(simp add:balanced_def)
qed

lemma balanced_sym:
  "balanced (Node k v l r) \<Longrightarrow> balanced (Node k' v' r l)"
  by (auto simp: balanced_def)

lemma balanced_Node_if_wbal2:
  assumes "balanced l" "balanced r" "abs(int(size_kdt l) - int(size_kdt r)) \<le> 1"
  shows "balanced (Node k v l r)"
proof -
  have "size_kdt l = size_kdt r \<or> (size_kdt l = size_kdt r + 1 \<or> size_kdt r = size_kdt l + 1)" (is "?A \<or> ?B")
    using assms(3) by linarith
  thus ?thesis
  proof
    assume "?A"
    thus ?thesis using assms(1,2)
      apply(simp add: balanced_def min_def max_def)
      by (metis assms(1,2) balanced_optimal le_antisym le_less)
  next
    assume "?B"
    thus ?thesis
      by (meson assms(1,2) balanced_sym balanced_Node_if_wbal1)
  qed
qed

end


(*  Title:      HOL/Induct/Sigma_Algebra.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Sigma algebras\<close>

theory Sigma_Algebra
imports Main
begin

text \<open>
  This is just a tiny example demonstrating the use of inductive
  definitions in classical mathematics.  We define the least \<open>\<sigma>\<close>-algebra over a given set of sets.
\<close>

inductive_set \<sigma>_algebra :: "'a set set \<Rightarrow> 'a set set" for A :: "'a set set"
where
  basic: "a \<in> \<sigma>_algebra A" if "a \<in> A" for a
| UNIV: "UNIV \<in> \<sigma>_algebra A"
| complement: "- a \<in> \<sigma>_algebra A" if "a \<in> \<sigma>_algebra A" for a
| Union: "(\<Union>i. a i) \<in> \<sigma>_algebra A" if "\<And>i::nat. a i \<in> \<sigma>_algebra A" for a

text \<open>
  The following basic facts are consequences of the closure properties
  of any \<open>\<sigma>\<close>-algebra, merely using the introduction rules, but
  no induction nor cases.
\<close>

theorem sigma_algebra_empty: "{} \<in> \<sigma>_algebra A"
proof -
  have "UNIV \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.UNIV)
  then have "-UNIV \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  also have "-UNIV = {}" by simp
  finally show ?thesis .
qed

theorem sigma_algebra_Inter:
  "(\<And>i::nat. a i \<in> \<sigma>_algebra A) \<Longrightarrow> (\<Inter>i. a i) \<in> \<sigma>_algebra A"
proof -
  assume "\<And>i::nat. a i \<in> \<sigma>_algebra A"
  then have "\<And>i::nat. -(a i) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  then have "(\<Union>i. -(a i)) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.Union)
  then have "-(\<Union>i. -(a i)) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  also have "-(\<Union>i. -(a i)) = (\<Inter>i. a i)" by simp
  finally show ?thesis .
qed

end


text\<open> 12 November 2021: Exercises for Homework 10 in CS 511 \<close>
text\<open> Your task to remove the invocations of the pre-defined method
      'blast' by an equivalent sequence of 'apply' steps \<close>

theory HW10
  imports Main
begin

text\<open> 'blast' is invoked four times, once in the proof of each of
      lemmas E1, F1, G1, and H1 below \<close>

(* lemma E1 is the same in Exercise 2.3.9 (e), page 161, in [LCS] *)
lemma E1 : "\<forall> x. (P x \<or> Q x) \<Longrightarrow> (\<forall> x. P x) \<or> (\<exists> x. Q x)"
  apply (rule disjCI)
  apply (rule allI)
  apply (erule_tac x="x" in allE)
  apply (erule disjE)
   apply assumption
  apply (erule notE)
  apply (rule exI)
  apply assumption
  done

(* lemma F1 is the same in Exercise 2.3.9 (f), page 161, in [LCS] *)
lemma F1 : "\<forall> x. \<exists> y. (P x \<or> Q y) \<Longrightarrow> \<exists> y. \<forall> x. (P x \<or> Q y)"
  apply (rule exCI, rule allI)
  apply (erule_tac x="x" in allE)
  apply (rotate_tac 1, erule exE)
  apply (erule_tac x="y" in allE)
  apply (erule disjE, rule disjI1, assumption)
  apply (rule disjI2, erule notE, rule allI)
  apply (rule disjI2, assumption)
  done

(* lemma G1 is the same in Exercise 2.3.9 (g), page 161, in [LCS] *)
lemma G1 : "\<forall> x. (\<not> P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x \<longrightarrow> Q x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x="x" in allE)
  apply (erule conjE)
  apply assumption
  done

(* lemma H1 is the same in Exercise 2.3.9 (h), page 161, in [LCS] *)
lemma H1 : "\<forall> x. (P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x \<longrightarrow> Q x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x="x" in allE)
  apply (erule conjE)
  apply assumption
  done

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) z = nil2"
| "zip (cons2 z2 x2) (nil2) = nil2"
| "zip (cons2 z2 x2) (cons2 x3 x4) =
     cons2 (pair2 z2 x3) (zip x2 x4)"

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

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

theorem property0 :
  "((zip (x xs ys) zs) =
      (x (zip xs (take (len xs) zs)) (zip ys (drop (len xs) zs))))"
  oops

end


(*  Title:      HOL/Library/List_Lexorder.thy
    Author:     Norbert Voelker
*)

section \<open>Lexicographic order on lists\<close>

theory List_Lexorder
imports Main
begin

instantiation list :: (ord) ord
begin

definition
  list_less_def: "xs < ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

definition
  list_le_def: "(xs :: _ list) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance list :: (order) order
proof
  let ?r = "{(u, v::'a). u < v}"
  have tr: "trans ?r"
    using trans_def by fastforce
  have \<section>: False
    if "(xs,ys) \<in> lexord ?r" "(ys,xs) \<in> lexord ?r" for xs ys :: "'a list"
  proof -
    have "(xs,xs) \<in> lexord ?r"
      using that transD [OF lexord_transI [OF tr]] by blast
    then show False
      by (meson case_prodD lexord_irreflexive less_irrefl mem_Collect_eq)
  qed
  show "xs \<le> xs" for xs :: "'a list" by (simp add: list_le_def)
  show "xs \<le> zs" if "xs \<le> ys" and "ys \<le> zs" for xs ys zs :: "'a list"
    using that transD [OF lexord_transI [OF tr]] by (auto simp add: list_le_def list_less_def)
  show "xs = ys" if "xs \<le> ys" "ys \<le> xs" for xs ys :: "'a list"
    using \<section> that list_le_def list_less_def by blast
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs" for xs ys :: "'a list"
    by (auto simp add: list_less_def list_le_def dest: \<section>)
qed

instance list :: (linorder) linorder
proof
  fix xs ys :: "'a list"
  have "total (lexord {(u, v::'a). u < v})"
    by (rule total_lexord) (auto simp: total_on_def)
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: total_on_def list_le_def list_less_def)
qed

instantiation list :: (linorder) distrib_lattice
begin

definition "(inf :: 'a list \<Rightarrow> _) = min"

definition "(sup :: 'a list \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_list_def sup_list_def max_min_distrib2)

end

lemma not_less_Nil [simp]: "\<not> x < []"
  by (simp add: list_less_def)

lemma Nil_less_Cons [simp]: "[] < a # x"
  by (simp add: list_less_def)

lemma Cons_less_Cons [simp]: "a # x < b # y \<longleftrightarrow> a < b \<or> a = b \<and> x < y"
  by (simp add: list_less_def)

lemma le_Nil [simp]: "x \<le> [] \<longleftrightarrow> x = []"
  unfolding list_le_def by (cases x) auto

lemma Nil_le_Cons [simp]: "[] \<le> x"
  unfolding list_le_def by (cases x) auto

lemma Cons_le_Cons [simp]: "a # x \<le> b # y \<longleftrightarrow> a < b \<or> a = b \<and> x \<le> y"
  unfolding list_le_def by auto

instantiation list :: (order) order_bot
begin

definition "bot = []"

instance
  by standard (simp add: bot_list_def)

end

lemma less_list_code [code]:
  "xs < ([]::'a::{equal, order} list) \<longleftrightarrow> False"
  "[] < (x::'a::{equal, order}) # xs \<longleftrightarrow> True"
  "(x::'a::{equal, order}) # xs < y # ys \<longleftrightarrow> x < y \<or> x = y \<and> xs < ys"
  by simp_all

end