(* Title:  Shortest_Path.thy
   Author: Lars Noschinski, TU München
*)

theory Shortest_Path imports
  Arc_Walk
  Weighted_Graph
  "HOL-Library.Extended_Real"
begin

section \<open>Shortest Paths\<close>

context wf_digraph begin

(*Rename, as we are outside of any local context?*)
definition \<mu> where
  "\<mu> f u v \<equiv> INF p\<in> {p. awalk u p v}. ereal (awalk_cost f p)"

lemma shortest_path_inf:
  assumes "\<not>(u \<rightarrow>\<^sup>* v)"
  shows "\<mu> f u v = \<infinity>"
proof -
  have *: "{p. awalk u p v} = {}"
    using assms by (auto simp: reachable_awalk)
  show "\<mu> f u v = \<infinity>" unfolding \<mu>_def *
    by (simp add: top_ereal_def)
qed

lemma min_cost_le_walk_cost:
  assumes "awalk u p v"
  shows "\<mu> c u v \<le> awalk_cost c p"
  using assms unfolding \<mu>_def by (auto intro: INF_lower2)

lemma pos_cost_pos_awalk_cost:
  assumes "awalk u p v"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> c e \<ge> 0"
  shows "awalk_cost c p \<ge> 0"
using assms by (induct p arbitrary: u) (auto simp: awalk_Cons_iff)

fun mk_cycles_path :: "nat
  \<Rightarrow> 'b awalk \<Rightarrow> 'b awalk" where
    "mk_cycles_path 0 c = []"
  | "mk_cycles_path (Suc n) c = c @ (mk_cycles_path n c)"

lemma mk_cycles_path_awalk:
  assumes "awalk u c u"
  shows "awalk u (mk_cycles_path n c) u"
using assms by (induct n) (auto simp: awalk_Nil_iff)

lemma mk_cycles_awalk_cost:
  assumes "awalk u p u"
  shows "awalk_cost c (mk_cycles_path n p) = n * awalk_cost c p"
using assms proof (induct rule: mk_cycles_path.induct)
  case 1 show ?case by simp
next
  case (2 n p)
  have "awalk_cost c (mk_cycles_path (Suc n) p)
      = awalk_cost c (p @ (mk_cycles_path n p))"
    by simp
  also have "\<dots> = awalk_cost c p + real n * awalk_cost c p"
  proof (cases n)
    case 0 then show ?thesis by simp
  next
    case (Suc n') then show ?thesis
      using 2 by simp
  qed
  also have "\<dots> = real (Suc n) * awalk_cost c p"
    by (simp add: algebra_simps)
  finally show ?case .
qed

lemma inf_over_nats:
  fixes a c :: real
  assumes "c < 0"
  shows "(INF (i :: nat). ereal (a + i * c)) = - \<infinity>"
proof (rule INF_eqI)
  fix i :: nat show "- \<infinity> \<le> a + real i * c" by simp
next
  fix y :: ereal
  assume "\<And>(i :: nat). i \<in> UNIV \<Longrightarrow> y \<le> a + real i * c"
  then have l_assm: "\<And>i::nat. y \<le> a + real i * c" by simp

  show "y \<le> - \<infinity>"
  proof (subst ereal_infty_less_eq, rule ereal_bot)
    fix B :: real
    obtain real_x where "a + real_x * c \<le> B" using \<open>c < 0\<close>
      by atomize_elim
         (rule exI[where x="(- abs B -a)/c"], auto simp: field_simps)
    obtain x :: nat where "a + x * c \<le> B"
    proof (atomize_elim, intro exI[where x="nat(ceiling real_x)"] conjI)
      have "real (nat(ceiling real_x)) * c \<le> real_x * c"
        using \<open>c < 0\<close> by (simp add: real_nat_ceiling_ge)
      then show "a + nat(ceiling real_x) * c \<le> B"
        using \<open>a + real_x * c \<le> B\<close> by simp
    qed
    then show "y \<le> ereal B"
    proof -
      have "ereal (a + x * c) \<le> ereal B"
        using \<open>a + x * c \<le> B\<close> by simp
      with l_assm show ?thesis by (rule order_trans)
    qed
  qed
qed

lemma neg_cycle_imp_inf_\<mu>:
  assumes walk_p: "awalk u p v"
  assumes walk_c: "awalk w c w"
  assumes w_in_p: "w \<in> set (awalk_verts u p)"
  assumes "awalk_cost f c < 0"
  shows "\<mu> f u v = -\<infinity>"
proof -
  from w_in_p obtain xs ys where pv_decomp: "awalk_verts u p = xs @ w # ys"
    by (auto simp: in_set_conv_decomp)

  define q r where "q = take (length xs) p" and "r = drop (length xs) p"
  define ext_p where "ext_p n = q @ mk_cycles_path n c @ r" for n

  have ext_p_cost: "\<And>n. awalk_cost f (ext_p n)
      = (awalk_cost f q + awalk_cost f r) + n * awalk_cost f c"
    using \<open>awalk w c w\<close>
    by (auto simp: ext_p_def intro: mk_cycles_awalk_cost)

  from q_def r_def have "awlast u q = w"
    using pv_decomp walk_p by (auto simp: awalk_verts_take_conv elim!: awalkE)
  moreover
  from q_def r_def have "awalk u (q @ r) v"
    using walk_p by simp
  ultimately
  have "awalk u q w" "awalk w r v" "\<And>n. awalk w (mk_cycles_path n c) w"
    using walk_c
    by (auto simp: intro: mk_cycles_path_awalk)
  then have "\<And>n. awalk u (ext_p n) v"
    unfolding ext_p_def by (blast intro: awalk_appendI)
  then have "{ext_p i|i. i \<in> UNIV} \<subseteq> {p. awalk u p v}"
    by auto
  then have "(INF p\<in>{p. awalk u p v}. ereal (awalk_cost f p))
      \<le> (INF p\<in> {ext_p i|i. i \<in> UNIV}. ereal (awalk_cost f p))"
    by (auto intro: INF_superset_mono)
  also have "\<dots> = (INF i\<in> UNIV. ereal (awalk_cost f (ext_p i)))"
    by (rule arg_cong[where f=Inf], auto)
  also have "\<dots> = - \<infinity>" unfolding ext_p_cost
    by (rule inf_over_nats[OF \<open>awalk_cost f c < 0\<close>])
  finally show ?thesis unfolding \<mu>_def by simp
qed

lemma walk_cheaper_path_imp_neg_cyc:
  assumes p_props: "awalk u p v"
  assumes less_path_\<mu>: "awalk_cost f p < (INF p\<in> {p. apath u p v}. ereal (awalk_cost f p))"
  shows "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0"
proof -
  define path_\<mu> where "path_\<mu> = (INF p\<in> {p. apath u p v}. ereal (awalk_cost f p))"
  then have "awalk u p v" and "awalk_cost f p < path_\<mu>"
    using p_props less_path_\<mu> by simp_all
  then show ?thesis
  proof (induct rule: awalk_to_apath_induct)
    case (path p) then have "apath u p v" by (auto simp: apath_def)
    then show ?case using path.prems by (auto simp: path_\<mu>_def dest: not_mem_less_INF)
  next
    case (decomp p q r s)
    then obtain w where p_props: "p = q @ r @ s" "awalk u q w" "awalk w r w" "awalk w s v"
      by (auto elim: awalk_cyc_decompE)
    then have "awalk u (q @ s) v"
      using \<open>awalk u p v\<close> by (auto simp: awalk_appendI)
    then have verts_ss: "set (awalk_verts u (q @ s)) \<subseteq> set (awalk_verts u p)"
      using \<open>awalk u p v\<close> \<open>p = q @ r @ s\<close> by (auto simp: set_awalk_verts)

    show ?case
    proof (cases "ereal (awalk_cost f (q @ s)) < path_\<mu>")
      case True then have "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u (q @ s)) \<and> awalk_cost f c < 0"
        by (rule decomp)
      then show ?thesis using verts_ss by auto
    next
      case False
      note \<open>awalk_cost f p < path_\<mu>\<close>
      also have "path_\<mu> \<le> awalk_cost f (q @ s)"
        using False by simp
      finally have "awalk_cost f r < 0" using \<open>p = q @ r @ s\<close> by simp
      moreover
      have "w \<in> set (awalk_verts u q)" using \<open>awalk u q w\<close> by auto
      then have "w \<in> set (awalk_verts u p)"
        using \<open>awalk u p v\<close> \<open>awalk u q w\<close> \<open>p = q @ r @ s\<close>
        by (auto simp: set_awalk_verts)
      ultimately
      show ?thesis using \<open>awalk w r w\<close> by auto
    qed
  qed
qed

lemma (in fin_digraph) neg_inf_imp_neg_cyc:
  assumes inf_mu: "\<mu> f u v = - \<infinity>"
  shows "\<exists>p. awalk u p v \<and> (\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
proof -
  define path_\<mu> where "path_\<mu> = (INF s\<in>{p. apath u p v}. ereal (awalk_cost f s))"

  have awalks_ne: "{p. awalk u p v} \<noteq> {}"
    using inf_mu unfolding \<mu>_def by safe (simp add: top_ereal_def)
  then have paths_ne: "{p. apath u p v} ~= {}"
    by (auto intro: apath_awalk_to_apath)

  obtain p where "apath u p v" "awalk_cost f p = path_\<mu>"
  proof -
    obtain p where "p \<in> {p. apath u p v}" "awalk_cost f p = path_\<mu>"
    using finite_INF_in[OF apaths_finite paths_ne, of "awalk_cost f"]
      by (auto simp: path_\<mu>_def)
    then show ?thesis using that by auto
  qed
  then have "path_\<mu> \<noteq> -\<infinity>" by auto
  then have "\<mu> f u v < path_\<mu>" using inf_mu by simp
  then obtain pw where p_def: "awalk u pw v" "awalk_cost f pw < path_\<mu>"
    by atomize_elim (auto simp: \<mu>_def INF_less_iff)
  then have "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u pw) \<and> awalk_cost f c < 0"
    by (intro walk_cheaper_path_imp_neg_cyc) (auto simp: path_\<mu>_def)
  with \<open>awalk u pw v\<close> show ?thesis by auto
qed

lemma (in fin_digraph) no_neg_cyc_imp_no_neg_inf:
  assumes no_neg_cyc: "\<And>p. awalk u p v
    \<Longrightarrow> \<not>(\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
  shows "- \<infinity> < \<mu> f u v"
proof (intro ereal_MInfty_lessI notI)
  assume "\<mu> f u v = - \<infinity>"
  then obtain p where p_props: "awalk u p v"
    and ex_cyc: "\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0"
    by atomize_elim (rule neg_inf_imp_neg_cyc)
  then show False using no_neg_cyc by blast
qed

lemma \<mu>_reach_conv:
  "\<mu> f u v < \<infinity> \<longleftrightarrow> u \<rightarrow>\<^sup>* v"
proof
  assume "\<mu> f u v < \<infinity>"
  then have "{p. awalk u p v} \<noteq> {}"
    unfolding \<mu>_def by safe (simp add: top_ereal_def)
  then show "u \<rightarrow>\<^sup>* v" by (simp add: reachable_awalk)
next
  assume "u \<rightarrow>\<^sup>* v"
  then obtain p where p_props: "apath u p v"
    by (metis reachable_awalk apath_awalk_to_apath)
  then have "{p} \<subseteq> {p. apath u p v}" by simp
  then have "\<mu> f u v \<le> (INF p\<in> {p}. ereal (awalk_cost f p))"
    unfolding \<mu>_def by (intro INF_superset_mono) (auto simp: apath_def)
  also have "\<dots> < \<infinity>" by (simp add: min_def)
  finally show "\<mu> f u v < \<infinity>" .
qed

lemma awalk_to_path_no_neg_cyc_cost:
  assumes p_props:"awalk u p v"
  assumes no_neg_cyc: "\<not> (\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
  shows "awalk_cost f (awalk_to_apath p) \<le> awalk_cost f p"
using assms
proof (induct rule: awalk_to_apath_induct)
  case path then show ?case by (auto simp: awalk_to_apath.simps)
next
  case (decomp p q r s)
  from decomp(2,3) have "is_awalk_cyc_decomp p (q,r,s)"
    using awalk_cyc_decomp_has_prop[OF decomp(1)] by auto
  then have decomp_props: "p = q @ r @ s" "\<exists>w. awalk w r w" by auto

  have "awalk_cost f (awalk_to_apath p) = awalk_cost f (awalk_to_apath (q @ s))"
    using decomp by (auto simp: step_awalk_to_apath[of _ p _ q r s])
  also have "\<dots> \<le> awalk_cost f (q @ s)"
  proof -
    have "awalk u (q @ s) v"
      using \<open>awalk u p v\<close> decomp_props by (auto dest!: awalk_ends_eqD)
    then have "set (awalk_verts u (q @ s)) \<subseteq> set (awalk_verts u p)"
      using \<open>awalk u p v\<close> \<open>p = q @ r @ s\<close>
      by (auto simp add: set_awalk_verts)
    then show ?thesis using decomp.prems by (intro decomp.hyps) auto
  qed
  also have "\<dots> \<le> awalk_cost f p"
  proof -
    obtain w where "awalk u q w" "awalk w r w" "awalk w s v"
      using decomp by (auto elim: awalk_cyc_decompE)
    then have "w \<in> set (awalk_verts u q)" by auto
    then have "w \<in> set (awalk_verts u p)"
      using \<open>p = q @ r @ s\<close> \<open>awalk u p v\<close> \<open>awalk u q w\<close>
      by (auto simp add: set_awalk_verts)
    then have "0 \<le> awalk_cost f r" using \<open>awalk w r w\<close>
      using decomp.prems by (auto simp: not_less)
    then show ?thesis using \<open>p = q @ r @ s\<close> by simp
  qed
  finally show ?case .
qed

lemma (in fin_digraph) no_neg_cyc_reach_imp_path:
  assumes reach: "u \<rightarrow>\<^sup>* v"
  assumes no_neg_cyc: "\<And>p. awalk u p v
    \<Longrightarrow> \<not>(\<exists>w c. awalk w c w \<and> w \<in> set (awalk_verts u p) \<and> awalk_cost f c < 0)"
  shows "\<exists>p. apath u p v \<and> \<mu> f u v = awalk_cost f p"
proof -
  define set_walks where "set_walks = {p. awalk u p v}"
  define set_paths where "set_paths = {p. apath u p v}"

  have "set_paths \<noteq> {}"
  proof -
    obtain p where "apath u p v"
      using reach by (metis apath_awalk_to_apath reachable_awalk)
    then show ?thesis unfolding set_paths_def by blast
  qed

  have "\<mu> f u v = (INF p\<in> set_walks. ereal (awalk_cost f p))"
    unfolding \<mu>_def set_walks_def by simp
  also have "\<dots> = (INF p\<in> set_paths. ereal (awalk_cost f p))"
  proof (rule antisym)
    have "awalk_to_apath ` set_walks \<subseteq> set_paths"
      unfolding set_walks_def set_paths_def
      by (intro subsetI) (auto elim: apath_awalk_to_apath)
    then have "(INF p\<in> set_paths. ereal (awalk_cost f p))
      \<le> (INF p\<in> awalk_to_apath ` set_walks. ereal (awalk_cost f p))"
      by (rule INF_superset_mono) simp
    also have "\<dots> = (INF p\<in> set_walks. ereal (awalk_cost f (awalk_to_apath p)))"
      by (simp add: image_comp)
    also have "\<dots> \<le> (INF p\<in> set_walks. ereal (awalk_cost f p))"
    proof -
      { fix p assume "p \<in> set_walks"
        then have "awalk u p v" by (auto simp: set_walks_def)
        then have "awalk_cost f (awalk_to_apath p) \<le> awalk_cost f p"
          using no_neg_cyc
          using no_neg_cyc and awalk_to_path_no_neg_cyc_cost
          by auto }
      then show ?thesis by (intro INF_mono) auto
    qed
    finally show
      "(INF p\<in> set_paths. ereal (awalk_cost f p))
      \<le> (INF p\<in> set_walks. ereal (awalk_cost f p))" by simp

    have "set_paths \<subseteq> set_walks"
      unfolding set_paths_def set_walks_def by (auto simp: apath_def)
    then show "(INF p\<in> set_walks. ereal (awalk_cost f p))
      \<le> (INF p\<in> set_paths. ereal (awalk_cost f p))"
      by (rule INF_superset_mono) simp
  qed
  also have "\<dots> \<in> (\<lambda>p. ereal (awalk_cost f p)) ` set_paths"
    using apaths_finite \<open>set_paths \<noteq> {}\<close>
    by (intro finite_INF_in) (auto simp: set_paths_def)
  finally show ?thesis
    by (simp add: set_paths_def image_def)
qed

lemma (in fin_digraph) min_cost_awalk:
  assumes reach: "u \<rightarrow>\<^sup>* v"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> c e \<ge> 0"
  shows "\<exists>p. apath u p v \<and> \<mu> c u v = awalk_cost c p"
proof -
  have pc: "\<And>u p v. awalk u p v \<Longrightarrow> 0 \<le> awalk_cost c p"
    using pos_cost_pos_awalk_cost pos_cost by auto

  from reach show ?thesis
    by (rule no_neg_cyc_reach_imp_path) (auto simp: not_less intro: pc)
qed

lemma (in fin_digraph) pos_cost_mu_triangle:
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> c e \<ge> 0" (* introduce predicate? *)
  assumes e_props: "arc_to_ends G e = (u,v)" "e \<in> arcs G"
  shows "\<mu> c s v \<le> \<mu> c s u + c e"
proof cases
  assume "\<mu> c s u = \<infinity>" then show ?thesis by simp
next
  assume "\<mu> c s u \<noteq> \<infinity>"
  then have "{p. awalk s p u} \<noteq> {}"
    unfolding \<mu>_def by safe (simp add: top_ereal_def)
  then have "s \<rightarrow>\<^sup>* u" by (simp add: reachable_awalk)
  with pos_cost
  obtain p where p_props: "apath s p u"
      and p_cost: "\<mu> c s u = awalk_cost c p"
    by (metis min_cost_awalk)

  have "awalk u [e] v"
    using e_props by (auto simp: arc_to_ends_def awalk_simps)
  with \<open>apath s p u\<close>
  have "awalk s (p @ [e]) v"
    by (auto simp: apath_def awalk_appendI)
  then have "\<mu> c s v \<le> awalk_cost c (p @ [e])"
    by (rule min_cost_le_walk_cost)
  also have "\<dots> \<le> awalk_cost c p + c e" by simp
  also have "\<dots> \<le> \<mu> c s u + c e" using p_cost by simp
  finally show ?thesis .
qed

lemma (in fin_digraph) mu_exact_triangle:
  assumes "v \<noteq> s"
  assumes "s \<rightarrow>\<^sup>* v"
  assumes nonneg_arcs: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"
  obtains u e where "\<mu> c s v = \<mu> c s u + c e" and "arc e (u,v)"
proof -
  obtain p where p_path: "apath s p v"
    and p_cost: "\<mu> c s v = awalk_cost c p"
    using assms by (metis min_cost_awalk)
  then obtain e p' where p'_props: "p = p' @ [e]" using \<open>v \<noteq> s\<close>
    by (cases p rule: rev_cases) (auto simp: apath_def)
  then obtain u where "awalk s p' u" "awalk u [e] v"
    using \<open>apath s p v\<close> by (auto simp: apath_def)
  then have mu_le: "\<mu> c s v \<le> \<mu> c s u + c e" and arc: "arc e (u,v)"
    using nonneg_arcs by (auto intro!: pos_cost_mu_triangle simp: arc_to_ends_def arc_def)

  have "\<mu> c s u + c e \<le> ereal (awalk_cost c p') + ereal (c e)"
    using \<open>awalk s p' u\<close>
    by (fast intro: add_right_mono min_cost_le_walk_cost)
  also have "\<dots> = awalk_cost c p" using p'_props by simp
  also have "\<dots> = \<mu> c s v" using p_cost by simp
  finally
  have "\<mu> c s v = \<mu> c s u + c e" using mu_le by auto
  then show ?thesis using arc ..
qed

lemma (in fin_digraph) mu_exact_triangle_Ex:
  assumes "v \<noteq> s"
  assumes "s \<rightarrow>\<^sup>* v"
  assumes "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"
  shows "\<exists>u e. \<mu> c s v = \<mu> c s u + c e \<and> arc e (u,v)"
using assms by (metis mu_exact_triangle)

lemma (in fin_digraph) mu_Inf_triangle:
  assumes "v \<noteq> s"
  assumes "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"
  shows "\<mu> c s v = Inf {\<mu> c s u + c e | u e. arc e (u, v)}" (is "_ = Inf ?S")
proof cases
  assume "s \<rightarrow>\<^sup>* v"
  then obtain u e where "\<mu> c s v = \<mu> c s u + c e" "arc e (u,v)"
    using assms by (metis mu_exact_triangle)
  then have "Inf ?S \<le> \<mu> c s v" by (auto intro: Complete_Lattices.Inf_lower)
  also have "\<dots> \<le> Inf ?S" using assms(2)
    by (auto intro!: Complete_Lattices.Inf_greatest pos_cost_mu_triangle
      simp: arc_def arc_to_ends_def)
  finally show ?thesis by simp
next
  assume "\<not>s \<rightarrow>\<^sup>* v"
  then have "\<mu> c s v = \<infinity>" by (metis shortest_path_inf)
  define S where "S = ?S"
  show "\<mu> c s v = Inf S"
  proof cases
    assume "S = {}"
    then show ?thesis unfolding \<open>\<mu> c s v = \<infinity>\<close>
      by (simp add: top_ereal_def)
  next
    assume "S \<noteq> {}"
    { fix x assume "x \<in> S"
      then obtain u e where "arc e (u,v)" and x_val: "x = \<mu> c s u + c e"
        unfolding S_def by auto
      then have "\<not>s \<rightarrow>\<^sup>* u" using \<open>\<not> s \<rightarrow>\<^sup>* v\<close> by (metis reachable_arc_trans)
      then have "\<mu> c s u + c e= \<infinity>" by (simp add: shortest_path_inf)
      then have "x = \<infinity>" using x_val by simp }
    then have "S = {\<infinity>}" using \<open>S \<noteq> {}\<close> by auto
    then show ?thesis using \<open>\<mu> c s v = \<infinity>\<close> by (simp add: min_def)
  qed
qed

end

end


(*  Title:      HOL/ex/Sqrt.thy
    Author:     Markus Wenzel, Tobias Nipkow, TU Muenchen
*)

theory real
imports Power Complex_Main "~~/src/HOL/Number_Theory/Primes"
begin

text {* The square root of any prime number (including 2) is irrational. *}

theorem sqrt-prime-irrational1: prime p \<Longrightarrow> sqrt (real p) \<notin> Q
apply clarsimp
apply (elim rationals-rep)
apply simp
apply (simp add : nonzero-eq-divide-eq)
apply (drule arg-cong [where f = \<lambda>x . x * x ])
apply (simp only: mult-ac)
apply (simp only: power2-eq-square[symmetric])
apply (simp only: real-sqrt-pow2 )
apply (simp only: mult-assoc[symmetric])
apply (simp add : power2-eq-square)
apply (simp only: real-of-nat-mult[symmetric])
apply (simp only: real-of-nat-inject)
apply (simp add : power2-eq-square[symmetric] eq-commute)
apply (frule-tac m=m in prime-dvd-power-two, simp)
apply (frule-tac m=n in prime-dvd-power-two)
apply (frule iffD1 [OF dvd-def ], clarsimp)
apply (simp add : power2-eq-square mult-ac prime-def )
apply (simp only: mult-assoc[symmetric])
apply (simp add : eq-commute)
apply (drule (1 ) gcd-greatest)
apply (thin-tac p dvd n)
apply (drule dvd-imp-le, simp)
apply (clarsimp simp: prime-def )
done

end


theory Ex1_1
imports Main
begin

primrec snoc :: "'a list => 'a => 'a list"where
"snoc [] val = [val]"|
"snoc (x#xs) val = x # snoc xs val"

thm rev.simps

thm append.simps

theorem helper : "snoc (ls @ xs ) x = ls @  snoc xs x"
proof (induct ls)
  case Nil
  show ?case by simp
 next
  fix a ls
  assume " snoc (ls @ xs) x = ls @ snoc xs x"
  thus  "snoc ((a # ls) @ xs) x = (a # ls) @ snoc xs x"  by simp
qed

lemma helper2 : "snoc xs x = xs @ [x]"
proof (induct xs)
  case Nil
  show ?case by simp
 next
  fix a xs
  assume "snoc xs x = xs @ [x]"
  thus " snoc (a # xs) x = (a # xs) @ [x] " by simp
qed

theorem rev_cons: "rev (x # xs) = snoc (rev xs) x"
proof (induct xs)
  case Nil
  show ?case by simp
 next
  fix a xs
  assume "rev (x # xs) = snoc (rev xs) x"
  from this show "rev (x # a # xs) = snoc (rev (a # xs)) x" by (simp add : helper)
qed


theory POLocales
imports Main
begin
(*see notebook for extended notes*)

(*Parameter of this locale is le*)
locale partial_order =
  fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
    and anti_sym [intro]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> x \<rbrakk> \<Longrightarrow> x = y"
    and trans [trans]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"

print_locales

print_locale partial_order

print_locale! partial_order

(*locale predicate definition*)
thm partial_order_def
(*equivalent to original assumptions - turned into conclusions*)

definition (in partial_order)
  less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y \<and> x \<noteq> y)"

(*generates foundational constant:*)
thm "partial_order.less_def"

(*derivation of transitivity law for strict ordering*)
lemma (in partial_order) less_le_trans [trans]:
  "\<lbrakk> x \<sqsubset> y; y \<sqsubset> z \<rbrakk> \<Longrightarrow> x \<sqsubset> z"
  unfolding less_def by (blast intro: trans)

(*commands inside context block refer to a single target (partial_order)*)
context partial_order
  begin

  (*infinum (greatest lower bound of po)*)
    definition is_inf where
      "is_inf x y i = (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

  (*suprenum (least upper bound)*)
    definition is_sup where
      "is_sup x y s = (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

    theorem inf_uniq: "\<lbrakk> is_inf x y i; is_inf x y i' \<rbrakk> \<Longrightarrow> i = i'"
    apply(simp add: is_inf_def)
    apply(simp add: anti_sym)
    done

    theorem sup_uniq: "\<lbrakk> is_sup x y s; is_sup x y s'\<rbrakk> \<Longrightarrow> s = s'"
    apply(simp add: is_sup_def)
    apply(simp add: anti_sym)
    done

  end

(*extension of partial orders to lattices*)
locale lattice = partial_order +
  assumes ex_inf: "\<exists>inf. is_inf x y inf"
    and ex_sup: "\<exists>sup. is_sup x y sup"
    begin

      (*THE: Definite description operator -
        denotes x such that P(x) \<rightarrow> T provided unique x*)
      definition meet (infixl "\<sqinter>" 70) where
        "x \<sqinter> y = (THE inf. is_inf x y inf)"

      definition join (infixl "\<squnion>" 65) where
        "x \<squnion> y = (THE sup. is_sup x y sup)"

      lemma meet_left:"x \<sqinter> y \<sqsubseteq> x"
      apply(simp add: meet_def)
      apply(simp add: is_inf_def)
      apply(rule theI)
      sorry

    end

locale total_order = partial_order +
  assumes total: "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

lemma (in total_order) less_total:
  "x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x"
using less_def total by auto

(*distributive lattice*)
locale distrib_lattice = lattice +
  assumes meet_distr: "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z"

lemma (in distrib_lattice) join_distr:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  apply(auto simp add: meet_distr meet_left)
  apply(simp add: join_def meet_def is_inf_def)
  apply(rule theI)
  sorry

(*sublocale x \<subseteq> y causes locale y to be interpreted in context of x
 conclusions of y are made available in x. Must prove that this is so*)
sublocale total_order \<subseteq> lattice
proof unfold_locales
(*since both extend lattices, only assumptions introduced in lattice remain as subgoals*)
fix x y
from total have "is_inf x y (if x \<sqsubseteq> y then x else y)"
  by (auto simp: is_inf_def)
then show "\<exists>inf. is_inf x y inf"
from total have "is_sup x y (if y \<sqsubseteq> x then y else x)"
  by (auto simp: is_sup_def)
then show "\<exists>sup. is_sup x y sup"
sorry

end


theory BPlusTree_Split
imports BPlusTree
begin

subsection "Auxiliary functions"

(* a version of split half that assures the left side to be non-empty *)
fun split_half:: "_ list \<Rightarrow> _ list \<times> _ list" where
  "split_half xs = (take ((length xs + 1) div 2) xs, drop ((length xs + 1) div 2) xs)"

lemma split_half_conc: "split_half xs = (ls, rs) = (xs = ls@rs \<and> length ls = (length xs + 1) div 2)"
  by force

lemma drop_not_empty: "xs \<noteq> [] \<Longrightarrow> drop (length xs div 2) xs \<noteq> []"
  apply(induction xs)
   apply(auto split!: list.splits)
  done

lemma take_not_empty: "xs \<noteq> [] \<Longrightarrow> take ((length xs + 1) div 2) xs \<noteq> []"
  apply(induction xs)
   apply(auto split!: list.splits)
  done

lemma split_half_not_empty: "length xs \<ge> 1 \<Longrightarrow> \<exists>ls a rs. split_half xs = (ls@[a],rs)"
  using take_not_empty
  by (metis (no_types, opaque_lifting) Ex_list_of_length One_nat_def le_trans length_Cons list.size(4) nat_1_add_1 not_one_le_zero rev_exhaust split_half.simps take0 take_all_iff)

subsection "The split function locale"

text "Here, we abstract away the inner workings of the split function
      for B-tree operations."

lemma leaves_conc: "leaves (Node (ls@rs) t) = leaves_list ls @ leaves_list rs @ leaves t"
  apply(induction ls)
  apply auto
  done

locale split_tree =
  fixes split ::  "('a bplustree\<times>'a::{linorder,order_top}) list \<Rightarrow> 'a \<Rightarrow> (('a bplustree\<times>'a) list \<times> ('a bplustree\<times>'a) list)"
  assumes split_req:
    "\<lbrakk>split xs p = (ls,rs)\<rbrakk> \<Longrightarrow> xs = ls @ rs"
    "\<lbrakk>split xs p = (ls@[(sub,sep)],rs); sorted_less (separators xs)\<rbrakk> \<Longrightarrow> sep < p"
    "\<lbrakk>split xs p = (ls,(sub,sep)#rs); sorted_less (separators xs)\<rbrakk> \<Longrightarrow> p \<le> sep"
begin

  lemmas split_conc = split_req(1)
  lemmas split_sorted = split_req(2,3)

  lemma [termination_simp]:"(ls, (sub, sep) # rs) = split ts y \<Longrightarrow>
        size sub < Suc (size_list (\<lambda>x. Suc (size (fst x))) ts  + size l)"
    using split_conc[of ts y ls "(sub,sep)#rs"] by auto

  lemma leaves_split: "split ts x = (ls,rs) \<Longrightarrow> leaves (Node ts t) = leaves_list ls @ leaves_list rs @ leaves t"
    using leaves_conc split_conc by blast

end

locale split_list =
  fixes split_list ::  "('a::{linorder,order_top}) list \<Rightarrow> 'a \<Rightarrow> 'a list \<times> 'a list"
  assumes split_list_req:
    "\<lbrakk>split_list ks p = (kls,krs)\<rbrakk> \<Longrightarrow> ks = kls @ krs"
    "\<lbrakk>split_list ks p = (kls@[sep],krs); sorted_less ks\<rbrakk> \<Longrightarrow> sep < p"
    "\<lbrakk>split_list ks p = (kls,(sep)#krs); sorted_less ks\<rbrakk> \<Longrightarrow> p \<le> sep"

locale split_full = split_tree: split_tree split + split_list split_list
    for split::
      "('a bplustree \<times> 'a::{linorder,order_top}) list \<Rightarrow> 'a
         \<Rightarrow> ('a bplustree \<times> 'a) list \<times> ('a bplustree \<times> 'a) list"
    and split_list::
      "'a::{linorder,order_top} list \<Rightarrow> 'a
         \<Rightarrow> 'a list \<times> 'a list"

section "Abstract split functions"

subsection "Linear split"

text "Finally we show that the split axioms are feasible by providing an example split function"

text "Linear split is similar to well known functions, therefore a quick proof can be done."

fun linear_split where "linear_split xs x = (takeWhile (\<lambda>(_,s). s<x) xs, dropWhile (\<lambda>(_,s). s<x) xs)"
fun linear_split_list where "linear_split_list xs x = (takeWhile (\<lambda>s. s<x) xs, dropWhile (\<lambda>s. s<x) xs)"

(* works but inhibits code extraction *)

(*interpretation bplustree_linear_search_list: split_list linear_split_list
  apply unfold_locales
  unfolding linear_split.simps
    apply (auto split: list.splits)
  subgoal
    by (metis (no_types, lifting) case_prodD in_set_conv_decomp takeWhile_eq_all_conv takeWhile_idem)
  subgoal
    by (metis case_prod_conv hd_dropWhile le_less_linear list.sel(1) list.simps(3))
  done *)

(* interpretation bplustree_linear_search: split_tree linear_split
  apply unfold_locales
  unfolding linear_split.simps
    apply (auto split: list.splits)
  subgoal
    by (metis (no_types, lifting) case_prodD in_set_conv_decomp takeWhile_eq_all_conv takeWhile_idem)
  subgoal
    by (metis case_prod_conv hd_dropWhile le_less_linear list.sel(1) list.simps(3))
  done *)
end


theory prop_50
imports Main
        "$HIPSTER_HOME/IsaHipster"
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 minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  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))"

  (*hipster take minus len butlast *)
lemma lemma_a [thy_expl]: "minus x2 x2 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_aa [thy_expl]: "minus x3 Z = x3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ab [thy_expl]: "minus x2 (S x2) = Z"
by (hipster_induct_schemes)

lemma lemma_ac [thy_expl]: "minus (S x2) x2 = S Z"
by (hipster_induct_schemes)

lemma lemma_ad [thy_expl]: "minus (minus x3 y3) (minus y3 x3) = minus x3 y3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ae [thy_expl]: "minus (minus x3 y3) (S Z) = minus x3 (S y3)"
by (hipster_induct_schemes minus.simps)

lemma lemma_af [thy_expl]: "minus (minus x4 y4) x4 = Z"
by (hipster_induct_schemes minus.simps)

  theorem x0 :
    "(butlast xs) = (take (minus (len xs) (S Z)) xs)"
    by (hipster_induct_schemes minus.simps len.simps take.simps butlast.simps)
    (*by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


header {* Predicate Logic *}

(*<*) theory ex4_3 imports Main begin (*>*)

text {*
We are again talking about proofs in the calculus of Natural Deduction.  In
addition to the rules given in the exercise ``Propositional Logic'', you may
now also use

  @{text "exI:"}~@{thm exI[no_vars]}\\
  @{text "exE:"}~@{thm exE[no_vars]}\\
  @{text "allI:"}~@{thm allI[no_vars]}\\
  @{text "allE:"}~@{thm allE[no_vars]}\\

Give a proof of the following propositions or an argument why the formula is
not valid:
*}

lemma "(\<exists>x. \<forall>y. P x y) \<longrightarrow> (\<forall>y. \<exists>x. P x y)"
  apply(rule impI)
  apply (erule exE)
  apply (rule allI)
  apply (erule allE)
  apply(rule exI)
  apply assumption
  done
lemma "(\<forall>x. P x \<longrightarrow> Q) = ((\<exists>x. P x) \<longrightarrow> Q)"
  apply (rule iffI)
   apply (rule impI)+
   apply(erule exE)
   apply(erule allE)
   apply(rule impE)
     apply assumption+

  apply (rule allI)
  apply(rule impI)
  apply (erule impE)
   apply (rule exI)
   apply assumption
  apply assumption
  done

lemma "((\<forall> x. P x) \<and> (\<forall> x. Q x)) = (\<forall> x. (P x \<and> Q x))"
  apply (rule iffI)
   apply(rule allI)
   apply (rule conjI)
    apply(erule conjE)
    apply (erule allE)+
    apply assumption
   apply(erule conjE)
   apply (erule allE)+
   apply assumption

  apply(rule conjI)
   apply (rule allI)
   apply (erule allE)
   apply(erule conjE)
   apply assumption
  apply(rule allI)
  apply (erule allE)
  apply(erule conjE)
  apply assumption
  done

lemma "((\<forall> x. P x) \<or> (\<forall> x. Q x)) = (\<forall> x. (P x \<or> Q x))"
  quickcheck
  oops

lemma "((\<exists> x. P x) \<or> (\<exists> x. Q x)) = (\<exists> x. (P x \<or> Q x))"
  apply(rule iffI)
   apply (erule disjE)
apply (erule exE)
apply (rule exI)
    apply (rule disjI1)
    apply assumption

   apply (erule exE)
   apply (rule exI)
   apply (erule disjI2)
  apply (erule exE)
  apply (erule disjE)
   apply(rule disjI1)
   apply (rule exI)
   apply assumption
  apply(rule disjI2)
  apply (rule exI)
  apply assumption
  done

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
  quickcheck oops

lemma "(\<not> (\<forall> x. P x)) = (\<exists> x. \<not> P x)"
  apply(rule iffI)
   apply(rule classical)
   apply(erule notE)
   apply(rule allI)
   apply(rule classical)
   apply(erule notE)
  apply(rule exI)
   apply assumption

  apply(erule exE)
  apply(rule notI)
  apply(erule allE)
  apply(erule notE)
  apply assumption
  done

(*<*) end (*>*)


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_BubSortPermutes
  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 le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

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

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

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

fun bubble :: "Nat list => (bool, (Nat list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "Nat list => Nat list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

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

end


theory Lemmas_log
imports Complex_Main
begin

lemma ld_sum_inequality:
  assumes "x > 0" "y > 0"
  shows   "log 2 x + log 2 y + 2 \<le> 2 * log 2 (x + y)"
proof -
  have 0: "0 \<le> (x-y)^2" using assms by(simp)
  have "2 powr (2 + log 2 x + log 2 y) = 4 * x * y" using assms
    by(simp add: powr_add)
  also have "4*x*y \<le> (x+y)^2" using 0 by(simp add: algebra_simps numeral_eq_Suc)
  also have "\<dots> = 2 powr (log 2 (x + y) * 2)" using assms
    by(simp add: powr_powr[symmetric] powr_numeral)
  finally show ?thesis by (simp add: mult_ac)
qed

lemma ld_ld_1_less:
  "\<lbrakk>x > 0; y > 0 \<rbrakk> \<Longrightarrow> 1 + log 2 x + log 2 y < 2 * log 2 (x+y)"
using ld_sum_inequality[of x y] by linarith
(*
proof -
  have 1: "2*x*y < (x+y)^2" using assms
    by(simp add: numeral_eq_Suc algebra_simps add_pos_pos)
  show ?thesis
    apply(rule powr_less_cancel_iff[of 2, THEN iffD1])
     apply simp
    using assms 1 by(simp add: powr_add log_powr[symmetric] powr_numeral)
qed
*)

lemma ld_le_2ld:
  assumes "x \<ge> 0" "y \<ge> 0" shows "log 2 (1+x+y) \<le> 1 + log 2 (1+x) + log 2 (1+y)"
proof -
  have 1: "1+x+y \<le> (x+1)*(y+1)" using assms
    by(simp add: algebra_simps)
  show ?thesis
    apply(rule powr_le_cancel_iff[of 2, THEN iffD1])
     apply simp
    using assms 1 by(simp add: powr_add algebra_simps)
qed

lemma ld_ld_less2: assumes "x \<ge> 2" "y \<ge> 2"
  shows "1 + log 2 x + log 2 y \<le> 2 * log 2 (x + y - 1)"
proof-
  from assms have "2*x \<le> x*x" "2*y \<le> y*y" by simp_all
  hence 1: "2 * x * y \<le> (x + y - 1)^2"
    by(simp add: numeral_eq_Suc algebra_simps)
  show ?thesis
    apply(rule powr_le_cancel_iff[of 2, THEN iffD1])
     apply simp
    using assms 1 by(simp add: powr_add log_powr[symmetric] powr_numeral)
qed

end


(*by Ammer*)
theory VEBT_Height imports VEBT_Definitions Complex_Main
begin

context VEBT_internal begin

section \<open>Heights of van Emde Boas Trees\<close>

fun height::"VEBT \<Rightarrow> nat" where
  "height (Leaf a b) = 0"|
  "height (Node _ deg treeList summary) = (1+ Max (height ` (insert summary (set treeList))))"

abbreviation "lb x \<equiv> log 2 x"

lemma setceilmax:  "invar_vebt s m \<Longrightarrow>\<forall> t \<in> set listy. invar_vebt t n
     \<Longrightarrow>m = Suc n \<Longrightarrow>(\<forall> t \<in> set listy. height t = \<lceil>lb n \<rceil> ) \<Longrightarrow> height s  =  \<lceil>lb m\<rceil>
      \<Longrightarrow> Max (height ` (insert s (set listy))) =  \<lceil>lb m\<rceil>"
proof(induction listy)
  case Nil
  hence "Max (height ` (insert s(set []))) = height s" by simp
  then show ?case using Nil by simp
next
  case (Cons a list)
  have "Max (height ` insert s (set (a # list))) =
 max (height a) (Max (height ` insert s (set ( list))))"
    by (simp add: insert_commute)
  moreover have "max (height a) (Max (height ` insert s (set ( list)))) = max (height a) \<lceil>lb m \<rceil>"
    using Cons insert_iff list.simps(15) max_def of_nat_max by force
  moreover have " \<forall> t \<in> set (a#list). invar_vebt t n " using Cons by simp
  moreover hence "invar_vebt a n" by simp
  hence "m \<ge> n"
    by (simp add: Cons.prems(3))
  hence "lb m \<ge> lb n"
    using deg_not_0 \<open>invar_vebt a n\<close> by fastforce
  hence "\<lceil> lb m\<rceil> \<ge> \<lceil> lb n\<rceil>"
    by (simp add: ceiling_mono)
  moreover hence " max \<lceil>log 2 n \<rceil> \<lceil>log 2 m \<rceil> =  \<lceil>log 2 m \<rceil>" by simp
  ultimately show ?case
    using Cons.prems(4) \<open>invar_vebt a n\<close>
    by (metis list.set_intros(1))
qed

lemma log_ceil_idem:
  assumes"(x::real) \<ge> 1"
  shows "\<lceil>lb x \<rceil> = \<lceil>lb \<lceil>x\<rceil>\<rceil>"
proof-
  have "\<lceil>log 2 x \<rceil> \<ge> 0"
    by (smt (verit, ccfv_SIG) assms zero_le_ceiling zero_le_log_cancel_iff)
  have " \<lceil>log 2 x \<rceil> -1 < log 2 x \<and>log 2 x  \<le> \<lceil>log 2 x \<rceil>"
    by linarith
  moreover hence "2 powr (\<lceil>log 2 x \<rceil> -1) < x  \<and> x \<le> 2 powr ( \<lceil>log 2 x \<rceil>)"
    by (smt (verit, ccfv_SIG) assms less_log_iff real_nat_ceiling_ge)
  moreover hence "2 powr ((\<lceil>log 2 x \<rceil> -1)) < \<lceil>x\<rceil>" and " \<lceil>x\<rceil> \<le> 2 powr (\<lceil>log 2 x \<rceil>)"
     apply linarith
    using \<open>0 \<le> \<lceil>log 2 x\<rceil>\<close> calculation(2) ceiling_mono powr_int by fastforce
  moreover hence  " \<lceil>log 2 x \<rceil> -1 < log 2 \<lceil> x \<rceil> \<and>log 2 \<lceil>x\<rceil> \<le> \<lceil>log 2 x \<rceil>"
    by (smt (verit, best) assms ceiling_correct less_log_iff)
  ultimately show ?thesis
    by linarith
qed

lemma heigt_uplog_rel:"invar_vebt t n \<Longrightarrow> (height t) = \<lceil>lb n\<rceil>"
proof(induction t n rule: invar_vebt.induct)
  case (1 a b)
  then show ?case by simp
next
  case (2 treeList n summary m deg)
  hence "m \<ge> n" by simp
  hence "log 2 m \<ge> log 2 n"
    by (simp add: "2.hyps"(3))
  hence "\<lceil> log 2 m\<rceil> \<ge> \<lceil> log 2 n\<rceil>"
    by (simp add: "2.hyps"(3))
  have "Max (height ` (insert summary (set treeList))) = \<lceil> log 2 m\<rceil>"
    by (smt (verit, best) "2.IH"(1) "2.IH"(2) "2.hyps"(3) List.finite_set Max_in empty_is_image finite_imageI finite_insert image_iff insert_iff insert_not_empty)
  hence "height (Node None deg treeList summary) = 1+  \<lceil> log 2 m\<rceil>" by simp
  moreover have "1+  \<lceil> log 2 m\<rceil> = \<lceil>1+ log 2 m\<rceil>" by linarith
  moreover have "1+ log 2 m = log 2 (2*m)"
    using "2.hyps"(1) deg_not_0 log_mult by force
  moreover hence "\<lceil>1+ log 2 m\<rceil> = \<lceil>log 2 (2*m)\<rceil>" by simp
  moreover hence " \<lceil>log 2 (2*m)\<rceil>  = \<lceil>log 2 (n+m)\<rceil>"
    using "2.hyps"(3) by force
  ultimately show ?case
    using "2.hyps"(4) by metis
next
  case (3 treeList n summary m deg)
  hence 00: "n \<ge> 1 \<and> Suc n = m"
    using set_n_deg_not_0 by blast
  hence 0:"m \<ge> n"using 3  by simp
  hence 1:"log 2 m \<ge> log 2 n"
    using "3.IH"(1) "3.hyps"(2) set_n_deg_not_0 by fastforce
  hence 2:"\<lceil> log 2 m\<rceil> \<ge> \<lceil> log 2 n\<rceil>"
    by (simp add: ceiling_mono)
  have 3: "Max (height ` (insert summary (set treeList))) = \<lceil> log 2 m\<rceil>"
    using "3.IH"(1) "3.IH"(2) "3.hyps"(3) List.finite_set Max_in empty_is_image
      finite_imageI finite_insert image_iff insert_iff insert_not_empty  "3.hyps"(1) setceilmax by auto
  hence 4:"height (Node None deg treeList summary) = 1+  \<lceil> log 2 m\<rceil>" by simp
  have 5:"1+  \<lceil> log 2 m\<rceil> = \<lceil>1+ log 2 m\<rceil>" by linarith
  have 6:"1+ log 2 m = log 2 (m+m)"
    using "3.hyps"(1) deg_not_0 log_mult by force
  hence 7:"log 2 (m+n) = 1+log 2 ((n+m) / 2) "
    by (simp add: "3.hyps"(3) log_divide)
  have 8:"log 2 ((n+m) / 2)  = log 2 (n + 1/2)"
    by (smt (verit, best) "3.hyps"(3) field_sum_of_halves of_nat_Suc of_nat_add)
  have 9 : "\<lceil> log 2 (n + 1/2) \<rceil> = \<lceil> log 2 \<lceil>n + 1/2 \<rceil> \<rceil>"
    by (smt (verit) "00" field_sum_of_halves log_ceil_idem of_nat_1 of_nat_mono)
  hence 10: " \<lceil>n + 1/2 \<rceil> = m" using 00 by linarith
  hence 11: "\<lceil> log 2 (n + 1/2) \<rceil>  = \<lceil> log 2 m \<rceil> " using 9 by simp
  hence 12:"\<lceil> 1+ log 2 (n + 1/2) \<rceil>  = \<lceil>1+ log 2 m \<rceil>"
    by (smt (verit) ceiling_add_one)
  hence "\<lceil> log 2 (n + n+1) \<rceil>  = \<lceil> log 2 (m+m) \<rceil>"
    using "3.hyps"(3) "6" "7" "8" by force
  then show ?case
    by (metis "12" "3.hyps"(4) "4" "5" "7" "8" add.commute)
next
  case (4 treeList n summary m deg mi ma)
  hence "m \<ge> n" by simp
  hence "log 2 m \<ge> log 2 n"
    by (simp add: "4.hyps"(3))
  hence "\<lceil> log 2 m\<rceil> \<ge> \<lceil> log 2 n\<rceil>"
    by (simp add: "4.hyps"(3))
  have "Max (height ` (insert summary (set treeList))) = \<lceil> log 2 m\<rceil>"
    by (smt (verit, best) "4.IH"(1) "4.IH"(2) "4.hyps"(3) List.finite_set Max_in empty_is_image finite_imageI finite_insert image_iff insert_iff insert_not_empty)
  hence "height (Node None deg treeList summary) = 1+  \<lceil> log 2 m\<rceil>" by simp
  moreover have "1+  \<lceil> log 2 m\<rceil> = \<lceil>1+ log 2 m\<rceil>" by linarith
  moreover have "1+ log 2 m = log 2 (2*m)"
    using "4.hyps"(1) deg_not_0 log_mult by force
  moreover hence "\<lceil>1+ log 2 m\<rceil> = \<lceil>log 2 (2*m)\<rceil>" by simp
  moreover hence " \<lceil>log 2 (2*m)\<rceil>  = \<lceil>log 2 (n+m)\<rceil>"
    using "4.hyps"(3) by force
  ultimately show ?case
    by (metis "4.hyps"(4) height.simps(2))
next
  case (5 treeList n summary m deg mi ma)
  hence 00: "n \<ge> 1 \<and> Suc n = m"
    using set_n_deg_not_0 by blast
  hence 0:"m \<ge> n"using 5  by simp
  hence 1:"log 2 m \<ge> log 2 n"
    using "5.IH"(1) "5.hyps"(2) set_n_deg_not_0 by fastforce
  hence 2:"\<lceil> log 2 m\<rceil> \<ge> \<lceil> log 2 n\<rceil>"
    by (simp add: ceiling_mono)
  have 3: "Max (height ` (insert summary (set treeList))) = \<lceil> log 2 m\<rceil>"
    using "5.IH"(1) "5.IH"(2) "5.hyps"(3) List.finite_set Max_in empty_is_image
      finite_imageI finite_insert image_iff insert_iff insert_not_empty  "5.hyps"(1) setceilmax by auto
  hence 4:"height (Node None deg treeList summary) = 1+  \<lceil> log 2 m\<rceil>" by simp
  have 5:"1+  \<lceil> log 2 m\<rceil> = \<lceil>1+ log 2 m\<rceil>" by linarith
  have 6:"1+ log 2 m = log 2 (m+m)"
    using "5.hyps"(1) deg_not_0 log_mult by force
  hence 7:"log 2 (m+n) = 1+log 2 ((n+m) / 2) "
    by (simp add: "5.hyps"(3) log_divide)
  have 8:"log 2 ((n+m) / 2)  = log 2 (n + 1/2)"
    by (smt (verit, best) "5.hyps"(3) field_sum_of_halves of_nat_Suc of_nat_add)
  have 9 : "\<lceil> log 2 (n + 1/2) \<rceil> = \<lceil> log 2 \<lceil>n + 1/2 \<rceil> \<rceil>"
    by (smt (verit) "00" field_sum_of_halves log_ceil_idem of_nat_1 of_nat_mono)
  hence 10: " \<lceil>n + 1/2 \<rceil> = m" using 00 by linarith
  hence 11: "\<lceil> log 2 (n + 1/2) \<rceil>  = \<lceil> log 2 m \<rceil> " using 9 by simp
  hence 12:"\<lceil> 1+ log 2 (n + 1/2) \<rceil>  = \<lceil>1+ log 2 m \<rceil>"
    by (smt (verit) ceiling_add_one)
  hence "\<lceil> log 2 (n + n+1) \<rceil>  = \<lceil> log 2 (m+m) \<rceil>"
    using "5.hyps"(3) "6" "7" "8" by force
  then show ?case
    using "4" "5" "5.hyps"(3) "5.hyps"(4) "6" by force
qed

lemma two_powr_height_bound_deg:
  assumes "invar_vebt t n "
  shows " 2^(height t) \<le> 2*(n::nat)"
proof-
  have " (height t) = \<lceil> log 2 n\<rceil>"
    by (simp add: assms heigt_uplog_rel)
  moreover  have "\<lceil> log 2 n\<rceil> \<le> log 2 n +1" by simp
  moreover hence "2 powr \<lceil> log 2 n\<rceil> \<le> 2 powr  (log 2 n +1)" by simp
  moreover have " 2 powr  (log 2 n +1) = 2 powr 1 * 2 powr  (log 2 n)"
    by (simp add: powr_add)
  moreover hence " 2 powr  (log 2 n +1) = 2 * n"
    using assms deg_not_0 by force
  ultimately show ?thesis
    by (metis linorder_not_less not_one_le_zero of_int_0 of_int_less_iff of_int_numeral of_int_of_nat_eq of_nat_le_iff one_add_one order_less_le powr_realpow real_of_nat_eq_numeral_power_cancel_iff zle_add1_eq_le)
qed

text \<open>Main Theorem\<close>

theorem height_double_log_univ_size:
  assumes "u = 2^deg" and "invar_vebt t deg "
  shows "height t \<le> 1 + lb (lb u)"
proof-
  have "(height t) = \<lceil>lb deg\<rceil>"
    by (simp add: assms(2) heigt_uplog_rel)
  have "2^(height t) \<le> 2 *  deg" using assms(2)  two_powr_height_bound_deg[of t deg]
    by (meson dual_order.eq_iff dual_order.trans self_le_ge2_pow)
  hence "height t \<le> 1 + lb deg"
    using \<open>int (height t) = \<lceil>lb (real deg)\<rceil>\<close> by linarith
  hence "height t \<le> 1 + lb (lb u)" using assms by simp
  thus ?thesis by simp
qed

lemma height_compose_list:  " t\<in> set treeList \<Longrightarrow>
 Max (height ` (insert summary (set treeList)))  \<ge>  height t"
  apply(induction treeList) apply simp
  by (meson List.finite_set Max_ge finite_imageI finite_insert image_eqI subsetD subset_insertI)

lemma height_compose_child:  " t\<in> set treeList \<Longrightarrow>
 height (Node info deg treeList summary)  \<ge> 1+  height t" by simp

lemma height_compose_summary: " height (Node info deg treeList summary)  \<ge> 1+  height summary" by simp

lemma  height_i_max: " i < length x13 \<Longrightarrow>
       height (x13 ! i) \<le> max foo  (Max (height ` set x13))"
  by (meson List.finite_set Max_ge finite_imageI max.coboundedI2 nth_mem rev_image_eqI)

lemma max_ins_scaled: " n* height x14 \<le> m + n* Max (insert (height x14) (height ` set x13))"
  by (meson List.finite_set Max_ge finite_imageI finite_insert insertI1 mult_le_mono2 trans_le_add2)

lemma max_idx_list:
  assumes "i < length x13 "
  shows " n * height (x13 !i) \<le> Suc (Suc (n * max (height x14) (Max (height ` set x13))))"
  by (metis assms height_i_max less_Suc_eq mult_le_mono2 nat_less_le)

end
end


(*  Title:      HOL/Nonstandard_Analysis/Free_Ultrafilter.thy
    Author:     Jacques D. Fleuriot, University of Cambridge
    Author:     Lawrence C Paulson
    Author:     Brian Huffman
*)

section \<open>Filters and Ultrafilters\<close>

theory Free_Ultrafilter
  imports "~~/src/HOL/Library/Infinite_Set"
begin

subsection \<open>Definitions and basic properties\<close>

subsubsection \<open>Ultrafilters\<close>

locale ultrafilter =
  fixes F :: "'a filter"
  assumes proper: "F \<noteq> bot"
  assumes ultra: "eventually P F \<or> eventually (\<lambda>x. \<not> P x) F"
begin

lemma eventually_imp_frequently: "frequently P F \<Longrightarrow> eventually P F"
  using ultra[of P] by (simp add: frequently_def)

lemma frequently_eq_eventually: "frequently P F = eventually P F"
  using eventually_imp_frequently eventually_frequently[OF proper] ..

lemma eventually_disj_iff: "eventually (\<lambda>x. P x \<or> Q x) F \<longleftrightarrow> eventually P F \<or> eventually Q F"
  unfolding frequently_eq_eventually[symmetric] frequently_disj_iff ..

lemma eventually_all_iff: "eventually (\<lambda>x. \<forall>y. P x y) F = (\<forall>Y. eventually (\<lambda>x. P x (Y x)) F)"
  using frequently_all[of P F] by (simp add: frequently_eq_eventually)

lemma eventually_imp_iff: "eventually (\<lambda>x. P x \<longrightarrow> Q x) F \<longleftrightarrow> (eventually P F \<longrightarrow> eventually Q F)"
  using frequently_imp_iff[of P Q F] by (simp add: frequently_eq_eventually)

lemma eventually_iff_iff: "eventually (\<lambda>x. P x \<longleftrightarrow> Q x) F \<longleftrightarrow> (eventually P F \<longleftrightarrow> eventually Q F)"
  unfolding iff_conv_conj_imp eventually_conj_iff eventually_imp_iff by simp

lemma eventually_not_iff: "eventually (\<lambda>x. \<not> P x) F \<longleftrightarrow> \<not> eventually P F"
  unfolding not_eventually frequently_eq_eventually ..

end

subsection \<open>Maximal filter = Ultrafilter\<close>

text \<open>
   A filter \<open>F\<close> is an ultrafilter iff it is a maximal filter,
   i.e. whenever \<open>G\<close> is a filter and @{prop "F \<subseteq> G"} then @{prop "F = G"}
\<close>

text \<open>
  Lemma that shows existence of an extension to what was assumed to
  be a maximal filter. Will be used to derive contradiction in proof of
  property of ultrafilter.
\<close>

lemma extend_filter: "frequently P F \<Longrightarrow> inf F (principal {x. P x}) \<noteq> bot"
  by (simp add: trivial_limit_def eventually_inf_principal not_eventually)

lemma max_filter_ultrafilter:
  assumes "F \<noteq> bot"
  assumes max: "\<And>G. G \<noteq> bot \<Longrightarrow> G \<le> F \<Longrightarrow> F = G"
  shows "ultrafilter F"
proof
  show "eventually P F \<or> (\<forall>\<^sub>Fx in F. \<not> P x)" for P
  proof (rule disjCI)
    assume "\<not> (\<forall>\<^sub>Fx in F. \<not> P x)"
    then have "inf F (principal {x. P x}) \<noteq> bot"
      by (simp add: not_eventually extend_filter)
    then have F: "F = inf F (principal {x. P x})"
      by (rule max) simp
    show "eventually P F"
      by (subst F) (simp add: eventually_inf_principal)
  qed
qed fact

lemma le_filter_frequently: "F \<le> G \<longleftrightarrow> (\<forall>P. frequently P F \<longrightarrow> frequently P G)"
  unfolding frequently_def le_filter_def
  apply auto
  apply (erule_tac x="\<lambda>x. \<not> P x" in allE)
  apply auto
  done

lemma (in ultrafilter) max_filter:
  assumes G: "G \<noteq> bot"
    and sub: "G \<le> F"
  shows "F = G"
proof (rule antisym)
  show "F \<le> G"
    using sub
    by (auto simp: le_filter_frequently[of F] frequently_eq_eventually le_filter_def[of G]
             intro!: eventually_frequently G proper)
qed fact

subsection \<open>Ultrafilter Theorem\<close>

lemma ex_max_ultrafilter:
  fixes F :: "'a filter"
  assumes F: "F \<noteq> bot"
  shows "\<exists>U\<le>F. ultrafilter U"
proof -
  let ?X = "{G. G \<noteq> bot \<and> G \<le> F}"
  let ?R = "{(b, a). a \<noteq> bot \<and> a \<le> b \<and> b \<le> F}"

  have bot_notin_R: "c \<in> Chains ?R \<Longrightarrow> bot \<notin> c" for c
    by (auto simp: Chains_def)

  have [simp]: "Field ?R = ?X"
    by (auto simp: Field_def bot_unique)

  have "\<exists>m\<in>Field ?R. \<forall>a\<in>Field ?R. (m, a) \<in> ?R \<longrightarrow> a = m" (is "\<exists>m\<in>?A. ?B m")
  proof (rule Zorns_po_lemma)
    show "Partial_order ?R"
      by (auto simp: partial_order_on_def preorder_on_def
          antisym_def refl_on_def trans_def Field_def bot_unique)
    show "\<forall>C\<in>Chains ?R. \<exists>u\<in>Field ?R. \<forall>a\<in>C. (a, u) \<in> ?R"
    proof (safe intro!: bexI del: notI)
      fix c x
      assume c: "c \<in> Chains ?R"

      have Inf_c: "Inf c \<noteq> bot" "Inf c \<le> F" if "c \<noteq> {}"
      proof -
        from c that have "Inf c = bot \<longleftrightarrow> (\<exists>x\<in>c. x = bot)"
          unfolding trivial_limit_def by (intro eventually_Inf_base) (auto simp: Chains_def)
        with c show "Inf c \<noteq> bot"
          by (simp add: bot_notin_R)
        from that obtain x where "x \<in> c" by auto
        with c show "Inf c \<le> F"
          by (auto intro!: Inf_lower2[of x] simp: Chains_def)
      qed
      then have [simp]: "inf F (Inf c) = (if c = {} then F else Inf c)"
        using c by (auto simp add: inf_absorb2)

      from c show "inf F (Inf c) \<noteq> bot"
        by (simp add: F Inf_c)
      from c show "inf F (Inf c) \<in> Field ?R"
        by (simp add: Chains_def Inf_c F)

      assume "x \<in> c"
      with c show "inf F (Inf c) \<le> x" "x \<le> F"
        by (auto intro: Inf_lower simp: Chains_def)
    qed
  qed
  then obtain U where U: "U \<in> ?A" "?B U" ..
  show ?thesis
  proof
    from U show "U \<le> F \<and> ultrafilter U"
      by (auto intro!: max_filter_ultrafilter)
  qed
qed

subsubsection \<open>Free Ultrafilters\<close>

text \<open>There exists a free ultrafilter on any infinite set.\<close>

locale freeultrafilter = ultrafilter +
  assumes infinite: "eventually P F \<Longrightarrow> infinite {x. P x}"
begin

lemma finite: "finite {x. P x} \<Longrightarrow> \<not> eventually P F"
  by (erule contrapos_pn) (erule infinite)

lemma finite': "finite {x. \<not> P x} \<Longrightarrow> eventually P F"
  by (drule finite) (simp add: not_eventually frequently_eq_eventually)

lemma le_cofinite: "F \<le> cofinite"
  by (intro filter_leI)
    (auto simp add: eventually_cofinite not_eventually frequently_eq_eventually dest!: finite)

lemma singleton: "\<not> eventually (\<lambda>x. x = a) F"
  by (rule finite) simp

lemma singleton': "\<not> eventually (op = a) F"
  by (rule finite) simp

lemma ultrafilter: "ultrafilter F" ..

end

lemma freeultrafilter_Ex:
  assumes [simp]: "infinite (UNIV :: 'a set)"
  shows "\<exists>U::'a filter. freeultrafilter U"
proof -
  from ex_max_ultrafilter[of "cofinite :: 'a filter"]
  obtain U :: "'a filter" where "U \<le> cofinite" "ultrafilter U"
    by auto
  interpret ultrafilter U by fact
  have "freeultrafilter U"
  proof
    fix P
    assume "eventually P U"
    with proper have "frequently P U"
      by (rule eventually_frequently)
    then have "frequently P cofinite"
      using \<open>U \<le> cofinite\<close> by (simp add: le_filter_frequently)
    then show "infinite {x. P x}"
      by (simp add: frequently_cofinite)
  qed
  then show ?thesis ..
qed

end


(*  Title:      HOL/Quotient_Examples/Quotient_Rat.thy
    Author:     Cezary Kaliszyk

Rational numbers defined with the quotient package, based on 'HOL/Rat.thy' by Makarius.
*)

theory Quotient_Rat imports Archimedean_Field
  "~~/src/HOL/Library/Quotient_Product"
begin

definition
  ratrel :: "(int \<times> int) \<Rightarrow> (int \<times> int) \<Rightarrow> bool" (infix "\<approx>" 50)
where
  [simp]: "x \<approx> y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"

lemma ratrel_equivp:
  "part_equivp ratrel"
proof (auto intro!: part_equivpI reflpI sympI transpI exI[of _ "1 :: int"])
  fix a b c d e f :: int
  assume nz: "d \<noteq> 0" "b \<noteq> 0"
  assume y: "a * d = c * b"
  assume x: "c * f = e * d"
  then have "c * b * f = e * d * b" using nz by simp
  then have "a * d * f = e * d * b" using y by simp
  then show "a * f = e * b" using nz by simp
qed

quotient_type rat = "int \<times> int" / partial: ratrel
 using ratrel_equivp .

instantiation rat :: "{zero, one, plus, uminus, minus, times, ord, abs, sgn}"
begin

quotient_definition
  "0 :: rat" is "(0::int, 1::int)" by simp

quotient_definition
  "1 :: rat" is "(1::int, 1::int)" by simp

fun times_rat_raw where
  "times_rat_raw (a :: int, b :: int) (c, d) = (a * c, b * d)"

quotient_definition
  "(op *) :: (rat \<Rightarrow> rat \<Rightarrow> rat)" is times_rat_raw by (auto simp add: mult.assoc mult.left_commute)

fun plus_rat_raw where
  "plus_rat_raw (a :: int, b :: int) (c, d) = (a * d + c * b, b * d)"

quotient_definition
  "(op +) :: (rat \<Rightarrow> rat \<Rightarrow> rat)" is plus_rat_raw
  by (auto simp add: mult.commute mult.left_commute int_distrib(2))

fun uminus_rat_raw where
  "uminus_rat_raw (a :: int, b :: int) = (-a, b)"

quotient_definition
  "(uminus :: (rat \<Rightarrow> rat))" is "uminus_rat_raw" by fastforce

definition
  minus_rat_def: "a - b = a + (-b::rat)"

fun le_rat_raw where
  "le_rat_raw (a :: int, b) (c, d) \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"

quotient_definition
  "(op \<le>) :: rat \<Rightarrow> rat \<Rightarrow> bool" is "le_rat_raw"
proof -
  {
    fix a b c d e f g h :: int
    assume "a * f * (b * f) \<le> e * b * (b * f)"
    then have le: "a * f * b * f \<le> e * b * b * f" by simp
    assume nz: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0" "h \<noteq> 0"
    then have b2: "b * b > 0"
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
    have f2: "f * f > 0" using nz(3)
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
    assume eq: "a * d = c * b" "e * h = g * f"
    have "a * f * b * f * d * d \<le> e * b * b * f * d * d" using le nz(2)
      by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
    then have "c * f * f * d * (b * b) \<le> e * f * d * d * (b * b)" using eq
      by (metis (no_types) mult.assoc mult.commute)
    then have "c * f * f * d \<le> e * f * d * d" using b2
      by (metis leD linorder_le_less_linear mult_strict_right_mono)
    then have "c * f * f * d * h * h \<le> e * f * d * d * h * h" using nz(4)
      by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
    then have "c * h * (d * h) * (f * f) \<le> g * d * (d * h) * (f * f)" using eq
      by (metis (no_types) mult.assoc mult.commute)
    then have "c * h * (d * h) \<le> g * d * (d * h)" using f2
      by (metis leD linorder_le_less_linear mult_strict_right_mono)
  }
  then show "\<And>x y xa ya. x \<approx> y \<Longrightarrow> xa \<approx> ya \<Longrightarrow> le_rat_raw x xa = le_rat_raw y ya" by auto
qed

definition
  less_rat_def: "(z::rat) < w = (z \<le> w \<and> z \<noteq> w)"

definition
  rabs_rat_def: "\<bar>i::rat\<bar> = (if i < 0 then - i else i)"

definition
  sgn_rat_def: "sgn (i::rat) = (if i = 0 then 0 else if 0 < i then 1 else - 1)"

instance ..

end

definition
  Fract_raw :: "int \<Rightarrow> int \<Rightarrow> (int \<times> int)"
where [simp]: "Fract_raw a b = (if b = 0 then (0, 1) else (a, b))"

quotient_definition "Fract :: int \<Rightarrow> int \<Rightarrow> rat" is
  Fract_raw by simp

lemmas [simp] = Respects_def

(* FIXME: (partiality_)descending raises exception TYPE_MATCH

instantiation rat :: comm_ring_1
begin

instance proof
  fix a b c :: rat
  show "a * b * c = a * (b * c)"
    by partiality_descending auto
  show "a * b = b * a"
    by partiality_descending auto
  show "1 * a = a"
    by partiality_descending auto
  show "a + b + c = a + (b + c)"
    by partiality_descending (auto simp add: mult.commute distrib_left)
  show "a + b = b + a"
    by partiality_descending auto
  show "0 + a = a"
    by partiality_descending auto
  show "- a + a = 0"
    by partiality_descending auto
  show "a - b = a + - b"
    by (simp add: minus_rat_def)
  show "(a + b) * c = a * c + b * c"
    by partiality_descending (auto simp add: mult.commute distrib_left)
  show "(0 :: rat) \<noteq> (1 :: rat)"
    by partiality_descending auto
qed

end

lemma add_one_Fract: "1 + Fract (int k) 1 = Fract (1 + int k) 1"
  by descending auto

lemma of_nat_rat: "of_nat k = Fract (of_nat k) 1"
  apply (induct k)
  apply (simp add: zero_rat_def Fract_def)
  apply (simp add: add_one_Fract)
  done

lemma of_int_rat: "of_int k = Fract k 1"
  apply (cases k rule: int_diff_cases)
  apply (auto simp add: of_nat_rat minus_rat_def)
  apply descending
  apply auto
  done

instantiation rat :: field begin

fun rat_inverse_raw where
  "rat_inverse_raw (a :: int, b :: int) = (if a = 0 then (0, 1) else (b, a))"

quotient_definition
  "inverse :: rat \<Rightarrow> rat" is rat_inverse_raw by (force simp add: mult.commute)

definition
  divide_rat_def: "q / r = q * inverse (r::rat)"

instance proof
  fix q :: rat
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by partiality_descending auto
next
  fix q r :: rat
  show "q / r = q * inverse r" by (simp add: divide_rat_def)
next
  show "inverse 0 = (0::rat)" by partiality_descending auto
qed

end

instantiation rat :: linorder
begin

instance proof
  fix q r s :: rat
  {
    assume "q \<le> r" and "r \<le> s"
    then show "q \<le> s"
    proof (partiality_descending, auto simp add: mult.assoc[symmetric])
      fix a b c d e f :: int
      assume nz: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
      then have d2: "d * d > 0"
        by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
      assume le: "a * d * b * d \<le> c * b * b * d" "c * f * d * f \<le> e * d * d * f"
      then have a: "a * d * b * d * f * f \<le> c * b * b * d * f * f" using nz(3)
        by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
      have "c * f * d * f * b * b \<le> e * d * d * f * b * b" using nz(1) le
        by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
      then have "a * f * b * f * (d * d) \<le> e * b * b * f * (d * d)" using a
        by (simp add: algebra_simps)
      then show "a * f * b * f \<le> e * b * b * f" using d2
        by (metis leD linorder_le_less_linear mult_strict_right_mono)
    qed
  next
    assume "q \<le> r" and "r \<le> q"
    then show "q = r"
      apply (partiality_descending, auto)
      apply (case_tac "b > 0", case_tac [!] "ba > 0")
      apply simp_all
      done
  next
    show "q \<le> q" by partiality_descending auto
    show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
      unfolding less_rat_def
      by partiality_descending (auto simp add: le_less mult.commute)
    show "q \<le> r \<or> r \<le> q"
      by partiality_descending (auto simp add: mult.commute linorder_linear)
  }
qed

end

instance rat :: archimedean_field
proof
  fix q r s :: rat
  show "q \<le> r ==> s + q \<le> s + r"
  proof (partiality_descending, auto simp add: algebra_simps, simp add: mult.assoc[symmetric])
    fix a b c d e :: int
    assume "e \<noteq> 0"
    then have e2: "e * e > 0"
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
      assume "a * b * d * d \<le> b * b * c * d"
      then show "a * b * d * d * e * e * e * e \<le> b * b * c * d * e * e * e * e"
        using e2 by (metis mult_left_mono mult.commute linorder_le_cases
          mult_left_mono_neg)
    qed
  show "q < r ==> 0 < s ==> s * q < s * r" unfolding less_rat_def
    proof (partiality_descending, auto simp add: algebra_simps, simp add: mult.assoc[symmetric])
    fix a b c d e f :: int
    assume a: "e \<noteq> 0" "f \<noteq> 0" "0 \<le> e * f" "a * b * d * d \<le> b * b * c * d"
    have "a * b * d * d * (e * f) \<le> b * b * c * d * (e * f)" using a
      by (simp add: mult_right_mono)
    then show "a * b * d * d * e * f * f * f \<le> b * b * c * d * e * f * f * f"
      by (simp add: mult.assoc[symmetric]) (metis a(3) mult_left_mono
        mult.commute mult_left_mono_neg zero_le_mult_iff)
  qed
  show "\<exists>z. r \<le> of_int z"
    unfolding of_int_rat
  proof (partiality_descending, auto)
    fix a b :: int
    assume "b \<noteq> 0"
    then have "a * b \<le> (a div b + 1) * b * b"
      by (metis mult.commute nonzero_mult_div_cancel_left less_int_def linorder_le_cases zdiv_mono1 zdiv_mono1_neg zle_add1_eq_le)
    then show "\<exists>z::int. a * b \<le> z * b * b" by auto
  qed
qed
*)

end


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

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

datatype Tree = TNode "Tree" "int" "Tree" | TNil

fun flatten :: "Tree => int list => int list" where
"flatten (TNode p z q) y = flatten p (cons2 z (flatten q y))"
| "flatten (TNil) y = y"

fun count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

fun add :: "int => Tree => Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "int list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "((count x (tsort xs)) = (count x xs))"
  oops

end


(* Title: Program Correctness Component Based on Kleene Algebra with Tests
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Two Standalone Components\<close>

theory VC_KAT_scratch
  imports Main
begin

subsection \<open>Component Based on Kleene Algebra with Tests\<close>

text \<open>This component supports the verification and step-wise refinement of simple while programs
in a partial correctness setting.\<close>

subsubsection \<open>KAT: Definition and Basic Properties\<close>

notation times (infixl "\<cdot>" 70)

class plus_ord = plus + ord +
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and less_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

class dioid = semiring + one + zero + plus_ord +
  assumes add_idem [simp]: "x + x = x"
  and mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

begin

subclass monoid_mult
  by (standard, simp_all)

subclass order
  apply (standard, simp_all add: less_def less_eq_def add_commute)
  apply force
  by (metis add_assoc)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distrib_left less_eq_def)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distrib_right less_eq_def)

lemma add_iso: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
  by (metis (no_types, lifting) abel_semigroup.commute add.abel_semigroup_axioms add.semigroup_axioms add_idem less_eq_def semigroup.assoc)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add.left_commute add_idem less_eq_def)

end

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim: "x \<cdot> y \<le> z \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> x"
proof -
  assume "x \<cdot> y \<le> z \<cdot> x"
  hence "x + z\<^sup>\<star> \<cdot> x \<cdot> y \<le> x + z\<^sup>\<star> \<cdot> z \<cdot> x"
    by (metis add_lub distrib_left eq_refl less_eq_def mult_assoc)
  also have  "... \<le> z\<^sup>\<star> \<cdot> x"
    using add_lub mult_isor star_unfoldr by fastforce
  finally show ?thesis
    by (simp add: star_inductr)
qed

end

class kat = kleene_algebra +
  fixes at :: "'a \<Rightarrow> 'a"
  assumes test_one [simp]: "at (at 1) = 1"
  and test_mult [simp]: "at (at (at (at x) \<cdot> at (at y))) = at (at y) \<cdot> at (at x)"
  and test_mult_comp [simp]: "at x \<cdot> at (at x) = 0"
  and test_de_morgan: "at x + at y = at (at (at x) \<cdot> at (at y))"

begin

definition t_op :: "'a \<Rightarrow> 'a" ("t_" [100] 101) where
  "t x = at (at x)"

lemma t_n [simp]: "t (at x) = at x"
  by (metis add_idem test_de_morgan test_mult t_op_def)

lemma t_comm: "t x \<cdot> t y = t y \<cdot> t x"
  by (metis add_commute test_de_morgan test_mult t_op_def)

lemma t_idem [simp]: "t x \<cdot> t x = t x"
  by (metis add_idem test_de_morgan test_mult t_op_def)

lemma t_mult_closed [simp]: "t (t x \<cdot> t y) = t x \<cdot> t y"
  using t_comm t_op_def by auto

subsubsection\<open>Propositional Hoare Logic\<close>

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> t p \<cdot> x \<le> x \<cdot> t q"

definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = t p \<cdot> x + at p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (t p \<cdot> x)\<^sup>\<star> \<cdot> at p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma H_skip: "H p 1 p"
  by (simp add: H_def)

lemma H_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (meson H_def mult_isol mult_isor order.trans)

lemma H_seq: "H r y q \<Longrightarrow> H p x r  \<Longrightarrow> H p (x \<cdot> y) q"
proof -
  assume h1: "H p x r" and h2: "H r y q"
  hence h3: "t p \<cdot> x \<le> x \<cdot> t r" and h4: "t r \<cdot> y \<le> y \<cdot> t q"
    using H_def apply  blast using H_def h2 by blast
  hence "t p \<cdot> x \<cdot> y \<le> x \<cdot> t r \<cdot> y"
    using mult_isor by blast
  also have "... \<le> x \<cdot> y \<cdot> t q"
    by (simp add: h4 mult_isol mult_assoc)
  finally show ?thesis
    by (simp add: H_def mult_assoc)
qed

lemma H_cond: "H (t p \<cdot> t r) x q \<Longrightarrow> H (t p \<cdot> at r) y q \<Longrightarrow> H p (if r then x else y fi) q"
proof -
  assume h1: "H (t p \<cdot> t r) x q" and h2: "H (t p \<cdot> at r) y q"
  hence h3: "t r \<cdot> t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t q" and h4: "at r \<cdot> t p \<cdot> at r \<cdot> y \<le> at r \<cdot> y \<cdot> t q"
    by (simp add: H_def mult_isol mult_assoc, metis H_def h2 mult_isol mult_assoc t_mult_closed t_n)
  hence h5: "t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t q" and  h6: "t p \<cdot> at r \<cdot> y \<le> at r \<cdot> y \<cdot> t q"
    by (simp add: mult_assoc t_comm, metis h4 mult_assoc t_comm t_idem t_n)
  have "t p \<cdot> (t r \<cdot> x + at r \<cdot> y) = t p \<cdot> t r \<cdot> x + t p \<cdot> at r \<cdot> y"
    by (simp add: distrib_left mult_assoc)
  also have "... \<le> t r \<cdot> x \<cdot> t q + t p \<cdot> at r \<cdot> y"
    using h5 add_iso by blast
  also have "... \<le> t r \<cdot> x \<cdot> t q + at r \<cdot> y \<cdot> t q"
    by (simp add: add_commute h6 add_iso)
  finally show ?thesis
    by (simp add: H_def if_then_else_def distrib_right)
qed

lemma H_loop: "H (t p \<cdot> t r) x p \<Longrightarrow> H p (while r do x od) (t p \<cdot> at r)"
proof -
  assume  "H (t p \<cdot> t r) x p"
  hence "t r \<cdot> t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t p"
    by (metis H_def distrib_left less_eq_def mult_assoc t_mult_closed)
  hence "t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t p"
    by (simp add: mult_assoc t_comm)
  hence "t p \<cdot> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<le> (t r \<cdot> x)\<^sup>\<star> \<cdot> t p \<cdot> at r"
    by (metis mult_isor star_sim mult_assoc)
  hence "t p \<cdot> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<le> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<cdot> t p \<cdot> at r"
    by (metis mult_assoc t_comm t_idem t_n)
  thus ?thesis
    by (metis H_def mult_assoc t_mult_closed t_n while_def)
qed

lemma H_while_inv: "t p \<le> t i \<Longrightarrow> t i \<cdot> at r \<le> t q \<Longrightarrow> H (t i \<cdot> t r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  by (metis H_cons H_loop t_mult_closed t_n while_inv_def)

end

subsubsection\<open>Soundness and Relation KAT\<close>

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid Id "{}" "(\<union>)" "(;)" "(\<subseteq>)" "(\<subset>)"
  by (standard, auto)

lemma (in dioid) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  by (metis local.dual_order.trans local.mult_isol mult_assoc)

lemma (in dioid) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  apply (induct i; clarsimp simp add: add_lub)
  proof -
    fix i
    assume "z \<cdot> x ^ i \<le> y" "z \<le> y" "y \<cdot> x \<le> y"
    hence "(z \<cdot> x ^ i) \<cdot> x \<le> y"
      using local.dual_order.trans local.mult_isor by blast
    thus "z \<cdot> (x \<cdot> x ^ i) \<le> y"
      by (simp add: mult_assoc local.power_commutes)
  qed

lemma power_is_relpow: "rel_d.power X i = X ^^ i"
  by (induct i, simp_all add: relpow_commute)

lemma rel_star_def: "X^* = (\<Union>i. rel_d.power X i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X ; Y^* = (\<Union>i. X ; rel_d.power Y i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* ; Y = (\<Union>i. (rel_d.power X i) ; Y)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

definition rel_at :: "'a rel \<Rightarrow> 'a rel" where
  "rel_at X = Id \<inter> - X"

interpretation rel_kat: kat Id "{}" "(\<union>)" "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_at
  apply standard
  apply auto[2]
  by (auto simp: rel_star_contr rel_d.power_inductl rel_star_contl  SUP_least rel_d.power_inductr rel_at_def)

subsubsection\<open>Embedding Predicates in Relations\<close>

type_synonym 'a pred = "'a \<Rightarrow> bool"

abbreviation p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> {(s,s) |s. P s}"

lemma t_p2r [simp]: "rel_kat.t_op \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp add: rel_kat.t_op_def rel_at_def)

lemma p2r_neg_hom [simp]: "rel_at \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  by (auto simp: rel_at_def)

lemma p2r_conj_hom [simp]: "\<lceil>P\<rceil> \<inter> \<lceil>Q\<rceil> = \<lceil>\<lambda>s.  P s \<and> Q s\<rceil>"
  by auto

lemma p2r_conj_hom_var [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_disj_hom [simp]: "\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  by auto

lemma impl_prop [simp]: "\<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by auto

subsubsection \<open>Store and Assignment\<close>

type_synonym 'a store = "string  \<Rightarrow> 'a"

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s, s(v := e s)) |s. True}"

lemma H_assign: "rel_kat.H \<lceil>\<lambda>s. P (s (v := e s))\<rceil> (v ::= e) \<lceil>P\<rceil>"
  by (auto simp: gets_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: gets_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

abbreviation H_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_kat.if_then_else \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_kat.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

subsubsection \<open>Verification Example\<close>

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_kat.H_while_inv, simp_all, clarsimp)
  apply (intro rel_kat.H_seq)
  apply (subst H_assign, simp)+
  apply (rule H_assign_var)
  using gcd_red_nat by auto

subsubsection \<open>Definition of Refinement KAT\<close>

class rkat = kat +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes R1: "H p (R p q) q"
  and R2: "H p x q \<Longrightarrow> x \<le> R p q"

begin

subsubsection \<open>Propositional Refinement Calculus\<close>

lemma R_skip: "1 \<le> R p p"
  by (simp add: H_skip R2)

lemma R_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> R p' q' \<le> R p q"
  by (simp add: H_cons R2 R1)

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
  using H_seq R2 R1 by blast

lemma R_cond: "if v then (R (t v \<cdot> t p) q) else (R (at v \<cdot> t p) q) fi \<le> R p q"
  by (metis H_cond R1 R2 t_comm t_n)

lemma R_loop: "while q do (R (t p \<cdot> t q) p) od  \<le> R p (t p \<cdot> at q)"
  by (simp add: H_loop R2 R1)

end

subsubsection \<open>Soundness and Relation RKAT\<close>

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_kat.H P X Q}"

interpretation rel_rkat: rkat Id "{}" "(\<union>)"  "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl rel_at rel_R
  by (standard, auto simp: rel_R_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

subsubsection \<open>Assignment Laws\<close>

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (simp add: H_assign_var rel_rkat.R2)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
proof -
  assume a1: "\<forall>s. Q' s \<longrightarrow> Q (s(v := e s))"
  have "\<forall>p pa cs f. \<exists>fa. (p fa \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>) \<and> (\<not> pa (fa(cs := f fa::'a)) \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>)"
    using R_assign by blast
  hence "v ::= e \<subseteq> rel_R \<lceil>Q'\<rceil> \<lceil>Q\<rceil>"
    using a1 by blast
  thus ?thesis
    by (meson dual_order.trans rel_d.mult_isol rel_rkat.R_seq)
qed

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
proof -
  assume a1: "\<forall>s. P s \<longrightarrow> P' (s(v := e s))"
  have "\<forall>p pa cs f. \<exists>fa. (p fa \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>) \<and> (\<not> pa (fa(cs := f fa::'a)) \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>)"
    using R_assign by blast
  then have "v ::= e \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>P'\<rceil>"
    using a1 by blast
  then show ?thesis
    by (meson dual_order.trans rel_d.mult_isor rel_rkat.R_seq)
qed

subsubsection \<open>Refinement Example\<close>

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkat.R_skip  by fastforce

end


theory RM_Sums_Diophantine imports Equation_Setup "../Diophantine/Register_Machine_Sums"
                                   "../Diophantine/Binary_And"

begin

context register_machine
begin

definition sum_ssub_nzero_of_bit_and  :: "polynomial \<Rightarrow> nat \<Rightarrow> polynomial list \<Rightarrow> polynomial list
                                    \<Rightarrow> relation"
  ("[_ = \<Sum>S- _ '(_ && _')]") where
  "[x = \<Sum>S- d (s && z)] \<equiv> let x' = push_param x (length p);
                                s' = push_param_list s (length p);
                                z' = push_param_list z (length p)
                            in [\<exists>length p] [\<forall><length p] (\<lambda>i. [Param i = s'!i && z'!i])
                                                        [\<and>] x' [=] ([\<Sum>S-] p d Param)"

lemma sum_ssub_nzero_of_bit_and_dioph[dioph]:
  fixes s z :: "polynomial list" and d :: nat and x
  shows "is_dioph_rel [x = \<Sum>S- d (s && z)]"
  unfolding sum_ssub_nzero_of_bit_and_def by (auto simp add: dioph)

lemma sum_rsub_nzero_of_bit_and_eval:
  fixes z s :: "polynomial list" and d :: nat and x :: polynomial
  assumes "length s = Suc m" "length z = Suc m" "length p > 0"
  shows "eval [x = \<Sum>S- d (s && z)] a
         \<longleftrightarrow> peval x a = \<Sum>S- p d (\<lambda>k. peval (s!k) a && peval (z!k) a)" (is "?P \<longleftrightarrow> ?Q")
proof -
  have invariance: "\<forall>k<length p. y1 k = y2 k \<Longrightarrow> \<Sum>S- p d y1 = \<Sum>S- p d y2" for y1 y2
    unfolding sum_ssub_nzero.simps apply (intro sum.cong, simp)
    using \<open>length p > 0\<close> by auto (metis Suc_pred le_imp_less_Suc length_greater_0_conv)

  have len_ps: "length s = length p"
    using m_def \<open>length s = Suc m\<close> \<open>length p > 0\<close> by auto
  have len_pz: "length z = length p"
    using m_def \<open>length z = Suc m\<close> \<open>length p > 0\<close> by auto

  show ?thesis
  proof (rule)
    assume ?P
    thus ?Q
      using sum_ssub_nzero_of_bit_and_def \<open>length p > 0\<close> apply (auto simp add: defs push_push)
      using push_push_map_i apply (simp add: push_param_list_def len_ps len_pz)
      unfolding list_eval_def apply (auto simp: assms len_ps len_pz invariance)
      apply (rule sum_ssub_nzero_cong) apply auto
      by (metis (no_types, lifting) One_nat_def assms(1) assms(2)
                le_imp_less_Suc len_ps m_def nth_map)

  next
    assume ?Q
    thus ?P
      using sum_ssub_nzero_of_bit_and_def \<open>length p > 0\<close> apply (auto simp add: defs push_push)
      apply (rule exI[of _ "map (\<lambda>k. peval (s ! k) a && peval (z ! k) a) [0..<length p]"], simp)
      using push_push push_push_map_i
      by (simp add: push_param_list_def invariance push_list_eval len_ps len_pz)
  qed
qed

definition sum_ssub_zero_of_bit_and  :: "polynomial \<Rightarrow> nat \<Rightarrow> polynomial list \<Rightarrow> polynomial list
                                    \<Rightarrow> relation"
  ("[_ = \<Sum>S0 _ '(_ && _')]") where
  "[x = \<Sum>S0 d (s && z)] \<equiv> let x' = push_param x (length p);
                                s' = push_param_list s (length p);
                                z' = push_param_list z (length p)
                            in [\<exists>length p] [\<forall><length p] (\<lambda>i. [Param i = s'!i && z'!i])
                                                        [\<and>] x' [=] [\<Sum>S0] p d Param"

lemma sum_ssub_zero_of_bit_and_dioph[dioph]:
  fixes s z :: "polynomial list" and d :: nat and x
  shows "is_dioph_rel [x = \<Sum>S0 d (s && z)]"
  unfolding sum_ssub_zero_of_bit_and_def by (auto simp add: dioph)

lemma sum_rsub_zero_of_bit_and_eval:
  fixes z s :: "polynomial list" and d :: nat and x :: polynomial
  assumes "length s = Suc m" "length z = Suc m" "length p > 0"
  shows "eval [x = \<Sum>S0 d (s && z)] a
         \<longleftrightarrow> peval x a = \<Sum>S0 p d (\<lambda>k. peval (s!k) a && peval (z!k) a)" (is "?P \<longleftrightarrow> ?Q")
proof -
  have invariance: "\<forall>k<length p. y1 k = y2 k \<Longrightarrow> \<Sum>S0 p d y1 = \<Sum>S0 p d y2" for y1 y2
    unfolding sum_ssub_zero.simps apply (intro sum.cong, simp)
    using \<open>length p > 0\<close> by auto (metis Suc_pred le_imp_less_Suc length_greater_0_conv)

  have len_ps: "length s = length p"
    using m_def \<open>length s = Suc m\<close> \<open>length p > 0\<close> by auto
  have len_pz: "length z = length p"
    using m_def \<open>length z = Suc m\<close> \<open>length p > 0\<close> by auto

  show ?thesis
  proof (rule)
    assume ?P
    thus ?Q
      using sum_ssub_zero_of_bit_and_def \<open>length p > 0\<close> apply (auto simp add: defs push_push)
      using push_push_map_i apply (simp add: push_param_list_def len_ps len_pz)
      unfolding list_eval_def apply (auto simp: assms len_ps len_pz invariance)
      apply (rule sum_ssub_zero_cong) apply auto
      by (metis (no_types, lifting) One_nat_def assms(1) assms(2)
                le_imp_less_Suc len_ps m_def nth_map)
  next
    assume ?Q
    thus ?P
      using sum_ssub_zero_of_bit_and_def \<open>length p > 0\<close> apply (auto simp add: defs push_push)
      apply (rule exI[of _ "map (\<lambda>k. peval (s ! k) a && peval (z!k) a) [0..<length p]"], simp)
      using push_push push_push_map_i
      by (simp add: push_param_list_def invariance push_list_eval len_ps len_pz)
  qed
qed

end

end


(* Author: Tobias Nipkow *)

theory Abs_Int2_ivl_ITP
imports Abs_Int2_ITP "../Abs_Int_Tests"
begin

subsection "Interval Analysis"

datatype ivl = I "int option" "int option"

definition "\<gamma>_ivl i = (case i of
  I (Some l) (Some h) \<Rightarrow> {l..h} |
  I (Some l) None \<Rightarrow> {l..} |
  I None (Some h) \<Rightarrow> {..h} |
  I None None \<Rightarrow> UNIV)"

abbreviation I_Some_Some :: "int \<Rightarrow> int \<Rightarrow> ivl"  ("{_\<dots>_}") where
"{lo\<dots>hi} == I (Some lo) (Some hi)"
abbreviation I_Some_None :: "int \<Rightarrow> ivl"  ("{_\<dots>}") where
"{lo\<dots>} == I (Some lo) None"
abbreviation I_None_Some :: "int \<Rightarrow> ivl"  ("{\<dots>_}") where
"{\<dots>hi} == I None (Some hi)"
abbreviation I_None_None :: "ivl"  ("{\<dots>}") where
"{\<dots>} == I None None"

definition "num_ivl n = {n\<dots>n}"

fun in_ivl :: "int \<Rightarrow> ivl \<Rightarrow> bool" where
"in_ivl k (I (Some l) (Some h)) \<longleftrightarrow> l \<le> k \<and> k \<le> h" |
"in_ivl k (I (Some l) None) \<longleftrightarrow> l \<le> k" |
"in_ivl k (I None (Some h)) \<longleftrightarrow> k \<le> h" |
"in_ivl k (I None None) \<longleftrightarrow> True"

instantiation option :: (plus)plus
begin

fun plus_option where
"Some x + Some y = Some(x+y)" |
"_ + _ = None"

instance ..

end

definition empty where "empty = {1\<dots>0}"

fun is_empty where
"is_empty {l\<dots>h} = (h<l)" |
"is_empty _ = False"

lemma [simp]: "is_empty i \<Longrightarrow> \<gamma>_ivl i = {}"
by(auto simp add: \<gamma>_ivl_def split: ivl.split option.split)

definition "plus_ivl i1 i2 = (if is_empty i1 | is_empty i2 then empty else
  case (i1,i2) of (I l1 h1, I l2 h2) \<Rightarrow> I (l1+l2) (h1+h2))"

instantiation ivl :: SL_top
begin

definition le_option :: "bool \<Rightarrow> int option \<Rightarrow> int option \<Rightarrow> bool" where
"le_option pos x y =
 (case x of (Some i) \<Rightarrow> (case y of Some j \<Rightarrow> i\<le>j | None \<Rightarrow> pos)
  | None \<Rightarrow> (case y of Some j \<Rightarrow> \<not>pos | None \<Rightarrow> True))"

fun le_aux where
"le_aux (I l1 h1) (I l2 h2) = (le_option False l2 l1 & le_option True h1 h2)"

definition le_ivl where
"i1 \<sqsubseteq> i2 =
 (if is_empty i1 then True else
  if is_empty i2 then False else le_aux i1 i2)"

definition min_option :: "bool \<Rightarrow> int option \<Rightarrow> int option \<Rightarrow> int option" where
"min_option pos o1 o2 = (if le_option pos o1 o2 then o1 else o2)"

definition max_option :: "bool \<Rightarrow> int option \<Rightarrow> int option \<Rightarrow> int option" where
"max_option pos o1 o2 = (if le_option pos o1 o2 then o2 else o1)"

definition "i1 \<squnion> i2 =
 (if is_empty i1 then i2 else if is_empty i2 then i1
  else case (i1,i2) of (I l1 h1, I l2 h2) \<Rightarrow>
          I (min_option False l1 l2) (max_option True h1 h2))"

definition "\<top> = {\<dots>}"

instance
proof
  case goal1 thus ?case
    by(cases x, simp add: le_ivl_def le_option_def split: option.split)
next
  case goal2 thus ?case
    by(cases x, cases y, cases z, auto simp: le_ivl_def le_option_def split: option.splits if_splits)
next
  case goal3 thus ?case
    by(cases x, cases y, simp add: le_ivl_def join_ivl_def le_option_def min_option_def max_option_def split: option.splits)
next
  case goal4 thus ?case
    by(cases x, cases y, simp add: le_ivl_def join_ivl_def le_option_def min_option_def max_option_def split: option.splits)
next
  case goal5 thus ?case
    by(cases x, cases y, cases z, auto simp add: le_ivl_def join_ivl_def le_option_def min_option_def max_option_def split: option.splits if_splits)
next
  case goal6 thus ?case
    by(cases x, simp add: Top_ivl_def le_ivl_def le_option_def split: option.split)
qed

end

instantiation ivl :: L_top_bot
begin

definition "i1 \<sqinter> i2 = (if is_empty i1 \<or> is_empty i2 then empty else
  case (i1,i2) of (I l1 h1, I l2 h2) \<Rightarrow>
    I (max_option False l1 l2) (min_option True h1 h2))"

definition "\<bottom> = empty"

instance
proof
  case goal1 thus ?case
    by (simp add:meet_ivl_def empty_def le_ivl_def le_option_def max_option_def min_option_def split: ivl.splits option.splits)
next
  case goal2 thus ?case
    by (simp add: empty_def meet_ivl_def le_ivl_def le_option_def max_option_def min_option_def split: ivl.splits option.splits)
next
  case goal3 thus ?case
    by (cases x, cases y, cases z, auto simp add: le_ivl_def meet_ivl_def empty_def le_option_def max_option_def min_option_def split: option.splits if_splits)
next
  case goal4 show ?case by(cases x, simp add: bot_ivl_def empty_def le_ivl_def)
qed

end

instantiation option :: (minus)minus
begin

fun minus_option where
"Some x - Some y = Some(x-y)" |
"_ - _ = None"

instance ..

end

definition "minus_ivl i1 i2 = (if is_empty i1 | is_empty i2 then empty else
  case (i1,i2) of (I l1 h1, I l2 h2) \<Rightarrow> I (l1-h2) (h1-l2))"

lemma gamma_minus_ivl:
  "n1 : \<gamma>_ivl i1 \<Longrightarrow> n2 : \<gamma>_ivl i2 \<Longrightarrow> n1-n2 : \<gamma>_ivl(minus_ivl i1 i2)"
by(auto simp add: minus_ivl_def \<gamma>_ivl_def split: ivl.splits option.splits)

definition "filter_plus_ivl i i1 i2 = ((*if is_empty i then empty else*)
  i1 \<sqinter> minus_ivl i i2, i2 \<sqinter> minus_ivl i i1)"

fun filter_less_ivl :: "bool \<Rightarrow> ivl \<Rightarrow> ivl \<Rightarrow> ivl * ivl" where
"filter_less_ivl res (I l1 h1) (I l2 h2) =
  (if is_empty(I l1 h1) \<or> is_empty(I l2 h2) then (empty, empty) else
   if res
   then (I l1 (min_option True h1 (h2 - Some 1)),
         I (max_option False (l1 + Some 1) l2) h2)
   else (I (max_option False l1 l2) h1, I l2 (min_option True h1 h2)))"

global_interpretation Val_abs
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
proof
  case goal1 thus ?case
    by(auto simp: \<gamma>_ivl_def le_ivl_def le_option_def split: ivl.split option.split if_splits)
next
  case goal2 show ?case by(simp add: \<gamma>_ivl_def Top_ivl_def)
next
  case goal3 thus ?case by(simp add: \<gamma>_ivl_def num_ivl_def)
next
  case goal4 thus ?case
    by(auto simp add: \<gamma>_ivl_def plus_ivl_def split: ivl.split option.splits)
qed

global_interpretation Val_abs1_gamma
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
defines aval_ivl = aval'
proof
  case goal1 thus ?case
    by(auto simp add: \<gamma>_ivl_def meet_ivl_def empty_def min_option_def max_option_def split: ivl.split option.split)
next
  case goal2 show ?case by(auto simp add: bot_ivl_def \<gamma>_ivl_def empty_def)
qed

lemma mono_minus_ivl:
  "i1 \<sqsubseteq> i1' \<Longrightarrow> i2 \<sqsubseteq> i2' \<Longrightarrow> minus_ivl i1 i2 \<sqsubseteq> minus_ivl i1' i2'"
apply(auto simp add: minus_ivl_def empty_def le_ivl_def le_option_def split: ivl.splits)
  apply(simp split: option.splits)
 apply(simp split: option.splits)
apply(simp split: option.splits)
done

global_interpretation Val_abs1
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
and test_num' = in_ivl
and filter_plus' = filter_plus_ivl and filter_less' = filter_less_ivl
proof
  case goal1 thus ?case
    by (simp add: \<gamma>_ivl_def split: ivl.split option.split)
next
  case goal2 thus ?case
    by(auto simp add: filter_plus_ivl_def)
      (metis gamma_minus_ivl add_diff_cancel add.commute)+
next
  case goal3 thus ?case
    by(cases a1, cases a2,
      auto simp: \<gamma>_ivl_def min_option_def max_option_def le_option_def split: if_splits option.splits)
qed

global_interpretation Abs_Int1
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
and test_num' = in_ivl
and filter_plus' = filter_plus_ivl and filter_less' = filter_less_ivl
defines afilter_ivl = afilter
and bfilter_ivl = bfilter
and step_ivl = step'
and AI_ivl = AI
and aval_ivl' = aval''
..

text{* Monotonicity: *}

global_interpretation Abs_Int1_mono
where \<gamma> = \<gamma>_ivl and num' = num_ivl and plus' = plus_ivl
and test_num' = in_ivl
and filter_plus' = filter_plus_ivl and filter_less' = filter_less_ivl
proof
  case goal1 thus ?case
    by(auto simp: plus_ivl_def le_ivl_def le_option_def empty_def split: if_splits ivl.splits option.splits)
next
  case goal2 thus ?case
    by(auto simp: filter_plus_ivl_def le_prod_def mono_meet mono_minus_ivl)
next
  case goal3 thus ?case
    apply(cases a1, cases b1, cases a2, cases b2, auto simp: le_prod_def)
    by(auto simp add: empty_def le_ivl_def le_option_def min_option_def max_option_def split: option.splits)
qed

subsubsection "Tests"

value "show_acom_opt (AI_ivl test1_ivl)"

text{* Better than @{text AI_const}: *}
value "show_acom_opt (AI_ivl test3_const)"
value "show_acom_opt (AI_ivl test4_const)"
value "show_acom_opt (AI_ivl test6_const)"

value "show_acom_opt (AI_ivl test2_ivl)"
value "show_acom (((step_ivl \<top>)^^0) (\<bottom>\<^sub>c test2_ivl))"
value "show_acom (((step_ivl \<top>)^^1) (\<bottom>\<^sub>c test2_ivl))"
value "show_acom (((step_ivl \<top>)^^2) (\<bottom>\<^sub>c test2_ivl))"

text{* Fixed point reached in 2 steps. Not so if the start value of x is known: *}

value "show_acom_opt (AI_ivl test3_ivl)"
value "show_acom (((step_ivl \<top>)^^0) (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (((step_ivl \<top>)^^1) (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (((step_ivl \<top>)^^2) (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (((step_ivl \<top>)^^3) (\<bottom>\<^sub>c test3_ivl))"
value "show_acom (((step_ivl \<top>)^^4) (\<bottom>\<^sub>c test3_ivl))"

text{* Takes as many iterations as the actual execution. Would diverge if
loop did not terminate. Worse still, as the following example shows: even if
the actual execution terminates, the analysis may not. The value of y keeps
decreasing as the analysis is iterated, no matter how long: *}

value "show_acom (((step_ivl \<top>)^^50) (\<bottom>\<^sub>c test4_ivl))"

text{* Relationships between variables are NOT captured: *}
value "show_acom_opt (AI_ivl test5_ivl)"

text{* Again, the analysis would not terminate: *}
value "show_acom (((step_ivl \<top>)^^50) (\<bottom>\<^sub>c test6_ivl))"

end