(*
  File: MetricSpaces.thy
  Author: Bohua Zhan

  Metric spaces.
*)

theory MetricSpaces
  imports RealTopology
begin

section \<open>Metric spaces\<close>

definition "metric_fun_name = succ(succ(\<emptyset>))"
definition "metric_fun(X) = graph_eval(X, metric_fun_name)"
setup {* add_field_data (@{term metric_fun_name}, @{term metric_fun}) *}

definition dist :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "dist(X,x,y) = metric_fun(X)`\<langle>x,y\<rangle>"
setup {* register_wellform_data ("dist(X,x,y)", ["x \<in>. X", "y \<in>. X"]) *}

definition is_metric_space_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_metric_space_raw(X) \<longleftrightarrow> (\<forall>x\<in>.X. \<forall>y\<in>.X. dist(X,x,y) \<in> real)"

lemma is_metric_space_rawI [backward]:
  "\<forall>x\<in>.X. \<forall>y\<in>.X. dist(X,x,y) \<in> real \<Longrightarrow> is_metric_space_raw(X)" by auto2

lemma is_metric_space_rawD [typing]:
  "is_metric_space_raw(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> dist(X,x,y) \<in> real" by auto2
setup {* del_prfstep_thm @{thm is_metric_space_raw_def} *}

definition is_metric_space :: "i \<Rightarrow> o" where [rewrite]:
  "is_metric_space(X) \<longleftrightarrow>
    is_metric_space_raw(X) \<and>
    (\<forall>x\<in>.X. \<forall>y\<in>.X. dist(X,x,y) = 0\<^sub>\<real> \<longleftrightarrow> x = y) \<and>
    (\<forall>x\<in>.X. \<forall>y\<in>.X. dist(X,x,y) = dist(X,y,x)) \<and>
    (\<forall>x\<in>.X. \<forall>y\<in>.X. \<forall>z\<in>.X. dist(X,x,y) +\<^sub>\<real> dist(X,y,z) \<ge>\<^sub>\<real> dist(X,x,z))"

lemma is_metric_spaceD [forward]:
  "is_metric_space(X) \<Longrightarrow> is_metric_space_raw(X)" by auto2

lemma is_metric_spaceD1 [forward]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> dist(X,x,y) = 0\<^sub>\<real> \<Longrightarrow> x = y"
@proof @have "dist(X,x,y) = 0\<^sub>\<real> \<longleftrightarrow> x = y" @qed

lemma is_metric_spaceD2 [rewrite]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> dist(X,x,x) = 0\<^sub>\<real>"
@proof @have "dist(X,x,x) = 0\<^sub>\<real> \<longleftrightarrow> x = x" @qed

lemma is_metric_spaceD3 [rewrite]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> dist(X,x,y) = dist(X,y,x)" by auto2

lemma is_metric_spaceD4 [backward]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> z \<in>. X \<Longrightarrow>
   dist(X,x,y) +\<^sub>\<real> dist(X,y,z) \<ge>\<^sub>\<real> dist(X,x,z)" by auto2

lemma is_metric_spaceD5:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> dist(X,x,y) \<ge>\<^sub>\<real> 0\<^sub>\<real>"
@proof
  @have "dist(X,x,y) +\<^sub>\<real> dist(X,y,x) \<ge>\<^sub>\<real> 0\<^sub>\<real>" @with @have "dist(X,x,x) = 0\<^sub>\<real>" @end
  @case "dist(X,x,y) <\<^sub>\<real> 0\<^sub>\<real>" @with @have "dist(X,y,x) <\<^sub>\<real> 0\<^sub>\<real>" @end
@qed
setup {* add_forward_prfstep_cond @{thm is_metric_spaceD5} [with_term "dist(?X,?x,?y)"] *}
setup {* del_prfstep_thm_str "@eqforward" @{thm is_metric_space_def} *}

lemma metric_space_dist_bound [backward1, backward2]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> z \<in>. X \<Longrightarrow>
   dist(X,x,y) <\<^sub>\<real> s \<Longrightarrow> dist(X,y,z) <\<^sub>\<real> t \<Longrightarrow> dist(X,x,z) <\<^sub>\<real> s +\<^sub>\<real> t"
@proof @have "dist(X,x,z) \<le>\<^sub>\<real> dist(X,x,y) +\<^sub>\<real> dist(X,y,z)" @qed

definition open_ball :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "open_ball(X,x,a) = {y\<in>.X. dist(X,x,y) <\<^sub>\<real> a}"
setup {* register_wellform_data ("open_ball(X,x,a)", ["x \<in>. X", "a \<in>. \<real>"]) *}

lemma open_ballD [forward]: "y \<in> open_ball(X,x,a) \<Longrightarrow> dist(X,x,y) <\<^sub>\<real> a" by auto2
lemma open_ballI [typing2]: "y \<in>. X \<Longrightarrow> dist(X,x,y) <\<^sub>\<real> a \<Longrightarrow> y \<in> open_ball(X,x,a)" by auto2
lemma open_ball_sub_carrier: "open_ball(X,x,a) \<subseteq> carrier(X)" by auto2
setup {* add_forward_prfstep_cond @{thm open_ball_sub_carrier} [with_term "open_ball(?X,?x,?a)"] *}
lemma open_ball_mem_self [backward]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> a >\<^sub>\<real> 0\<^sub>\<real> \<Longrightarrow> x \<in> open_ball(X,x,a)" by auto2
lemma open_ball_eq [rewrite]:
  "carrier(X) = carrier(Y) \<Longrightarrow> metric_fun(X) = metric_fun(Y) \<Longrightarrow>
   open_ball(X,x,a) = open_ball(Y,x,a)" by auto2
setup {* del_prfstep_thm @{thm open_ball_def} *}

(* Subset relation on open balls *)
lemma open_ball_subset [backward]:
  "is_metric_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> y \<in>. X \<Longrightarrow> a +\<^sub>\<real> dist(X,x,y) \<le>\<^sub>\<real> b \<Longrightarrow> open_ball(X,x,a) \<subseteq> open_ball(X,y,b)"
@proof
  @have "\<forall>z\<in>open_ball(X,x,a). z \<in> open_ball(X,y,b)" @with
    @have "dist(X,y,z) \<le>\<^sub>\<real> dist(X,y,x) +\<^sub>\<real> dist(X,x,z)"
    @have "dist(X,y,z) <\<^sub>\<real> a +\<^sub>\<real> dist(X,y,x)" @end
@qed

section \<open>Metric topology\<close>

definition metric_basis :: "i \<Rightarrow> i" where [rewrite]:
  "metric_basis(X) = (\<Union>x\<in>.X. \<Union>a\<in>.\<real>. {open_ball(X,x,a)})"

lemma metric_basisE [backward]:
  "U \<in> metric_basis(X) \<Longrightarrow> \<exists>x\<in>.X. \<exists>a\<in>.\<real>. U = open_ball(X,x,a)" by auto2

lemma metric_basisI [resolve]:
  "x \<in>. X \<Longrightarrow> a \<in>. \<real> \<Longrightarrow> open_ball(X,x,a) \<in> metric_basis(X)" by auto2

lemma metric_basis_eq [rewrite]:
  "carrier(X) = carrier(Y) \<Longrightarrow> metric_fun(X) = metric_fun(Y) \<Longrightarrow>
   metric_basis(X) = metric_basis(Y)" by auto2

lemma metric_basis_union [rewrite]:
  "is_metric_space(X) \<Longrightarrow> \<Union>metric_basis(X) = carrier(X)"
@proof
  @have "\<forall>x\<in>.X. x \<in> \<Union>metric_basis(X)" @with
    @have "x \<in> open_ball(X,x,1\<^sub>\<real>)" @end
@qed
setup {* del_prfstep_thm @{thm metric_basis_def} *}

lemma metric_basis_is_basis [forward]:
  "is_metric_space(X) \<Longrightarrow> collection_is_basis(metric_basis(X))"
@proof
  @let "B = metric_basis(X)"
  @have "\<forall>U\<in>B. \<forall>V\<in>B. \<forall>w\<in>U\<inter>V. \<exists>W\<in>B. w\<in>W \<and> W\<subseteq>U\<inter>V" @with
    @obtain "x\<in>.X" "a\<in>.\<real>" where "U = open_ball(X,x,a)"
    @obtain "y\<in>.X" "b\<in>.\<real>" where "V = open_ball(X,y,b)"
    @have "dist(X,w,x) <\<^sub>\<real> a"
    @have "dist(X,w,y) <\<^sub>\<real> b"
    @let "c = min(\<real>, a -\<^sub>\<real> dist(X,w,x), b -\<^sub>\<real> dist(X,w,y))"
    @have "c >\<^sub>\<real> 0\<^sub>\<real>" @with @have "a -\<^sub>\<real> dist(X,w,x) >\<^sub>\<real> 0\<^sub>\<real>" @end
    @let "W = open_ball(X,w,c)"
    @have "w \<in> W"
    @have "W \<subseteq> U" @with @have "c \<le>\<^sub>\<real> a -\<^sub>\<real> dist(X,w,x)" @end
    @have "W \<subseteq> V" @with @have "c \<le>\<^sub>\<real> b -\<^sub>\<real> dist(X,w,y)" @end
  @end
@qed

definition metric_top_space :: "i \<Rightarrow> i" where [rewrite]:
  "metric_top_space(X) = Struct({\<langle>carrier_name,carrier(X)\<rangle>,
    \<langle>open_sets_name,top_from_basis(metric_basis(X))\<rangle>, \<langle>metric_fun_name,metric_fun(X)\<rangle>})"

lemma metric_top_spaceD [rewrite]:
  "carrier(metric_top_space(X)) = carrier(X)"
  "open_sets(metric_top_space(X)) = top_from_basis(metric_basis(X))"
  "metric_fun(metric_top_space(X)) = metric_fun(X)"
  "A = metric_top_space(X) \<Longrightarrow> x \<in>. A \<Longrightarrow> y \<in>. A \<Longrightarrow> dist(A,x,y) = dist(X,x,y)" by auto2+
setup {* del_prfstep_thm @{thm metric_top_space_def} *}

lemma metric_top_space_is_metric [forward]:
  "is_metric_space(A) \<Longrightarrow> is_metric_space(metric_top_space(A))" by auto2

lemma metric_top_space_is_topology [forward]:
  "is_metric_space(A) \<Longrightarrow> is_top_space(metric_top_space(A))"
@proof
  @let "B = metric_basis(A)" "X = metric_top_space(A)"
  @have "collection_is_basis(B)"
  @have "open_sets(X) = top_from_basis(B)"
  @have "top_has_basis(X,B)"
@qed

definition is_metric_top_space :: "i \<Rightarrow> o" where [rewrite]:
  "is_metric_top_space(X) \<longleftrightarrow> (is_metric_space(X) \<and> is_top_space(X) \<and>
    open_sets(X) = top_from_basis(metric_basis(X)))"

lemma metric_top_space_is_metric_top [forward]:
  "is_metric_space(A) \<Longrightarrow> is_metric_top_space(metric_top_space(A))"
@proof @have "carrier(A) = carrier(metric_top_space(A))" @qed

lemma metric_top_space_open:
  "is_metric_top_space(X) \<Longrightarrow> U \<subseteq> carrier(X) \<Longrightarrow>
   is_open(X,U) \<longleftrightarrow> (\<forall>x\<in>U. \<exists>a>\<^sub>\<real>0\<^sub>\<real>. open_ball(X,x,a) \<subseteq> U)"
@proof
  @have "top_has_basis(X,metric_basis(X))"
  @case "is_open(X,U)" @with
    @have "\<forall>x\<in>U. \<exists>a>\<^sub>\<real>0\<^sub>\<real>. open_ball(X,x,a) \<subseteq> U" @with
      @obtain "B\<in>metric_basis(X)" where "x \<in> B" "B \<subseteq> U"
      @obtain "y\<in>.X" "a\<in>.\<real>" where "B = open_ball(X,y,a)"
      @have "dist(X,x,y) <\<^sub>\<real> a"
      @have "open_ball(X,x,a -\<^sub>\<real> dist(X,x,y)) \<subseteq> open_ball(X,y,a)"
    @end
  @end
@qed

end


(*  Title:      HOL/Archimedean_Field.thy
    Author:     Brian Huffman
*)

section \<open>Archimedean Fields, Floor and Ceiling Functions\<close>

theory Archimedean_Field
imports Main
begin

lemma cInf_abs_ge:
  fixes S :: "'a::{linordered_idom,conditionally_complete_linorder} set"
  assumes "S \<noteq> {}"
    and bdd: "\<And>x. x\<in>S \<Longrightarrow> \<bar>x\<bar> \<le> a"
  shows "\<bar>Inf S\<bar> \<le> a"
proof -
  have "Sup (uminus ` S) = - (Inf S)"
  proof (rule antisym)
    show "- (Inf S) \<le> Sup (uminus ` S)"
      apply (subst minus_le_iff)
      apply (rule cInf_greatest [OF \<open>S \<noteq> {}\<close>])
      apply (subst minus_le_iff)
      apply (rule cSup_upper)
       apply force
      using bdd
      apply (force simp: abs_le_iff bdd_above_def)
      done
  next
    have *: "\<And>x. x \<in> S \<Longrightarrow> Inf S \<le> x"
      by (meson abs_le_iff bdd bdd_below_def cInf_lower minus_le_iff)
    show "Sup (uminus ` S) \<le> - Inf S"
      using \<open>S \<noteq> {}\<close> by (force intro: * cSup_least)
  qed
  with cSup_abs_le [of "uminus ` S"] assms show ?thesis
    by fastforce
qed

lemma cSup_asclose:
  fixes S :: "'a::{linordered_idom,conditionally_complete_linorder} set"
  assumes S: "S \<noteq> {}"
    and b: "\<forall>x\<in>S. \<bar>x - l\<bar> \<le> e"
  shows "\<bar>Sup S - l\<bar> \<le> e"
proof -
  have *: "\<bar>x - l\<bar> \<le> e \<longleftrightarrow> l - e \<le> x \<and> x \<le> l + e" for x l e :: 'a
    by arith
  have "bdd_above S"
    using b by (auto intro!: bdd_aboveI[of _ "l + e"])
  with S b show ?thesis
    unfolding * by (auto intro!: cSup_upper2 cSup_least)
qed

lemma cInf_asclose:
  fixes S :: "'a::{linordered_idom,conditionally_complete_linorder} set"
  assumes S: "S \<noteq> {}"
    and b: "\<forall>x\<in>S. \<bar>x - l\<bar> \<le> e"
  shows "\<bar>Inf S - l\<bar> \<le> e"
proof -
  have *: "\<bar>x - l\<bar> \<le> e \<longleftrightarrow> l - e \<le> x \<and> x \<le> l + e" for x l e :: 'a
    by arith
  have "bdd_below S"
    using b by (auto intro!: bdd_belowI[of _ "l - e"])
  with S b show ?thesis
    unfolding * by (auto intro!: cInf_lower2 cInf_greatest)
qed

subsection \<open>Class of Archimedean fields\<close>

text \<open>Archimedean fields have no infinite elements.\<close>

class archimedean_field = linordered_field +
  assumes ex_le_of_int: "\<exists>z. x \<le> of_int z"

lemma ex_less_of_int: "\<exists>z. x < of_int z"
  for x :: "'a::archimedean_field"
proof -
  from ex_le_of_int obtain z where "x \<le> of_int z" ..
  then have "x < of_int (z + 1)" by simp
  then show ?thesis ..
qed

lemma ex_of_int_less: "\<exists>z. of_int z < x"
  for x :: "'a::archimedean_field"
proof -
  from ex_less_of_int obtain z where "- x < of_int z" ..
  then have "of_int (- z) < x" by simp
  then show ?thesis ..
qed

lemma reals_Archimedean2: "\<exists>n. x < of_nat n"
  for x :: "'a::archimedean_field"
proof -
  obtain z where "x < of_int z"
    using ex_less_of_int ..
  also have "\<dots> \<le> of_int (int (nat z))"
    by simp
  also have "\<dots> = of_nat (nat z)"
    by (simp only: of_int_of_nat_eq)
  finally show ?thesis ..
qed

lemma real_arch_simple: "\<exists>n. x \<le> of_nat n"
  for x :: "'a::archimedean_field"
proof -
  obtain n where "x < of_nat n"
    using reals_Archimedean2 ..
  then have "x \<le> of_nat n"
    by simp
  then show ?thesis ..
qed

text \<open>Archimedean fields have no infinitesimal elements.\<close>

lemma reals_Archimedean:
  fixes x :: "'a::archimedean_field"
  assumes "0 < x"
  shows "\<exists>n. inverse (of_nat (Suc n)) < x"
proof -
  from \<open>0 < x\<close> have "0 < inverse x"
    by (rule positive_imp_inverse_positive)
  obtain n where "inverse x < of_nat n"
    using reals_Archimedean2 ..
  then obtain m where "inverse x < of_nat (Suc m)"
    using \<open>0 < inverse x\<close> by (cases n) (simp_all del: of_nat_Suc)
  then have "inverse (of_nat (Suc m)) < inverse (inverse x)"
    using \<open>0 < inverse x\<close> by (rule less_imp_inverse_less)
  then have "inverse (of_nat (Suc m)) < x"
    using \<open>0 < x\<close> by (simp add: nonzero_inverse_inverse_eq)
  then show ?thesis ..
qed

lemma ex_inverse_of_nat_less:
  fixes x :: "'a::archimedean_field"
  assumes "0 < x"
  shows "\<exists>n>0. inverse (of_nat n) < x"
  using reals_Archimedean [OF \<open>0 < x\<close>] by auto

lemma ex_less_of_nat_mult:
  fixes x :: "'a::archimedean_field"
  assumes "0 < x"
  shows "\<exists>n. y < of_nat n * x"
proof -
  obtain n where "y / x < of_nat n"
    using reals_Archimedean2 ..
  with \<open>0 < x\<close> have "y < of_nat n * x"
    by (simp add: pos_divide_less_eq)
  then show ?thesis ..
qed

subsection \<open>Existence and uniqueness of floor function\<close>

lemma exists_least_lemma:
  assumes "\<not> P 0" and "\<exists>n. P n"
  shows "\<exists>n. \<not> P n \<and> P (Suc n)"
proof -
  from \<open>\<exists>n. P n\<close> have "P (Least P)"
    by (rule LeastI_ex)
  with \<open>\<not> P 0\<close> obtain n where "Least P = Suc n"
    by (cases "Least P") auto
  then have "n < Least P"
    by simp
  then have "\<not> P n"
    by (rule not_less_Least)
  then have "\<not> P n \<and> P (Suc n)"
    using \<open>P (Least P)\<close> \<open>Least P = Suc n\<close> by simp
  then show ?thesis ..
qed

lemma floor_exists:
  fixes x :: "'a::archimedean_field"
  shows "\<exists>z. of_int z \<le> x \<and> x < of_int (z + 1)"
proof (cases "0 \<le> x")
  case True
  then have "\<not> x < of_nat 0"
    by simp
  then have "\<exists>n. \<not> x < of_nat n \<and> x < of_nat (Suc n)"
    using reals_Archimedean2 by (rule exists_least_lemma)
  then obtain n where "\<not> x < of_nat n \<and> x < of_nat (Suc n)" ..
  then have "of_int (int n) \<le> x \<and> x < of_int (int n + 1)"
    by simp
  then show ?thesis ..
next
  case False
  then have "\<not> - x \<le> of_nat 0"
    by simp
  then have "\<exists>n. \<not> - x \<le> of_nat n \<and> - x \<le> of_nat (Suc n)"
    using real_arch_simple by (rule exists_least_lemma)
  then obtain n where "\<not> - x \<le> of_nat n \<and> - x \<le> of_nat (Suc n)" ..
  then have "of_int (- int n - 1) \<le> x \<and> x < of_int (- int n - 1 + 1)"
    by simp
  then show ?thesis ..
qed

lemma floor_exists1: "\<exists>!z. of_int z \<le> x \<and> x < of_int (z + 1)"
  for x :: "'a::archimedean_field"
proof (rule ex_ex1I)
  show "\<exists>z. of_int z \<le> x \<and> x < of_int (z + 1)"
    by (rule floor_exists)
next
  fix y z
  assume "of_int y \<le> x \<and> x < of_int (y + 1)"
    and "of_int z \<le> x \<and> x < of_int (z + 1)"
  with le_less_trans [of "of_int y" "x" "of_int (z + 1)"]
       le_less_trans [of "of_int z" "x" "of_int (y + 1)"] show "y = z"
    by (simp del: of_int_add)
qed

subsection \<open>Floor function\<close>

class floor_ceiling = archimedean_field +
  fixes floor :: "'a \<Rightarrow> int"  ("\<lfloor>_\<rfloor>")
  assumes floor_correct: "of_int \<lfloor>x\<rfloor> \<le> x \<and> x < of_int (\<lfloor>x\<rfloor> + 1)"

lemma floor_unique: "of_int z \<le> x \<Longrightarrow> x < of_int z + 1 \<Longrightarrow> \<lfloor>x\<rfloor> = z"
  using floor_correct [of x] floor_exists1 [of x] by auto

lemma floor_eq_iff: "\<lfloor>x\<rfloor> = a \<longleftrightarrow> of_int a \<le> x \<and> x < of_int a + 1"
using floor_correct floor_unique by auto

lemma of_int_floor_le [simp]: "of_int \<lfloor>x\<rfloor> \<le> x"
  using floor_correct ..

lemma le_floor_iff: "z \<le> \<lfloor>x\<rfloor> \<longleftrightarrow> of_int z \<le> x"
proof
  assume "z \<le> \<lfloor>x\<rfloor>"
  then have "(of_int z :: 'a) \<le> of_int \<lfloor>x\<rfloor>" by simp
  also have "of_int \<lfloor>x\<rfloor> \<le> x" by (rule of_int_floor_le)
  finally show "of_int z \<le> x" .
next
  assume "of_int z \<le> x"
  also have "x < of_int (\<lfloor>x\<rfloor> + 1)" using floor_correct ..
  finally show "z \<le> \<lfloor>x\<rfloor>" by (simp del: of_int_add)
qed

lemma floor_less_iff: "\<lfloor>x\<rfloor> < z \<longleftrightarrow> x < of_int z"
  by (simp add: not_le [symmetric] le_floor_iff)

lemma less_floor_iff: "z < \<lfloor>x\<rfloor> \<longleftrightarrow> of_int z + 1 \<le> x"
  using le_floor_iff [of "z + 1" x] by auto

lemma floor_le_iff: "\<lfloor>x\<rfloor> \<le> z \<longleftrightarrow> x < of_int z + 1"
  by (simp add: not_less [symmetric] less_floor_iff)

lemma floor_split[linarith_split]: "P \<lfloor>t\<rfloor> \<longleftrightarrow> (\<forall>i. of_int i \<le> t \<and> t < of_int i + 1 \<longrightarrow> P i)"
  by (metis floor_correct floor_unique less_floor_iff not_le order_refl)

lemma floor_mono:
  assumes "x \<le> y"
  shows "\<lfloor>x\<rfloor> \<le> \<lfloor>y\<rfloor>"
proof -
  have "of_int \<lfloor>x\<rfloor> \<le> x" by (rule of_int_floor_le)
  also note \<open>x \<le> y\<close>
  finally show ?thesis by (simp add: le_floor_iff)
qed

lemma floor_less_cancel: "\<lfloor>x\<rfloor> < \<lfloor>y\<rfloor> \<Longrightarrow> x < y"
  by (auto simp add: not_le [symmetric] floor_mono)

lemma floor_of_int [simp]: "\<lfloor>of_int z\<rfloor> = z"
  by (rule floor_unique) simp_all

lemma floor_of_nat [simp]: "\<lfloor>of_nat n\<rfloor> = int n"
  using floor_of_int [of "of_nat n"] by simp

lemma le_floor_add: "\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor> \<le> \<lfloor>x + y\<rfloor>"
  by (simp only: le_floor_iff of_int_add add_mono of_int_floor_le)

text \<open>Floor with numerals.\<close>

lemma floor_zero [simp]: "\<lfloor>0\<rfloor> = 0"
  using floor_of_int [of 0] by simp

lemma floor_one [simp]: "\<lfloor>1\<rfloor> = 1"
  using floor_of_int [of 1] by simp

lemma floor_numeral [simp]: "\<lfloor>numeral v\<rfloor> = numeral v"
  using floor_of_int [of "numeral v"] by simp

lemma floor_neg_numeral [simp]: "\<lfloor>- numeral v\<rfloor> = - numeral v"
  using floor_of_int [of "- numeral v"] by simp

lemma zero_le_floor [simp]: "0 \<le> \<lfloor>x\<rfloor> \<longleftrightarrow> 0 \<le> x"
  by (simp add: le_floor_iff)

lemma one_le_floor [simp]: "1 \<le> \<lfloor>x\<rfloor> \<longleftrightarrow> 1 \<le> x"
  by (simp add: le_floor_iff)

lemma numeral_le_floor [simp]: "numeral v \<le> \<lfloor>x\<rfloor> \<longleftrightarrow> numeral v \<le> x"
  by (simp add: le_floor_iff)

lemma neg_numeral_le_floor [simp]: "- numeral v \<le> \<lfloor>x\<rfloor> \<longleftrightarrow> - numeral v \<le> x"
  by (simp add: le_floor_iff)

lemma zero_less_floor [simp]: "0 < \<lfloor>x\<rfloor> \<longleftrightarrow> 1 \<le> x"
  by (simp add: less_floor_iff)

lemma one_less_floor [simp]: "1 < \<lfloor>x\<rfloor> \<longleftrightarrow> 2 \<le> x"
  by (simp add: less_floor_iff)

lemma numeral_less_floor [simp]: "numeral v < \<lfloor>x\<rfloor> \<longleftrightarrow> numeral v + 1 \<le> x"
  by (simp add: less_floor_iff)

lemma neg_numeral_less_floor [simp]: "- numeral v < \<lfloor>x\<rfloor> \<longleftrightarrow> - numeral v + 1 \<le> x"
  by (simp add: less_floor_iff)

lemma floor_le_zero [simp]: "\<lfloor>x\<rfloor> \<le> 0 \<longleftrightarrow> x < 1"
  by (simp add: floor_le_iff)

lemma floor_le_one [simp]: "\<lfloor>x\<rfloor> \<le> 1 \<longleftrightarrow> x < 2"
  by (simp add: floor_le_iff)

lemma floor_le_numeral [simp]: "\<lfloor>x\<rfloor> \<le> numeral v \<longleftrightarrow> x < numeral v + 1"
  by (simp add: floor_le_iff)

lemma floor_le_neg_numeral [simp]: "\<lfloor>x\<rfloor> \<le> - numeral v \<longleftrightarrow> x < - numeral v + 1"
  by (simp add: floor_le_iff)

lemma floor_less_zero [simp]: "\<lfloor>x\<rfloor> < 0 \<longleftrightarrow> x < 0"
  by (simp add: floor_less_iff)

lemma floor_less_one [simp]: "\<lfloor>x\<rfloor> < 1 \<longleftrightarrow> x < 1"
  by (simp add: floor_less_iff)

lemma floor_less_numeral [simp]: "\<lfloor>x\<rfloor> < numeral v \<longleftrightarrow> x < numeral v"
  by (simp add: floor_less_iff)

lemma floor_less_neg_numeral [simp]: "\<lfloor>x\<rfloor> < - numeral v \<longleftrightarrow> x < - numeral v"
  by (simp add: floor_less_iff)

lemma le_mult_floor_Ints:
  assumes "0 \<le> a" "a \<in> Ints"
  shows "of_int (\<lfloor>a\<rfloor> * \<lfloor>b\<rfloor>) \<le> (of_int\<lfloor>a * b\<rfloor> :: 'a :: linordered_idom)"
  by (metis Ints_cases assms floor_less_iff floor_of_int linorder_not_less mult_left_mono of_int_floor_le of_int_less_iff of_int_mult)

text \<open>Addition and subtraction of integers.\<close>

lemma floor_add_int: "\<lfloor>x\<rfloor> + z = \<lfloor>x + of_int z\<rfloor>"
  using floor_correct [of x] by (simp add: floor_unique[symmetric])

lemma int_add_floor: "z + \<lfloor>x\<rfloor> = \<lfloor>of_int z + x\<rfloor>"
  using floor_correct [of x] by (simp add: floor_unique[symmetric])

lemma one_add_floor: "\<lfloor>x\<rfloor> + 1 = \<lfloor>x + 1\<rfloor>"
  using floor_add_int [of x 1] by simp

lemma floor_diff_of_int [simp]: "\<lfloor>x - of_int z\<rfloor> = \<lfloor>x\<rfloor> - z"
  using floor_add_int [of x "- z"] by (simp add: algebra_simps)

lemma floor_uminus_of_int [simp]: "\<lfloor>- (of_int z)\<rfloor> = - z"
  by (metis floor_diff_of_int [of 0] diff_0 floor_zero)

lemma floor_diff_numeral [simp]: "\<lfloor>x - numeral v\<rfloor> = \<lfloor>x\<rfloor> - numeral v"
  using floor_diff_of_int [of x "numeral v"] by simp

lemma floor_diff_one [simp]: "\<lfloor>x - 1\<rfloor> = \<lfloor>x\<rfloor> - 1"
  using floor_diff_of_int [of x 1] by simp

lemma le_mult_floor:
  assumes "0 \<le> a" and "0 \<le> b"
  shows "\<lfloor>a\<rfloor> * \<lfloor>b\<rfloor> \<le> \<lfloor>a * b\<rfloor>"
proof -
  have "of_int \<lfloor>a\<rfloor> \<le> a" and "of_int \<lfloor>b\<rfloor> \<le> b"
    by (auto intro: of_int_floor_le)
  then have "of_int (\<lfloor>a\<rfloor> * \<lfloor>b\<rfloor>) \<le> a * b"
    using assms by (auto intro!: mult_mono)
  also have "a * b < of_int (\<lfloor>a * b\<rfloor> + 1)"
    using floor_correct[of "a * b"] by auto
  finally show ?thesis
    unfolding of_int_less_iff by simp
qed

lemma floor_divide_of_int_eq: "\<lfloor>of_int k / of_int l\<rfloor> = k div l"
  for k l :: int
proof (cases "l = 0")
  case True
  then show ?thesis by simp
next
  case False
  have *: "\<lfloor>of_int (k mod l) / of_int l :: 'a\<rfloor> = 0"
  proof (cases "l > 0")
    case True
    then show ?thesis
      by (auto intro: floor_unique)
  next
    case False
    obtain r where "r = - l"
      by blast
    then have l: "l = - r"
      by simp
    with \<open>l \<noteq> 0\<close> False have "r > 0"
      by simp
    with l show ?thesis
      using pos_mod_bound [of r]
      by (auto simp add: zmod_zminus2_eq_if less_le field_simps intro: floor_unique)
  qed
  have "(of_int k :: 'a) = of_int (k div l * l + k mod l)"
    by simp
  also have "\<dots> = (of_int (k div l) + of_int (k mod l) / of_int l) * of_int l"
    using False by (simp only: of_int_add) (simp add: field_simps)
  finally have "(of_int k / of_int l :: 'a) = \<dots> / of_int l"
    by simp
  then have "(of_int k / of_int l :: 'a) = of_int (k div l) + of_int (k mod l) / of_int l"
    using False by (simp only:) (simp add: field_simps)
  then have "\<lfloor>of_int k / of_int l :: 'a\<rfloor> = \<lfloor>of_int (k div l) + of_int (k mod l) / of_int l :: 'a\<rfloor>"
    by simp
  then have "\<lfloor>of_int k / of_int l :: 'a\<rfloor> = \<lfloor>of_int (k mod l) / of_int l + of_int (k div l) :: 'a\<rfloor>"
    by (simp add: ac_simps)
  then have "\<lfloor>of_int k / of_int l :: 'a\<rfloor> = \<lfloor>of_int (k mod l) / of_int l :: 'a\<rfloor> + k div l"
    by (simp add: floor_add_int)
  with * show ?thesis
    by simp
qed

lemma floor_divide_of_nat_eq: "\<lfloor>of_nat m / of_nat n\<rfloor> = of_nat (m div n)"
  for m n :: nat
    by (metis floor_divide_of_int_eq of_int_of_nat_eq unique_euclidean_semiring_with_nat_class.of_nat_div)

lemma floor_divide_lower:
  fixes q :: "'a::floor_ceiling"
  shows "q > 0 \<Longrightarrow> of_int \<lfloor>p / q\<rfloor> * q \<le> p"
  using of_int_floor_le pos_le_divide_eq by blast

lemma floor_divide_upper:
  fixes q :: "'a::floor_ceiling"
  shows "q > 0 \<Longrightarrow> p < (of_int \<lfloor>p / q\<rfloor> + 1) * q"
  by (meson floor_eq_iff pos_divide_less_eq)

subsection \<open>Ceiling function\<close>

definition ceiling :: "'a::floor_ceiling \<Rightarrow> int"  ("\<lceil>_\<rceil>")
  where "\<lceil>x\<rceil> = - \<lfloor>- x\<rfloor>"

lemma ceiling_correct: "of_int \<lceil>x\<rceil> - 1 < x \<and> x \<le> of_int \<lceil>x\<rceil>"
  unfolding ceiling_def using floor_correct [of "- x"]
  by (simp add: le_minus_iff)

lemma ceiling_unique: "of_int z - 1 < x \<Longrightarrow> x \<le> of_int z \<Longrightarrow> \<lceil>x\<rceil> = z"
  unfolding ceiling_def using floor_unique [of "- z" "- x"] by simp

lemma ceiling_eq_iff: "\<lceil>x\<rceil> = a \<longleftrightarrow> of_int a - 1 < x \<and> x \<le> of_int a"
using ceiling_correct ceiling_unique by auto

lemma le_of_int_ceiling [simp]: "x \<le> of_int \<lceil>x\<rceil>"
  using ceiling_correct ..

lemma ceiling_le_iff: "\<lceil>x\<rceil> \<le> z \<longleftrightarrow> x \<le> of_int z"
  unfolding ceiling_def using le_floor_iff [of "- z" "- x"] by auto

lemma less_ceiling_iff: "z < \<lceil>x\<rceil> \<longleftrightarrow> of_int z < x"
  by (simp add: not_le [symmetric] ceiling_le_iff)

lemma ceiling_less_iff: "\<lceil>x\<rceil> < z \<longleftrightarrow> x \<le> of_int z - 1"
  using ceiling_le_iff [of x "z - 1"] by simp

lemma le_ceiling_iff: "z \<le> \<lceil>x\<rceil> \<longleftrightarrow> of_int z - 1 < x"
  by (simp add: not_less [symmetric] ceiling_less_iff)

lemma ceiling_mono: "x \<ge> y \<Longrightarrow> \<lceil>x\<rceil> \<ge> \<lceil>y\<rceil>"
  unfolding ceiling_def by (simp add: floor_mono)

lemma ceiling_less_cancel: "\<lceil>x\<rceil> < \<lceil>y\<rceil> \<Longrightarrow> x < y"
  by (auto simp add: not_le [symmetric] ceiling_mono)

lemma ceiling_of_int [simp]: "\<lceil>of_int z\<rceil> = z"
  by (rule ceiling_unique) simp_all

lemma ceiling_of_nat [simp]: "\<lceil>of_nat n\<rceil> = int n"
  using ceiling_of_int [of "of_nat n"] by simp

lemma ceiling_add_le: "\<lceil>x + y\<rceil> \<le> \<lceil>x\<rceil> + \<lceil>y\<rceil>"
  by (simp only: ceiling_le_iff of_int_add add_mono le_of_int_ceiling)

lemma mult_ceiling_le:
  assumes "0 \<le> a" and "0 \<le> b"
  shows "\<lceil>a * b\<rceil> \<le> \<lceil>a\<rceil> * \<lceil>b\<rceil>"
  by (metis assms ceiling_le_iff ceiling_mono le_of_int_ceiling mult_mono of_int_mult)

lemma mult_ceiling_le_Ints:
  assumes "0 \<le> a" "a \<in> Ints"
  shows "(of_int \<lceil>a * b\<rceil> :: 'a :: linordered_idom) \<le> of_int(\<lceil>a\<rceil> * \<lceil>b\<rceil>)"
  by (metis Ints_cases assms ceiling_le_iff ceiling_of_int le_of_int_ceiling mult_left_mono of_int_le_iff of_int_mult)

lemma finite_int_segment:
  fixes a :: "'a::floor_ceiling"
  shows "finite {x \<in> \<int>. a \<le> x \<and> x \<le> b}"
proof -
  have "finite {ceiling a..floor b}"
    by simp
  moreover have "{x \<in> \<int>. a \<le> x \<and> x \<le> b} = of_int ` {ceiling a..floor b}"
    by (auto simp: le_floor_iff ceiling_le_iff elim!: Ints_cases)
  ultimately show ?thesis
    by simp
qed

corollary finite_abs_int_segment:
  fixes a :: "'a::floor_ceiling"
  shows "finite {k \<in> \<int>. \<bar>k\<bar> \<le> a}"
  using finite_int_segment [of "-a" a] by (auto simp add: abs_le_iff conj_commute minus_le_iff)

subsubsection \<open>Ceiling with numerals.\<close>

lemma ceiling_zero [simp]: "\<lceil>0\<rceil> = 0"
  using ceiling_of_int [of 0] by simp

lemma ceiling_one [simp]: "\<lceil>1\<rceil> = 1"
  using ceiling_of_int [of 1] by simp

lemma ceiling_numeral [simp]: "\<lceil>numeral v\<rceil> = numeral v"
  using ceiling_of_int [of "numeral v"] by simp

lemma ceiling_neg_numeral [simp]: "\<lceil>- numeral v\<rceil> = - numeral v"
  using ceiling_of_int [of "- numeral v"] by simp

lemma ceiling_le_zero [simp]: "\<lceil>x\<rceil> \<le> 0 \<longleftrightarrow> x \<le> 0"
  by (simp add: ceiling_le_iff)

lemma ceiling_le_one [simp]: "\<lceil>x\<rceil> \<le> 1 \<longleftrightarrow> x \<le> 1"
  by (simp add: ceiling_le_iff)

lemma ceiling_le_numeral [simp]: "\<lceil>x\<rceil> \<le> numeral v \<longleftrightarrow> x \<le> numeral v"
  by (simp add: ceiling_le_iff)

lemma ceiling_le_neg_numeral [simp]: "\<lceil>x\<rceil> \<le> - numeral v \<longleftrightarrow> x \<le> - numeral v"
  by (simp add: ceiling_le_iff)

lemma ceiling_less_zero [simp]: "\<lceil>x\<rceil> < 0 \<longleftrightarrow> x \<le> -1"
  by (simp add: ceiling_less_iff)

lemma ceiling_less_one [simp]: "\<lceil>x\<rceil> < 1 \<longleftrightarrow> x \<le> 0"
  by (simp add: ceiling_less_iff)

lemma ceiling_less_numeral [simp]: "\<lceil>x\<rceil> < numeral v \<longleftrightarrow> x \<le> numeral v - 1"
  by (simp add: ceiling_less_iff)

lemma ceiling_less_neg_numeral [simp]: "\<lceil>x\<rceil> < - numeral v \<longleftrightarrow> x \<le> - numeral v - 1"
  by (simp add: ceiling_less_iff)

lemma zero_le_ceiling [simp]: "0 \<le> \<lceil>x\<rceil> \<longleftrightarrow> -1 < x"
  by (simp add: le_ceiling_iff)

lemma one_le_ceiling [simp]: "1 \<le> \<lceil>x\<rceil> \<longleftrightarrow> 0 < x"
  by (simp add: le_ceiling_iff)

lemma numeral_le_ceiling [simp]: "numeral v \<le> \<lceil>x\<rceil> \<longleftrightarrow> numeral v - 1 < x"
  by (simp add: le_ceiling_iff)

lemma neg_numeral_le_ceiling [simp]: "- numeral v \<le> \<lceil>x\<rceil> \<longleftrightarrow> - numeral v - 1 < x"
  by (simp add: le_ceiling_iff)

lemma zero_less_ceiling [simp]: "0 < \<lceil>x\<rceil> \<longleftrightarrow> 0 < x"
  by (simp add: less_ceiling_iff)

lemma one_less_ceiling [simp]: "1 < \<lceil>x\<rceil> \<longleftrightarrow> 1 < x"
  by (simp add: less_ceiling_iff)

lemma numeral_less_ceiling [simp]: "numeral v < \<lceil>x\<rceil> \<longleftrightarrow> numeral v < x"
  by (simp add: less_ceiling_iff)

lemma neg_numeral_less_ceiling [simp]: "- numeral v < \<lceil>x\<rceil> \<longleftrightarrow> - numeral v < x"
  by (simp add: less_ceiling_iff)

lemma ceiling_altdef: "\<lceil>x\<rceil> = (if x = of_int \<lfloor>x\<rfloor> then \<lfloor>x\<rfloor> else \<lfloor>x\<rfloor> + 1)"
  by (intro ceiling_unique; simp, linarith?)

lemma floor_le_ceiling [simp]: "\<lfloor>x\<rfloor> \<le> \<lceil>x\<rceil>"
  by (simp add: ceiling_altdef)

subsubsection \<open>Addition and subtraction of integers.\<close>

lemma ceiling_add_of_int [simp]: "\<lceil>x + of_int z\<rceil> = \<lceil>x\<rceil> + z"
  using ceiling_correct [of x] by (simp add: ceiling_def)

lemma ceiling_add_numeral [simp]: "\<lceil>x + numeral v\<rceil> = \<lceil>x\<rceil> + numeral v"
  using ceiling_add_of_int [of x "numeral v"] by simp

lemma ceiling_add_one [simp]: "\<lceil>x + 1\<rceil> = \<lceil>x\<rceil> + 1"
  using ceiling_add_of_int [of x 1] by simp

lemma ceiling_diff_of_int [simp]: "\<lceil>x - of_int z\<rceil> = \<lceil>x\<rceil> - z"
  using ceiling_add_of_int [of x "- z"] by (simp add: algebra_simps)

lemma ceiling_diff_numeral [simp]: "\<lceil>x - numeral v\<rceil> = \<lceil>x\<rceil> - numeral v"
  using ceiling_diff_of_int [of x "numeral v"] by simp

lemma ceiling_diff_one [simp]: "\<lceil>x - 1\<rceil> = \<lceil>x\<rceil> - 1"
  using ceiling_diff_of_int [of x 1] by simp

lemma ceiling_split[linarith_split]: "P \<lceil>t\<rceil> \<longleftrightarrow> (\<forall>i. of_int i - 1 < t \<and> t \<le> of_int i \<longrightarrow> P i)"
  by (auto simp add: ceiling_unique ceiling_correct)

lemma ceiling_diff_floor_le_1: "\<lceil>x\<rceil> - \<lfloor>x\<rfloor> \<le> 1"
proof -
  have "of_int \<lceil>x\<rceil> - 1 < x"
    using ceiling_correct[of x] by simp
  also have "x < of_int \<lfloor>x\<rfloor> + 1"
    using floor_correct[of x] by simp_all
  finally have "of_int (\<lceil>x\<rceil> - \<lfloor>x\<rfloor>) < (of_int 2::'a)"
    by simp
  then show ?thesis
    unfolding of_int_less_iff by simp
qed

lemma nat_approx_posE:
  fixes e:: "'a::{archimedean_field,floor_ceiling}"
  assumes "0 < e"
  obtains n :: nat where "1 / of_nat(Suc n) < e"
proof
  have "(1::'a) / of_nat (Suc (nat \<lceil>1/e\<rceil>)) < 1 / of_int (\<lceil>1/e\<rceil>)"
  proof (rule divide_strict_left_mono)
    show "(of_int \<lceil>1 / e\<rceil>::'a) < of_nat (Suc (nat \<lceil>1 / e\<rceil>))"
      using assms by (simp add: field_simps)
    show "(0::'a) < of_nat (Suc (nat \<lceil>1 / e\<rceil>)) * of_int \<lceil>1 / e\<rceil>"
      using assms by (auto simp: zero_less_mult_iff pos_add_strict)
  qed auto
  also have "1 / of_int (\<lceil>1/e\<rceil>) \<le> 1 / (1/e)"
    by (rule divide_left_mono) (auto simp: \<open>0 < e\<close> ceiling_correct)
  also have "\<dots> = e" by simp
  finally show  "1 / of_nat (Suc (nat \<lceil>1 / e\<rceil>)) < e"
    by metis
qed

lemma ceiling_divide_upper:
  fixes q :: "'a::floor_ceiling"
  shows "q > 0 \<Longrightarrow> p \<le> of_int (ceiling (p / q)) * q"
  by (meson divide_le_eq le_of_int_ceiling)

lemma ceiling_divide_lower:
  fixes q :: "'a::floor_ceiling"
  shows "q > 0 \<Longrightarrow> (of_int \<lceil>p / q\<rceil> - 1) * q < p"
  by (meson ceiling_eq_iff pos_less_divide_eq)

subsection \<open>Negation\<close>

lemma floor_minus: "\<lfloor>- x\<rfloor> = - \<lceil>x\<rceil>"
  unfolding ceiling_def by simp

lemma ceiling_minus: "\<lceil>- x\<rceil> = - \<lfloor>x\<rfloor>"
  unfolding ceiling_def by simp

subsection \<open>Natural numbers\<close>

lemma of_nat_floor: "r\<ge>0 \<Longrightarrow> of_nat (nat \<lfloor>r\<rfloor>) \<le> r"
  by simp

lemma of_nat_ceiling: "of_nat (nat \<lceil>r\<rceil>) \<ge> r"
  by (cases "r\<ge>0") auto

subsection \<open>Frac Function\<close>

definition frac :: "'a \<Rightarrow> 'a::floor_ceiling"
  where "frac x \<equiv> x - of_int \<lfloor>x\<rfloor>"

lemma frac_lt_1: "frac x < 1"
  by (simp add: frac_def) linarith

lemma frac_eq_0_iff [simp]: "frac x = 0 \<longleftrightarrow> x \<in> \<int>"
  by (simp add: frac_def) (metis Ints_cases Ints_of_int floor_of_int )

lemma frac_ge_0 [simp]: "frac x \<ge> 0"
  unfolding frac_def by linarith

lemma frac_gt_0_iff [simp]: "frac x > 0 \<longleftrightarrow> x \<notin> \<int>"
  by (metis frac_eq_0_iff frac_ge_0 le_less less_irrefl)

lemma frac_of_int [simp]: "frac (of_int z) = 0"
  by (simp add: frac_def)

lemma frac_frac [simp]: "frac (frac x) = frac x"
  by (simp add: frac_def)

lemma floor_add: "\<lfloor>x + y\<rfloor> = (if frac x + frac y < 1 then \<lfloor>x\<rfloor> + \<lfloor>y\<rfloor> else (\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor>) + 1)"
proof -
  have "x + y < 1 + (of_int \<lfloor>x\<rfloor> + of_int \<lfloor>y\<rfloor>) \<Longrightarrow> \<lfloor>x + y\<rfloor> = \<lfloor>x\<rfloor> + \<lfloor>y\<rfloor>"
    by (metis add.commute floor_unique le_floor_add le_floor_iff of_int_add)
  moreover
  have "\<not> x + y < 1 + (of_int \<lfloor>x\<rfloor> + of_int \<lfloor>y\<rfloor>) \<Longrightarrow> \<lfloor>x + y\<rfloor> = 1 + (\<lfloor>x\<rfloor> + \<lfloor>y\<rfloor>)"
    apply (simp add: floor_eq_iff)
    apply (auto simp add: algebra_simps)
    apply linarith
    done
  ultimately show ?thesis by (auto simp add: frac_def algebra_simps)
qed

lemma floor_add2[simp]: "x \<in> \<int> \<or> y \<in> \<int> \<Longrightarrow> \<lfloor>x + y\<rfloor> = \<lfloor>x\<rfloor> + \<lfloor>y\<rfloor>"
by (metis add.commute add.left_neutral frac_lt_1 floor_add frac_eq_0_iff)

lemma frac_add:
  "frac (x + y) = (if frac x + frac y < 1 then frac x + frac y else (frac x + frac y) - 1)"
  by (simp add: frac_def floor_add)

lemma frac_unique_iff: "frac x = a \<longleftrightarrow> x - a \<in> \<int> \<and> 0 \<le> a \<and> a < 1"
  for x :: "'a::floor_ceiling"
  apply (auto simp: Ints_def frac_def algebra_simps floor_unique)
   apply linarith+
  done

lemma frac_eq: "frac x = x \<longleftrightarrow> 0 \<le> x \<and> x < 1"
  by (simp add: frac_unique_iff)

lemma frac_neg: "frac (- x) = (if x \<in> \<int> then 0 else 1 - frac x)"
  for x :: "'a::floor_ceiling"
  apply (auto simp add: frac_unique_iff)
   apply (simp add: frac_def)
  apply (meson frac_lt_1 less_iff_diff_less_0 not_le not_less_iff_gr_or_eq)
  done

lemma frac_in_Ints_iff [simp]: "frac x \<in> \<int> \<longleftrightarrow> x \<in> \<int>"
proof safe
  assume "frac x \<in> \<int>"
  hence "of_int \<lfloor>x\<rfloor> + frac x \<in> \<int>" by auto
  also have "of_int \<lfloor>x\<rfloor> + frac x = x" by (simp add: frac_def)
  finally show "x \<in> \<int>" .
qed (auto simp: frac_def)

lemma frac_1_eq: "frac (x+1) = frac x"
  by (simp add: frac_def)

subsection \<open>Rounding to the nearest integer\<close>

definition round :: "'a::floor_ceiling \<Rightarrow> int"
  where "round x = \<lfloor>x + 1/2\<rfloor>"

lemma of_int_round_ge: "of_int (round x) \<ge> x - 1/2"
  and of_int_round_le: "of_int (round x) \<le> x + 1/2"
  and of_int_round_abs_le: "\<bar>of_int (round x) - x\<bar> \<le> 1/2"
  and of_int_round_gt: "of_int (round x) > x - 1/2"
proof -
  from floor_correct[of "x + 1/2"] have "x + 1/2 < of_int (round x) + 1"
    by (simp add: round_def)
  from add_strict_right_mono[OF this, of "-1"] show A: "of_int (round x) > x - 1/2"
    by simp
  then show "of_int (round x) \<ge> x - 1/2"
    by simp
  from floor_correct[of "x + 1/2"] show "of_int (round x) \<le> x + 1/2"
    by (simp add: round_def)
  with A show "\<bar>of_int (round x) - x\<bar> \<le> 1/2"
    by linarith
qed

lemma round_of_int [simp]: "round (of_int n) = n"
  unfolding round_def by (subst floor_eq_iff) force

lemma round_0 [simp]: "round 0 = 0"
  using round_of_int[of 0] by simp

lemma round_1 [simp]: "round 1 = 1"
  using round_of_int[of 1] by simp

lemma round_numeral [simp]: "round (numeral n) = numeral n"
  using round_of_int[of "numeral n"] by simp

lemma round_neg_numeral [simp]: "round (-numeral n) = -numeral n"
  using round_of_int[of "-numeral n"] by simp

lemma round_of_nat [simp]: "round (of_nat n) = of_nat n"
  using round_of_int[of "int n"] by simp

lemma round_mono: "x \<le> y \<Longrightarrow> round x \<le> round y"
  unfolding round_def by (intro floor_mono) simp

lemma round_unique: "of_int y > x - 1/2 \<Longrightarrow> of_int y \<le> x + 1/2 \<Longrightarrow> round x = y"
  unfolding round_def
proof (rule floor_unique)
  assume "x - 1 / 2 < of_int y"
  from add_strict_left_mono[OF this, of 1] show "x + 1 / 2 < of_int y + 1"
    by simp
qed

lemma round_unique': "\<bar>x - of_int n\<bar> < 1/2 \<Longrightarrow> round x = n"
  by (subst (asm) abs_less_iff, rule round_unique) (simp_all add: field_simps)

lemma round_altdef: "round x = (if frac x \<ge> 1/2 then \<lceil>x\<rceil> else \<lfloor>x\<rfloor>)"
  by (cases "frac x \<ge> 1/2")
    (rule round_unique, ((simp add: frac_def field_simps ceiling_altdef; linarith)+)[2])+

lemma floor_le_round: "\<lfloor>x\<rfloor> \<le> round x"
  unfolding round_def by (intro floor_mono) simp

lemma ceiling_ge_round: "\<lceil>x\<rceil> \<ge> round x"
  unfolding round_altdef by simp

lemma round_diff_minimal: "\<bar>z - of_int (round z)\<bar> \<le> \<bar>z - of_int m\<bar>"
  for z :: "'a::floor_ceiling"
proof (cases "of_int m \<ge> z")
  case True
  then have "\<bar>z - of_int (round z)\<bar> \<le> \<bar>of_int \<lceil>z\<rceil> - z\<bar>"
    unfolding round_altdef by (simp add: field_simps ceiling_altdef frac_def) linarith
  also have "of_int \<lceil>z\<rceil> - z \<ge> 0"
    by linarith
  with True have "\<bar>of_int \<lceil>z\<rceil> - z\<bar> \<le> \<bar>z - of_int m\<bar>"
    by (simp add: ceiling_le_iff)
  finally show ?thesis .
next
  case False
  then have "\<bar>z - of_int (round z)\<bar> \<le> \<bar>of_int \<lfloor>z\<rfloor> - z\<bar>"
    unfolding round_altdef by (simp add: field_simps ceiling_altdef frac_def) linarith
  also have "z - of_int \<lfloor>z\<rfloor> \<ge> 0"
    by linarith
  with False have "\<bar>of_int \<lfloor>z\<rfloor> - z\<bar> \<le> \<bar>z - of_int m\<bar>"
    by (simp add: le_floor_iff)
  finally show ?thesis .
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
Termination for recursive functions.
*)
theory Factorial
imports
  "../../AutoCorres"
  "../../../lib/OptionMonadWP"
begin

(* Parse the input file. *)
install_C_file "factorial.c"

autocorres "factorial.c"

context factorial begin

(* Termination *)
thm factorial'.simps

lemma ovalidNF_grab_asm2:
  "ovalidNF (\<lambda>s. G \<and> P s) f Q \<Longrightarrow> G \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def)

lemma ovalidNF_grab_asm_eq:
  "(G \<longrightarrow> ovalidNF P f Q) = ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (auto simp: ovalidNF_def)

lemma ovalid_post_triv:
  "(\<And>r s. Q r s) \<Longrightarrow> ovalid P f Q"
  by (simp add: ovalid_def)

lemma factorial'_terminates: "no_ofail (\<lambda>_. m > unat n) (factorial' m n)"
proof (induct n arbitrary: m rule: less_induct)
   fix x m
   assume induct_asm0: "(\<And>y m. y < x \<Longrightarrow> no_ofail (\<lambda>_. unat y < m) (factorial' m y))"
   have induct_asm: "(\<And>y m. no_ofail (\<lambda>_. y < x \<and> unat y < m) (factorial' m y))"
     apply (rule no_ofail_grab_asm)
     by (rule induct_asm0)

   show "no_ofail (\<lambda>_. unat x < m) (factorial' m x)"
     apply (subst factorial'.simps)
     apply (wp induct_asm ovalid_post_triv)
     apply unat_arith
    done
qed

lemma factorial'_terminates_old: "m > unat n \<longrightarrow> factorial' m n s \<noteq> None"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, simp add: ocondition_def obind_def split: option.splits)
  apply (metis One_nat_def Suc_eq_plus1 less_diff_conv option.distinct(1) unatSuc)
  done

(* A fun fact *)
function fact :: "('n :: len) word \<Rightarrow> ('n :: len) word" where
  "fact n = (if n = 0 then 1 else n * fact (n - 1))"
  by auto
termination by (metis "termination" in_measure measure_unat wf_measure)
declare fact.simps [simp del]

(* Termination & correctness *)
lemma factorial'_correct: "ovalidNF (\<lambda>_. m > unat n) (factorial' m n) (\<lambda>r _. r = fact n)"
proof (induct n arbitrary: m)
   fix n m
   show "ovalidNF (\<lambda>_. unat 0 < m) (factorial' m 0) (\<lambda>r _. r = fact 0)"
     apply (subst factorial'.simps)
     apply (simp add: ovalidNF_def ocondition_def ofail_def oreturn_def obind_def fact.simps)
     done

   assume induct_asm0: "\<And>m. ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. r = fact n)"
   have induct_asm: "\<And>m. 1 + n \<noteq> 0 \<Longrightarrow> ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. (1 + n) * r = fact (1 + n))"
     apply (subst fact.simps)
     apply simp
     apply (insert induct_asm0)
     apply (unfold ovalidNF_def)
     apply simp
     done

   show "\<lbrakk> 1 + n \<noteq> 0 \<rbrakk>
          \<Longrightarrow> ovalidNF (\<lambda>_. unat (1 + n) < m) (factorial' m (1 + n))
              (\<lambda>r _. r = fact (1 + n))"
     apply (subst factorial'.simps)
     apply (rule_tac G = "1 + n \<noteq> 0" in ovalidNF_grab_asm2)
      apply wp
       apply (simp del: One_nat_def)
       apply (wp induct_asm)
       apply assumption
      apply unat_arith
     apply assumption
    done
qed

lemma factorial'_correct_old: "m > unat n \<longrightarrow> factorial' m n s = Some (fact n)"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (clarsimp split: option.splits)
  apply (intro conjI impI)
    apply unat_arith
   apply (metis (hide_lams, no_types) Nat.add_0_right Nat.le_iff_add Suc_eq_plus1_left Suc_pred factorial.factorial'_terminates_old less_nat_zero_code nat_add_left_cancel_less nat_less_le unatSuc)
  apply (unat_arith, force)
  done

(* Termination & correctness of call_factorial *)
thm call_factorial'_def

lemma "\<lbrace> \<top> \<rbrace> call_factorial' \<lbrace> \<lambda>r s. r = fact 42 \<rbrace>!"
  unfolding call_factorial'_def
  apply wp
   using factorial'_correct_old
   apply force
  apply (force simp: option_monad_mono_eq (* factorial'_mono *))
  done

end

end


(*  Title:      HOL/Isar_Examples/Basic_Logic.thy
    Author:     Makarius

Basic propositional and quantifier reasoning.
*)

section \<open>Basic logical reasoning\<close>

theory Basic_Logic
  imports Main
begin

subsection \<open>Pure backward reasoning\<close>

text \<open>
  In order to get a first idea of how Isabelle/Isar proof documents may look
  like, we consider the propositions \<open>I\<close>, \<open>K\<close>, and \<open>S\<close>. The following (rather
  explicit) proofs should require little extra explanations.
\<close>

lemma I: "A \<longrightarrow> A"
proof
qed

lemma S: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
proof
  assume abc: "A \<longrightarrow> B \<longrightarrow> C"
  show "(A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
  proof
    assume ab: "A \<longrightarrow> B"
    show "A \<longrightarrow> C"
    proof
      assume a: "A"
      hence "B" using ab by simp
      thus "C" using abc a by simp
    qed
  qed
qed

text \<open>
  Isar provides several ways to fine-tune the reasoning, avoiding excessive
  detail. Several abbreviated language elements are available, enabling the
  writer to express proofs in a more concise way, even without referring to
  any automated proof tools yet.

  Concluding any (sub-)proof already involves solving any remaining goals by
  assumption\<^footnote>\<open>This is not a completely trivial operation, as proof by
  assumption may involve full higher-order unification.\<close>. Thus we may skip the
  rather vacuous body of the above proof.
\<close>

lemma "A \<longrightarrow> A"
proof
qed

text \<open>
  Note that the \<^theory_text>\<open>proof\<close> command refers to the \<open>rule\<close> method (without
  arguments) by default. Thus it implicitly applies a single rule, as
  determined from the syntactic form of the statements involved. The \<^theory_text>\<open>by\<close>
  command abbreviates any proof with empty body, so the proof may be further
  pruned.
\<close>

lemma "A \<longrightarrow> A"
  by simp

text \<open>
  Proof by a single rule may be abbreviated as double-dot.
\<close>

lemma "A \<longrightarrow> A" ..

text \<open>
  Thus we have arrived at an adequate representation of the proof of a
  tautology that holds by a single standard rule.\<^footnote>\<open>Apparently, the
  rule here is implication introduction.\<close>

  \<^medskip>
  Let us also reconsider \<open>K\<close>. Its statement is composed of iterated
  connectives. Basic decomposition is by a single rule at a time, which is why
  our first version above was by nesting two proofs.

  The \<open>intro\<close> proof method repeatedly decomposes a goal's conclusion.\<^footnote>\<open>The
  dual method is \<open>elim\<close>, acting on a goal's premises.\<close>
\<close>

lemma "A \<longrightarrow> B \<longrightarrow> A"
proof (intro impI)
  assume A
  show A by fact
qed

text \<open>Again, the body may be collapsed.\<close>

lemma "A \<longrightarrow> B \<longrightarrow> A"
  by (intro impI)

text \<open>
  Just like \<open>rule\<close>, the \<open>intro\<close> and \<open>elim\<close> proof methods pick standard
  structural rules, in case no explicit arguments are given. While implicit
  rules are usually just fine for single rule application, this may go too far
  with iteration. Thus in practice, \<open>intro\<close> and \<open>elim\<close> would be typically
  restricted to certain structures by giving a few rules only, e.g.\ \<^theory_text>\<open>proof
  (intro impI allI)\<close> to strip implications and universal quantifiers.

  Such well-tuned iterated decomposition of certain structures is the prime
  application of \<open>intro\<close> and \<open>elim\<close>. In contrast, terminal steps that solve a
  goal completely are usually performed by actual automated proof methods
  (such as \<^theory_text>\<open>by blast\<close>.
\<close>

subsection \<open>Variations of backward vs.\ forward reasoning\<close>

text \<open>
  Certainly, any proof may be performed in backward-style only. On the other
  hand, small steps of reasoning are often more naturally expressed in
  forward-style. Isar supports both backward and forward reasoning as a
  first-class concept. In order to demonstrate the difference, we consider
  several proofs of \<open>A \<and> B \<longrightarrow> B \<and> A\<close>.

  The first version is purely backward.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume ab: "A \<and> B"
  show "B \<and> A"
  proof
    show B by (rule conjunct2) fact
  next
    from ab show A ..
  qed
qed

text \<open>
  Above, the projection rules \<open>conjunct1\<close> / \<open>conjunct2\<close> had to be named
  explicitly, since the goals \<open>B\<close> and \<open>A\<close> did not provide any structural clue.
  This may be avoided using \<^theory_text>\<open>from\<close> to focus on the \<open>A \<and> B\<close> assumption as the
  current facts, enabling the use of double-dot proofs. Note that \<^theory_text>\<open>from\<close>
  already does forward-chaining, involving the \<open>conjE\<close> rule here.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume ab: "A \<and> B"
  show "B \<and> A"
  proof
    from ab show B ..
    from ab show A ..
  qed
qed

text \<open>
  In the next version, we move the forward step one level upwards.
  Forward-chaining from the most recent facts is indicated by the \<^theory_text>\<open>then\<close>
  command. Thus the proof of \<open>B \<and> A\<close> from \<open>A \<and> B\<close> actually becomes an
  elimination, rather than an introduction. The resulting proof structure
  directly corresponds to that of the \<open>conjE\<close> rule, including the repeated
  goal proposition that is abbreviated as \<open>?thesis\<close> below.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  then show "B \<and> A"
  proof
    assume B A
    then show ?thesis ..
  qed
qed

text \<open>
  In the subsequent version we flatten the structure of the main body by doing
  forward reasoning all the time. Only the outermost decomposition step is
  left as backward.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume ab: "A \<and> B"
  from ab have A ..
  from ab have B ..
  from \<open>B\<close> \<open>A\<close> show "B \<and> A" ..
qed

text \<open>
  We can still push forward-reasoning a bit further, even at the risk of
  getting ridiculous. Note that we force the initial proof step to do nothing
  here, by referring to the \<open>-\<close> proof method.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof -
  {
    assume ab: "A \<and> B"
    from ab have A ..
    from ab have B ..
    from \<open>B\<close> \<open>A\<close> have "B \<and> A" ..
  }
  then show ?thesis ..
qed

text \<open>
  \<^medskip>
  With these examples we have shifted through a whole range from purely
  backward to purely forward reasoning. Apparently, in the extreme ends we get
  slightly ill-structured proofs, which also require much explicit naming of
  either rules (backward) or local facts (forward).

  The general lesson learned here is that good proof style would achieve just
  the \<^emph>\<open>right\<close> balance of top-down backward decomposition, and bottom-up
  forward composition. In general, there is no single best way to arrange some
  pieces of formal reasoning, of course. Depending on the actual applications,
  the intended audience etc., rules (and methods) on the one hand vs.\ facts
  on the other hand have to be emphasized in an appropriate way. This requires
  the proof writer to develop good taste, and some practice, of course.

  \<^medskip>
  For our example the most appropriate way of reasoning is probably the middle
  one, with conjunction introduction done after elimination.
\<close>

lemma "A \<and> B \<longrightarrow> B \<and> A"
proof
  assume "A \<and> B"
  then show "B \<and> A"
  proof
    assume B A
    then show ?thesis ..
  qed
qed

subsection \<open>A few examples from ``Introduction to Isabelle''\<close>

text \<open>
  We rephrase some of the basic reasoning examples of @{cite
  "isabelle-intro"}, using HOL rather than FOL.
\<close>

subsubsection \<open>A propositional proof\<close>

text \<open>
  We consider the proposition \<open>P \<or> P \<longrightarrow> P\<close>. The proof below involves
  forward-chaining from \<open>P \<or> P\<close>, followed by an explicit case-analysis on the
  two \<^emph>\<open>identical\<close> cases.
\<close>

lemma "P \<or> P \<longrightarrow> P"
proof
  assume "P \<or> P"
  then show "P" ..
qed

text \<open>
  Case splits are \<^emph>\<open>not\<close> hardwired into the Isar language as a special
  feature. The \<^theory_text>\<open>next\<close> command used to separate the cases above is just a
  short form of managing block structure.

  \<^medskip>
  In general, applying proof methods may split up a goal into separate
  ``cases'', i.e.\ new subgoals with individual local assumptions. The
  corresponding proof text typically mimics this by establishing results in
  appropriate contexts, separated by blocks.

  In order to avoid too much explicit parentheses, the Isar system implicitly
  opens an additional block for any new goal, the \<^theory_text>\<open>next\<close> statement then
  closes one block level, opening a new one. The resulting behaviour is what
  one would expect from separating cases, only that it is more flexible. E.g.\
  an induction base case (which does not introduce local assumptions) would
  \<^emph>\<open>not\<close> require \<^theory_text>\<open>next\<close> to separate the subsequent step case.

  \<^medskip>
  In our example the situation is even simpler, since the two cases actually
  coincide. Consequently the proof may be rephrased as follows.
\<close>

lemma "P \<or> P \<longrightarrow> P"
proof
  assume "P \<or> P"
  then show P
  proof
    assume P
    show P by fact
    show P by fact
  qed
qed

text \<open>Again, the rather vacuous body of the proof may be collapsed.
  Thus the case analysis degenerates into two assumption steps, which
  are implicitly performed when concluding the single rule step of the
  double-dot proof as follows.\<close>

lemma "P \<or> P \<longrightarrow> P"
proof
  assume "P \<or> P"
  then show P ..
qed

subsubsection \<open>A quantifier proof\<close>

text \<open>
  To illustrate quantifier reasoning, let us prove
  \<open>(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)\<close>. Informally, this holds because any \<open>a\<close> with
  \<open>P (f a)\<close> may be taken as a witness for the second existential statement.

  The first proof is rather verbose, exhibiting quite a lot of (redundant)
  detail. It gives explicit rules, even with some instantiation. Furthermore,
  we encounter two new language elements: the \<^theory_text>\<open>fix\<close> command augments the
  context by some new ``arbitrary, but fixed'' element; the \<^theory_text>\<open>is\<close> annotation
  binds term abbreviations by higher-order pattern matching.
\<close>

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then show "\<exists>y. P y"
  proof
    fix a
    assume "P (f a)" (is "P ?wit")
    then show ?thesis by (intro exI [of P ?wit])
  qed
qed

text \<open>
  While explicit rule instantiation may occasionally improve readability of
  certain aspects of reasoning, it is usually quite redundant. Above, the
  basic proof outline gives already enough structural clues for the system to
  infer both the rules and their instances (by higher-order unification). Thus
  we may as well prune the text as follows.
\<close>

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then show "\<exists>y. P y"
  proof
    fix a
    assume "P (f a)"
    then show ?thesis ..
  qed
qed

text \<open>
  Explicit \<open>\<exists>\<close>-elimination as seen above can become quite cumbersome in
  practice. The derived Isar language element ``\<^theory_text>\<open>obtain\<close>'' provides a more
  handsome way to do generalized existence reasoning.
\<close>

lemma "(\<exists>x. P (f x)) \<longrightarrow> (\<exists>y. P y)"
proof
  assume "\<exists>x. P (f x)"
  then obtain a where "P (f a)" ..
  then show "\<exists>y. P y" ..
qed

text \<open>
  Technically, \<^theory_text>\<open>obtain\<close> is similar to \<^theory_text>\<open>fix\<close> and \<^theory_text>\<open>assume\<close> together with a
  soundness proof of the elimination involved. Thus it behaves similar to any
  other forward proof element. Also note that due to the nature of general
  existence reasoning involved here, any result exported from the context of
  an \<^theory_text>\<open>obtain\<close> statement may \<^emph>\<open>not\<close> refer to the parameters introduced there.
\<close>

subsubsection \<open>Deriving rules in Isabelle\<close>

text \<open>
  We derive the conjunction elimination rule from the corresponding
  projections. The proof is quite straight-forward, since Isabelle/Isar
  supports non-atomic goals and assumptions fully transparently.
\<close>

theorem conjE: "A \<and> B \<Longrightarrow> (A \<Longrightarrow> B \<Longrightarrow> C) \<Longrightarrow> C"
proof -
  assume "A \<and> B"
  then show "(A \<Longrightarrow> B \<Longrightarrow> C) \<Longrightarrow> C" ..
qed

end


theory GabrielaLimonta1
imports "~~/src/HOL/IMP/Hoare_Sound_Complete" "~~/src/HOL/IMP/VCG"
begin

(* Homework 11.1 *)
abbreviation "xx \<equiv> ''x''" abbreviation "yy \<equiv> ''y''"
abbreviation "aa \<equiv> ''a''" abbreviation "bb \<equiv> ''b''"

definition Cdiff :: com where  "Cdiff \<equiv>
  bb ::= N 0;;
  WHILE (Less (V bb) (V xx)) DO
    (yy ::= Plus (V yy) (N -1);;
    bb ::= Plus (V bb) (N 1))"

definition P_Cdiff :: "int \<Rightarrow> int \<Rightarrow> assn" where
"P_Cdiff x y \<equiv> \<lambda>s. s xx = x \<and> s yy = y \<and> 0 \<le> x"

definition Q_Cdiff :: "int \<Rightarrow> int \<Rightarrow> assn" where
"Q_Cdiff x y \<equiv> \<lambda>t. t yy = y - x"

definition iCdiff :: "int \<Rightarrow> int \<Rightarrow> assn" where
  "iCdiff x y \<equiv> \<lambda>s. s xx = x \<and> y = s yy + s bb \<and> s bb \<le> x"

definition ACdiff :: "int \<Rightarrow> int \<Rightarrow> acom" where
  "ACdiff x y \<equiv>
  (bb ::= N 0) ;;
  {iCdiff x y} WHILE (Less (V bb) (V xx)) DO
    (yy ::= Plus (V yy) (N -1);;
    bb ::= Plus (V bb) (N 1))"

lemma strip_ACdiff: "strip (ACdiff x y) = Cdiff"
  unfolding Cdiff_def P_Cdiff_def Q_Cdiff_def iCdiff_def ACdiff_def
  by simp

lemma Cdiff_correct: "\<turnstile> {P_Cdiff x y} strip (ACdiff x y) {Q_Cdiff x y}"
  unfolding strip_ACdiff[of x y, symmetric]
  apply(rule vc_sound')
  unfolding Cdiff_def P_Cdiff_def Q_Cdiff_def iCdiff_def ACdiff_def
  by auto

end


theory T67
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T72
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


header {* Isomorphisms of Free Groups *}

theory "Isomorphisms"
imports
   "UnitGroup"
   "~~/src/HOL/Algebra/IntRing"
   "FreeGroups"
   C2
   "~~/src/HOL/Cardinals/Cardinal_Order_Relation"
begin

subsection {* The Free Group over the empty set *}

text {* The Free Group over an empty set of generators is isomorphic to the trivial
group. *}

lemma free_group_over_empty_set: "\<exists>h. h \<in> \<F>\<^bsub>{}\<^esub> \<cong> unit_group"
proof(rule group.unit_group_unique)
  show "group \<F>\<^bsub>{}\<^esub>" by (rule free_group_is_group)
next
  have "carrier \<F>\<^bsub>{}::'a set\<^esub> = {[]}"
    by (auto simp add:free_group_def)
  thus "card (carrier \<F>\<^bsub>{}::'a set\<^esub>) = 1"
    by simp
qed

subsection {* The Free Group over one generator *}

text {* The Free Group over one generator is isomorphic to the free abelian group
over one element, also known as the integers. *}

abbreviation "int_group"
  where "int_group \<equiv> \<lparr> carrier = carrier \<Z>, mult = op +, one = 0::int \<rparr>"

lemma replicate_set_eq[simp]: "\<forall>x \<in> set xs. x = y \<Longrightarrow> xs = replicate (length xs) y"
  by(induct xs)auto

lemma int_group_gen_by_one: "\<langle>{1}\<rangle>\<^bsub>int_group\<^esub> = carrier int_group"
proof
  show "\<langle>{1}\<rangle>\<^bsub>int_group\<^esub> \<subseteq> carrier int_group"
    by auto
  show "carrier int_group \<subseteq> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
  proof
    interpret int: group int_group by (simp add: int.a_group)
    fix x
    have plus1: "1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (auto intro:gen_span.gen_gens)
    hence "inv\<^bsub>int_group\<^esub> 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (auto intro:gen_span.gen_inv)
    moreover
    have "-1 = inv\<^bsub>int_group\<^esub> 1"
      by (rule sym, rule int.inv_equality) simp_all
    ultimately
    have minus1: "-1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (simp)

    show "x \<in> \<langle>{1::int}\<rangle>\<^bsub>int_group\<^esub>" (*
    It does not work directly, unfortunately:
    apply(induct x rule:int_induct[of _ "0::int"])
    apply (auto simp add: int_arith_rules intro:gen_span.intros[of int_group])
    *)
    proof(induct x rule:int_induct[of _ "0::int"])
    case base
      have "\<one>\<^bsub>int_group\<^esub> \<in> \<langle>{1\<Colon>int}\<rangle>\<^bsub>int_group\<^esub>"
        by (rule gen_span.gen_one)
      thus"0 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by simp
    next
    case (step1 i)
      from `i \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>` and plus1
      have "i \<otimes>\<^bsub>int_group\<^esub> 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by (rule gen_span.gen_mult)
      thus "i + 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>" by simp
    next
    case (step2 i)
      from `i \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>` and minus1
      have "i \<otimes>\<^bsub>int_group\<^esub> -1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by (rule gen_span.gen_mult)
      thus "i - 1 \<in> \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
        by simp
    qed
  qed
qed

lemma free_group_over_one_gen: "\<exists>h. h \<in> \<F>\<^bsub>{()}\<^esub> \<cong> int_group"
proof-
  interpret int: group int_group by (simp add: int.a_group)

  def f \<equiv> "\<lambda>(x::unit).(1::int)"
  have "f \<in> {()} \<rightarrow> carrier int_group"
    by auto
  hence "int.lift f \<in> hom \<F>\<^bsub>{()}\<^esub> int_group"
    by (rule int.lift_is_hom)
  then
  interpret hom: group_hom "\<F>\<^bsub>{()}\<^esub>" int_group "int.lift f"
    unfolding group_hom_def group_hom_axioms_def
    by(auto intro: int.a_group free_group_is_group)

  { (* This shows injectiveness of the given map *)
    fix x
    assume "x \<in> carrier \<F>\<^bsub>{()}\<^esub>"
    hence "canceled x" by (auto simp add:free_group_def)
    assume "int.lift f x = (0::int)"
    have "x = []"
    proof(rule ccontr)
      assume "x \<noteq> []"
      then obtain a and xs where "x = a # xs" by (cases x, auto)
      hence "length (takeWhile (\<lambda>y. y = a) x) > 0" by auto
      then obtain i where i: "length (takeWhile (\<lambda>y. y = a) x) = Suc i"
        by (cases "length (takeWhile (\<lambda>y. y = a) x)", auto)
      have "Suc i \<ge> length x"
      proof(rule ccontr)
        assume "\<not> length x \<le> Suc i"
        hence "length (takeWhile (\<lambda>y. y = a) x) < length x" using i by simp
        hence "\<not> (\<lambda>y. y = a) (x ! length (takeWhile (\<lambda>y. y = a) x))"
          by (rule nth_length_takeWhile)
        hence "\<not> (\<lambda>y. y = a) (x ! Suc i)" using i by simp
        hence "fst (x ! Suc i) \<noteq> fst a" by (cases "x ! Suc i", cases "a", auto)
        moreover
        {
          have "takeWhile (\<lambda>y. y = a) x ! i = x ! i"
            using i by (auto intro: takeWhile_nth)
          moreover
          have "(takeWhile (\<lambda>y. y = a) x) ! i \<in> set (takeWhile (\<lambda>y. y = a) x)"
            using i by auto
          ultimately
          have "(\<lambda>y. y = a) (x ! i)"
            by (auto dest:set_takeWhileD)
        }
        hence "fst (x ! i) = fst a" by auto
        moreover
        have "snd (x ! i) = snd (x ! Suc i)" by simp
        ultimately
        have "canceling (x ! i) (x ! Suc i)" unfolding canceling_def by auto
        hence "cancels_to_1_at i x (cancel_at i x)"
          using `\<not> length x \<le> Suc i` unfolding cancels_to_1_at_def
          by (auto simp add:length_takeWhile_le)
        hence "cancels_to_1 x (cancel_at i x)" unfolding cancels_to_1_def by auto
        hence "\<not> canceled x" unfolding canceled_def by auto
        thus False using `canceled x` by contradiction
      qed
      hence "length (takeWhile (\<lambda>y. y = a) x) = length x"
        using i[THEN sym] by (auto dest:le_antisym simp add:length_takeWhile_le)
      hence "takeWhile (\<lambda>y. y = a) x = x"
        by (subst takeWhile_eq_take, simp)
      moreover
      have "\<forall>y \<in> set (takeWhile (\<lambda>y. y = a) x). y = a"
        by (auto dest: set_takeWhileD)
      ultimately
      have "\<forall>y \<in> set x. y = a" by auto
      hence "x = replicate (length x) a" by simp
      hence "int.lift f x = int.lift f (replicate (length x) a)" by simp
      also have "... = pow int_group (int.lift_gi f a) (length x)"
        by (induct x,auto simp add:int.lift_def [simplified])
      also have "... = (int.lift_gi f a) * int (length x)"
        by (induct ("length x"), auto simp add:int_distrib)
      finally have "\<dots> = 0" using `int.lift f x = 0` by simp
      hence "nat (abs (group.lift_gi int_group f a * int (length x))) = 0" by simp
      hence "nat (abs (group.lift_gi int_group f a)) * length x = 0" by simp
      hence "nat (abs (group.lift_gi int_group f a)) = 0"
        using `x \<noteq> []` by auto
      moreover
      have "inv\<^bsub>int_group\<^esub> 1 = -1"
        using int.inv_equality by auto
      hence "abs (group.lift_gi int_group f a) = 1"
      using `group int_group`
        by(auto simp add: group.lift_gi_def f_def)
      ultimately
      show False by simp
    qed
  }
  hence "\<forall>x\<in>carrier \<F>\<^bsub>{()}\<^esub>. int.lift f x = \<one>\<^bsub>int_group\<^esub> \<longrightarrow> x = \<one>\<^bsub>\<F>\<^bsub>{()}\<^esub>\<^esub>"
    by (auto simp add:free_group_def)
  moreover
  {
    have "carrier \<F>\<^bsub>{()}\<^esub> = \<langle>insert`{()}\<rangle>\<^bsub>\<F>\<^bsub>{()}\<^esub>\<^esub>"
      by (rule gens_span_free_group[THEN sym])
    moreover
    have "carrier int_group = \<langle>{1}\<rangle>\<^bsub>int_group\<^esub>"
      by (rule int_group_gen_by_one[THEN sym])
    moreover
    have "int.lift f ` insert ` {()} = {1}"
      by (auto simp add: int.lift_def [simplified] insert_def f_def int.lift_gi_def [simplified])
    moreover
    have  "int.lift f ` \<langle>insert`{()}\<rangle>\<^bsub>\<F>\<^bsub>{()}\<^esub>\<^esub> = \<langle>int.lift f ` (insert `{()})\<rangle>\<^bsub>int_group\<^esub>"
      by (rule hom.hom_span, auto intro:insert_closed)
    ultimately
    have "int.lift f ` carrier \<F>\<^bsub>{()}\<^esub> = carrier int_group"
      by simp
  }
  ultimately
  have "int.lift f \<in> \<F>\<^bsub>{()}\<^esub> \<cong> int_group"
    using `int.lift f \<in> hom \<F>\<^bsub>{()}\<^esub> int_group`
    using hom.hom_mult int.is_group
    by (auto intro:group_isoI simp add: free_group_is_group)
  thus ?thesis by auto
qed

subsection {* Free Groups over isomorphic sets of generators *}

text {* Free Groups are isomorphic if their set of generators are isomorphic. *}

definition lift_generator_function :: "('a \<Rightarrow> 'b) \<Rightarrow> (bool \<times> 'a) list \<Rightarrow> (bool \<times> 'b) list"
where "lift_generator_function f = map (map_prod id f)"

theorem isomorphic_free_groups:
  assumes "bij_betw f gens1 gens2"
  shows "lift_generator_function f \<in> \<F>\<^bsub>gens1\<^esub> \<cong> \<F>\<^bsub>gens2\<^esub>"
unfolding lift_generator_function_def
proof(rule group_isoI)
  show "\<forall>x\<in>carrier \<F>\<^bsub>gens1\<^esub>.
       map (map_prod id f) x = \<one>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> \<longrightarrow> x = \<one>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub>"
    by(auto simp add:free_group_def)
next
  from `bij_betw f gens1 gens2` have "inj_on f gens1" by (auto simp:bij_betw_def)
  show "map (map_prod id f) ` carrier \<F>\<^bsub>gens1\<^esub> = carrier \<F>\<^bsub>gens2\<^esub>"
  proof(rule Set.set_eqI,rule iffI)
    from `bij_betw f gens1 gens2` have "f ` gens1 = gens2" by (auto simp:bij_betw_def)
    fix x :: "(bool \<times> 'b) list"
    assume "x \<in> image (map (map_prod id f)) (carrier \<F>\<^bsub>gens1\<^esub>)"
    then obtain y :: "(bool \<times> 'a) list" where "x = map (map_prod id f) y"
                    and "y \<in> carrier \<F>\<^bsub>gens1\<^esub>" by auto
    from `y \<in> carrier \<F>\<^bsub>gens1\<^esub>`
    have "canceled y" and "y \<in> lists(UNIV\<times>gens1)" by (auto simp add:free_group_def)

    from `y \<in> lists (UNIV\<times>gens1)`
      and `x = map (map_prod id f) y`
      and `image f gens1 = gens2`
    have "x \<in> lists (UNIV\<times>gens2)"
      by (auto iff:lists_eq_set)
    moreover

    from `x = map (map_prod id f) y`
     and `y \<in> lists (UNIV\<times>gens1)`
     and `canceled y`
     and `inj_on f gens1`
    have "canceled x"
      by (auto intro!:rename_gens_canceled subset_inj_on[OF `inj_on f gens1`] iff:lists_eq_set)
    ultimately
    show "x \<in> carrier \<F>\<^bsub>gens2\<^esub>" by (simp add:free_group_def)
  next
    fix x
    assume "x \<in> carrier \<F>\<^bsub>gens2\<^esub>"
    hence "canceled x" and "x \<in> lists (UNIV\<times>gens2)"
      unfolding free_group_def by auto
    def y \<equiv> "map (map_prod id (the_inv_into gens1 f)) x"
    have "map (map_prod id f) y =
          map (map_prod id f) (map (map_prod id (the_inv_into gens1 f)) x)"
      by (simp add:y_def)
    also have "\<dots> = map (map_prod id f \<circ> map_prod id (the_inv_into gens1 f)) x"
      by simp
    also have "\<dots> = map (map_prod id (f \<circ> the_inv_into gens1 f)) x"
      by auto
    also have "\<dots> = map id x"
    proof(rule map_ext, rule impI)
      fix xa :: "bool \<times> 'b"
      assume "xa \<in> set x"
      from `x \<in> lists (UNIV\<times>gens2)`
      have "set (map snd x) \<subseteq> gens2"  by auto
      hence "snd ` set x \<subseteq> gens2" by (simp add: set_map)
      with `xa \<in> set x` have "snd xa \<in> gens2" by auto
      with `bij_betw f gens1 gens2` have "snd xa \<in> f`gens1"
        by (auto simp add: bij_betw_def)

      have "map_prod id (f \<circ> the_inv_into gens1 f) xa
            = map_prod id (f \<circ> the_inv_into gens1 f) (fst xa, snd xa)" by simp
      also have "\<dots> = (fst xa, f (the_inv_into gens1 f (snd xa)))"
        by (auto simp del:pair_collapse)
      also with `snd xa \<in> image f gens1` and `inj_on f gens1`
           have "\<dots> = (fst xa, snd xa)"
           by (auto elim:f_the_inv_into_f simp del:pair_collapse)
      also have "\<dots> = id xa" by simp
      finally show "map_prod id (f \<circ> the_inv_into gens1 f) xa = id xa".
    qed
    also have "\<dots> = x" unfolding id_def by auto
    finally have "map (map_prod id f) y = x".
    moreover
    {
      from `bij_betw f gens1 gens2`
      have "bij_betw (the_inv_into gens1 f) gens2 gens1" by (rule bij_betw_the_inv_into)
      hence "inj_on (the_inv_into gens1 f) gens2" by (rule bij_betw_imp_inj_on)

      with `canceled x`
       and `x \<in> lists (UNIV\<times>gens2)`
      have "canceled y"
        by (auto intro!:rename_gens_canceled[OF subset_inj_on] simp add:y_def)
      moreover
      {
        from `bij_betw (the_inv_into gens1 f) gens2 gens1`
         and `x\<in>lists(UNIV\<times>gens2)`
        have "y \<in> lists(UNIV\<times>gens1)"
          unfolding y_def and bij_betw_def
          by (auto iff:lists_eq_set dest!:subsetD)
      }
      ultimately
      have "y \<in> carrier \<F>\<^bsub>gens1\<^esub>" by (simp add:free_group_def)
    }
    ultimately
    show "x \<in> map (map_prod id f) ` carrier \<F>\<^bsub>gens1\<^esub>" by auto
  qed
next
  from `bij_betw f gens1 gens2` have "inj_on f gens1" by (auto simp:bij_betw_def)
  {
  fix x
  assume "x \<in> carrier \<F>\<^bsub>gens1\<^esub>"
  fix y
  assume "y \<in> carrier \<F>\<^bsub>gens1\<^esub>"

  from `x \<in> carrier \<F>\<^bsub>gens1\<^esub>` and `y \<in> carrier \<F>\<^bsub>gens1\<^esub>`
  have "x \<in> lists(UNIV\<times>gens1)" and "y \<in> lists(UNIV\<times>gens1)"
    by (auto simp add:occuring_gens_in_element)
(*  hence "occuring_generators (x@y) \<subseteq> gens1"
    by(auto simp add:occuring_generators_def)
  with `inj_on f gens1` have "inj_on f (occuring_generators (x@y))"
    by (rule subset_inj_on) *)

  have "map (map_prod id f) (x \<otimes>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub> y)
       = map (map_prod id f) (normalize (x@y))" by (simp add:free_group_def)
  also (* from `inj_on f (occuring_generators (x@y))` *)
       from `x \<in> lists(UNIV\<times>gens1)` and `y \<in> lists(UNIV\<times>gens1)`
        and `inj_on f gens1`
       have "\<dots> = normalize (map (map_prod id f) (x@y))"
         by -(rule rename_gens_normalize[THEN sym],
              auto intro!: subset_inj_on[OF `inj_on f gens1`] iff:lists_eq_set)
  also have "\<dots> = normalize (map (map_prod id f) x @ map (map_prod id f) y)"
       by (auto)
  also have "\<dots> = map (map_prod id f) x \<otimes>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> map (map_prod id f) y"
       by (simp add:free_group_def)
  finally have "map (map_prod id f) (x \<otimes>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub> y) =
                map (map_prod id f) x \<otimes>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> map (map_prod id f) y".
  }
  thus "\<forall>x\<in>carrier \<F>\<^bsub>gens1\<^esub>.
       \<forall>y\<in>carrier \<F>\<^bsub>gens1\<^esub>.
          map (map_prod id f) (x \<otimes>\<^bsub>\<F>\<^bsub>gens1\<^esub>\<^esub> y) =
          map (map_prod id f) x \<otimes>\<^bsub>\<F>\<^bsub>gens2\<^esub>\<^esub> map (map_prod id f) y"
   by auto
qed (auto intro: free_group_is_group)

subsection {* Bases of isomorphic free groups *}

text {*
Isomorphic free groups have bases of same cardinality. The proof is very different
for infinite bases and for finite bases.

The proof for the finite case uses the set of of homomorphisms from the free
group to the group with two elements, as suggested by Christian Sievers. The
definition of @{term hom} is not suitable for proofs about the cardinality of that
set, as its definition does not require extensionality. This is amended by the
following definition:
*}

definition homr
  where "homr G H = {h. h \<in> hom G H \<and> h \<in> extensional (carrier G)}"

lemma (in group_hom) restrict_hom[intro!]:
  shows "restrict h (carrier G) \<in> homr G H"
  unfolding homr_def and hom_def
  by (auto)

lemma hom_F_C2_Powerset:
  "\<exists> f. bij_betw f (Pow X) (homr (\<F>\<^bsub>X\<^esub>) C2)"
proof
  interpret F: group "\<F>\<^bsub>X\<^esub>" by (rule free_group_is_group)
  interpret C2: group C2 by (rule C2_is_group)
  let ?f = "\<lambda>S . restrict (C2.lift (\<lambda>x. x \<in> S)) (carrier \<F>\<^bsub>X\<^esub>)"
  let ?f' = "\<lambda>h . X \<inter> Collect(h \<circ> insert)"
  show "bij_betw ?f (Pow X) (homr (\<F>\<^bsub>X\<^esub>) C2)"
  proof(induct rule: bij_betwI[of ?f _ _ ?f'])
  case 1 show ?case
    proof
      fix S assume "S \<in> Pow X"
      interpret h: group_hom "\<F>\<^bsub>X\<^esub>" C2 "C2.lift (\<lambda>x. x \<in> S)"
        by unfold_locales (auto intro: C2.lift_is_hom)
      show "?f S \<in> homr \<F>\<^bsub>X\<^esub> C2"
        by (rule h.restrict_hom)
     qed
  next
  case 2 show ?case by auto next
  case (3 S) show ?case
    proof (induct rule: Set.set_eqI)
      case (1 x) show ?case
      proof(cases "x \<in> X")
      case True thus ?thesis using insert_closed[of x X]
         by (auto simp add:insert_def C2.lift_def C2.lift_gi_def)
      next case False thus ?thesis using 3 by auto
    qed
  qed
  next
  case (4 h)
    hence hom: "h \<in> hom \<F>\<^bsub>X\<^esub> C2"
      and extn: "h \<in> extensional (carrier \<F>\<^bsub>X\<^esub>)"
      unfolding homr_def by auto
    have "\<forall>x \<in> carrier \<F>\<^bsub>X\<^esub> . h x = group.lift C2 (\<lambda>z. z \<in> X & (h \<circ> FreeGroups.insert) z) x"
     by (rule C2.lift_is_unique[OF C2_is_group _ hom, of "(\<lambda>z. z \<in> X & (h \<circ> FreeGroups.insert) z)"],
             auto)
    thus ?case
    by -(rule extensionalityI[OF restrict_extensional extn], auto)
  qed
qed

lemma group_iso_betw_hom:
  assumes "group G1" and "group G2"
      and iso: "i \<in> G1 \<cong> G2"
  shows   "\<exists> f . bij_betw f (homr G2 H) (homr G1 H)"
proof-
  interpret G2: group G2 by (rule `group G2`)
  let ?i' = "restrict (inv_into (carrier G1) i) (carrier G2)"
  have "inv_into (carrier G1) i \<in> G2 \<cong> G1" by (rule group.iso_sym[OF `group G1` iso])
  hence iso': "?i' \<in> G2 \<cong> G1"
    by (auto simp add:Group.iso_def hom_def G2.m_closed)
  show ?thesis
  proof(rule, induct rule: bij_betwI[of "(\<lambda>h. compose (carrier G1) h i)" _ _ "(\<lambda>h. compose (carrier G2) h ?i')"])
  case 1
    show ?case
    proof
      fix h assume "h \<in> homr G2 H"
      hence "compose (carrier G1) h i \<in> hom G1 H"
        using iso
        by (auto intro: group.hom_compose[OF `group G1`, of _ G2] simp add:Group.iso_def homr_def)
      thus "compose (carrier G1) h i \<in> homr G1 H"
        unfolding homr_def by simp
     qed
  next
  case 2
    show ?case
    proof
      fix h assume "h \<in> homr G1 H"
      hence "compose (carrier G2) h ?i' \<in> hom G2 H"
        using iso'
        by (auto intro: group.hom_compose[OF `group G2`, of _ G1] simp add:Group.iso_def homr_def)
      thus "compose (carrier G2) h ?i' \<in> homr G2 H"
        unfolding homr_def by simp
     qed
  next
  case (3 x)
    hence "compose (carrier G2) (compose (carrier G1) x i) ?i'
          = compose (carrier G2) x (compose (carrier G2) i ?i')"
      using iso iso'
      by (auto intro: compose_assoc[THEN sym]   simp add:Group.iso_def hom_def homr_def)
    also have "\<dots> = compose (carrier G2) x (\<lambda>y\<in>carrier G2. y)"
      using iso
      by (subst compose_id_inv_into, auto simp add:Group.iso_def hom_def bij_betw_def)
    also have "\<dots> = x"
      using 3
      by (auto intro:compose_Id simp add:homr_def)
    finally
    show ?case .
  next
  case (4 y)
    hence "compose (carrier G1) (compose (carrier G2) y ?i') i
          = compose (carrier G1) y (compose (carrier G1) ?i' i)"
      using iso iso'
      by (auto intro: compose_assoc[THEN sym] simp add:Group.iso_def hom_def homr_def)
    also have "\<dots> = compose (carrier G1) y (\<lambda>x\<in>carrier G1. x)"
      using iso
      by (subst compose_inv_into_id, auto simp add:Group.iso_def hom_def bij_betw_def)
    also have "\<dots> = y"
      using 4
      by (auto intro:compose_Id simp add:homr_def)
    finally
    show ?case .
  qed
qed

lemma isomorphic_free_groups_bases_finite:
  assumes iso: "i \<in> \<F>\<^bsub>X\<^esub> \<cong> \<F>\<^bsub>Y\<^esub>"
      and finite: "finite X"
  shows "\<exists>f. bij_betw f X Y"
proof-
  obtain f
    where "bij_betw f (homr \<F>\<^bsub>Y\<^esub> C2) (homr \<F>\<^bsub>X\<^esub> C2)"
    using group_iso_betw_hom[OF free_group_is_group free_group_is_group iso]
    by auto
  moreover
  obtain g'
    where "bij_betw g' (Pow X) (homr (\<F>\<^bsub>X\<^esub>) C2)"
    using hom_F_C2_Powerset by auto
  then obtain g
    where "bij_betw g (homr (\<F>\<^bsub>X\<^esub>) C2) (Pow X)"
    by (auto intro: bij_betw_inv_into)
  moreover
  obtain h
    where "bij_betw h (Pow Y) (homr (\<F>\<^bsub>Y\<^esub>) C2)"
    using hom_F_C2_Powerset by auto
  ultimately
  have "bij_betw (g \<circ> f \<circ> h) (Pow Y) (Pow X)"
    by (auto intro: bij_betw_trans)
  hence eq_card: "card (Pow Y) = card (Pow X)"
    by (rule bij_betw_same_card)
  with finite
  have "finite (Pow Y)"
   by -(rule card_ge_0_finite, auto simp add:card_Pow)
  hence finite': "finite Y" by simp

  with eq_card finite
  have "card X = card Y"
   by (auto simp add:card_Pow)
  with finite finite'
  show ?thesis
   by (rule finite_same_card_bij)
qed

text {*
The proof for the infinite case is trivial once the fact that the free group
over an infinite set has the same cardinality is established.
*}

lemma free_group_card_infinite:
  assumes "\<not> finite X"
  shows "|X| =o |carrier \<F>\<^bsub>X\<^esub>|"
proof-
  have "inj_on insert X"
   and "insert ` X \<subseteq> carrier \<F>\<^bsub>X\<^esub>"
    by (auto intro:insert_closed inj_onI simp add:insert_def)
  hence "|X| \<le>o |carrier \<F>\<^bsub>X\<^esub>|"
    by (subst card_of_ordLeq[THEN sym], auto)
  moreover
  have "|carrier \<F>\<^bsub>X\<^esub>| \<le>o |lists ((UNIV::bool set)\<times>X)|"
    by (auto intro!:card_of_mono1 simp add:free_group_def)
  moreover
  have "|lists ((UNIV::bool set)\<times>X)| =o |(UNIV::bool set)\<times>X|"
    using `\<not> finite X`
    by (auto intro:card_of_lists_infinite dest!:finite_cartesian_productD2)
  moreover
  have  "|(UNIV::bool set)\<times>X| =o |X|"
    using `\<not> finite X`
    by (auto intro: card_of_Times_infinite[OF _ _ ordLess_imp_ordLeq[OF finite_ordLess_infinite2], THEN conjunct2])
  ultimately
  show "|X| =o |carrier \<F>\<^bsub>X\<^esub>|"
    by (subst ordIso_iff_ordLeq, auto intro: ord_trans)
qed

theorem isomorphic_free_groups_bases:
  assumes iso: "i \<in> \<F>\<^bsub>X\<^esub> \<cong> \<F>\<^bsub>Y\<^esub>"
  shows "\<exists>f. bij_betw f X Y"
proof(cases "finite X")
case True
  thus ?thesis using iso by -(rule isomorphic_free_groups_bases_finite)
next
case False show ?thesis
  proof(cases "finite Y")
  case True
  from iso obtain i' where "i' \<in> \<F>\<^bsub>Y\<^esub> \<cong> \<F>\<^bsub>X\<^esub>"
       by (auto intro: group.iso_sym[OF free_group_is_group])
  with `finite Y`
  have "\<exists>f. bij_betw f Y X" by -(rule isomorphic_free_groups_bases_finite)
  thus "\<exists>f. bij_betw f X Y" by (auto intro: bij_betw_the_inv_into) next
case False
  from `\<not> finite X` have "|X| =o |carrier \<F>\<^bsub>X\<^esub>|"
    by (rule free_group_card_infinite)
  moreover
  from `\<not> finite Y` have "|Y| =o |carrier \<F>\<^bsub>Y\<^esub>|"
    by (rule free_group_card_infinite)
  moreover
  from iso have "|carrier \<F>\<^bsub>X\<^esub>| =o |carrier \<F>\<^bsub>Y\<^esub>|"
    by (auto simp add:Group.iso_def iff:card_of_ordIso[THEN sym])
  ultimately
  have "|X| =o |Y|" by (auto intro: ordIso_equivalence)
  thus ?thesis by (subst card_of_ordIso)
qed
qed

end


theory Lmap_llist_of_stream2
    imports Main "$HIPSTER_HOME/IsaHipster"
      begin
setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec llist_of_stream2 :: "'a Stream \<Rightarrow> 'a Llist"
  where "llist_of_stream2 s = LCons (shd s) (llist_of_stream2 (stl s))"

primcorec stream_of_llist2 :: "'a Llist \<Rightarrow> 'a Stream"
where "stream_of_llist2 l = SCons (lhd l) (stream_of_llist2 (ltl l))"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"

theorem lmap_llist_of_stream2:
  "lmap f (llist_of_stream2 xs) = llist_of_stream2 (smap f xs)"
  apply(coinduction arbitrary: f xs rule: Llist.coinduct_strong)
    by (metis (no_types, lifting) Llist.case_eq_if llist_of_stream2.disc_iff llist_of_stream2.simps(2) llist_of_stream2.simps(3) lmap.disc_iff(2) lmap.sel(1) lmap.sel(2) smap.simps(1) smap.simps(2))
(*  by hipster_coinduct_sledgehammer
    Metis: Failed to replay Metis proof
resynchronize: Out of sync
Failed to apply initial proof method\<here>:*)
end