theory ring_powers
  imports "HOL-Algebra.Chinese_Remainder" "HOL-Library.Permutations" function_ring indices
"HOL-Algebra.Generated_Rings"
begin

text\<open>Powers of a ring\<close>

text\<open>(R_list n R) produces the list [R, ... , R] of length n\<close>

fun R_list :: "nat \<Rightarrow> 'a ring \<Rightarrow> ('a ring) list" where
"R_list 0 R = []"|
"R_list (Suc n) R = R#(R_list n R)"

text\<open>Cartesian powers of a ring\<close>

definition cartesian_power :: "'a ring \<Rightarrow> nat \<Rightarrow> ('a list) ring" ("Pow _ _") where
"cartesian_power R n \<equiv> RDirProd_list (R_list n R)"

lemma R_list_project[simp]:
  assumes "i < n"
  shows "(\<pi>\<^bsub>=i\<^esub> (R_list n R)) = R"
proof-
  have "\<And>i. i < n \<Longrightarrow> (\<pi>\<^bsub>=i\<^esub> (R_list n R)) = R"
  apply(induction n)
  apply blast
  proof-
    show "\<And>n i. (\<And>i. i < n \<Longrightarrow> \<pi>\<^bsub>=i\<^esub> (R_list n R) = R) \<Longrightarrow> i < Suc n \<Longrightarrow> \<pi>\<^bsub>=i\<^esub> (R_list (Suc n) R) = R"
    proof-
      fix n
      fix i
      assume IH: "\<And>i. (i < n \<Longrightarrow> \<pi>\<^bsub>=i\<^esub> (R_list n R) = R)"
      assume A: "i < Suc n"
      show "\<pi>\<^bsub>=i\<^esub> (R_list (Suc n) R) = R "
      proof(cases "i = 0")
        case True
        then show ?thesis by simp
      next
        case False
        then have "\<pi>\<^bsub>=i\<^esub> (R_list (Suc n) R) =  \<pi>\<^bsub>=(i-1)\<^esub> (R_list n R) "
          by auto
        then show ?thesis using A IH
          using False by auto
      qed
    qed
  qed
  then show ?thesis using assms
    by blast
qed

lemma R_list_length:
"length (R_list n R) = n"
  apply(induction n) by auto

lemma cartesian_power_car_memI[simp]:
  assumes "length as = n"
  assumes "set as \<subseteq> carrier R"
  shows "as \<in> carrier (Pow R n)"
proof-
  have "(\<And>i. i < length (R_list n R) \<Longrightarrow>  as ! i \<in> carrier (\<pi>\<^bsub>=i\<^esub> (R_list n R)))"
  proof-
    fix i assume A: "i < length (R_list n R)"
    then have "i < n"
      by (simp add: R_list_length)
    then have "as ! i \<in> carrier R"
      using assms nth_mem by blast
    then show "as ! i \<in> carrier (\<pi>\<^bsub>=i\<^esub> (R_list n R))"
      by (metis R_list_project \<open>i < n\<close>)
  qed
  then show ?thesis
    using RDirProd_list_carrier_memI[of as "(R_list n R)"]
    by (simp add: R_list_length assms(1) cartesian_power_def)
qed

lemma cartesian_power_car_memI'[simp]:
  assumes "length as = n"
  assumes "(\<And>i. i < length (R_list n R) \<Longrightarrow>  as ! i \<in> carrier (\<pi>\<^bsub>=i\<^esub> (R_list n R)))"
  shows "as \<in> carrier (Pow R n)"
  using assms   RDirProd_list_carrier_memI[of as "(R_list n R)"]
  by (simp add: R_list_length cartesian_power_def)

lemma cartesian_power_car_memI''[simp]:
  assumes "length as = n"
  assumes "\<And>i. i < length (R_list n R) \<Longrightarrow>  as ! i \<in> carrier R"
  shows "as \<in> carrier (Pow R n)"
  by (metis R_list_length R_list_project assms(1) assms(2) cartesian_power_car_memI')

lemma cartesian_power_car_memE[simp]:
  assumes "as \<in> carrier (Pow R n)"
  shows "length as = n"
  using RDirProd_list_carrier_mem(1)
  by (metis R_list_length assms cartesian_power_def)

lemma cartesian_power_car_memE'[simp]:
  assumes "as \<in> carrier (Pow R n)"
  assumes "i < n"
  shows " as ! i \<in> carrier R"
  using assms  RDirProd_list_carrier_mem(2)
  by (metis R_list_length R_list_project cartesian_power_def project_at_index_simp)

lemma insert_at_ind_pow_car[simp]:
  assumes "length as = n"
  assumes "as \<in> carrier (Pow R n)"
  assumes "a \<in> carrier R"
  assumes "k \<le> n"
  shows "(insert_at_ind as a k) \<in> carrier (Pow R (Suc n))"
  apply(rule cartesian_power_car_memI')
  apply (metis Groups.add_ac(2) assms(1) assms(4) insert_at_ind_length plus_1_eq_Suc)
proof-
  fix i
  assume A: "i < length (R_list (Suc n) R)"
  have P0: "carrier (\<pi>\<^bsub>=i\<^esub> (R_list (Suc n) R)) = carrier R"
    by (metis A R_list_length R_list_project)
  have P1: "i \<le> n"
    by (metis A R_list_length less_Suc_eq_le)
  have "insert_at_ind as a k ! i \<in> carrier R "
    apply(cases "i = k")
    apply (simp add: assms(1) assms(3) assms(4))
  proof(cases "i < k")
    case True
    then show ?thesis
    by (metis assms(1) assms(2) assms(4) cartesian_power_car_memE' insert_at_ind_eq' less_le_trans)
  next
    case False
    then show ?thesis
      using insert_at_ind_eq''[of "i-1" as k]
      by (smt P1 add_diff_inverse_nat assms(1) assms(2) assms(3) cartesian_power_car_memE' diff_less
          insert_at_ind_eq le_neq_implies_less less_Suc_eq_le less_imp_diff_less less_one
          linorder_neqE_nat plus_1_eq_Suc)
  qed
  then show "insert_at_ind as a k ! i \<in> carrier (\<pi>\<^bsub>=i\<^esub> (R_list (Suc n) R))"
    using P0
    by blast
qed

lemma insert_at_ind_pow_not_car[simp]:
  assumes "k \<le>n"
  assumes "length x = n"
  assumes "(insert_at_ind x a k) \<in> carrier (Pow R (Suc n))"
  shows "x \<in> carrier Pow R n"
apply(rule cartesian_power_car_memI')
  using assms
  apply blast
    using assms
    by (metis R_list_length R_list_project Suc_mono cartesian_power_car_memE' insert_at_ind_eq'
      insert_at_ind_eq'' le_eq_less_or_eq less_SucI not_less_iff_gr_or_eq)

lemma insert_at_ind_pow_not_car'[simp]:
  assumes "k \<le>n"
  assumes "length x = n"
  assumes "x \<notin> carrier Pow R n"
  shows "(insert_at_ind x a n) \<notin> carrier (Pow R (Suc n))"
  by (metis assms(2) assms(3) insert_at_ind_pow_not_car lessI less_Suc_eq_le)

text\<open>Cartesian products of subsets\<close>

abbreviation cartesian_product :: "('a list) set \<Rightarrow> ('a list) set \<Rightarrow> ('a list) set" where
"cartesian_product A B \<equiv> {xs. \<exists>as \<in> A. \<exists>bs \<in> B. xs = as@bs}"

lemma cartesian_product_closed[simp]:
  assumes "A \<subseteq> carrier (Pow R n)"
  assumes "B \<subseteq> carrier (Pow R m)"
  shows "cartesian_product A B \<subseteq> carrier (Pow R (n + m))"
proof
  fix x
  assume "x \<in> cartesian_product A B "
  then obtain as bs where as_bs_def: "x = as@bs \<and> as \<in> A \<and> bs \<in> B"
    by blast
  show "x \<in> carrier Pow R (n + m) "
    apply(rule cartesian_power_car_memI'')
     apply (metis as_bs_def assms cartesian_power_car_memE length_append subsetD)
       by (metis R_list_length as_bs_def  add_diff_inverse_nat assms
           cartesian_power_car_memE cartesian_power_car_memE' nat_add_left_cancel_less nth_append
           subset_iff)
qed

lemma cartesian_product_carrier:
"cartesian_product (carrier (Pow R n)) (carrier (Pow R m)) =  carrier (Pow R (n + m))"
proof
  show "cartesian_product (carrier Pow R n) (carrier Pow R m) \<subseteq> carrier Pow R (n + m)"
    using cartesian_product_closed[of "(carrier Pow R n)" R n "(carrier Pow R m) " m]
    by blast
  show "carrier (Pow R (n + m)) \<subseteq> cartesian_product (carrier Pow R n) (carrier Pow R m)"
  proof
    fix x
    assume A: "x \<in> carrier (Pow R (n + m))"

    have 0: "take n x \<in> carrier (Pow R n)"
      apply(rule cartesian_power_car_memI'')
       apply (metis A cartesian_power_car_memE le_add1 length_take min.absorb2)
         by (metis A R_list_length add.commute cartesian_power_car_memE'
            nth_take trans_less_add2)
    have 1: "drop n x \<in> carrier (Pow R m)"
      apply(rule cartesian_power_car_memI'')
        apply (metis A add_diff_cancel_left' cartesian_power_car_memE length_drop)
          by (metis A R_list_length cartesian_power_car_memE cartesian_power_car_memE' le_add1 nat_add_left_cancel_less nth_drop)
    show "x \<in> cartesian_product (carrier Pow R n) (carrier Pow R m)"
      using 0 1
      by (metis (mono_tags, lifting) append_take_drop_id mem_Collect_eq)
qed

text\<open>Higher function rings\<close>
qed

abbreviation ring_pow_function_ring ("Fun\<^bsub>_\<^esub> _") where
"ring_pow_function_ring n R \<equiv> function_ring (carrier (Pow R n)) R"

definition substitute :: "'a ring \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>  ('a list \<Rightarrow> 'a) \<Rightarrow> 'a  \<Rightarrow> ('a list \<Rightarrow> 'a) " ("sub\<^bsub>_\<^esub> _ _") where
"substitute R m n f c = restrict (\<lambda> as. f (insert_at_ind as c n)) (carrier (Pow R m))"

lemma sub_domain:
  assumes "f \<in> carrier (Fun\<^bsub>Suc k\<^esub> R)"
  assumes "a \<in> carrier R"
  assumes "n \<le>k"
  shows "(substitute R k n f a)  \<in> carrier (Fun\<^bsub>k\<^esub> R)"
  apply(rule function_ring_car_memI)
proof-
  show "\<And>x. x \<in> carrier Pow R k \<Longrightarrow> (substitute R k n f a)  x \<in> (carrier R)"
  proof-
    fix x
    assume A: "x \<in> carrier Pow R k"
    show "(substitute R k n f a)  x \<in> (carrier R)"
    proof(cases "n = k")
      case True
      then have "(substitute R k n f a)  x = f (insert_at_ind x a n)"
        by (metis (no_types, lifting) A restrict_apply' substitute_def)

      then show "(substitute R k n f a) x \<in> carrier R"
        by (metis A True assms(1) assms(2) cartesian_power_car_memE
            function_ring_car_simp insert_at_ind_pow_car order_refl)
    next
      case False
      then have F0: "(substitute R k n f a)  x = f (insert_at_ind x a n)"
        unfolding substitute_def
        using assms
        by (meson A restrict_apply')
      have "(insert_at_ind x a n) \<in> carrier (Pow R (Suc k))"
        using A assms insert_at_ind_pow_car[of x k R a n]
        by (simp add: cartesian_power_def)
      then show "(substitute R k n f a) x \<in> carrier R"
        by (metis F0 assms(1) function_ring_car_simp)
    qed
  qed
  show "\<And>x. x \<notin> carrier Pow R k \<Longrightarrow> (substitute R k n f a)  x = undefined"
  proof-
    fix x
    assume "x \<notin> carrier Pow R k"
    show "(substitute R k n f a) x = undefined"
      unfolding substitute_def
      by (meson \<open>x \<notin> carrier Pow R k\<close> restrict_apply)
  qed
qed

text\<open>Pullbacks preserve ring power functions\<close>

lemma fun_struct_maps:
"struct_maps (Pow R n) R = carrier (Fun\<^bsub>n\<^esub> R)"
proof
  show "struct_maps (Pow R n) R \<subseteq> carrier Fun\<^bsub>n\<^esub> R"
    by (smt function_ring_car_memI struct_mapsE(1) struct_mapsE(2) subsetI)
  show "carrier (Fun\<^bsub>n\<^esub> R) \<subseteq> struct_maps (Pow R n) R"
    by (smt function_ring_car_simp function_ring_not_car_simp struct_mapsI subsetI)
qed

lemma pullback_fun_closed:
  assumes "f \<in> struct_maps (Pow R n) (Pow R m)"
  assumes "g \<in> carrier (Fun\<^bsub>m\<^esub> R)"
  shows "pullback (Pow R n) f g \<in> carrier (Fun\<^bsub>n\<^esub> R)"
  using assms(1) assms(2) fun_struct_maps pullback_closed by blast

text\<open>Projections of ring powers on each other\<close>

definition pow_proj ::  "'a ring \<Rightarrow> (nat set) \<Rightarrow> nat  \<Rightarrow> ('a list)  \<Rightarrow> ('a list) " where
"pow_proj R S n = restrict (proj_at_indices S) (carrier (Pow R n))"

lemma pow_proj_is_map[simp]:
  assumes "S \<subseteq> (index_set n)"
  shows "pow_proj R S n \<in> struct_maps (Pow R n) (Pow R (card S))"
proof(rule struct_mapsI)
  show "\<And>x. x \<in> carrier (Pow R n) \<Longrightarrow> pow_proj R S n x \<in> carrier (Pow R (card S))"
  proof-
    fix x
    assume A: "x \<in> carrier (Pow R n)"
    show "pow_proj R S n x \<in> carrier (Pow R (card S))"
      apply(rule cartesian_power_car_memI'')
       apply (metis A assms cartesian_power_car_memE indices_of_def pow_proj_def
          proj_at_indices_length restrict_apply')
    proof-
      fix i
      assume B: "i < length (R_list (card S) R)"
      have C: "x ! enum S i \<in> carrier R"
        by (metis A B R_list_length assms cartesian_power_car_memE'
            enumerate_in_set index_set_notmemI not_le subsetD)
      show "pow_proj R S n x ! i \<in> carrier R "
        using proj_at_indicesE[of S x i]
        unfolding pow_proj_def
        by (metis A B C R_list_length assms cartesian_power_car_memE indices_of_def restrict_apply)
    qed
  qed
  show "\<And>x. x \<notin> carrier Pow R n \<Longrightarrow> pow_proj R S n x = undefined"
    by (simp add: cartesian_power_def pow_proj_def)
qed

text\<open>inclusion of function rings into one another\<close>

text\<open>Includes R^|S| into R^n by pulling back along the projection R^n => R^|S| at indices S \<close>

definition ring_pow_inc :: "'a ring \<Rightarrow> (nat set) \<Rightarrow> nat  \<Rightarrow> ('a list  \<Rightarrow> 'a) => ('a list  \<Rightarrow> 'a)  " where
"ring_pow_inc R S n f = pullback (Pow R n) (pow_proj R S n) f"

lemma ring_pow_inc_is_fun:
  assumes "S \<subseteq> (index_set n)"
  assumes "f \<in> carrier (Fun\<^bsub>card S\<^esub> R)"
  shows "ring_pow_inc R S n f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
  by (metis assms(1) assms(2) pow_proj_is_map pullback_fun_closed ring_pow_inc_def)

text\<open>The "standard" inclusion of powers of function rings into one another\<close>

abbreviation std_proj:: "'a ring \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a list) \<Rightarrow> ('a list)" where
"std_proj R n m \<equiv> pow_proj R (index_set m) n"

lemma std_proj_id[simp]:
  assumes "m \<le> n"
  assumes "as \<in> carrier (Pow R n)"
  assumes "i < m"
  shows "std_proj R n m as ! i = as ! i"
  unfolding pow_proj_def using assms proj_at_indicesE[of "(index_set m)" as i]
  by (metis cartesian_power_car_memE dual_order.strict_trans in_set_conv_nth index_list_index
      index_list_length index_set_def index_set_to_list indices_of_def le_eq_less_or_eq
      proj_at_index_listE proj_at_indices_def restrict_apply subsetI)

abbreviation std_inc:: "'a ring \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a list  \<Rightarrow> 'a)  => ('a list  \<Rightarrow> 'a)" where
"std_inc R n m f \<equiv> ring_pow_inc R (index_set m) n f"

lemma std_proj_is_map[simp]:
  assumes "m \<le> n"
  shows "std_proj R n m \<in> struct_maps (Pow R n) (Pow R m)"
  by (metis (mono_tags, hide_lams) assms index_list_length index_set_memI index_set_notmemI
      index_set_to_list length_map  not_le  not_less_iff_gr_or_eq order_refl order_trans
      pow_proj_is_map set_to_list_def subsetD subsetI)

text\<open>Polynomial rings\<close>

definition var :: "'a ring \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a)" where
"var R n i = restrict (\<lambda>x.  x!i) (carrier (Pow R n))"

lemma var_in_car:
  assumes "i < n"
  shows "var R n i \<in> carrier (Fun\<^bsub>n\<^esub> R)"
  apply(rule function_ring_car_memI)
  apply (simp add: assms cartesian_power_def var_def)
  by (simp add: cartesian_power_def var_def)

lemma varE[simp]:
  assumes "i < n"
  assumes "x \<in> carrier (Pow R n)"
  shows "var R n i x = x ! i"
  unfolding var_def project_at_index_def
  using  assms(2)
  by (meson restrict_apply')

lemma std_inc_of_var:
  assumes "i < n"
  assumes "n \<le>m"
  shows "std_inc R m n (var R n i) =  (var R m i)"
  apply(rule ext)
proof-
  fix x
  show "std_inc R m n (var R n i) x = var R m i x"
    apply(cases "x \<in> carrier (Pow R m )")
  proof-
    show "x \<in> carrier Pow R m \<Longrightarrow> std_inc R m n (var R n i) x = var R m i x"
    proof-
      assume A: "x \<in> carrier Pow R m"
      have "(restrict (proj_at_indices (index_set n)) (carrier Pow R m)) x =  ((proj_at_indices (index_set n)) x)"
        by (meson A restrict_apply')
      then have B: "std_inc R m n (var R n i) x = (var R n i) ((proj_at_indices (index_set n)) x)"
        unfolding ring_pow_inc_def pow_proj_def pullback_def s_comp_def
        by (metis A comp_apply restrict_apply)
      have C: "var R m i x = x ! i"
        using assms A varE[of i m x R]
        by linarith
      have D: "enum (index_set m) i = i"
        using assms
        by (metis index_list_index index_list_length index_set_to_list
            length_map less_le_trans nth_map set_to_list_def)
      have E: "(\<lambda>as\<in>carrier Pow R m. as ! i) (proj_at_indices (index_set m) x) = (var R m i) ((proj_at_indices (index_set m)) x)"
        by (metis project_at_index_simp restrict_apply var_def)
      have F: "index_set m \<subseteq> index_set (length x)"
        using A cartesian_power_car_memE
        by blast
      have G: "(var R m i) ((proj_at_indices (index_set m)) x) = x !enum (index_set m) i"

        unfolding var_def project_at_index_def
        using F proj_at_indicesE[of "(index_set m)" x i]
        by (smt A C D E card.infinite cartesian_power_car_memE index_list_index index_list_length
            index_set_def index_set_to_list indices_of_def not_less_zero nth_equalityI
            proj_at_index_list_length proj_at_indicesE proj_at_indices_def proj_at_indices_length
            set_to_list_ind)
      then show "std_inc R m n (var R n i) x = var R m i x"
        by (metis A B C \<open>restrict (proj_at_indices (index_set n)) (carrier Pow R m) x =
               proj_at_indices (index_set n) x\<close> assms(1) assms(2) pow_proj_def std_proj_id
              std_proj_is_map struct_mapsE(1) varE)
    qed
    show "x \<notin> carrier Pow R m \<Longrightarrow> std_inc R m n (var R n i) x = var R m i x"
      by (metis pullback_def restrict_apply ring_pow_inc_def s_comp_def var_def)
  qed
qed

text\<open>defintion of polynomial ring\<close>

definition var_set :: "'a ring \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a) set" where
"var_set R n = var R n ` {0..n-1}"

lemma var_setE:
  assumes "f \<in> var_set R n"
  obtains i where "f = var R n i \<and> i \<in> {0 .. n-1}"
  by (metis assms imageE that var_set_def)

lemma var_setI:
  assumes "i \<in> {0..n-1}"
  assumes  "f = var R n i"
  shows "f \<in> var_set R n"
  using assms(1) assms(2) var_set_def by fastforce

definition constant_ring where
"constant_ring R n = (constant_function (carrier (Pow R n)) ` (carrier R)) "

lemma constant_ring_subring:
  assumes "cring R"
  shows "subring (constant_ring R n) (Fun\<^bsub>n\<^esub> R)"
  apply(rule ring.subringI)
  using assms cring_imp_Fun_is_cring
  using cring.axioms(1)
  apply blast
    unfolding constant_ring_def
    apply (simp add: image_subset_iff)
  proof-
    show "\<one>\<^bsub>Fun\<^bsub>n\<^esub> R\<^esub> \<in> constant_function (carrier Pow R n) ` carrier R"
      unfolding constant_function_def
      using function_ring_def
      by (smt assms cring.axioms(1) cring.cring_simprules(6) cring_imp_Fun_is_cring fun_struct_maps
      image_iff mem_Collect_eq restrict_ext ring.function_oneE struct_maps_def)
    show "\<And>h. h \<in> constant_function (carrier Pow R n) ` carrier R \<Longrightarrow> \<ominus>\<^bsub>Fun\<^bsub>n\<^esub> R\<^esub> h \<in> constant_function (carrier Pow R n) ` carrier R"
      using assms constant_function_minus cring.cring_simprules(3) by fastforce
    show "\<And>h1 h2.
       h1 \<in> constant_function (carrier Pow R n) ` carrier R \<Longrightarrow>
       h2 \<in> constant_function (carrier Pow R n) ` carrier R \<Longrightarrow> h1 \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> R\<^esub> h2 \<in> constant_function (carrier Pow R n) ` carrier R"
      by (smt assms constant_function_mult cring.cring_simprules(5) image_iff)
    show " \<And>h1 h2.
       h1 \<in> constant_function (carrier Pow R n) ` carrier R \<Longrightarrow>
       h2 \<in> constant_function (carrier Pow R n) ` carrier R \<Longrightarrow> h1 \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> R\<^esub> h2 \<in> constant_function (carrier Pow R n) ` carrier R"
      by (smt assms constant_function_add cring.cring_simprules(1) image_iff)
  qed

definition polynomial_functions where
"polynomial_functions R n = generate_ring (Fun\<^bsub>n\<^esub> R) ((var_set R n) \<union> (constant_ring R n)) "

end


(*
    Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
*)

section \<open>Some examples of applying the method winding\_eval\<close>

theory Winding_Number_Eval_Examples imports Winding_Number_Eval
begin

lemma example1:
  assumes "R>1"
  shows "winding_number (part_circlepath 0 R 0 pi +++ linepath (-R) R) \<i> = 1"
proof (eval_winding,simp_all)
  define CR where  "CR \<equiv>part_circlepath 0 R 0 pi"
  define L where "L\<equiv> linepath (- (complex_of_real R)) R"
  show "\<i> \<notin> path_image CR" unfolding CR_def using \<open>R>1\<close>
    by (intro not_on_circlepathI,auto)
  show *:"\<i> \<notin> closed_segment (- (of_real R)) R" using \<open>R>1\<close> complex_eq_iff
    by (intro not_on_closed_segmentI,auto)
  from cindex_pathE_linepath[OF this] have "cindex_pathE L \<i> = -1"
    unfolding L_def using \<open>R>1\<close> by auto
  moreover have "cindex_pathE CR \<i> = -1"
    unfolding CR_def using \<open>R>1\<close>
    apply (subst cindex_pathE_part_circlepath)
    by (simp_all add:jumpF_pathstart_part_circlepath jumpF_pathfinish_part_circlepath)
  ultimately show "- complex_of_real (cindex_pathE CR \<i>) - cindex_pathE L \<i> = 2"
    unfolding L_def CR_def by auto
qed

lemma example2:
  assumes "R>1"
  shows "winding_number (part_circlepath 0 R 0 pi +++ linepath (-R) R) (-\<i>) = 0"
proof (eval_winding,simp_all)
  define CR where  "CR \<equiv>part_circlepath 0 R 0 pi"
  define L where "L\<equiv> linepath (- (complex_of_real R)) R"
  show "-\<i> \<notin> path_image CR" unfolding CR_def using \<open>R>1\<close>
    by (intro not_on_circlepathI,auto)
  show *:"-\<i> \<notin> closed_segment (- (of_real R)) R" using \<open>R>1\<close> complex_eq_iff
    by (intro not_on_closed_segmentI,auto)
  from cindex_pathE_linepath[OF this] have "cindex_pathE L (-\<i>) = 1"
    unfolding L_def using \<open>R>1\<close> by auto
  moreover have "cindex_pathE CR (-\<i>) = -1"
    unfolding CR_def using \<open>R>1\<close>
    apply (subst cindex_pathE_part_circlepath)
    by (simp_all add:jumpF_pathstart_part_circlepath jumpF_pathfinish_part_circlepath)
  ultimately show "-cindex_pathE CR (-\<i>) = cindex_pathE L (-\<i>)"
    unfolding L_def CR_def by auto
qed

lemma example3:
  fixes lb ub z :: complex
  defines "rec \<equiv>  linepath lb (Complex (Re ub) (Im lb)) +++ linepath (Complex (Re ub) (Im lb)) ub
              +++ linepath ub (Complex (Re lb) (Im ub)) +++ linepath (Complex (Re lb) (Im ub)) lb"
  assumes order_asms:"Re lb < Re z" "Re z < Re ub" "Im lb < Im z" "Im z < Im ub"
  shows "winding_number rec z = 1"
  unfolding rec_def
proof (eval_winding)
  let ?l1 = "linepath lb (Complex (Re ub) (Im lb))"
  and ?l2 = "linepath (Complex (Re ub) (Im lb)) ub"
  and ?l3 = "linepath ub (Complex (Re lb) (Im ub))"
  and ?l4 = "linepath (Complex (Re lb) (Im ub)) lb"
  show l1: "z \<notin> path_image ?l1"
    apply (auto intro!: not_on_closed_segmentI_complex)
    using order_asms by (simp add: algebra_simps crossproduct_eq)
  show l2:"z \<notin> path_image ?l2"
    apply (auto intro!: not_on_closed_segmentI_complex)
    using order_asms by (simp add: algebra_simps crossproduct_eq)
  show l3:"z \<notin> path_image ?l3"
    apply (auto intro!: not_on_closed_segmentI_complex)
    using order_asms by (simp add: algebra_simps crossproduct_eq)
  show l4:"z \<notin> path_image ?l4"
    apply (auto intro!: not_on_closed_segmentI_complex)
    using order_asms by (simp add: algebra_simps crossproduct_eq)
  show "- complex_of_real (cindex_pathE ?l1 z + (cindex_pathE ?l2 z + (cindex_pathE ?l3 z +
          cindex_pathE ?l4 z))) = 2 * 1"
  proof -
    have "(Im z - Im ub) * (Re ub - Re lb) < 0"
      using mult_less_0_iff order_asms(1) order_asms(2) order_asms(4) by fastforce
    then have "cindex_pathE ?l3 z = -1"
      apply (subst cindex_pathE_linepath)
      using l3 order_asms by (auto simp add:algebra_simps)
    moreover have "(Im lb - Im z) * (Re ub - Re lb) <0"
      using mult_less_0_iff order_asms(1) order_asms(2) order_asms(3) by fastforce
    then have "cindex_pathE ?l1 z = -1"
      apply (subst cindex_pathE_linepath)
      using l1 order_asms by (auto simp add:algebra_simps)
    moreover have "cindex_pathE ?l2 z = 0"
      apply (subst cindex_pathE_linepath)
      using l2 order_asms by (auto simp add:algebra_simps)
    moreover have "cindex_pathE ?l4 z = 0"
      apply (subst cindex_pathE_linepath)
      using l4 order_asms by (auto simp add:algebra_simps)
    ultimately show ?thesis by auto
  qed
qed

end


theory ex10
  imports "HOL-Data_Structures.Tree23_Map" "HOL-Data_Structures.Base_FDS"
begin

datatype 'a trie = Leaf | Node bool "'a \<rightharpoonup> 'a trie"

fun isin:: "'a trie \<Rightarrow> 'a list \<Rightarrow> bool" where
  "isin Leaf _ = False"
| "isin (Node b m) ks =
     (case ks of [] \<Rightarrow> b
              | k#ks' \<Rightarrow>
                 case m k of None \<Rightarrow> False
                           | Some t \<Rightarrow> (isin t ks'))"

(*fun isin:: "'a trie \<Rightarrow> 'a list \<Rightarrow> bool" where
  "isin Leaf _ = False"
| "isin (Node b m) [] = b"
| "isin (Node b m) (k#ks') = (case m k of None \<Rightarrow> False
                                   | Some t \<Rightarrow> (isin t ks'))"*)

term "(m:: nat \<rightharpoonup> nat trie)(3 \<mapsto> (Node False Map.empty))"

fun ins:: "'a list \<Rightarrow> 'a trie \<Rightarrow> 'a trie" where
  "ins [] Leaf = Node True (Map.empty)"
| "ins (k#ks) Leaf = Node False (Map.empty(k \<mapsto> (ins ks Leaf)))"
| "ins [] (Node b m) = Node True m"
| "ins (k#ks) (Node b m) = (case m k of Some t \<Rightarrow> Node b (m(k \<mapsto> (ins ks t)))
                                        | None \<Rightarrow> Node b (m(k \<mapsto> (ins ks Leaf))))"

lemma ins_correct: "isin (ins as t) bs = (as=bs \<or> isin t bs)"
  apply(induction as t arbitrary: bs rule: ins.induct)
  by (auto split: list.splits option.splits)

fun delete :: "'a list \<Rightarrow> 'a trie \<Rightarrow> 'a trie" where
  "delete _ Leaf = Leaf"
| "delete [] (Node b m) = (Node False m)"
| "delete (k#ks) (Node b m) = (case m k of None \<Rightarrow> (Node b m)
                                         | Some t \<Rightarrow> (Node b (m(k \<mapsto> delete ks t))))"
lemma "isin (delete as t) bs = (as \<noteq> bs \<and> isin t bs)"
  apply(induction as t arbitrary: bs rule: ins.induct)
  by (auto split: list.splits option.splits)

abbreviation "empty23 \<equiv> Tree23.Leaf"
abbreviation "inv23 t \<equiv> complete t \<and> sorted1 (inorder t)"

datatype 'a trie' = Leaf' | Node' bool "('a\<times> 'a trie' ) tree23"

fun isin':: "'a::linorder trie' \<Rightarrow> 'a list \<Rightarrow> bool" where
  "isin' Leaf' _ = False"
| "isin' (Node' b m) ks =
     (case ks of [] \<Rightarrow> b
              | k#ks' \<Rightarrow>
                 case lookup m k of None \<Rightarrow> False
                           | Some t \<Rightarrow> (isin' t ks'))"

fun ins':: "'a::linorder list \<Rightarrow> 'a trie' \<Rightarrow> 'a trie'" where
  "ins' [] Leaf' = Node' True empty23"
| "ins' (k#ks) Leaf' = Node' False (update k (ins' ks Leaf') empty23)"
| "ins' [] (Node' b m) = Node' True m"
| "ins' (k#ks) (Node' b m) = (case lookup m k of Some t \<Rightarrow> Node' b (update k (ins' ks t) m)
                                        | None \<Rightarrow> Node' b (update k (ins' ks Leaf') m))"

fun delete' :: "'a::linorder list \<Rightarrow> 'a trie' \<Rightarrow> 'a trie'" where
  "delete' _ Leaf' = Leaf'"
| "delete' [] (Node' b m) = (Node' False m)"
| "delete' (k#ks) (Node' b m) = (case lookup m k of None \<Rightarrow> (Node' b m)
                                         | Some t \<Rightarrow> (Node' b (update k (delete' ks t) m)))"

term "size_tree23"

fun trie'_inv where
  "trie'_inv Leaf' = True"
| "trie'_inv (Node' b m) = (inv23 m \<and> (\<forall>k t. lookup m k = Some t \<longrightarrow> trie'_inv t))"

find_consts "('a option \<Rightarrow> 'b option)"

fun trie'_\<alpha> where
  "trie'_\<alpha> Leaf' = Leaf"
| "trie'_\<alpha> (Node' b m) = Node b (map_option trie'_\<alpha> o (lookup m))"

lemmas map23_thms[simp] = M.map_empty Tree23_Map.M.map_update Tree23_Map.M.map_delete
Tree23_Map.M.invar_empty Tree23_Map.M.invar_update Tree23_Map.M.invar_delete
M.invar_def M.inorder_update M.inorder_inv_update sorted_upd_list

lemma isin'_refine: "trie'_inv t \<Longrightarrow> isin' t ks \<longleftrightarrow> isin (trie'_\<alpha> t) ks"
  apply (induction t ks rule: isin'.induct)
  by (auto split: list.splits option.splits)

thm ins_correct

declare[[names_short]]

lemma ins'_refine: "trie'_inv t \<Longrightarrow> ins xs (trie'_\<alpha> t) = trie'_\<alpha> (ins' xs t) \<and> trie'_inv (ins' xs t)"
  apply(induction xs t rule: ins'.induct)
  by (auto split: option.splits)

lemma ins'_correct: "trie'_inv t \<Longrightarrow>
         (isin' (ins' xs t) ks \<longleftrightarrow> xs=ks \<or> isin' t ks) \<and> trie'_inv (ins' xs t)"
  apply(simp add: isin'_refine ins_correct[symmetric] ins'_refine)
  done

end


theory Chapter5
imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter_0: "iter r 0 x x" |
iter_Suc: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

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

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
(* your definition/proof here *)

text\<open>
Each step should use at most one of the assumptions @{text T}, @{text A}
or @{text TA}.
\endexercise

\exercise
Give a readable, structured proof of the following lemma:
\<close>
lemma "(\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs)
      \<or> (\<exists>ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
(* your definition/proof here *)

text\<open>
Hint: There are predefined functions @{const take} and {const drop} of type
@{typ "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"} such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"}
and @{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
the relevant @{const take} and @{const drop} lemmas for you.
\endexercise

\exercise
Give a structured proof by rule inversion:
\<close>
inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"
lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
(* your definition/proof here *)

text\<open>
\exercise
Give a structured proof by rule inversions:
\<close>

lemma "\<not> ev(Suc(Suc(Suc 0)))"
(* your definition/proof here *)

text\<open>
If there are no cases to be proved you can close
a proof immediateley with \isacom{qed}.
\endexercise

\exercise
Recall predicate @{const star} from Section 4.5 and @{const iter}
from Exercise~\ref{exe:iter}.
\<close>

lemma "iter r n x y \<Longrightarrow> star r x y"
(* your definition/proof here *)

text\<open>
Prove this lemma in a structured style, do not just sledgehammer each case of the
required induction.
\endexercise

\exercise
Define a recursive function
\<close>

fun elems :: "'a list \<Rightarrow> 'a set" where
(* your definition/proof here *)

text\<open> that collects all elements of a list into a set. Prove \<close>

lemma "x \<in> elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Extend Exercise~\ref{exe:cfg} with a function that checks if some
\mbox{@{text "alpha list"}} is a balanced
string of parentheses. More precisely, define a recursive function \<close>
(* your definition/proof here *)
fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open> such that @{term"balanced n w"}
is true iff (informally) @{text"a\<^sup>n @ w \<in> S"}. Formally, prove \<close>

corollary "balanced n w \<longleftrightarrow> S (replicate n a @ w)"

text\<open> where @{const replicate} @{text"::"} @{typ"nat \<Rightarrow> 'a \<Rightarrow> 'a list"} is predefined
and @{term"replicate n x"} yields the list @{text"[x, \<dots>, x]"} of length @{text n}.
\<close>

end


(*  Title:    HOL/Library/Nonpos_Ints.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Non-negative, non-positive integers and reals\<close>

theory Nonpos_Ints
imports Complex_Main
begin

subsection\<open>Non-positive integers\<close>
text \<open>
  The set of non-positive integers on a ring. (in analogy to the set of non-negative
  integers @{term "\<nat>"}) This is useful e.g. for the Gamma function.
\<close>

definition nonpos_Ints ("\<int>\<^sub>\<le>\<^sub>0") where "\<int>\<^sub>\<le>\<^sub>0 = {of_int n |n. n \<le> 0}"

lemma zero_in_nonpos_Ints [simp,intro]: "0 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "0::int"])

lemma neg_one_in_nonpos_Ints [simp,intro]: "-1 \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-1::int"])

lemma neg_numeral_in_nonpos_Ints [simp,intro]: "-numeral n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by (auto intro!: exI[of _ "-numeral n::int"])

lemma one_notin_nonpos_Ints [simp]: "(1 :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma numeral_notin_nonpos_Ints [simp]: "(numeral n :: 'a :: ring_char_0) \<notin> \<int>\<^sub>\<le>\<^sub>0"
  by (auto simp: nonpos_Ints_def)

lemma minus_of_nat_in_nonpos_Ints [simp, intro]: "- of_nat n \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  have "- of_nat n = of_int (-int n)" by simp
  also have "-int n \<le> 0" by simp
  hence "of_int (-int n) \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
  finally show ?thesis .
qed

lemma of_nat_in_nonpos_Ints_iff: "(of_nat n :: 'a :: {ring_1,ring_char_0}) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n = 0"
proof
  assume "(of_nat n :: 'a) \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain m where "of_nat n = (of_int m :: 'a)" "m \<le> 0" by (auto simp: nonpos_Ints_def)
  hence "(of_int m :: 'a) = of_nat n" by simp
  also have "... = of_int (int n)" by simp
  finally have "m = int n" by (subst (asm) of_int_eq_iff)
  with \<open>m \<le> 0\<close> show "n = 0" by auto
qed simp

lemma nonpos_Ints_of_int: "n \<le> 0 \<Longrightarrow> of_int n \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def by blast

lemma nonpos_IntsI:
  "x \<in> \<int> \<Longrightarrow> x \<le> 0 \<Longrightarrow> (x :: 'a :: linordered_idom) \<in> \<int>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Ints_def Ints_def by auto

lemma nonpos_Ints_subset_Ints: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_nonpos [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<le> (0 :: 'a :: linordered_idom)"
  unfolding nonpos_Ints_def by auto

lemma nonpos_Ints_Int [dest]: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<int>"
  unfolding nonpos_Ints_def Ints_def by blast

lemma nonpos_Ints_cases:
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = of_int n" "n \<le> 0"
  using assms unfolding nonpos_Ints_def by (auto elim!: Ints_cases)

lemma nonpos_Ints_cases':
  assumes "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  obtains n where "x = -of_nat n"
proof -
  from assms obtain m where "x = of_int m" and m: "m \<le> 0" by (auto elim!: nonpos_Ints_cases)
  hence "x = - of_int (-m)" by auto
  also from m have "(of_int (-m) :: 'a) = of_nat (nat (-m))" by simp_all
  finally show ?thesis by (rule that)
qed

lemma of_real_in_nonpos_Ints_iff: "(of_real x :: 'a :: real_algebra_1) \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "of_real x \<in> (\<int>\<^sub>\<le>\<^sub>0 :: 'a set)"
  then obtain n where "(of_real x :: 'a) = of_int n" "n \<le> 0" by (erule nonpos_Ints_cases)
  note \<open>of_real x = of_int n\<close>
  also have "of_int n = of_real (of_int n)" by (rule of_real_of_int_eq [symmetric])
  finally have "x = of_int n" by (subst (asm) of_real_eq_iff)
  with \<open>n \<le> 0\<close> show "x \<in> \<int>\<^sub>\<le>\<^sub>0" by (simp add: nonpos_Ints_of_int)
qed (auto elim!: nonpos_Ints_cases intro!: nonpos_Ints_of_int)

lemma nonpos_Ints_altdef: "\<int>\<^sub>\<le>\<^sub>0 = {n \<in> \<int>. (n :: 'a :: linordered_idom) \<le> 0}"
  by (auto intro!: nonpos_IntsI elim!: nonpos_Ints_cases)

lemma uminus_in_Nats_iff: "-x \<in> \<nat> \<longleftrightarrow> x \<in> \<int>\<^sub>\<le>\<^sub>0"
proof
  assume "-x \<in> \<nat>"
  then obtain n where "n \<ge> 0" "-x = of_int n" by (auto simp: Nats_altdef1)
  hence "-n \<le> 0" "x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "x \<in> \<int>\<^sub>\<le>\<^sub>0" unfolding nonpos_Ints_def by blast
next
  assume "x \<in> \<int>\<^sub>\<le>\<^sub>0"
  then obtain n where "n \<le> 0" "x = of_int n" by (auto simp: nonpos_Ints_def)
  hence "-n \<ge> 0" "-x = of_int (-n)" by (simp_all add: eq_commute minus_equation_iff[of x])
  thus "-x \<in> \<nat>" unfolding Nats_altdef1 by blast
qed

lemma uminus_in_nonpos_Ints_iff: "-x \<in> \<int>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<nat>"
  using uminus_in_Nats_iff[of "-x"] by simp

lemma nonpos_Ints_mult: "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<nat>"
  using Nats_mult[of "-x" "-y"] by (simp add: uminus_in_Nats_iff)

lemma Nats_mult_nonpos_Ints: "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of x "-y"] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_mult_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x * y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_mult[of "-x" y] by (simp add: uminus_in_Nats_iff)

lemma nonpos_Ints_add:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x + y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "-y"] uminus_in_Nats_iff[of "y+x", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma nonpos_Ints_diff_Nats:
  "x \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> y \<in> \<nat> \<Longrightarrow> x - y \<in> \<int>\<^sub>\<le>\<^sub>0"
  using Nats_add[of "-x" "y"] uminus_in_Nats_iff[of "x-y", simplified minus_add]
  by (simp add: uminus_in_Nats_iff add.commute)

lemma Nats_diff_nonpos_Ints:
  "x \<in> \<nat> \<Longrightarrow> y \<in> \<int>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x - y \<in> \<nat>"
  using Nats_add[of "x" "-y"] by (simp add: uminus_in_Nats_iff add.commute)

lemma plus_of_nat_eq_0_imp: "z + of_nat n = 0 \<Longrightarrow> z \<in> \<int>\<^sub>\<le>\<^sub>0"
proof -
  assume "z + of_nat n = 0"
  hence A: "z = - of_nat n" by (simp add: eq_neg_iff_add_eq_0)
  show "z \<in> \<int>\<^sub>\<le>\<^sub>0" by (subst A) simp
qed

subsection\<open>Non-negative reals\<close>

definition nonneg_Reals :: "'a::real_algebra_1 set"  ("\<real>\<^sub>\<ge>\<^sub>0")
  where "\<real>\<^sub>\<ge>\<^sub>0 = {of_real r | r. r \<ge> 0}"

lemma nonneg_Reals_of_real_iff [simp]: "of_real r \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> r \<ge> 0"
  by (force simp add: nonneg_Reals_def)

lemma nonneg_Reals_subset_Reals: "\<real>\<^sub>\<ge>\<^sub>0 \<subseteq> \<real>"
  unfolding nonneg_Reals_def Reals_def by blast

lemma nonneg_Reals_Real [dest]: "x \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> x \<in> \<real>"
  unfolding nonneg_Reals_def Reals_def by blast

lemma nonneg_Reals_of_nat_I [simp]: "of_nat n \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis nonneg_Reals_of_real_iff of_nat_0_le_iff of_real_of_nat_eq)

lemma nonneg_Reals_cases:
  assumes "x \<in> \<real>\<^sub>\<ge>\<^sub>0"
  obtains r where "x = of_real r" "r \<ge> 0"
  using assms unfolding nonneg_Reals_def by (auto elim!: Reals_cases)

lemma nonneg_Reals_zero_I [simp]: "0 \<in> \<real>\<^sub>\<ge>\<^sub>0"
  unfolding nonneg_Reals_def by auto

lemma nonneg_Reals_one_I [simp]: "1 \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (mono_tags, lifting) nonneg_Reals_of_nat_I of_nat_1)

lemma nonneg_Reals_minus_one_I [simp]: "-1 \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis nonneg_Reals_of_real_iff le_minus_one_simps(3) of_real_1 of_real_def real_vector.scale_minus_left)

lemma nonneg_Reals_numeral_I [simp]: "numeral w \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (no_types) nonneg_Reals_of_nat_I of_nat_numeral)

lemma nonneg_Reals_minus_numeral_I [simp]: "- numeral w \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  using nonneg_Reals_of_real_iff not_zero_le_neg_numeral by fastforce

lemma nonneg_Reals_add_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a + b \<in> \<real>\<^sub>\<ge>\<^sub>0"
apply (simp add: nonneg_Reals_def)
apply clarify
apply (rename_tac r s)
apply (rule_tac x="r+s" in exI, auto)
done

lemma nonneg_Reals_mult_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<ge>\<^sub>0"
  unfolding nonneg_Reals_def  by (auto simp: of_real_def)

lemma nonneg_Reals_inverse_I [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "a \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> inverse a \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: nonneg_Reals_def image_iff) (metis inverse_nonnegative_iff_nonnegative of_real_inverse)

lemma nonneg_Reals_divide_I [simp]:
  fixes a :: "'a::real_div_algebra"
  shows "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: divide_inverse)

lemma nonneg_Reals_pow_I [simp]: "a \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> a^n \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (induction n) auto

lemma complex_nonneg_Reals_iff: "z \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> Re z \<ge> 0 \<and> Im z = 0"
  by (auto simp: nonneg_Reals_def) (metis complex_of_real_def complex_surj)

lemma ii_not_nonneg_Reals [iff]: "\<i> \<notin> \<real>\<^sub>\<ge>\<^sub>0"
  by (simp add: complex_nonneg_Reals_iff)

subsection\<open>Non-positive reals\<close>

definition nonpos_Reals :: "'a::real_algebra_1 set"  ("\<real>\<^sub>\<le>\<^sub>0")
  where "\<real>\<^sub>\<le>\<^sub>0 = {of_real r | r. r \<le> 0}"

lemma nonpos_Reals_of_real_iff [simp]: "of_real r \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> r \<le> 0"
  by (force simp add: nonpos_Reals_def)

lemma nonpos_Reals_subset_Reals: "\<real>\<^sub>\<le>\<^sub>0 \<subseteq> \<real>"
  unfolding nonpos_Reals_def Reals_def by blast

lemma nonpos_Ints_subset_nonpos_Reals: "\<int>\<^sub>\<le>\<^sub>0 \<subseteq> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonpos_Ints_cases nonpos_Ints_nonpos nonpos_Ints_of_int
    nonpos_Reals_of_real_iff of_real_of_int_eq subsetI)

lemma nonpos_Reals_of_nat_iff [simp]: "of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> n=0"
  by (metis nonpos_Reals_of_real_iff of_nat_le_0_iff of_real_of_nat_eq)

lemma nonpos_Reals_Real [dest]: "x \<in> \<real>\<^sub>\<le>\<^sub>0 \<Longrightarrow> x \<in> \<real>"
  unfolding nonpos_Reals_def Reals_def by blast

lemma nonpos_Reals_cases:
  assumes "x \<in> \<real>\<^sub>\<le>\<^sub>0"
  obtains r where "x = of_real r" "r \<le> 0"
  using assms unfolding nonpos_Reals_def by (auto elim!: Reals_cases)

lemma uminus_nonneg_Reals_iff [simp]: "-x \<in> \<real>\<^sub>\<ge>\<^sub>0 \<longleftrightarrow> x \<in> \<real>\<^sub>\<le>\<^sub>0"
  apply (auto simp: nonpos_Reals_def nonneg_Reals_def)
  apply (metis nonpos_Reals_of_real_iff minus_minus neg_le_0_iff_le of_real_minus)
  apply (metis neg_0_le_iff_le of_real_minus)
  done

lemma uminus_nonpos_Reals_iff [simp]: "-x \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> x \<in> \<real>\<^sub>\<ge>\<^sub>0"
  by (metis (no_types) minus_minus uminus_nonneg_Reals_iff)

lemma nonpos_Reals_zero_I [simp]: "0 \<in> \<real>\<^sub>\<le>\<^sub>0"
  unfolding nonpos_Reals_def by force

lemma nonpos_Reals_one_I [simp]: "1 \<notin> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_minus_one_I uminus_nonneg_Reals_iff by blast

lemma nonpos_Reals_numeral_I [simp]: "numeral w \<notin> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_minus_numeral_I uminus_nonneg_Reals_iff by blast

lemma nonpos_Reals_add_I [simp]: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a + b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_add_I add_uminus_conv_diff minus_diff_eq minus_minus uminus_nonpos_Reals_iff)

lemma nonpos_Reals_mult_I1: "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_mult_I mult_minus_right uminus_nonneg_Reals_iff)

lemma nonpos_Reals_mult_I2: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a * b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_mult_I mult_minus_left uminus_nonneg_Reals_iff)

lemma nonpos_Reals_mult_of_nat_iff:
  fixes a:: "'a :: real_div_algebra" shows "a * of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0 \<or> n=0"
  apply (auto intro: nonpos_Reals_mult_I2)
  apply (auto simp: nonpos_Reals_def)
  apply (rule_tac x="r/n" in exI)
  apply (auto simp: divide_simps)
  done

lemma nonpos_Reals_inverse_I:
    fixes a :: "'a::real_div_algebra"
    shows "a \<in> \<real>\<^sub>\<le>\<^sub>0 \<Longrightarrow> inverse a \<in> \<real>\<^sub>\<le>\<^sub>0"
  using nonneg_Reals_inverse_I uminus_nonneg_Reals_iff by fastforce

lemma nonpos_Reals_divide_I1:
    fixes a :: "'a::real_div_algebra"
    shows "\<lbrakk>a \<in> \<real>\<^sub>\<ge>\<^sub>0; b \<in> \<real>\<^sub>\<le>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (simp add: nonpos_Reals_inverse_I nonpos_Reals_mult_I1 divide_inverse)

lemma nonpos_Reals_divide_I2:
    fixes a :: "'a::real_div_algebra"
    shows "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; b \<in> \<real>\<^sub>\<ge>\<^sub>0\<rbrakk> \<Longrightarrow> a / b \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_divide_I minus_divide_left uminus_nonneg_Reals_iff)

lemma nonpos_Reals_divide_of_nat_iff:
  fixes a:: "'a :: real_div_algebra" shows "a / of_nat n \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> a \<in> \<real>\<^sub>\<le>\<^sub>0 \<or> n=0"
  apply (auto intro: nonpos_Reals_divide_I2)
  apply (auto simp: nonpos_Reals_def)
  apply (rule_tac x="r*n" in exI)
  apply (auto simp: divide_simps mult_le_0_iff)
  done

lemma nonpos_Reals_pow_I: "\<lbrakk>a \<in> \<real>\<^sub>\<le>\<^sub>0; odd n\<rbrakk> \<Longrightarrow> a^n \<in> \<real>\<^sub>\<le>\<^sub>0"
  by (metis nonneg_Reals_pow_I power_minus_odd uminus_nonneg_Reals_iff)

lemma complex_nonpos_Reals_iff: "z \<in> \<real>\<^sub>\<le>\<^sub>0 \<longleftrightarrow> Re z \<le> 0 \<and> Im z = 0"
   using complex_is_Real_iff by (force simp add: nonpos_Reals_def)

lemma ii_not_nonpos_Reals [iff]: "\<i> \<notin> \<real>\<^sub>\<le>\<^sub>0"
  by (simp add: complex_nonpos_Reals_iff)

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Direct Products\<close>

theory Relation_Algebra_Direct_Products
  imports Relation_Algebra_Functions
begin

text \<open>This section uses the definition of direct products from Schmidt and
Str\"ohlein's book to prove the well known universal property.\<close>

context relation_algebra
begin

definition is_direct_product :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "is_direct_product x y \<equiv> x\<^sup>\<smile> ; x = 1' \<and> y\<^sup>\<smile> ; y = 1' \<and> x ; x\<^sup>\<smile> \<cdot> y ; y\<^sup>\<smile> = 1' \<and> x\<^sup>\<smile> ; y = 1"

text \<open>We collect some basic properties.\<close>

lemma dp_p_fun1: "is_direct_product x y \<Longrightarrow> is_p_fun x"
by (metis is_direct_product_def eq_refl is_p_fun_def)

lemma dp_sur1: "is_direct_product x y \<Longrightarrow> is_sur x"
by (metis is_direct_product_def eq_refl is_sur_def)

lemma dp_total1: "is_direct_product x y \<Longrightarrow> is_total x"
by (metis is_direct_product_def inf_le1 is_total_def)

lemma dp_map1: "is_direct_product x y \<Longrightarrow> is_map x"
by (metis dp_p_fun1 dp_total1 is_map_def)

lemma dp_p_fun2: "is_direct_product x y \<Longrightarrow> is_p_fun y"
by (metis is_direct_product_def eq_refl is_p_fun_def)

lemma dp_sur2: "is_direct_product x y \<Longrightarrow> is_sur y"
by (metis is_direct_product_def eq_refl is_sur_def)

lemma dp_total2: "is_direct_product x y \<Longrightarrow> is_total y"
by (metis is_direct_product_def inf_le2 is_total_def)

lemma dp_map2: "is_direct_product x y \<Longrightarrow> is_map y"
by (metis dp_p_fun2 dp_total2 is_map_def)

text \<open>Next we prove four auxiliary lemmas.\<close>

lemma dp_aux1 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "x\<^sup>\<smile> ; z = 1"
  shows "(w ; x\<^sup>\<smile> \<cdot> y ; z\<^sup>\<smile>) ; z = y"
by (metis assms inf_top_left mult.assoc ss_422iii total_one inf.commute inf_top_right)

lemma dp_aux2 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "z\<^sup>\<smile> ; x = 1"
  shows "(w ; x\<^sup>\<smile> \<cdot> y ; z\<^sup>\<smile>) ; z = y"
by (metis assms conv_contrav conv_invol conv_one inf_top_left mult.assoc ss_422iii total_one)

lemma dp_aux3 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "x\<^sup>\<smile> ; z = 1"
  shows "(y ; z\<^sup>\<smile> \<cdot> w ; x\<^sup>\<smile>) ; z = y"
by (metis assms dp_aux1 inf.commute)

lemma dp_aux4 [simp]:
  assumes "is_p_fun z"
    and "is_total w"
    and "z\<^sup>\<smile> ; x = 1"
  shows "( y ; z\<^sup>\<smile> \<cdot> w ; x\<^sup>\<smile>) ; z = y"
by (metis assms dp_aux2 inf.commute)

text \<open>Next we define a function which is an isomorphism on projections.\<close>

definition Phi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<Phi>")
  where "\<Phi> \<equiv> (\<lambda>w x y z. w ; y\<^sup>\<smile> \<cdot> x ; z\<^sup>\<smile>)"

lemma Phi_conv: "(\<Phi> w x y z)\<^sup>\<smile> = y ; w\<^sup>\<smile> \<cdot> z ; x\<^sup>\<smile>"
by (simp add: Phi_def)

text \<open>We prove that @{const Phi} is an isomorphism with respect to the
projections.\<close>

lemma mono_dp_1:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "\<Phi> w x y z ; y = w"
by (metis assms dp_aux4 is_direct_product_def dp_p_fun1 dp_total2 Phi_def)

lemma mono_dp_2:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "\<Phi> w x y z ; z = x"
by (metis assms dp_aux1 is_direct_product_def dp_p_fun2 dp_total1 Phi_def)

text \<open>We now show that @{const Phi} is an injective function.\<close>

lemma Phi_map:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_map (\<Phi> w x y z)"
proof -
  have "\<Phi> w x y z ; -(1') = \<Phi> w x y z ; -(y ; y\<^sup>\<smile> \<cdot> z ; z\<^sup>\<smile>)"
    by (metis assms(2) is_direct_product_def)
  also have "... = \<Phi> w x y z ; y ; -(y\<^sup>\<smile>) + \<Phi> w x y z ; z ; -(z\<^sup>\<smile>)"
   by (metis compl_inf assms(2) ss43iii dp_map1 dp_map2 mult.assoc distrib_left)
 also have "... = w ; -(y\<^sup>\<smile>) + x ; -(z\<^sup>\<smile>)"
   by (metis assms mono_dp_1 mono_dp_2)
 also have "... = -(w ; y\<^sup>\<smile>) + -(x ; z\<^sup>\<smile>)"
   by (metis assms(1) ss43iii dp_map1 dp_map2)
 also have "... = -(\<Phi> w x y z)"
   by (metis compl_inf Phi_def)
 finally show ?thesis
   by (metis is_maprop)
qed

lemma Phi_inj:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_inj (\<Phi> w x y z)"
by (metis Phi_def Phi_conv Phi_map assms inj_p_fun is_map_def)

text \<open>Next we show that the converse of @{const Phi} is an injective
function.\<close>

lemma Phi_conv_map:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_map ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis Phi_conv Phi_def Phi_map assms)

lemma Phi_conv_inj:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_inj ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis Phi_inj Phi_conv Phi_def assms)

lemma Phi_sur:
  assumes "is_direct_product w x"
  and "is_direct_product y z"
  shows "is_sur (\<Phi> w x y z)"
by (metis assms Phi_conv Phi_def Phi_map is_map_def sur_total)

lemma Phi_conv_sur:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_sur ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis assms Phi_conv Phi_def Phi_sur)

lemma Phi_bij:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_bij (\<Phi> w x y z)"
by (metis assms Phi_inj Phi_map Phi_sur is_bij_def)

lemma Phi_conv_bij:
  assumes "is_direct_product w x"
    and "is_direct_product y z"
  shows "is_bij ((\<Phi> w x y z)\<^sup>\<smile>)"
by (metis Phi_bij Phi_def Phi_conv assms)

text \<open>Next we construct, for given functions~@{term f} and~@{term g}, a
function~@{term F} which makes the standard product diagram commute, and we
verify these commutation properties.\<close>

definition F :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "F \<equiv> (\<lambda>f x g y. f ; x\<^sup>\<smile> \<cdot> g ; y\<^sup>\<smile>)"

lemma f_proj:
  assumes "is_direct_product x y"
  and "is_map g"
  shows "F f x g y ; x = f"
by (metis assms dp_aux4 F_def is_map_def is_direct_product_def dp_p_fun1)

lemma g_proj:
  assumes "is_direct_product x y"
  and "is_map f"
  shows "F f x g y ; y = g"
by (metis assms dp_aux1 F_def is_map_def is_direct_product_def dp_p_fun2)

text \<open>Finally we show uniqueness of~@{const F}, hence universality of the
construction.\<close>

lemma
  assumes "is_direct_product x y"
  and "is_map f"
  and "is_map g"
  and "is_map G"
  and "f = G ; x"
  and "g = G ; y"
  shows "G = F f x g y"
proof -
  have "F f x g y = G ; (x ; x\<^sup>\<smile>) \<cdot> G ; (y ; y\<^sup>\<smile>)"
    by (metis assms(5) assms(6) F_def mult.assoc)
  also have "\<dots> = G ; (x ; x\<^sup>\<smile> \<cdot> y ; y\<^sup>\<smile>)"
    by (metis assms(4) map_distl)
  thus ?thesis
    by (metis assms(1) is_direct_product_def calculation mult.right_neutral)
qed

end (* relation_algebra *)

end


theory Check_Prime
imports Main
  "HOL-Computational_Algebra.Primes"
  "HOL-Number_Theory.Eratosthenes"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Code_Target_Nat"
begin

text \<open>Checking for primality by testing all numbers smaller than \<open>p div 2\<close> as divisors.\<close>

definition isPrime :: "int \<Rightarrow> bool" where
"isPrime n = ((n > 1) \<and>
    foldr (\<lambda>p r. p*p > n \<or> (n mod p \<noteq> 0 \<and> r))
         (2#3#(map (\<lambda>i. 2*i+1) [2..n div 2])) True)"

lemma "prime (7681::nat)" by eval

lemma "isPrime 3329" by eval
(* unfolding isPrime_def by auto  takes approx 20sec*)

(* takes approx 1:05 min*)
lemma "isPrime 7681" by eval
(* unfolding isPrime_def by auto takes approx 1:05 min*)

definition isPrime' :: "int \<Rightarrow> bool" where
"isPrime' n = ((n > 1) \<and>
    foldr (\<lambda>p r. p*p > n \<or> (n mod p \<noteq> 0 \<and> r))
         (2#3#(concat (map (\<lambda>i. [6*i-1,6*i+1]) [1..n div 6]))) True)"

lemma "isPrime' 3329"
unfolding isPrime'_def apply auto sorry

function (sequential) prime_test ::"nat \<Rightarrow> nat \<Rightarrow> bool" where
"prime_test 0 p = False" |
"prime_test (Suc 0) p = True" |
"prime_test t p = (if p mod t = 0 then False
  else prime_test (t-1) p)"
by pat_completeness auto
termination by lexicographic_order

definition "check_prime p = prime_test (p div 2) p"

lemma "prime (993319::nat)" sorry by eval
lemma "check_prime 993319" sorry by eval
lemma "isPrime 993319" sorry by eval

lemma "prime (479001599::nat)" sorry by eval (*15 sec*)
(*lemma "isPrime 479001599" sorry >2min*)
lemma "check_prime 479001599" sorry by eval (* 5 sec*)

(*works for up to 9 digits*)

(*lemma "prime (2971215073::nat)" sorry >2:30 min *)
(*lemma "check_prime 2971215073" sorry >2:30 min*)

lemma "prime (31636373::nat)" sorry by eval
lemma "check_prime 31636373" sorry by eval
(* lemma "isPrime 31636373"  by eval *)

text \<open>For tricky simplification.\<close>
lemma Suc_Suc:
  assumes "x>1"
  shows"x = Suc (Suc (x-2))"
using assms by auto

text \<open>Check the moduluses of Kyber for primeality.\<close>
text \<open>This takes 2-3 min to run\<close>

(*takes approx 15 sec*)
lemma check_3329:
  "check_prime (3329::nat)" by eval
(* unfolding check_prime_def sorry
apply simp apply (subst Suc_Suc, simp, subst prime_test.simps(3), auto)+
by (metis and_numerals(8) and_one_eq gr_zeroI numeral_2_eq_2 zero_neq_one)
*)

(* takes approx 33 sec *)
lemma check_7681:
  "check_prime (7681::nat)" unfolding check_prime_def sorry
apply simp apply (subst Suc_Suc, simp, subst prime_test.simps(3), auto)+
by (metis and_numerals(8) and_one_eq gr_zeroI numeral_2_eq_2 zero_neq_one)

text \<open>Show that our \<open>check_prime\<close> function is correct and is true only for primes.\<close>
lemma prime_test_lower:
assumes "check_prime p" "t\<le>p div 2" "t\<ge>1"
shows "prime_test t p"
proof (induct rule: inc_induct[OF assms(2)])
  case 1
  then show ?case using assms(1) unfolding check_prime_def by auto
next
  case (2 n)
  then have "prime_test (Suc (Suc (n-1))) p" using assms by auto
  then show ?case using prime_test.simps(3)[of "n-1" p]
  by (metis "2.hyps"(1) Suc_diff_le add_diff_cancel_left' assms(3) order_trans plus_1_eq_Suc)
qed

lemma check_prime_not_dividend:
assumes "p>3" "t\<le>p div 2"
  "check_prime p" "t>1"
shows "\<not> (t dvd p)"
proof (induct rule: inc_induct[OF assms(2)])
  case 1
  then have gr:"p div 2 > 1" using assms by linarith
  have "check_prime p = (if p mod (p div 2) = 0 then False
    else prime_test ((p div 2)-1) p)"
    unfolding check_prime_def
    apply (subst Suc_Suc[OF gr])
    apply (subst prime_test.simps(3))
    using Suc_Suc gr by presburger
  then show ?case using \<open>p>3\<close> \<open>check_prime p\<close> by presburger
next
  case (2 n)
  then have gr:"n > 1" using assms by linarith
  have "check_prime p = prime_test n p"
    using prime_test_lower[OF \<open>check_prime p\<close>, of n] 2 assms by auto
  moreover have "\<dots> = (if p mod n = 0 then False
    else prime_test (n-1) p)"
    unfolding check_prime_def
    apply (subst Suc_Suc[OF gr])
    apply (subst prime_test.simps(3))
    using Suc_Suc gr by presburger
  ultimately show ?case using \<open>p>3\<close> \<open>check_prime p\<close> by presburger
qed

lemma dvd_lt_div_2:
assumes "m dvd (p::nat)" "p>1" "m\<noteq>p"
shows "m \<le> p div 2"
using assms
by (metis Groups.mult_ac(2) One_nat_def div_less_iff_less_mult dvd_mult_div_cancel
linorder_neqE_nat linorder_not_le mult_1_right not_less_eq numeral_2_eq_2 zero_less_Suc)

lemma not_check_prime_dvd:
assumes "check_prime p"
  "p>1"
  "m dvd p"
  "m \<noteq> p"
  "m \<noteq> 1"
shows False
proof -
  consider (2) "p=2" | (3) "p=3" | (greater) "p>3" using \<open>p>1\<close> by linarith
  then show False proof (cases)
    case 2
    then show ?thesis using assms
    by (metis One_nat_def Suc_1 Suc_lessI dvd_antisym nat_dvd_not_less odd_pos zero_less_numeral)
  next
    case 3
    then show ?thesis using assms
    by (metis One_nat_def Suc_lessI dvd_pos_nat eval_nat_numeral(3) nat_dvd_not_less
      numeral_2_eq_2 odd_numeral zero_less_numeral)
  next
    case greater
    have "1 < m" using assms
    by (metis One_nat_def Suc_lessI dvd_pos_nat not_less_eq not_less_iff_gr_or_eq)
    have m_div:"m \<le> p div 2" using dvd_lt_div_2[OF \<open>m dvd p\<close> \<open>1<p\<close> \<open>m\<noteq>p\<close>] .
    show ?thesis using check_prime_not_dividend[OF \<open>3<p\<close> m_div assms(1) \<open>1<m\<close>]
      \<open>m dvd p\<close> by auto
  qed
qed

lemma check_prime_dvd:
assumes "check_prime p"
  "p>1"
  "m dvd p"
  "m \<noteq> p"
shows "m=1"
using not_check_prime_dvd[OF assms] assms by blast

lemma prime_is_check:
assumes "prime p" "t\<le>p div 2" "t\<ge>1"
shows "prime_test t p"
proof (induct rule: dec_induct[OF assms(3)])
  case (2 n)
  have Suc_n: "1 < Suc (Suc (n - 1))" by auto
  have not_mod: "\<not>(p mod Suc n = 0)" using assms(1) unfolding prime_nat_iff
  by (metis (mono_tags, lifting) "2.hyps"(1) "2.hyps"(2) One_nat_def assms(2)
    div_less_dividend less_numeral_extra(1) mod_0_imp_dvd not_less_eq numeral_2_eq_2
    order_less_le_trans order_less_trans)
  have "prime_test (Suc n) p = prime_test (Suc (Suc (n-1))) p" using 2 by auto
  moreover have "\<dots> = (if p mod (Suc n) = 0 then False
    else prime_test n p)"
   apply (subst prime_test.simps(3))
   using "2.hyps"(1) by force
  moreover have "\<dots> = prime_test n p" using not_mod by auto
  ultimately show ?case using 2(3) by auto
qed auto

lemma check_prime_checks_prime:
assumes "p>1"
shows "check_prime p \<longleftrightarrow> prime p"
proof (safe, goal_cases)
  assume p: "check_prime p"
  then show "prime p" unfolding check_prime_def prime_nat_iff using assms
  proof (safe, goal_cases)
    case (1 m)
    show ?case using check_prime_dvd[OF p 1(2) 1(3) 1(4)] .
  qed
next
  assume p: "prime p"
  then show "check_prime p" using prime_is_check[OF p, of "p div 2"]
  by (metis assms dual_order.eq_iff dvd_lt_div_2 nat_neq_iff one_dvd check_prime_def)
qed

text \<open>Relate primeality to 7681 and 3329.\<close>
lemma prime_3329: "prime (3329::nat)"
by (subst check_prime_checks_prime[symmetric])
   (use check_3329 in \<open>auto\<close>)

lemma prime_7681: "prime (7681::nat)"
by (subst check_prime_checks_prime[symmetric])
   (use check_7681 in \<open>auto\<close>)

end


(* Practice of Natural Deduction *)
(* http://rainyday.blog.so-net.ne.jp/2017-09-24 *)

theory NaturalDeduction
  imports Main
begin

theorem Example_1_4:
  (*fixes P Q*)
  assumes 1: "P \<and> Q"
  assumes 2: "R"
  shows "Q \<and> R"
proof -
  have 3: "Q" using 1 by (rule conjunct2)
  show 4: "Q \<and> R" using 3 2 by (rule conjI)
qed

find_theorems "\<not>\<not> _ \<Longrightarrow> _"              (* notnotD *)
theorem notnotI: "P \<Longrightarrow> \<not>\<not> P" by auto

theorem Example_1_5:
  assumes 1: "P"
  assumes 2: "\<not>\<not> (Q \<and> R)"
  shows "\<not>\<not> P \<and> R"
proof -
  have 3: "\<not>\<not> P" using 1 by (rule notnotI)
  have 4: "Q \<and> R" using 2 by (rule notnotD)
  have 5: "R" using 4 by (rule conjunct2)
  show 6: "\<not>\<not> P \<and> R" using 3 5 by (rule conjI)
qed

theorem  mp: "(P\<Longrightarrow>Q) \<Longrightarrow> P \<Longrightarrow> Q" by auto
theorem  mt: "(P\<Longrightarrow>Q) \<Longrightarrow> \<not> Q \<Longrightarrow> \<not> P" by auto

theorem Example_1_7:
  assumes 1: "P \<Longrightarrow> (Q \<Longrightarrow> R)"
  assumes 2: "P"
  assumes 3: "\<not> R"
  shows "\<not> Q"
proof -
  have 4: "Q \<Longrightarrow> R" using 1 2 by (rule mp)
  show 5: "\<not> Q" using 4 3 by (rule mt)
qed

theorem Example_1_9:
  assumes 1: "\<not> Q \<Longrightarrow> \<not> P"
  shows "P \<Longrightarrow> \<not>\<not> Q"
proof -
  assume 2: "P"
  have 3: "\<not>\<not> P" using 2 by (rule notnotI)
  show 4: "\<not>\<not> Q" using 1 3 by (rule mt)
qed

theorem Example_1_11:
  shows "(Q \<Longrightarrow> R) \<Longrightarrow> (( \<not> Q \<Longrightarrow> \<not> P) \<Longrightarrow> (P \<Longrightarrow> R))"
proof -
  assume 1: "Q \<Longrightarrow> R"
  show "(\<not> Q \<Longrightarrow> \<not> P) \<Longrightarrow> (P \<Longrightarrow> R)"
  proof -
    assume 2: "\<not> Q \<Longrightarrow> \<not> P"
    show "P \<Longrightarrow> R"
    proof -
      assume 3: "P"
      have 4: "\<not>\<not> P" using 3 by (rule notnotI)
      have 5: "\<not>\<not> Q" using 2 4 by (rule mt)
      have 6: "Q" using 5 by (rule notnotD)
      show 7: "R" using 1 6 by (rule mp)
    qed
  qed
qed

theorem Example_1_11':
  shows "(Q \<Longrightarrow> R) \<Longrightarrow> ((\<not> Q \<Longrightarrow> \<not> P) \<Longrightarrow> (P \<Longrightarrow> R))"
proof-
  assume 1: "Q \<Longrightarrow> R"
  assume 2: "\<not> Q \<Longrightarrow> \<not> P"
  assume 3: "P"
  have 4: "\<not>\<not> P" using 3 by (rule notnotI)
  have 5: "\<not>\<not> Q" using 2 4 by (rule mt)
  have 6: "Q" using 5 by (rule notnotD)
  show 7: "R" using 1 6 by (rule mp)
qed

find_theorems "_ \<Longrightarrow> _ \<or> _"  (* disjI1 , disjI2 *)
theorem disjE: "P \<or> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R" by auto

theorem Example_1_16:
  assumes 1: "Q \<Longrightarrow> R"
  shows "P \<or> Q \<Longrightarrow> P \<or> R"
proof -
  assume 2: "P \<or> Q"
  show "P \<or> R"
  proof -
    have 34: "P \<Longrightarrow> P \<or> R"
    proof -
      assume 3: "P"
      show 4: "P \<or> R" using 3 by (rule disjI1)
    qed
    have 57: "Q \<Longrightarrow> P \<or> R"
    proof -
      assume 5: "Q"
      have 6: "R" using 1 5 by (rule mp)
      show 7: "P \<or> R" using 6 by (rule disjI2)
    qed
    show "P \<or> R" using 2 34 57 by (rule disjE)
  qed
qed

theorem Example_copy:
  shows "P \<Longrightarrow> (Q \<Longrightarrow> P)"
proof -
  assume 1: "P"
  show "Q \<Longrightarrow> P"
  proof -
    assume 2: "Q"
    show 3: "P" using 1 by assumption
  qed
qed

theorem Example_1_21:
  assumes 1: "P \<Longrightarrow> Q"
  assumes 2: "P \<Longrightarrow> \<not>Q"
  shows "\<not> P"
proof -
  have 36: "P \<Longrightarrow> False"
  proof -
    assume 3: "P"
    have 4: "Q" using 1 3 by (rule mp)
    have 5: "\<not> Q" using 2 3 by (rule mp)
    show 6: "False" using 5 4 by (rule notE)
  qed
  show "\<not> P" using 36 by (rule notI)
qed

end


(* Author: Hauke Brinkop and Tobias Nipkow *)

section \<open>Pairing Heap in Binary Tree Representation\<close>

theory Pairing_Heap_Tree
imports
  "HOL-Library.Tree_Multiset"
  "HOL-Data_Structures.Priority_Queue_Specs"
begin

subsection \<open>Definitions\<close>

text \<open>Pairing heaps \cite{FredmanSST86}
in their original representation as binary trees.\<close>

fun get_min  :: "'a :: linorder tree \<Rightarrow> 'a" where
"get_min (Node _ x _) = x"

fun link :: "('a::linorder) tree \<Rightarrow> 'a tree" where
"link (Node hsx x (Node hsy y hs)) =
   (if x < y then Node (Node hsy y hsx) x hs else Node (Node hsx x hsy) y hs)" |
"link t = t"

fun pass\<^sub>1 :: "('a::linorder) tree \<Rightarrow> 'a tree" where
"pass\<^sub>1 (Node hsx x (Node hsy y hs)) = link (Node hsx x (Node hsy y (pass\<^sub>1 hs)))" |
"pass\<^sub>1 hs = hs"

fun pass\<^sub>2 :: "('a::linorder) tree \<Rightarrow> 'a tree" where
"pass\<^sub>2 (Node hsx x hs) = link(Node hsx x (pass\<^sub>2 hs))" |
"pass\<^sub>2 Leaf = Leaf"

fun del_min :: "('a::linorder) tree \<Rightarrow> 'a tree" where
  "del_min Leaf = Leaf"
| "del_min (Node hs _ Leaf) = pass\<^sub>2 (pass\<^sub>1 hs)"

fun merge :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "merge Leaf hp = hp"
| "merge hp Leaf = hp"
| "merge (Node hsx x Leaf) (Node hsy y Leaf) = link (Node hsx x (Node hsy y Leaf))"

fun insert :: "('a::linorder) \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x hp = merge (Node Leaf x Leaf) hp"

text \<open>The invariant is the conjunction of \<open>is_root\<close> and \<open>pheap\<close>:\<close>

fun is_root :: "'a tree \<Rightarrow> bool" where
  "is_root hp = (case hp of Leaf \<Rightarrow> True | Node l x r \<Rightarrow> r = Leaf)"

fun pheap :: "('a :: linorder) tree \<Rightarrow> bool" where
"pheap Leaf = True" |
"pheap (Node l x r) = ((\<forall>y \<in> set_tree l. x \<le> y) \<and> pheap l \<and> pheap r)"

subsection \<open>Correctness Proofs\<close>

subsubsection \<open>Invariants\<close>

lemma link_struct: "\<exists>l a. link (Node hsx x (Node hsy y hs)) = Node l a hs"
by simp

lemma pass\<^sub>1_struct: "\<exists>l a r. pass\<^sub>1 (Node hs1 x hs) = Node l a r"
by (cases hs) simp_all

lemma pass\<^sub>2_struct: "\<exists>l a. pass\<^sub>2 (Node hs1 x hs) = Node l a Leaf"
by(induction hs arbitrary: hs1 x rule: pass\<^sub>2.induct) (auto, metis link_struct)

lemma is_root_merge:
  "is_root h1 \<Longrightarrow> is_root h2 \<Longrightarrow> is_root (merge h1 h2)"
by (simp split: tree.splits)

lemma is_root_insert: "is_root h \<Longrightarrow> is_root (insert x h)"
by (simp split: tree.splits)

lemma is_root_del_min:
  assumes "is_root h" shows "is_root (del_min h)"
proof (cases h)
  case [simp]: (Node lx x rx)
  have "rx = Leaf" using assms by simp
  thus ?thesis
  proof (cases lx)
    case (Node ly y ry)
    then obtain la a ra where "pass\<^sub>1 lx = Node a la ra"
      using pass\<^sub>1_struct by blast
    moreover obtain lb b where "pass\<^sub>2 \<dots> = Node b lb Leaf"
      using pass\<^sub>2_struct by blast
    ultimately show ?thesis using assms by simp
  qed simp
qed simp

lemma pheap_merge:
  "\<lbrakk> is_root h1; is_root h2; pheap h1; pheap h2 \<rbrakk> \<Longrightarrow> pheap (merge h1 h2)"
by (auto split: tree.splits)

lemma pheap_insert: "is_root h \<Longrightarrow> pheap h \<Longrightarrow> pheap (insert x h)"
by (auto split: tree.splits)

lemma pheap_link: "t \<noteq> Leaf \<Longrightarrow> pheap t \<Longrightarrow> pheap (link t)"
by(induction t rule: link.induct)(auto)

lemma pheap_pass1: "pheap h \<Longrightarrow> pheap (pass\<^sub>1 h)"
by(induction h rule: pass\<^sub>1.induct) (auto)

lemma pheap_pass2: "pheap h \<Longrightarrow> pheap (pass\<^sub>2 h)"
by (induction h)(auto simp: pheap_link)

lemma pheap_del_min: "is_root h \<Longrightarrow> pheap h \<Longrightarrow> pheap (del_min h)"
by (auto simp: pheap_pass1 pheap_pass2 split: tree.splits)

subsubsection \<open>Functional Correctness\<close>

lemma get_min_in:
  "h \<noteq> Leaf \<Longrightarrow> get_min h \<in> set_tree h"
by(auto simp add: neq_Leaf_iff)

lemma get_min_min: "\<lbrakk> is_root h; pheap h; x \<in> set_tree h \<rbrakk> \<Longrightarrow> get_min h \<le> x"
by(auto split: tree.splits)

lemma mset_link: "mset_tree (link t) = mset_tree t"
by(cases t rule: link.cases)(auto simp: add_ac)

lemma mset_pass\<^sub>1: "mset_tree (pass\<^sub>1 h) = mset_tree h"
by (induction h rule: pass\<^sub>1.induct) auto

lemma mset_pass\<^sub>2: "mset_tree (pass\<^sub>2 h) = mset_tree h"
by (induction h rule: pass\<^sub>2.induct) (auto simp: mset_link)

lemma mset_merge: "\<lbrakk> is_root h1; is_root h2 \<rbrakk>
 \<Longrightarrow>  mset_tree (merge h1 h2) = mset_tree h1 + mset_tree h2"
by (induction h1 h2 rule: merge.induct) (auto simp add: ac_simps)
(*
lemma mset_merge_pairs: "mset_tree (merge_pairs h) = mset_tree h"
by(induction h rule: merge_pairs.induct)(auto simp: mset_link add_ac)
*)
lemma mset_del_min: "\<lbrakk> is_root h; t \<noteq> Leaf \<rbrakk> \<Longrightarrow>
  mset_tree (del_min h) = mset_tree h - {#get_min h#}"
by(induction h rule: del_min.induct)(auto simp: mset_pass\<^sub>1 mset_pass\<^sub>2)

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation pairing: Priority_Queue_Merge
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and merge = merge and insert = insert
and del_min = del_min and get_min = get_min
and invar = "\<lambda>h. is_root h \<and> pheap h" and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case (2 q) show ?case by (cases q) auto
next
  case 3 thus ?case by(simp add: mset_merge)
next
  case 4 thus ?case by(simp add: mset_del_min)
next
  case 5 thus ?case by(simp add: eq_Min_iff get_min_in get_min_min)
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case using is_root_insert pheap_insert by blast
next
  case 8 thus ?case using is_root_del_min pheap_del_min by blast
next
  case 9 thus ?case by (simp add: mset_merge)
next
  case 10 thus ?case using is_root_merge pheap_merge by blast
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Generic Lemmas used in the Word Library"

theory HOL_Lemmas
imports Main
begin

definition
  strict_part_mono :: "'a set \<Rightarrow> ('a :: order \<Rightarrow> 'b :: order) \<Rightarrow> bool" where
 "strict_part_mono S f \<equiv> \<forall>A\<in>S. \<forall>B\<in>S. A < B \<longrightarrow> f A < f B"

lemma strict_part_mono_by_steps:
  "strict_part_mono {..n :: nat} f = (n \<noteq> 0 \<longrightarrow> f (n - 1) < f n \<and> strict_part_mono {.. n - 1} f)"
  apply (cases n; simp add: strict_part_mono_def)
  apply (safe; clarsimp)
  apply (case_tac "B = Suc nat"; simp)
  apply (case_tac "A = nat"; clarsimp)
  apply (erule order_less_trans [rotated])
  apply simp
  done

lemma strict_part_mono_singleton[simp]:
  "strict_part_mono {x} f"
  by (simp add: strict_part_mono_def)

lemma strict_part_mono_lt:
  "\<lbrakk> x < f 0; strict_part_mono {.. n :: nat} f \<rbrakk> \<Longrightarrow> \<forall>m \<le> n. x < f m"
  by (metis atMost_iff le_0_eq le_cases neq0_conv order.strict_trans strict_part_mono_def)

lemma strict_part_mono_reverseE:
  "\<lbrakk> f n \<le> f m; strict_part_mono {.. N :: nat} f; n \<le> N \<rbrakk> \<Longrightarrow> n \<le> m"
  by (rule ccontr) (fastforce simp: linorder_not_le strict_part_mono_def)

lemma takeWhile_take_has_property:
  "n \<le> length (takeWhile P xs) \<Longrightarrow> \<forall>x \<in> set (take n xs). P x"
  by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)

lemma takeWhile_take_has_property_nth:
  "\<lbrakk> n < length (takeWhile P xs) \<rbrakk> \<Longrightarrow> P (xs ! n)"
  by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)

lemma takeWhile_replicate:
  "takeWhile f (replicate len x) = (if f x then replicate len x else [])"
  by (induct_tac len) auto

lemma takeWhile_replicate_id:
  "f x \<Longrightarrow> takeWhile f (replicate len x) = replicate len x"
  by (simp add: takeWhile_replicate)

lemma power_sub:
  fixes a :: nat
  assumes lt: "n \<le> m"
  and     av: "0 < a"
  shows "a ^ (m - n) = a ^ m div a ^ n"
proof (subst nat_mult_eq_cancel1 [symmetric])
  show "(0::nat) < a ^ n" using av by simp
next
  from lt obtain q where mv: "n + q = m"
    by (auto simp: le_iff_add)

  have "a ^ n * (a ^ m div a ^ n) = a ^ m"
  proof (subst mult.commute)
    have "a ^ m = (a ^ m div a ^ n) * a ^ n + a ^ m mod a ^ n"
      by (rule  div_mult_mod_eq [symmetric])

    moreover have "a ^ m mod a ^ n = 0"
      by (subst mod_eq_0_iff_dvd, subst dvd_def, rule exI [where x = "a ^ q"],
      (subst power_add [symmetric] mv)+, rule refl)

    ultimately show "(a ^ m div a ^ n) * a ^ n = a ^ m" by simp
  qed

  then show "a ^ n * a ^ (m - n) = a ^ n * (a ^ m div a ^ n)" using lt
    by (simp add: power_add [symmetric])
qed

lemma union_sub:
  "\<lbrakk>B \<subseteq> A; C \<subseteq> B\<rbrakk> \<Longrightarrow> (A - B) \<union> (B - C) = (A - C)"
  by fastforce

lemma insert_sub:
  "x \<in> xs \<Longrightarrow> (insert x (xs - ys)) = (xs - (ys - {x}))"
  by blast

lemma ran_upd:
  "\<lbrakk> inj_on f (dom f); f y = Some z \<rbrakk> \<Longrightarrow> ran (\<lambda>x. if x = y then None else f x) = ran f - {z}"
  unfolding ran_def
  apply (rule set_eqI)
  apply simp
  by (metis domI inj_on_eq_iff option.sel)

lemma nat_less_power_trans:
  fixes n :: nat
  assumes nv: "n < 2 ^ (m - k)"
  and     kv: "k \<le> m"
  shows "2 ^ k * n < 2 ^ m"
proof (rule order_less_le_trans)
  show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
    by (rule mult_less_mono2 [OF nv zero_less_power]) simp

  show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
    by (subst power_add [symmetric]) simp
qed

lemma nat_le_power_trans:
  fixes n :: nat
  shows "\<lbrakk>n \<le> 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> 2 ^ k * n \<le> 2 ^ m"
  by (metis le_add_diff_inverse mult_le_mono2 semiring_normalization_rules(26))

lemma x_power_minus_1:
  fixes x :: "'a :: {ab_group_add, power, numeral, one}"
  shows "x + (2::'a) ^ n - (1::'a) = x + (2 ^ n - 1)" by simp

lemma nat_diff_add:
  fixes i :: nat
  shows "\<lbrakk> i + j = k \<rbrakk> \<Longrightarrow> i = k - j"
  by arith

lemma pow_2_gt: "n \<ge> 2 \<Longrightarrow> (2::int) < 2 ^ n"
  by (induct n) auto

lemma if_apply_def2:
  "(if P then F else G) = (\<lambda>x. (P \<longrightarrow> F x) \<and> (\<not> P \<longrightarrow> G x))"
  by simp

lemma case_bool_If:
  "case_bool P Q b = (if b then P else Q)"
  by simp

lemma sum_to_zero:
  "(a :: 'a :: ring) + b = 0 \<Longrightarrow> a = (- b)"
  by (drule arg_cong[where f="\<lambda> x. x - a"], simp)

lemma arith_is_1:
  "\<lbrakk> x \<le> Suc 0; x > 0 \<rbrakk> \<Longrightarrow> x = 1"
  by arith

lemma if_f:
  "(if a then f b else f c) = f (if a then b else c)"
  by simp

lemma upt_add_eq_append':
  assumes "i \<le> j" and "j \<le> k"
  shows "[i..<k] = [i..<j] @ [j..<k]"
  using assms le_Suc_ex upt_add_eq_append by blast

lemma split_upt_on_n:
  "n < m \<Longrightarrow> [0 ..< m] = [0 ..< n] @ [n] @ [Suc n ..< m]"
  by (metis append_Cons append_Nil less_Suc_eq_le less_imp_le_nat upt_add_eq_append'
            upt_rec zero_less_Suc)

lemma drop_Suc_nth:
  "n < length xs \<Longrightarrow> drop n xs = xs!n # drop (Suc n) xs"
  by (simp add: Cons_nth_drop_Suc)

lemma n_less_equal_power_2 [simp]:
  "n < 2 ^ n"
  by (induct n; simp)

lemma nat_min_simps [simp]:
  "(a::nat) \<le> b \<Longrightarrow> min b a = a"
  "a \<le> b \<Longrightarrow> min a b = a"
  by auto

lemma power_sub_int:
  "\<lbrakk> m \<le> n; 0 < b \<rbrakk> \<Longrightarrow> b ^ n div b ^ m = (b ^ (n - m) :: int)"
  apply (subgoal_tac "\<exists>n'. n = m + n'")
   apply (clarsimp simp: power_add)
  apply (rule exI[where x="n - m"])
  apply simp
  done

lemma suc_le_pow_2:
  "1 < (n::nat) \<Longrightarrow> Suc n < 2 ^ n"
  by (induct n; clarsimp)
     (case_tac "n = 1"; clarsimp)

lemma nat_le_Suc_less_imp:
  "x < y \<Longrightarrow> x \<le> y - Suc 0"
  by arith

lemma length_takeWhile_less:
  "\<exists>x\<in>set xs. \<not> P x \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (induct xs) (auto split: if_splits)

lemma drop_eq_mono:
  assumes le: "m \<le> n"
  assumes drop: "drop m xs = drop m ys"
  shows "drop n xs = drop n ys"
proof -
  have ex: "\<exists>p. n = p + m" by (rule exI[of _ "n - m"]) (simp add: le)
  then obtain p where p: "n = p + m" by blast
  show ?thesis unfolding p drop_drop[symmetric] drop by simp
qed

lemma nat_Suc_less_le_imp:
  "(k::nat) < Suc n \<Longrightarrow> k \<le> n"
  by auto

lemma nat_add_less_by_max:
  "\<lbrakk> (x::nat) \<le> xmax ; y < k - xmax \<rbrakk> \<Longrightarrow> x + y < k"
  by simp

lemma mod_lemma: "[| (0::nat) < c; r < b |] ==> b * (q mod c) + r < b * c"
  apply (cut_tac m = q and n = c in mod_less_divisor)
  apply (drule_tac [2] m = "q mod c" in less_imp_Suc_add, auto)
  apply (erule_tac P = "%x. lhs < rhs x" for lhs rhs in ssubst)
  apply (simp add: add_mult_distrib2)
  done

lemma nat_le_Suc_less:
  "0 < y \<Longrightarrow> (x \<le> y - Suc 0) = (x < y)"
  by arith

lemma nat_power_minus_less:
  "a < 2 ^ (x - n) \<Longrightarrow> (a :: nat) < 2 ^ x"
  by (erule order_less_le_trans) simp

end


theory ex05
  imports Complex_Main "HOL-Library.Tree"
begin

lemma exp_fact_estimate: "n > 3 \<Longrightarrow> (2::nat)^n < fact n"
proof(induction n)
  case 0
  then show ?case
    by auto
next
  case (Suc n)
  have "n = 3 \<or> n > 3"
    using Suc.prems
    by auto
  then show ?case
  proof
    assume GT: "n > 3"
    hence "(2::nat) ^ n < fact n"
      using Suc.IH
      by simp
    hence "(2::nat)* 2 ^ n < fact n + fact n"
      by simp
    also have "... < fact n + n * fact n"
      using GT
      by simp
    also have "... = fact (Suc n)"
      by simp
    finally show "(2::nat) ^ Suc n < fact (Suc n)"
      by simp
  next
    assume "n = 3"
    thus "(2::nat) ^ Suc n < fact (Suc n)"
      by (simp add: eval_nat_numeral)
  qed
qed

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

value "sumto id 3"

lemma sum_of_naturals: "2 * sumto (\<lambda>x . x ) n = n * (n + 1 )"
  by (induction n) auto

find_theorems "(_ + _)^2"

lemma "sumto (\<lambda>x . x ) n ^ 2 = sumto (\<lambda>x . x^3 ) n"
proof (induction n)
  case 0 show ?case by simp
next
  case (Suc n)
  note [simp] = algebra_simps
  have "(sumto (\<lambda>x. x) (Suc n)) ^ 2 = ((sumto (\<lambda>x. x) n) + (n+1)) ^ 2"
    by simp
  also have "... = (sumto (\<lambda>x. x) n)^2 + (2::nat) * (sumto (\<lambda>x. x) n)*(n+1) + (n+1)^2"
    by (simp only: power2_sum)
  also have "... = (sumto (\<lambda>x. x^3) n) + (2::nat) * (sumto (\<lambda>x. x) n)*(n+1) + (n+1)^2"
    using Suc.IH
    by simp
  also have "... = (sumto (\<lambda>x. x^3) n) + n*(n+1)*(n+1) + (n+1)^2"
    using sum_of_naturals
    by simp
  also have "... = (sumto (\<lambda>x. x^3) n) + (n+1)^3"
    by (simp add: eval_nat_numeral)
  also have "... = (sumto (\<lambda>x. x^3) (Suc n))"
    by simp
  finally show ?case
    .
qed

fun enum :: "nat \<Rightarrow> unit tree set" where
  "enum 0 = {\<langle>\<rangle>}" |
  "enum (Suc n) = enum n \<union> {Node l () r | l r. l \<in> enum n \<and> r \<in> enum n}"

find_theorems "_ \<le> _ \<Longrightarrow> _ \<le> Suc _"

lemma enum_sound: "t \<in> enum n \<Longrightarrow> height t \<le> n"
  apply(induction n arbitrary: t)
   apply (auto simp: le_SucI)
  done

lemma enum_complete: "height t \<le> n \<Longrightarrow> t \<in> enum n"
  apply(induction n arbitrary: t)
  subgoal for t
    apply auto
    done
  subgoal for n t
    apply (cases t)
    apply auto
    done
  done

lemma enum_complete_isar: "height t \<le> n \<Longrightarrow> t \<in> enum n"
proof(induction n arbitrary: t)
  case 0
  then show ?case
    by auto
next
  case (Suc n)
  then show ?case
    by (cases t) auto
qed

datatype 'a tchar = L | N 'a

fun pretty::"'a tree \<Rightarrow> 'a tchar list" where
  "pretty \<langle>\<rangle> = [L]" |
  "pretty (Node l a r) = N a # (pretty l) @ (pretty r)"

value "pretty (Node (Node \<langle>\<rangle> (1::nat) \<langle>\<rangle>) (2::nat) (Node \<langle>\<rangle> (3::nat) \<langle>\<rangle>))"

find_theorems "?xs @ _ = ?xs @ _"

lemma pretty_unique: "pretty t @ xs = pretty t' @ ys \<Longrightarrow> t=t'"
  apply(induction t arbitrary: t' xs ys)
  subgoal for t' apply(cases t')
     apply auto
    done
  subgoal for t1 x t2 t' xs ys
    apply(cases t')
     apply auto
    apply force
    done
  done

fun bin_tree2::"'a tree \<Rightarrow> 'b tree \<Rightarrow> bool" where
  "bin_tree2 \<langle>\<rangle> \<langle>\<rangle> = True" |
  "bin_tree2 (Node l1 a1 r1) (Node l2 a2 r2) = ((bin_tree2 l1 l2) \<or> (bin_tree2 r1 r2))"

lemma pretty_unique': "pretty t @ xs = pretty t' @ ys \<Longrightarrow> t=t'"
  apply(induction t t' arbitrary: xs ys rule: bin_tree2.induct)
  apply force+
  done

end


theory Nat_Demo
imports Main
begin

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

lemma add_02: "add m 0 = m"
apply(induction m)
apply(auto)
done

end


section\<open>  Uma Teoria para Listas Genéricas \<close>

theory list_no_text
imports nat_tutorial
begin

subsection\<open>Definições Básicas\<close>

datatype 'a  List  = Empty | cons 'a "'a List"

primrec cat::"'a List\<Rightarrow>'a List \<Rightarrow>'a List"
   where
     cat01: "cat Empty l = l"|
     cat02: "cat (cons h t) l= cons h (cat t l)"

subsection\<open> Verificação com scripts de comandos \<close>

theorem th_cat01as: "\<forall> l2 l3. cat l (cat l2 l3) = cat (cat l l2) l3"
   apply (induct l)
   apply (simp_all)
done

subsection\<open>Verificação com a linguagem Isar\<close>

theorem th_cat01isA: "\<forall> l2 l3. cat l (cat l2 l3) = cat (cat l l2) l3"
   proof (induct l)
     show "\<forall> l2 l3. cat Empty (cat l2 l3) = cat (cat Empty l2) l3" by simp
   next
     fix e0 and l0
     assume IH: "\<forall> l2 l3. cat l0 (cat l2 l3) = cat (cat l0 l2) l3"
     show "\<forall> l2 l3. cat (cons e0 l0) (cat l2 l3) = cat (cat (cons e0 l0) l2) l3"
       by (simp add:IH)
   qed

 theorem th_cat01isB: "\<forall> l2 l3. cat l (cat l2 l3) = cat (cat l l2) l3"
   proof (induct l)
     show "\<forall> l2 l3. cat Empty (cat l2 l3) = cat (cat Empty l2) l3"
       proof (rule allI, rule allI)
         fix k and  m
         have "cat Empty (cat k m) = cat k m" by (simp only:cat01)
         also  have "cat k m = cat (cat Empty k) m" by (simp only:cat01)
         finally show "cat Empty (cat k m) = cat (cat Empty k) m" by this
       qed
    next
      fix e0::'a and l0::"'a List"
      assume IH: "\<forall> l2 l3. cat l0 (cat l2 l3) = cat (cat l0 l2) l3"
      show "\<forall> l2 l3. cat (cons e0 l0) (cat l2 l3) = cat (cat (cons e0 l0) l2) l3"
        proof (rule allI, rule allI)
          fix k and m
          have "cat (cons e0 l0) (cat k m) = cons e0 (cat l0  (cat k m))"
             by (simp only:cat02)
          also have "cons e0 (cat l0 (cat k m)) = cons e0 (cat (cat l0 k) m)"
              by (simp only:IH)
          also have "cons e0 (cat (cat l0 k) m) = cat (cons e0 (cat l0 k)) m"
             by (simp only:cat02)
          also  have "cat (cons e0 (cat l0 k)) m = cat (cat (cons e0 l0) k) m"
             by (simp only:cat02)
          finally  show "cat (cons e0 l0) (cat k m) =cat (cat (cons e0 l0) k) m"
             by this
       qed
   qed

subsection\<open>Pit Stop\<close>

end


theory Uniform_Sampling imports
  Cyclic_Group_SPMF
  "~~/src/HOL/Number_Theory/Cong"
begin

definition sample_uniform_units :: "nat \<Rightarrow> nat spmf"
  where "sample_uniform_units q = spmf_of_set ({..< q} - {0})"

lemma lossless_sample_uniform_units:
  assumes "(p::nat) > 1"
  shows "lossless_spmf (sample_uniform_units p)"
  unfolding sample_uniform_units_def
  using assms by auto

(*General lemma for mapping using sample_uniform*)

lemma one_time_pad':
  assumes inj_on: "inj_on f ({..<q} - {0})"
    and sur: "f ` ({..<q} - {0}) = ({..<q} - {0})"
  shows "map_spmf f (sample_uniform_units q) = (sample_uniform_units q)"
(is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set (({..<q} - {0}))"
    by(auto simp add: sample_uniform_units_def)
  also have "map_spmf(\<lambda>s. f s) (spmf_of_set ({..<q} - {0})) = spmf_of_set ((\<lambda>s. f s) ` ({..<q} - {0}))"
    by(simp add: inj_on)
  also have "f ` ({..<q} - {0}) = ({..<q} - {0})"
    apply(rule endo_inj_surj) by(simp, simp add: sur, simp add: inj_on)
  ultimately show ?thesis using rhs by simp
qed

lemma one_time_pad:
  assumes inj_on: "inj_on f {..<q}"
    and sur: "f ` {..<q} = {..<q}"
  shows "map_spmf f (sample_uniform q) = (sample_uniform q)"
(is "?lhs = ?rhs")
proof-
  have rhs: "?rhs = spmf_of_set ({..< q})"
    by(auto simp add: sample_uniform_def)
  also have "map_spmf(\<lambda>s. f s) (spmf_of_set {..<q}) = spmf_of_set ((\<lambda>s. f s) ` {..<q})"
    by(simp add: inj_on)
  also have "f ` {..<q} = {..<q}"
    apply(rule endo_inj_surj) by(simp, simp add: sur, simp add: inj_on)
  ultimately show ?thesis using rhs by simp
qed

(*(y + b)*)

lemma plus_inj_eq:
  assumes x: "x < q"
    and x': "x' < q"
    and map: "((y :: nat) + x) mod q = (y + x') mod q"
shows "x = x'"
proof-
  have "((y :: nat) + x) mod q = (y + x') mod q \<Longrightarrow> x mod q = x' mod q"
  proof-
    have "((y:: nat) + x) mod q = (y + x') mod q \<Longrightarrow> [((y:: nat) + x) = (y + x')] (mod q)"
      by(simp add: cong_nat_def)
    moreover have "[((y:: nat) + x) = (y + x')] (mod q) \<Longrightarrow> [x = x'] (mod q)"
      by (simp add: cong_add_lcancel_nat)
    moreover have "[x = x'] (mod q) \<Longrightarrow> x mod q = x' mod q"
      by(simp add: cong_nat_def)
    ultimately show ?thesis by(simp add: map)
  qed
  moreover have "x mod q = x' mod q \<Longrightarrow> x = x'"
    by(simp add: x x')
  ultimately show ?thesis by(simp add: map)
qed

lemma inj_uni_samp_plus: "inj_on  (\<lambda>(b :: nat). (y + b) mod q ) {..<q}"
  by(simp add: inj_on_def)(auto simp only: plus_inj_eq)

lemma surj_uni_samp_plus:
  assumes inj: "inj_on  (\<lambda>(b :: nat). (y + b) mod q ) {..<q}"
  shows "(\<lambda>(b :: nat). (y + b) mod q) ` {..< q} =  {..< q}"
  apply(rule endo_inj_surj) using inj by auto

lemma samp_uni_plus_one_time_pad:
shows "map_spmf (\<lambda>b. (y + b) mod q) (sample_uniform q) = sample_uniform q"
  using inj_uni_samp_plus surj_uni_samp_plus one_time_pad by simp

(*x*b*)

lemma mult_inj_eq:
  assumes coprime: "coprime x (q::nat)"
    and y: "y < q"
    and y': "y' < q"
    and map: "x * y mod q = x * y' mod q"
  shows "y = y'"
proof-
  have "x*y mod q = x*y' mod q \<Longrightarrow> y mod q = y' mod q"
  proof-
    have "x*y mod q = x*y' mod q \<Longrightarrow> [x*y = x*y'] (mod q)"
      by(simp add: cong_nat_def)
    moreover have "[x*y = x*y'] (mod q) = [y = y'] (mod q)"
      by(simp add: cong_mult_lcancel_nat coprime)
    moreover have "[y = y'] (mod q) \<Longrightarrow> y mod q = y' mod q"
      by(simp add: cong_nat_def)
    ultimately show ?thesis by(simp add: map)
  qed
  moreover have "y mod q = y' mod q \<Longrightarrow> y = y'"
    by(simp add: y y')
  ultimately show ?thesis by(simp add: map)
qed

lemma inj_on_mult:
  assumes coprime: "coprime x (q::nat)"
  shows "inj_on (\<lambda> b. x*b mod q) {..<q}"
  apply(auto simp add: inj_on_def)
  using coprime by(simp only: mult_inj_eq)

lemma surj_on_mult:
  assumes coprime: "coprime x (q::nat)"
    and inj: "inj_on (\<lambda> b. x*b mod q) {..<q}"
  shows "(\<lambda> b. x*b mod q) ` {..< q} = {..< q}"
  apply(rule endo_inj_surj) using coprime inj by auto

lemma mult_one_time_pad:
  assumes coprime: "coprime x q"
  shows "map_spmf (\<lambda> b. x*b mod q) (sample_uniform q) = sample_uniform q"
  using inj_on_mult surj_on_mult one_time_pad coprime by simp

lemma inj_on_mult':
  assumes coprime: "coprime x (q::nat)"
  shows "inj_on (\<lambda> b. x*b mod q) ({..<q} - {0})"
  apply(auto simp add: inj_on_def)
  using coprime by(simp only: mult_inj_eq)

lemma surj_on_mult':
  assumes coprime: "coprime x (q::nat)"
    and inj: "inj_on (\<lambda> b. x*b mod q) ({..<q} - {0})"
  shows "(\<lambda> b. x*b mod q) ` ({..<q} - {0}) = ({..<q} - {0})"
proof(rule endo_inj_surj)
  show " finite ({..<q} - {0})" by auto
  show "(\<lambda>b. x * b mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0}"
  proof-
    obtain nn :: "nat set \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat set \<Rightarrow> nat" where
      "\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x2 \<and> x1 v3 \<notin> x0) = (nn x0 x1 x2 \<in> x2 \<and> x1 (nn x0 x1 x2) \<notin> x0)"
        by moura
    hence 1: "\<forall>N f Na. nn Na f N \<in> N \<and> f (nn Na f N) \<notin> Na \<or> f ` N \<subseteq> Na"
      by (meson image_subsetI)
    have 2: "x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<notin> {..<q} \<or> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> insert 0 {..<q}"
      by force
    have 3: "(x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> insert 0 {..<q} - {0}) = (x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> {..<q} - {0})"
      by simp
    { assume "x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q = x * 0 mod q"
      hence "(0 \<le> q) = (0 = q) \<or> (nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<notin> {..<q} \<or> nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<in> {0}) \<or> nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<notin> {..<q} - {0} \<or> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> {..<q} - {0}"
        by (metis antisym_conv1 insertCI lessThan_iff local.coprime mult_inj_eq) }
    moreover
    { assume "0 \<noteq> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q"
      moreover
      { assume "x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> insert 0 {..<q} \<and> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<notin> {0}"
        hence "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0}"
          using 3 1 by (meson Diff_iff) }
      ultimately have "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0} \<or> (0 \<le> q) = (0 = q)"
        using 2 by (metis antisym_conv1 lessThan_iff mod_less_divisor singletonD) }
    ultimately have "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0} \<or> nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) \<notin> {..<q} - {0} \<or> x * nn ({..<q} - {0}) (\<lambda>n. x * n mod q) ({..<q} - {0}) mod q \<in> {..<q} - {0}"
      by force
    thus "(\<lambda>n. x * n mod q) ` ({..<q} - {0}) \<subseteq> {..<q} - {0}"
      using 1 by meson
  qed
  show "inj_on (\<lambda>b. x * b mod q) ({..<q} - {0})"
    using inj by blast
qed

lemma mult_one_time_pad':
  assumes coprime: "coprime x q"
  shows "map_spmf (\<lambda> b. x*b mod q) (sample_uniform_units q) = sample_uniform_units q"
  using inj_on_mult' surj_on_mult' one_time_pad' coprime by simp

(*y + x*b*)

lemma samp_uni_add_mult:
  assumes coprime: "coprime x (q::nat)"
    and x': "x' < q"
    and y': "y' < q"
    and map: "(y + x * x') mod q = (y + x * y') mod q"
  shows "x' = y'"
proof-
  have "(y + x * x') mod q = (y + x * y') mod q \<Longrightarrow> x' mod q = y' mod q"
  proof-
  have "(y + x * x') mod q = (y + x * y') mod q \<Longrightarrow> [y + x*x' = y + x *y'] (mod q)"
    using cong_nat_def by blast
  moreover have "[y + x*x' = y + x *y'] (mod q) \<Longrightarrow> [x' = y'] (mod q)"
    by(simp add: cong_add_lcancel_nat)(simp add: coprime cong_mult_lcancel_nat)
  ultimately show ?thesis by(simp add: cong_nat_def map)
  qed
  moreover have "x' mod q = y' mod q \<Longrightarrow> x' = y'"
    by(simp add: x' y')
  ultimately show ?thesis by(simp add: map)
qed

lemma inj_on_add_mult:
  assumes coprime: "coprime x (q::nat)"
  shows "inj_on (\<lambda> b. (y + x*b) mod q) {..<q}"
  apply(auto simp add: inj_on_def)
  using coprime by(simp only: samp_uni_add_mult)

lemma surj_on_add_mult:
  assumes coprime: "coprime x (q::nat)"
    and inj: "inj_on (\<lambda> b. (y + x*b) mod q) {..<q}"
  shows "(\<lambda> b. (y + x*b) mod q) ` {..< q} = {..< q}"
  apply(rule endo_inj_surj) using coprime inj by auto

lemma add_mult_one_time_pad:
  assumes coprime: "coprime x q"
  shows "map_spmf (\<lambda> b. (y + x*b) mod q) (sample_uniform q) = (sample_uniform q)"
  using inj_on_add_mult surj_on_add_mult one_time_pad coprime by simp

(*(y - b) *)

lemma inj_on_minus: "inj_on  (\<lambda>(b :: nat). (y + (q - b)) mod q ) {..<q}"
proof(unfold inj_on_def; auto)
  fix x :: nat and y' :: nat
  assume x: "x < q"
  assume y': "y' < q"
  assume map: "(y + q - x) mod q = (y + q - y') mod q"
  have "\<forall>n na p. \<exists>nb. \<forall>nc nd pa. (\<not> (nc::nat) < nd \<or> \<not> pa (nc - nd) \<or> pa 0) \<and> (\<not> p (0::nat) \<or> p (n - na) \<or> na + nb = n)"
    by (metis (no_types) nat_diff_split)
  hence "\<not> y < y' - q \<and> \<not> y < x - q"
    using y' x by (metis add.commute less_diff_conv not_add_less2)
  hence "\<exists>n. (y' + n) mod q = (n + x) mod q"
    using map by (metis add.commute add_diff_inverse_nat less_diff_conv mod_add_left_eq)
  thus "x = y'"
    by (metis plus_inj_eq  x y' add.commute)
qed

lemma surj_on_minus:
  assumes inj: "inj_on  (\<lambda>(b :: nat). (y + (q - b)) mod q ) {..<q}"
  shows "(\<lambda>(b :: nat). (y + (q - b)) mod q) ` {..< q} = {..< q}"
  apply(rule endo_inj_surj) using inj by auto

lemma samp_uni_minus_one_time_pad:
  shows "map_spmf(\<lambda> b. (y + (q - b)) mod q) (sample_uniform q) = sample_uniform q"
  using inj_on_minus surj_on_minus one_time_pad by simp

lemma not_coin_spmf: "map_spmf (\<lambda> a. \<not> a) coin_spmf = coin_spmf"
proof-
  have "inj_on Not {True, False}"
    by simp
  moreover have  "Not ` {True, False} = {True, False}"
    by auto
  ultimately show ?thesis using one_time_pad
    by (simp add: UNIV_bool)
qed

end


theory Set_Applicative imports
  Applicative_Lifting.Applicative_Set
begin

subsection \<open>Applicative instance for @{typ "'a set"}\<close>

lemma ap_set_conv_bind: "ap_set f x = Set.bind f (\<lambda>f. Set.bind x (\<lambda>x. {f x}))"
by(auto simp add: ap_set_def bind_UNION)

context includes applicative_syntax begin

lemma in_ap_setI: "\<lbrakk> f' \<in> f; x' \<in> x \<rbrakk> \<Longrightarrow> f' x' \<in> f \<diamondop> x"
by(auto simp add: ap_set_def)

lemma in_ap_setE [elim!]:
  "\<lbrakk> x \<in> f \<diamondop> y; \<And>f' y'. \<lbrakk> x = f' y'; f' \<in> f; y' \<in> y \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
by(auto simp add: ap_set_def)

lemma in_ap_pure_set [iff]: "x \<in> {f} \<diamondop> y \<longleftrightarrow> (\<exists>y'\<in>y. x = f y')"
unfolding ap_set_def by auto

end

end