theory heap_insert
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil2

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

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

fun listInsert :: "Nat => Nat list => Nat list" where
"listInsert x (list.Nil2) = Cons2 x (list.Nil2)"
| "listInsert x (Cons2 z ys) =
     (if le x z then Cons2 x (Cons2 z ys) else
        Cons2 z (listInsert x ys))"

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

fun toList :: "Nat => Heap => Nat list" where
"toList (Z) y = list.Nil2"
| "toList (S z) (Node x2 x3 x4) =
     Cons2 x3 (toList z (merge x2 x4))"
| "toList (S z) (Heap.Nil2) = list.Nil2"

fun insert2 :: "Nat => Heap => Heap" where
"insert2 x y = merge (Node Nil2 x Nil2) y"

fun heapSize :: "Heap => Nat" where
"heapSize (Node l y r) = S (plus (heapSize l) (heapSize r))"
| "heapSize (Nil2) = Z"

fun toList2 :: "Heap => Nat list" where
"toList2 x = toList (heapSize x) x"

(*hipster plus
          le
          listInsert
          merge
          toList
          insert2
          heapSize
          toList2 *)

theorem x0 :
  "!! (x :: Nat) (h :: Heap) .
     (toList2 (insert2 x h)) = (listInsert x (toList2 h))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Multigraph
  imports
    Main
begin

type_synonym ('a, 'b) edge = "'a \<times> 'b set"

type_synonym ('a, 'b) multigraph = "('a, 'b) edge set"

definition endpoints :: "('a, 'b) edge \<Rightarrow> 'b set" where
  "endpoints \<equiv> snd"

lemma mem_endpoints_iff:
  shows "e \<in> endpoints ` G \<longleftrightarrow> (\<exists>\<epsilon>. (\<epsilon>, e) \<in> G)"
  by (force simp add: endpoints_def)

definition V :: "('a, 'b) multigraph \<Rightarrow> 'b set" where
  "V G \<equiv> \<Union> (endpoints ` G)"

lemma mem_VI:
  assumes "(\<epsilon>, {u, v}) \<in> G"
  shows
    "u \<in> V G"
    "v \<in> V G"
  using assms
  by (force simp add: V_def endpoints_def)+

lemma mem_VI_2:
  assumes "{u, v} \<in> endpoints ` G"
  shows
    "u \<in> V G"
    "v \<in> V G"
  using assms
  by (auto simp add: mem_endpoints_iff dest: mem_VI)

lemma mem_VE:
  assumes "v \<in> V G"
  obtains e where
    "e \<in> G"
    "v \<in> endpoints e"
  using assms
  by (auto simp add: V_def endpoints_def)

lemma V_subset:
  assumes "G \<subseteq> G'"
  shows "V G \<subseteq> V G'"
  using assms
  by (auto simp add: V_def)

definition is_multiple_edge :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> bool" where
  "is_multiple_edge G vs \<equiv> \<exists>\<epsilon> \<epsilon>'. \<epsilon> \<noteq> \<epsilon>' \<and> (\<epsilon>, vs) \<in> G \<and> (\<epsilon>', vs) \<in> G"

definition simple :: "('a, 'b) multigraph \<Rightarrow> bool" where
  "simple G \<equiv> \<forall>vs. \<not> is_multiple_edge G vs"

(* TODO: Rename. *)
locale other =
  fixes other :: "('a, 'b) edge \<Rightarrow> 'b \<Rightarrow> 'b"
  assumes other: "v \<in> endpoints e \<Longrightarrow> endpoints e = {v, other e v}"

lemma (in other) other_other_eq:
  assumes "v \<in> endpoints e"
  shows "other e (other e v) = v"
  using assms
proof -
  have "other e v \<in> endpoints e"
    using assms
    by (fastforce dest: other)
  thus ?thesis
    using assms
    by (fastforce dest: other)
qed

(* QUESTION: Do we need that the edge identifiers are unique? *)
locale multigraph = other
  where other = other
  for other :: "('a, 'b) edge \<Rightarrow> 'b \<Rightarrow> 'b" +
  fixes G :: "('a, 'b) multigraph"
  assumes endpoints_non_empty: "e \<in> G \<Longrightarrow> endpoints e \<noteq> {}"

lemma (in multigraph) no_hyperedges:
  assumes "e \<in> G"
  obtains u v where
    "endpoints e = {u, v}"
proof -
  obtain u where
    "u \<in> endpoints e"
    using assms endpoints_non_empty
    by fastforce
  thus ?thesis
    by (fastforce dest: other that)
qed

lemma (in multigraph) mem_VE:
  assumes "u \<in> V G"
  obtains v where
    "{u, v} \<in> endpoints ` G"
proof -
  obtain e where
    "e \<in> G"
    "u \<in> endpoints e"
    using assms
    by (elim mem_VE)
  thus ?thesis
    using assms
    by (blast dest: other intro: that)
qed

locale finite_multigraph = multigraph +
  assumes finite_edges: "finite G"

lemma (in finite_multigraph) finite_vertices:
  shows "finite (V G)"
  using finite_edges
  by (auto simp add: V_def elim: no_hyperedges)

(* TODO: Move. *)
definition idk :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) multigraph" where
  "idk G X Y \<equiv> {e \<in> G. endpoints e \<subseteq> X \<union> Y \<and> endpoints e \<inter> X \<noteq> {} \<and> endpoints e \<inter> Y \<noteq> {}}"

lemma mem_idkD:
  assumes "e \<in> idk G X Y"
  shows
    "e \<in> G"
    "endpoints e \<subseteq> X \<union> Y"
    "endpoints e \<inter> X \<noteq> {}"
    "endpoints e \<inter> Y \<noteq> {}"
  using assms
  by (simp_all add: idk_def)

lemma idk_subset:
  shows "idk G X Y \<subseteq> G"
  by (simp add: idk_def)

definition idk_2 :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) multigraph" where
  "idk_2 G X \<equiv> idk G X X"

lemma mem_idk_2D:
  assumes "e \<in> idk_2 G X"
  shows "endpoints e \<subseteq> X"
  using assms
  by (auto simp add: idk_2_def dest: mem_idkD(2))

lemma mem_endpoints_idk_2D:
  assumes "{u, v} \<in> endpoints ` idk_2 G X"
  shows
    "u \<in> X"
    "v \<in> X"
  using assms
  by (blast dest: mem_idk_2D)+

lemma idk_2_subset:
  shows "idk_2 G X \<subseteq> G"
  unfolding idk_2_def
  using idk_subset
  .

definition idk_3 :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) multigraph" where
  "idk_3 G \<equiv> idk G (V G)"

lemma idk_3_subset:
  shows "idk_3 G X \<subseteq> G"
  unfolding idk_3_def
  using idk_subset
  .

lemma mem_endpoints_idk_3I:
  assumes "x \<in> X"
  assumes "{x, y} \<in> endpoints ` G"
  shows "{x, y} \<in> endpoints ` idk_3 G X"
  using assms
  sorry

definition idk_4 :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) multigraph" where
  "idk_4 G X \<equiv> G - idk_3 G X"

lemma idk_4_subset:
  shows "idk_4 G X \<subseteq> G"
  using idk_3_subset
  by (simp add: idk_4_def)

lemma V_idk_4_subset:
  shows "V (idk_4 G X) \<subseteq> V G - X"
  sorry

(* TODO: Requires biconnected G. *)
lemma V_idk_4_eq:
  shows "V (idk_4 G X) = V G - X"
  sorry

lemma mem_endpoints_idk_4I:
  assumes "{x, y} \<in> endpoints ` G"
  assumes "x \<notin> X"
  assumes "y \<notin> X"
  shows "{x, y} \<in> endpoints ` idk_4 G X"
  using assms
  sorry

(* TODO: Move. *)
(* TODO: Generalize. *)
definition E :: "('a, 'b) multigraph \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) multigraph" where
  "E G X \<equiv> {e \<in> G. endpoints e \<inter> X \<noteq> {}}"

lemma E_subset:
  shows "E G X \<subseteq> G"
  by (simp add: E_def)

lemma E_empty_set_eq:
  shows "E G {} = {}"
  by (simp add: E_def)

lemma (in multigraph) E_V_eq:
  shows "E G (V G) = G"
proof (standard, goal_cases)
  case 1
  show ?case
    using E_subset
    .
next
  case 2
  show ?case
  proof
    fix e
    assume "e \<in> G"
    thus "e \<in> E G (V G)"
      unfolding E_def V_def
      by (blast dest: endpoints_non_empty)
  qed
qed

lemma E_union_eq:
  shows "E G (X \<union> Y) = E G X \<union> E G Y"
  by (auto simp add: E_def)

lemma V_E_superset:
  assumes "X \<subseteq> V G"
  shows "X \<subseteq> V (E G X)"
  using assms
  by (fastforce simp add: V_def E_def)

lemma mem_endpoints_EI:
  assumes "x \<in> X"
  assumes "{x, y} \<in> endpoints ` G"
  shows "{x, y} \<in> endpoints ` E G X"
  using assms
  sorry

lemma (in multigraph) mem_V_EE:
  assumes "x \<in> V (E G X)"
  assumes "x \<notin> X"
  obtains y where
    "{x, y} \<in> endpoints ` E G X"
    "y \<in> X"
  sorry

lemma mem_V_EI:
  assumes "u \<in> X"
  assumes "{u, v} \<in> endpoints ` G"
  shows "v \<in> V (E G X)"
  using assms
  unfolding V_def
  by (fast intro: mem_endpoints_EI)

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_50
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 y (nil2)) = nil2"
| "butlast (cons2 y (cons2 x2 x3)) =
     cons2 y (butlast (cons2 x2 x3))"

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

theorem property0 :
  "((butlast xs) = (take (t2 (len xs) (S Z)) xs))"
  oops

end


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