(*
    Title:      Mod_Type.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Class for modular arithmetic*}

theory Mod_Type
imports
  "$ISABELLE_HOME/src/HOL/Library/Numeral_Type"
  "$ISABELLE_HOME/src/HOL/Multivariate_Analysis/Cartesian_Euclidean_Space"
  Dual_Order
begin

subsection{*Definition and properties*}

text{*Class for modular arithmetic. It is inspired by the locale mod\_type.*}

class mod_type = times + wellorder + neg_numeral +
fixes Rep :: "'a => int"
  and Abs :: "int => 'a"
  assumes type: "type_definition Rep Abs {0..<int CARD ('a)}"
  and size1: "1 < int CARD ('a)"
  and zero_def: "0 = Abs 0"
  and one_def:  "1 = Abs 1"
  and add_def:  "x + y = Abs ((Rep x + Rep y) mod (int CARD ('a)))"
  and mult_def: "x * y = Abs ((Rep x * Rep y) mod (int CARD ('a)))"
  and diff_def: "x - y = Abs ((Rep x - Rep y) mod (int CARD ('a)))"
  and minus_def: "- x = Abs ((- Rep x) mod (int CARD ('a)))"
  and strict_mono_Rep: "strict_mono Rep"
begin

lemmas definitions =
  zero_def one_def add_def mult_def minus_def diff_def

lemma Rep_less_n: "Rep x < int CARD ('a)"
  by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])

lemma Rep_le_n: "Rep x \<le> int CARD ('a)"
  by (rule Rep_less_n [THEN order_less_imp_le])

lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
  by (rule type_definition.Rep_inject [OF type, symmetric])

lemma Rep_inverse: "Abs (Rep x) = x"
  by (rule type_definition.Rep_inverse [OF type])

lemma Abs_inverse: "m \<in> {0..<int CARD ('a)} \<Longrightarrow> Rep (Abs m) = m"
  by (rule type_definition.Abs_inverse [OF type])

lemma Rep_Abs_mod: "Rep (Abs (m mod int CARD ('a))) = m mod int CARD ('a)"
  by (simp add: Abs_inverse pos_mod_conj [OF size0])

lemma Rep_Abs_0: "Rep (Abs 0) = 0"
  apply (rule Abs_inverse [of 0])
  using size0 by simp

lemma Rep_0: "Rep 0 = 0"
  by (simp add: zero_def Rep_Abs_0)

lemma Rep_Abs_1: "Rep (Abs 1) = 1"
  by (simp add: Abs_inverse size1)

lemma Rep_1: "Rep 1 = 1"
  by (simp add: one_def Rep_Abs_1)

lemma Rep_mod: "Rep x mod int CARD ('a) = Rep x"
  apply (rule_tac x=x in type_definition.Abs_cases [OF type])
  apply (simp add: type_definition.Abs_inverse [OF type])
  apply (simp add: mod_pos_pos_trivial)
done

lemmas Rep_simps =
  Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1

subsection{*Conversion between a modular class and the subset of natural numbers associated.*}
text{*Definitions to make transformations among elements of a modular class and naturals*}
definition to_nat :: "'a => nat"
  where "to_nat = nat \<circ> Rep"

definition Abs' :: "int => 'a"
  where "Abs' x = Abs(x mod int CARD ('a))"

definition from_nat :: "nat \<Rightarrow> 'a"
  where "from_nat = (Abs' \<circ> int)"

lemma bij_Rep: "bij_betw (Rep) (UNIV::'a set) {0..<int CARD('a)}"
proof (unfold bij_betw_def, rule conjI)
  show "inj Rep" by (metis strict_mono_imp_inj_on strict_mono_Rep)
  show "range Rep = {0..<int CARD('a)}" using Typedef.type_definition.Rep_range[OF type] .
qed

lemma mono_Rep: "mono Rep" by (metis strict_mono_Rep strict_mono_mono)

lemma Rep_ge_0: "0 \<le> Rep x" using bij_Rep unfolding bij_betw_def by auto

lemma bij_Abs: "bij_betw (Abs) {0..<int CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  show "inj_on Abs {0..<int CARD('a)}" by (metis inj_on_inverseI type type_definition.Abs_inverse)
  show "Abs ` {0..<int CARD('a)} = (UNIV::'a set)" by (metis type type_definition.univ)
qed

corollary bij_Abs': "bij_betw (Abs') {0..<int CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  show "inj_on Abs' {0..<int CARD('a)}"
    unfolding inj_on_def Abs'_def
    by (auto, metis Rep_Abs_mod mod_pos_pos_trivial)
  show "Abs' ` {0..<int CARD('a)} = (UNIV::'a set)"
  proof (unfold image_def Abs'_def, auto)
    fix x show "\<exists>xa\<in>{0..<int CARD('a)}. x = Abs (xa mod int CARD('a))"
      by (rule bexI[of _ "Rep x"], auto simp add: Rep_less_n[of x] Rep_ge_0[of x], metis Rep_inverse Rep_mod)
  qed
qed

lemma bij_from_nat: "bij_betw (from_nat) {0..<CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  have set_eq: "{0\<Colon>int..<int CARD('a)} = int` {0..<CARD('a)}" apply (auto)
  proof -
    fix x::int  assume x1: "(0\<Colon>int) \<le> x" and x2: "x < int CARD('a)" show "x \<in> int ` {0\<Colon>nat..<CARD('a)}"
    proof (unfold image_def, auto, rule bexI[of _ "nat x"])
      show " x = int (nat x)" using x1 by auto
      show "nat x \<in> {0\<Colon>nat..<CARD('a)}" using x1 x2 by auto
    qed
  qed
  show "inj_on (from_nat::nat\<Rightarrow>'a) {0\<Colon>nat..<CARD('a)}"
  proof (unfold from_nat_def , rule comp_inj_on)
    show "inj_on int {0\<Colon>nat..<CARD('a)}" by (metis inj_of_nat subset_inj_on top_greatest)
    show "inj_on (Abs'::int=>'a) (int ` {0\<Colon>nat..<CARD('a)})"
      using bij_Abs unfolding bij_betw_def set_eq
      by (metis (hide_lams, no_types) Abs'_def Abs_inverse Rep_inverse Rep_mod inj_on_def set_eq)
  qed
  show "(from_nat::nat=>'a)` {0\<Colon>nat..<CARD('a)} = UNIV"
    unfolding from_nat_def using bij_Abs'
    unfolding bij_betw_def set_eq o_def by blast
qed

lemma to_nat_is_inv: "the_inv_into {0..<CARD('a)} (from_nat::nat=>'a) = (to_nat::'a=>nat)"
proof (unfold the_inv_into_def fun_eq_iff from_nat_def to_nat_def o_def, clarify)
  fix x::"'a" show "(THE y\<Colon>nat. y \<in> {0\<Colon>nat..<CARD('a)} \<and> Abs' (int y) = x) = nat (Rep x)"
  proof (rule the_equality, auto)
    show " Abs' (Rep x) = x" by (metis Abs'_def Rep_inverse Rep_mod)
    show "nat (Rep x) < CARD('a)" by (metis (full_types) Rep_less_n nat_int size0 zless_nat_conj)
    assume x:  "\<not> (0\<Colon>int) \<le> Rep x" show "(0\<Colon>nat) < CARD('a)" and "Abs' (0\<Colon>int) = x"
      using Rep_ge_0 x by auto
  next
    fix y::nat assume y: "y < CARD('a)"
    have "(Rep(Abs'(int y)::'a)) = (Rep((Abs(int y mod int CARD('a)))::'a))" unfolding Abs'_def ..
    also have "... =  (Rep (Abs (int y)::'a))" using zmod_int[of y "CARD('a)"]
      using y mod_less by auto
    also have "... =  (int y)" proof (rule Abs_inverse) show "int y \<in> {0\<Colon>int..<int CARD('a)}"
      using y by auto qed
    finally show "y = nat (Rep (Abs' (int y)::'a))" by (metis nat_int)
  qed
qed

lemma bij_to_nat: "bij_betw (to_nat) (UNIV::'a set) {0..<CARD('a)}"
  using bij_betw_the_inv_into[OF bij_from_nat] unfolding to_nat_is_inv .

lemma finite_mod_type: "finite (UNIV::'a set)"
  using finite_imageD[of "to_nat" "UNIV::'a set"] using bij_to_nat unfolding bij_betw_def by auto

subclass (in mod_type) finite by (intro_classes, rule finite_mod_type)

lemma least_0: "(LEAST n. n \<in> (UNIV::'a set)) = 0"
proof (rule Least_equality, auto)
  fix y::"'a"
  have "(0::'a) \<le> Abs (Rep y mod int CARD('a))" using strict_mono_Rep unfolding strict_mono_def
  by (metis (hide_lams, mono_tags) Rep_0 Rep_ge_0 strict_mono_Rep strict_mono_less_eq)
  also have "... = y" by (metis Rep_inverse Rep_mod)
  finally show "(0\<Colon>'a) \<le> y" .
qed

lemma add_to_nat_def: "x + y = from_nat (to_nat x + to_nat y)"
  unfolding from_nat_def to_nat_def o_def using Rep_ge_0[of x] using Rep_ge_0[of y]
  using Rep_less_n[of x] Rep_less_n[of y]
  unfolding Abs'_def unfolding add_def[of x y] by auto

lemma to_nat_1: "to_nat 1 = 1"
  by (metis (hide_lams, mono_tags) Rep_1 comp_apply to_nat_def transfer_nat_int_numerals(2))

lemma add_def':
  shows "x + y = Abs' (Rep x + Rep y)" unfolding Abs'_def using add_def by simp

lemma Abs'_0:
  shows "Abs' (CARD('a))=(0::'a)" by (metis (hide_lams, mono_tags) Abs'_def mod_self zero_def)

lemma Rep_plus_one_le_card:
  assumes a: "a + 1 \<noteq> 0"
  shows "(Rep a) + 1 < CARD ('a)"
proof (rule ccontr)
  assume "\<not> Rep a + 1 < CARD('a)" hence to_nat_eq_card: "Rep a + 1 = CARD('a)"
    by (metis (hide_lams, mono_tags) Rep_less_n add1_zle_eq dual_order.le_less)
  have "a+1 = Abs' (Rep a + Rep (1::'a))" using add_def' by auto
  also have "... = Abs' ((Rep a) + 1)" using Rep_1 by simp
  also have "... = Abs' (CARD('a))" unfolding to_nat_eq_card ..
  also have "... = 0" using Abs'_0 by auto
  finally show False using a by contradiction
qed

lemma to_nat_plus_one_less_card: "\<forall>a. a+1 \<noteq> 0 --> to_nat a + 1 < CARD('a)"
proof (clarify)
fix a
assume a: "a + 1 \<noteq> 0"
have "Rep a + 1 < int CARD('a)" using Rep_plus_one_le_card[OF a] by auto
hence "nat (Rep a + 1) < nat (int CARD('a))" unfolding zless_nat_conj using size0 by fast
thus "to_nat a + 1 < CARD('a)" unfolding to_nat_def o_def using nat_add_distrib[OF Rep_ge_0] by simp
qed

corollary to_nat_plus_one_less_card':
assumes "a+1 \<noteq> 0"
shows "to_nat a + 1 < CARD('a)" using to_nat_plus_one_less_card assms by simp

lemma strict_mono_to_nat: "strict_mono to_nat"
  using strict_mono_Rep
  unfolding strict_mono_def to_nat_def using Rep_ge_0 by (metis comp_apply nat_less_eq_zless)

lemma to_nat_eq [simp]: "to_nat x = to_nat y <-> x = y"
  using injD [OF bij_betw_imp_inj_on[OF bij_to_nat]] by blast

lemma mod_type_forall_eq [simp]: "(\<forall>j::'a. (to_nat j)<CARD('a) \<longrightarrow> P j) = (\<forall>a. P a)"
proof (auto)
  fix a assume a: "\<forall>j. (to_nat::'a=>nat) j < CARD('a) \<longrightarrow> P j"
  have "(to_nat::'a=>nat) a < CARD('a)" using bij_to_nat unfolding bij_betw_def by auto
  thus "P a" using a by auto
qed

lemma to_nat_from_nat:
  assumes t:"to_nat j = k"
  shows "from_nat k = j"
proof -
  have "from_nat k = from_nat (to_nat j)"  unfolding t ..
  also have "... = from_nat (the_inv_into {0..<CARD('a)} (from_nat) j)" unfolding to_nat_is_inv ..
  also have "... = j"
  proof (rule f_the_inv_into_f)
    show "inj_on from_nat {0..<CARD('a)}" by (metis bij_betw_imp_inj_on bij_from_nat)
    show "j \<in> from_nat ` {0..<CARD('a)}" by (metis UNIV_I bij_betw_def bij_from_nat)
  qed
  finally show "from_nat k = j" .
qed

lemma to_nat_mono:
  assumes ab: "a < b"
  shows "to_nat a < to_nat b"
  using strict_mono_to_nat unfolding strict_mono_def using assms by fast

lemma to_nat_mono':
  assumes ab: "a \<le> b"
  shows "to_nat a \<le> to_nat b"
proof (cases "a=b")
  case True thus ?thesis by auto
next
  case False
  hence "a<b" using ab by simp
  thus ?thesis using to_nat_mono by fastforce
qed

lemma least_mod_type:
  shows "0 \<le> (n::'a)"
  using least_0 by (metis (full_types) Least_le UNIV_I)

lemma to_nat_from_nat_id:
  assumes x: "x<CARD('a)"
  shows "to_nat ((from_nat x)::'a) = x"
  unfolding to_nat_is_inv[symmetric] proof (rule the_inv_into_f_f)
  show "inj_on (from_nat::nat=>'a) {0..<CARD('a)}" using bij_from_nat unfolding bij_betw_def by auto
  show "x \<in> {0..<CARD('a)}" using x by simp
qed

lemma from_nat_to_nat_id[simp]:
  shows "from_nat (to_nat x) = x" by (metis to_nat_from_nat)

lemma from_nat_to_nat:
  assumes t:"from_nat j = k" and j: "j<CARD('a)"
  shows "to_nat k = j" by (metis j t to_nat_from_nat_id)

lemma from_nat_mono:
  assumes i_le_j: "i<j" and j: "j<CARD('a)"
  shows "(from_nat i::'a) < from_nat j"
proof -
have i: "i<CARD('a)" using i_le_j j by simp
obtain a where a: "i=to_nat a"
  using bij_to_nat unfolding bij_betw_def using i to_nat_from_nat_id by metis
obtain b where b: "j=to_nat b"
  using bij_to_nat unfolding bij_betw_def using j to_nat_from_nat_id by metis
show ?thesis by (metis a b from_nat_to_nat_id i_le_j strict_mono_less strict_mono_to_nat)
qed

lemma from_nat_mono':
  assumes i_le_j: "i \<le> j" and "j<CARD ('a)"
  shows "(from_nat i::'a) \<le> from_nat j"
proof (cases "i=j")
  case True
  have "(from_nat i::'a) = from_nat j" using True by simp
  thus ?thesis by simp
next
  case False
  hence "i<j" using i_le_j by simp
  thus ?thesis by (metis assms(2) from_nat_mono less_imp_le)
qed

lemma to_nat_suc:
  assumes "to_nat (x)+1 < CARD ('a)"
  shows "to_nat (x + 1::'a) = (to_nat x) + 1"
proof -
  have "(x::'a) + 1 = from_nat (to_nat x + to_nat (1::'a))" unfolding add_to_nat_def ..
  hence "to_nat ((x::'a) + 1) = to_nat (from_nat (to_nat x + to_nat (1::'a))::'a)" by presburger
  also have "... = to_nat (from_nat (to_nat x + 1)::'a)" unfolding to_nat_1 ..
  also have "... = (to_nat x + 1)" by (metis assms to_nat_from_nat_id)
  finally show ?thesis .
qed

lemma to_nat_le:
  assumes "y < from_nat k"
  shows  "to_nat y < k"
proof (cases "k<CARD('a)")
  case True show ?thesis by (metis (full_types) True assms to_nat_from_nat_id to_nat_mono)
next
  case False have "to_nat y < CARD ('a)" using bij_to_nat unfolding bij_betw_def by auto
  thus ?thesis using False by auto
qed

lemma le_Suc:
  assumes ab: "a < (b::'a)"
  shows "a + 1 \<le> b"
proof -
  have "a + 1 = (from_nat (to_nat (a + 1))::'a)" using from_nat_to_nat_id [of "a+1",symmetric] .
  also have "... \<le> (from_nat (to_nat (b::'a))::'a)"
  proof (rule from_nat_mono')
    have "to_nat a < to_nat b" using ab by (metis to_nat_mono)
    hence "to_nat a + 1 \<le> to_nat b" by simp
    thus "to_nat b < CARD ('a)" using bij_to_nat unfolding  bij_betw_def by auto
    hence "to_nat a + 1 < CARD ('a)" by (metis `to_nat a + 1 \<le> to_nat b` preorder_class.le_less_trans)
    thus "to_nat (a + 1) \<le> to_nat b" by (metis `to_nat a + 1 \<le> to_nat b` to_nat_suc)
  qed
  also have "... = b" by (metis from_nat_to_nat_id)
  finally show "a + (1\<Colon>'a) \<le> b" .
qed

lemma le_Suc':
assumes ab: "a + 1 \<le> b"
  and less_card: "(to_nat a) + 1 < CARD ('a)"
  shows "a < b"
proof -
  have "a = (from_nat (to_nat a)::'a)" using from_nat_to_nat_id [of "a",symmetric] .
  also have "... < (from_nat (to_nat b)::'a)"
  proof (rule from_nat_mono)
    show "to_nat b < CARD('a)" using bij_to_nat unfolding  bij_betw_def by auto
    have "to_nat (a + 1) \<le>  to_nat b" using ab by (metis to_nat_mono')
    hence "to_nat (a) + 1 \<le>  to_nat b"  using to_nat_suc[OF less_card] by auto
    thus "to_nat a < to_nat b" by simp
  qed
  finally show "a < b" by (metis to_nat_from_nat)
qed

lemma Suc_le:
  assumes less_card: "(to_nat a) + 1 < CARD ('a)"
  shows "a < a + 1"
proof -
  have "(to_nat a) < (to_nat a) + 1" by simp
  hence "(to_nat a) < to_nat (a + 1)" by (metis less_card to_nat_suc)
  hence "(from_nat (to_nat a)::'a) < from_nat (to_nat (a + 1))"
    by (rule from_nat_mono, metis less_card to_nat_suc)
  thus "a < a + 1" by (metis to_nat_from_nat)
qed

lemma Suc_le':
  fixes a::'a
  assumes "a + 1 \<noteq> 0"
  shows "a < a + 1" using Suc_le to_nat_plus_one_less_card assms by blast

lemma from_nat_not_eq:
  assumes a_eq_to_nat: "a \<noteq> to_nat b"
  and a_less_card: "a<CARD('a)"
  shows "from_nat a \<noteq> b"
proof (rule ccontr)
  assume "\<not> from_nat a \<noteq> b" hence "from_nat a = b" by simp
  hence "to_nat ((from_nat a)::'a) = to_nat b" by auto
  thus False by (metis a_eq_to_nat a_less_card to_nat_from_nat_id)
qed

lemma Suc_less:
  fixes i::'a
  assumes "i<j"
  and "i+1 \<noteq> j"
  shows "i+1<j" by (metis assms le_Suc le_neq_trans)

lemma Greatest_is_minus_1: "\<forall>a::'a. a \<le> -1"
proof (clarify)
  fix a::'a
  have zero_ge_card_1: "0 \<le> int CARD('a) - 1" using size1 by auto
  have card_less: "int CARD('a) - 1 < int CARD('a)" by auto
  have not_zero: "1 mod int CARD('a) \<noteq> 0"
    by (metis (hide_lams, mono_tags) Rep_Abs_1 Rep_mod zero_neq_one)
  have int_card: "int (CARD('a) - 1) = int CARD('a) - 1" using zdiff_int[of 1 "CARD ('a)"]
    using size1 by simp
  have "a = Abs' (Rep a)" by (metis (hide_lams, mono_tags) Rep_0 add_0_right add_def'
      comm_monoid_add_class.add.right_neutral)
  also have "... = Abs' (int (nat (Rep a)))" by (metis Rep_ge_0 int_nat_eq)
  also have "...  \<le> Abs' (int (CARD('a) - 1))"
  proof (rule from_nat_mono'[unfolded from_nat_def o_def, of "nat (Rep a)" "CARD('a) - 1"])
    show "nat (Rep a) \<le> CARD('a) - 1" using Rep_less_n
      by (metis (hide_lams, mono_tags) Rep_1 Rep_le_n dual_linorder.leD dual_linorder.le_less_linear
          of_nat_1 of_nat_diff zle_diff1_eq zle_int zless_nat_eq_int_zless)
    show "CARD('a) - 1 < CARD('a)" using finite_UNIV_card_ge_0 finite_mod_type by fastforce
  qed
  also have "... = - 1"
  unfolding Abs'_def unfolding minus_def zmod_zminus1_eq_if unfolding Rep_1
  apply (rule cong [of Abs], rule refl)
  unfolding if_not_P [OF not_zero]
  unfolding int_card
  unfolding mod_pos_pos_trivial[OF zero_ge_card_1 card_less]
  using mod_pos_pos_trivial[OF _ size1] by presburger
  finally show "a \<le> -1" by fastforce
qed

lemma a_eq_minus_1: "\<forall>a::'a. a+1 = 0 \<longrightarrow> a = -1"
  by (metis eq_neg_iff_add_eq_0)

lemma forall_from_nat_rw:
  shows "(\<forall>x\<in>{0..<CARD('a)}. P (from_nat x::'a)) = (\<forall>x. P (from_nat x))"
proof (auto)
  fix y assume *: "\<forall>x\<in>{0..<CARD('a)}. P (from_nat x)"
  have "from_nat y \<in> (UNIV::'a set)" by auto
  from this obtain x where x1: "from_nat y = (from_nat x::'a)" and x2: "x\<in>{0..<CARD('a)}"
    using bij_from_nat unfolding bij_betw_def
    by (metis from_nat_to_nat_id rangeI the_inv_into_onto to_nat_is_inv)
  show "P (from_nat y::'a)" unfolding x1 using * x2 by simp
qed

lemma from_nat_eq_imp_eq:
  assumes f_eq: "from_nat x = (from_nat xa::'a)"
and x: "x<CARD('a)" and xa: "xa<CARD('a)"
  shows "x=xa" using assms from_nat_not_eq by metis

lemma to_nat_less_card:
  fixes j::"'a"
  shows "to_nat j < CARD ('a)"
  using bij_to_nat unfolding bij_betw_def by auto

lemma from_nat_0: "from_nat 0 = 0"
  unfolding from_nat_def o_def of_nat_0 Abs'_def mod_0 zero_def ..
lemma to_nat_0: "to_nat 0 = 0" unfolding to_nat_def o_def Rep_0 nat_0 ..
lemma to_nat_eq_0: "(to_nat x = 0) = (x = 0)" using to_nat_0 to_nat_from_nat by auto

lemma suc_not_zero:
  assumes "to_nat a + 1 \<noteq> CARD('a)"
  shows "a+1 \<noteq> 0"
proof (rule ccontr, simp)
  assume a_plus_one_zero: "a + 1 = 0"
  hence rep_eq_card: "Rep a + 1 = CARD('a)"
    using assms to_nat_0 Suc_eq_plus1 Suc_lessI Zero_not_Suc to_nat_less_card to_nat_suc
    by (metis (hide_lams, mono_tags))
  moreover have "Rep a + 1 < CARD('a)"
    using Abs'_0 Rep_1 Suc_eq_plus1 Suc_lessI Suc_neq_Zero add_def' assms
    rep_eq_card to_nat_0 to_nat_less_card to_nat_suc by (metis (hide_lams, mono_tags))
  ultimately show False by fastforce
qed

lemma from_nat_suc:
shows "from_nat (j + 1) = from_nat j + 1"
unfolding from_nat_def o_def Abs'_def add_def' Rep_1 Rep_Abs_mod
unfolding of_nat_add apply (subst mod_add_left_eq) unfolding int_1 ..

lemma to_nat_plus_1_set:
shows "to_nat a + 1 \<in> {1..<CARD('a)+1}"
using to_nat_less_card by simp

end

subsection{*Instantiations*}

instantiation bit0 and bit1:: (finite) mod_type
begin

definition "(Rep::'a bit0 => int)  x = Rep_bit0 x"
definition "(Abs::int => 'a bit0) x = Abs_bit0' x"

definition "(Rep::'a bit1 => int)  x = Rep_bit1 x"
definition "(Abs::int => 'a bit1) x = Abs_bit1' x"

instance
proof
  show "(0::'a bit0) = Abs (0::int)" unfolding Abs_bit0_def Abs_bit0'_def zero_bit0_def by auto
  show "(1::int) < int CARD('a bit0)" by (metis bit0.size1)
  show "type_definition (Rep::'a bit0 => int) (Abs:: int => 'a bit0) {0\<Colon>int..<int CARD('a bit0)}"
  proof (unfold type_definition_def Rep_bit0_def [abs_def]
      Abs_bit0_def [abs_def] Abs_bit0'_def, intro conjI)
    show "\<forall>x\<Colon>'a bit0. Rep_bit0 x \<in> {0\<Colon>int..<int CARD('a bit0)}"
      unfolding card_bit0 unfolding int_mult
      using Rep_bit0 [where ?'a = "'a"] by simp
    show "\<forall>x\<Colon>'a bit0. Abs_bit0 (Rep_bit0 x mod int CARD('a bit0)) = x"
      by (metis Rep_bit0_inverse bit0.Rep_mod)
    show "\<forall>y\<Colon>int. y \<in> {0\<Colon>int..<int CARD('a bit0)}
      \<longrightarrow> Rep_bit0 ((Abs_bit0::int => 'a bit0) (y mod int CARD('a bit0))) = y"
      by (metis bit0.Abs_inverse bit0.Rep_mod)
  qed
  show "(1::'a bit0) = Abs (1::int)" unfolding Abs_bit0_def Abs_bit0'_def one_bit0_def
    by (metis bit0.of_nat_eq of_nat_1 one_bit0_def)
  fix x y :: "'a bit0"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def plus_bit0_def Abs_bit0'_def by fastforce
  show "x * y = Abs (Rep x * Rep y mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def times_bit0_def Abs_bit0'_def by fastforce
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def minus_bit0_def Abs_bit0'_def by fastforce
  show "- x = Abs (- Rep x mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def uminus_bit0_def Abs_bit0'_def by fastforce
  show "(0::'a bit1) = Abs (0::int)" unfolding Abs_bit1_def Abs_bit1'_def zero_bit1_def by auto
  show "(1::int) < int CARD('a bit1)" by (metis bit1.size1)
  show "(1::'a bit1) = Abs (1::int)" unfolding Abs_bit1_def Abs_bit1'_def one_bit1_def
    by (metis bit1.of_nat_eq of_nat_1 one_bit1_def)
  fix x y :: "'a bit1"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit1))"
    unfolding Abs_bit1_def Abs_bit1'_def Rep_bit1_def plus_bit1_def by fastforce
  show "x * y = Abs (Rep x * Rep y mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def times_bit1_def Abs_bit1'_def by fastforce
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def minus_bit1_def Abs_bit1'_def by fastforce
  show "- x = Abs (- Rep x mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def uminus_bit1_def Abs_bit1'_def by fastforce
  show "type_definition (Rep::'a bit1 => int) (Abs:: int => 'a bit1) {0\<Colon>int..<int CARD('a bit1)}"
  proof (unfold type_definition_def Rep_bit1_def [abs_def]
      Abs_bit1_def [abs_def] Abs_bit1'_def, intro conjI)
    have int_2: "int 2 = 2" by auto
   show "\<forall>x\<Colon>'a bit1. Rep_bit1 x \<in> {0\<Colon>int..<int CARD('a bit1)}"
      unfolding card_bit1
      unfolding int_Suc int_mult
      using Rep_bit1 [where ?'a = "'a"] unfolding int_2 unfolding add.commute ..
   show "\<forall>x\<Colon>'a bit1. Abs_bit1 (Rep_bit1 x mod int CARD('a bit1)) = x"
      by (metis Rep_bit1_inverse bit1.Rep_mod)
   show "\<forall>y\<Colon>int. y \<in> {0\<Colon>int..<int CARD('a bit1)}
    \<longrightarrow> Rep_bit1 ((Abs_bit1::int => 'a bit1) (y mod int CARD('a bit1))) = y"
   by (metis bit1.Abs_inverse bit1.Rep_mod)
  qed
  show "strict_mono (Rep::'a bit0 => int)" unfolding strict_mono_def
    by (metis Rep_bit0_def less_bit0_def)
  show "strict_mono (Rep::'a bit1 => int)" unfolding strict_mono_def
    by (metis Rep_bit1_def less_bit1_def)
qed
end

end


theory Putnam
 imports "HOL-Complex_Analysis.Complex_Analysis" "HOL-Algebra.Algebra"
begin

(*
problem_number:2021_b4
natural language statement:
Let $F_{0}, F_{1}, \ldots$ be the sequence of Fibonacci numbers, with $F_{0}=0, F_{1}=1$,
 and $F_{n}=F_{n-1}+F_{n-2}$ for $n \geq 2$. For $m>2$, let $R_{m}$ be the remainder
 when the product $\prod_{k=1}^{F_{m}-1} k^{k}$ is divided by $F_{m}$.
 Prove that $R_{m}$ is also a Fibonacci number.
lean statement:

codex statement:
theorem fibonacci_of_product_mod_fibonacci:
  fixes m::nat
  assumes "m>2"
  shows "fib m  dvd  (\<Prod>k=1..fib m - 1. k ^ k)"
Our comment on the codex statement: not quite right.
 *)
theorem exercise_2021_b4:
  fixes F R::"nat \<Rightarrow> nat"
  defines "isFib \<equiv> (\<lambda>f::nat\<Rightarrow>nat. f 0 = 0 \<and> f 1=1 \<and> (\<forall>n\<ge>2. f n = f (n-1) + f (n-2)))"
  assumes "isFib F" "R 0 = 0" "R 1 = 1"
  assumes "\<forall>m\<ge>2. R m = (\<Prod>k=1..F m-1. k^k) mod F m"
  shows "isFib R"
  oops

(*
problem_number:2020_b5
natural language statement:
For $j \in\{1,2,3,4\}$, let $z_{j}$ be a complex number with $\left|z_{j}\right|=1$
and $z_{j} \neq 1$. Prove that $3-z_{1}-z_{2}-z_{3}-z_{4}+z_{1} z_{2} z_{3} z_{4} \neq 0 .$
lean statement:

codex statement:
theorem sum_of_four_complex_number_neq_zero:
  fixes z::"complex set"
  assumes "card z = 4" "\<forall>x\<in>z. norm x = 1" "\<forall>x\<in>z. x \<noteq> 1"
  shows "3 - (\<Sum>x\<in>z. x) + (\<Prod>x\<in>z. x) \<noteq> 0"
Our comment on the codex statement: looks good to me!
 *)
theorem exercise_2020_b5:
  fixes z::"complex set"
  assumes "card z = 4" "\<forall>x\<in>z. norm x = 1" "\<forall>x\<in>z. x \<noteq> 1"
  shows "3 - (\<Sum>x\<in>z. x) + (\<Prod>x\<in>z. x) \<noteq> 0" oops

(*
problem_number:2018_a5
natural language statement:
Let $f: \mathbb{R} \rightarrow \mathbb{R}$ be an infinitely differentiable
 function satisfying $f(0)=0, f(1)=1$, and $f(x) \geq 0$ for all $x \in$ $\mathbb{R}$.
Show that there exist a positive integer $n$ and a real number $x$ such that $f^{(n)}(x)<0$.
lean statement:

codex statement:
theorem exists_n_x_of_derivative_neg:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x. f differentiable (at x)" "f 0 = 0" "f 1 = 1" "\<forall>x. 0 \<le> f x"
  shows "\<exists>n x. (deriv ^^ n) f x < 0"
Our comment on the codex statement: mostly correct except for the infinitely differentiable part.
 *)
theorem exercise_2018_a5:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x n. (deriv ^^ n) f differentiable (at x)" "f 0 = 0" "f 1 = 1" "\<forall>x. 0 \<le> f x"
  shows "\<exists>n>0. \<exists> x. (deriv ^^ n) f x < 0"
  oops

(*
problem_number:2018_b2
natural language statement:
Let $n$ be a positive integer, and let $f_{n}(z)=n+(n-1) z+$ $(n-2) z^{2}+\cdots+z^{n-1}$.
Prove that $f_{n}$ has no roots in the closed unit disk $\{z \in \mathbb{C}:|z| \leq 1\}$.
lean statement:

codex statement:
theorem no_roots_in_closed_unit_disk:
  fixes n::nat and f::"complex \<Rightarrow> complex"
  assumes "n>0"
  shows "\<forall>z. cmod z \<le> 1 \<longrightarrow> f z \<noteq> 0"
Our comment on the codex statement: the definition of 'f' is not quite right.
 *)
theorem exercise_2018_b2:
  fixes n::nat and f::"nat \<Rightarrow> complex \<Rightarrow> complex"
  assumes "n>0" "f n z = (\<Sum>i<n. (n-i)*z^i)"
  shows "\<forall>i>0. \<forall>z. cmod z \<le> 1 \<longrightarrow> f i z \<noteq> 0"
  oops

(*
problem_number:2018_b4
natural language statement:
Given a real number $a$, we define a sequence by $x_{0}=1$, $x_{1}=x_{2}=a$,
 and $x_{n+1}=2 x_{n} x_{n-1}-x_{n-2}$ for $n \geq 2$.
Prove that if $x_{n}=0$ for some $n$, then the sequence is periodic.
lean statement:

codex statement:
theorem periodic_of_zero_in_seq:
  fixes a::real
  assumes "\<exists>n. x n = 0"
  shows "\<exists>m. \<forall>n. x (n+m) = x n"
Our comment on the codex statement: the model knows what does it mean by a function being periodic,
  though it fails to define the sequence x properly.
 *)
theorem exercise_2018_b4:
  fixes a::real and x::"nat \<Rightarrow> real"
  assumes "\<exists>n. x n = 0" "x 0=1 " "x 1 = a" "x 2 = a" "\<forall>n\<ge>2. x (n+1) = 2 * x n *x (n-1) - x (n-2)"
  shows "(\<exists>n. x n = 0) \<longrightarrow> (\<exists>m>0. \<forall>n. x (n+m) = x n)" oops

(*
problem_number:2018_b6
natural language statement:
Let $S$ be the set of sequences of length 2018 whose terms are in the set $\{1,2,3,4,5,6,10\}$
  and sum to 3860 . Prove that the cardinality of $S$ is at most
  $2^{3860} \cdot\left(\frac{2018}{2048}\right)^{2018} .$
lean statement:

codex statement:
theorem card_set_of_sequences_leq_exp_of_sum_of_terms:
  fixes n::nat and S::"nat set"
  assumes "card S = 7" "n>0" "\<forall>x\<in>S. x\<le>n"
  shows "card {x. set x \<subseteq> S \<and> length x = n \<and> sum_list x = m} \<le> 2^m * (n/2^nat_ceiling_log2 n)^n"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2018_b6:
  fixes S::"(nat list) set"
  assumes "\<forall>xs\<in>S. length xs = 2018 \<and> sum_list xs =3860 \<and> (set xs \<subseteq> {1,2,3,4,5,6,10})"
  shows "card S \<le> floor (2^3860 * (2018 / 2048) ^ 2018)"
  oops

(*
problem_number:2017_b3
natural language statement:
Suppose that $f(x)=\sum_{i=0}^{\infty} c_{i} x^{i}$ is a power series
for which each coefficient $c_{i}$ is 0 or 1 . Show that if $f(2 / 3)=3 / 2$,
then $f(1 / 2)$ must be irrational.

lean statement:

codex statement:
theorem irrational_of_power_series_eq_frac:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x. f x = (\<Sum>i. c i * x^i)" "\<forall>i. c i = (0::real) \<or> c i = 1" "f (2/3) = 3/2"
  shows "irrational (f (1/2))"
Our comment on the codex statement: mostly correct, except for a minor error in the conclusion.
 *)

theorem exercise_2017_b3:
  fixes f::"real \<Rightarrow> real"
  assumes "\<forall>x. f x = suminf (\<lambda>i. c i * x^i)" "\<forall>i. c i = (0::real) \<or> c i = 1" "f (2/3) = 3/2"
  shows "(f (1/2)) \<notin> \<rat>"
  oops

(*
problem_number:2016_a6
natural language statement:
Suppose that $G$ is a finite group generated by the two elements $g$ and $h$,
where the order of $g$ is odd. Show that every element of $G$ can be written
 in the form $g^{m_1} h^{n_1} g^{m_2} h^{n_2} \cdots g^{m_r} h^{n_r}$
 with $1 \leq r \leq|G|$ and $m_1, n_1, m_2, n_2, \ldots, m_r, n_r \in$ $\{-1,1\} .$
(Here $|G|$ is the number of elements of $G$.)

lean statement:

codex statement:
theorem exists_odd_order_generator_of_finite_group:
  fixes G::"('a, 'b) monoid_scheme" (structure)
  assumes "group G" "finite (carrier G)" "order G = n" "\<exists>g. g \<in> carrier G \<and> order g = 2"
  shows "\<exists>g. g \<in> carrier G \<and> order g = 2"
Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2016_a6:
  undefined text \<open>Takes some efforts to define, revisit later\<close>
  oops

(*
problem_number:2015_b1
natural language statement:
Let $f$ be a three times differentiable function (defined on $\mathbb{R}$ and real-valued)
 such that $f$ has at least five distinct real zeros. Prove that $f+6 f^{\prime}
+12 f^{\prime \prime}+8 f^{\prime \prime \prime}$ has at least two distinct real zeros.

lean statement:

codex statement:

Our comment on the codex statement: <YOU CAN LEAVE YOUR COMMENT HERE>
 *)
theorem exercise_2015_b1:
  fixes f::"real\<Rightarrow> real" and roots::"real set"
  defines "roots_with \<equiv> (\<lambda>f::real\<Rightarrow>real. {x::real. f x = 0})"
  defines "g \<equiv> (\<lambda>x. f x + 6 * deriv f x + 12 * ((deriv ^^ 2) f x) + 8 * ((deriv ^^ 3) f x))"
  assumes "\<forall>k\<le>3. \<forall>x. (deriv ^^ k) f differentiable (at x)"
  assumes "infinite (roots_with f) \<or> card (roots_with f) \<ge>5"
  shows "infinite (roots_with g) \<or> card (roots_with g) \<ge> 2"
  oops

end


(*  Title:      HOL/Induct/PropLog.thy
    Author:     Tobias Nipkow
    Copyright   1994  TU Muenchen & University of Cambridge
*)

section \<open>Meta-theory of propositional logic\<close>

theory PropLog imports Main begin

text \<open>
  Datatype definition of propositional logic formulae and inductive
  definition of the propositional tautologies.

  Inductive definition of propositional logic.  Soundness and
  completeness w.r.t.\ truth-tables.

  Prove: If \<open>H \<Turnstile> p\<close> then \<open>G \<Turnstile> p\<close> where \<open>G \<in>
  Fin(H)\<close>
\<close>

subsection \<open>The datatype of propositions\<close>

datatype 'a pl =
    false
  | var 'a ("#_" [1000])
  | imp "'a pl" "'a pl" (infixr "\<rightharpoonup>" 90)

subsection \<open>The proof system\<close>

inductive thms :: "['a pl set, 'a pl] \<Rightarrow> bool"  (infixl "\<turnstile>" 50)
  for H :: "'a pl set"
  where
    H: "p \<in> H \<Longrightarrow> H \<turnstile> p"
  | K: "H \<turnstile> p\<rightharpoonup>q\<rightharpoonup>p"
  | S: "H \<turnstile> (p\<rightharpoonup>q\<rightharpoonup>r) \<rightharpoonup> (p\<rightharpoonup>q) \<rightharpoonup> p\<rightharpoonup>r"
  | DN: "H \<turnstile> ((p\<rightharpoonup>false) \<rightharpoonup> false) \<rightharpoonup> p"
  | MP: "\<lbrakk>H \<turnstile> p\<rightharpoonup>q; H \<turnstile> p\<rbrakk> \<Longrightarrow> H \<turnstile> q"

subsection \<open>The semantics\<close>

subsubsection \<open>Semantics of propositional logic.\<close>

primrec eval :: "['a set, 'a pl] => bool"  ("_[[_]]" [100,0] 100)
  where
    "tt[[false]] = False"
  | "tt[[#v]] = (v \<in> tt)"
  | eval_imp: "tt[[p\<rightharpoonup>q]] = (tt[[p]] \<longrightarrow> tt[[q]])"

text \<open>
  A finite set of hypotheses from \<open>t\<close> and the \<open>Var\<close>s in
  \<open>p\<close>.
\<close>

primrec hyps :: "['a pl, 'a set] => 'a pl set"
  where
    "hyps false  tt = {}"
  | "hyps (#v)   tt = {if v \<in> tt then #v else #v\<rightharpoonup>false}"
  | "hyps (p\<rightharpoonup>q) tt = hyps p tt Un hyps q tt"

subsubsection \<open>Logical consequence\<close>

text \<open>
  For every valuation, if all elements of \<open>H\<close> are true then so
  is \<open>p\<close>.
\<close>

definition sat :: "['a pl set, 'a pl] => bool"  (infixl "\<Turnstile>" 50)
  where "H \<Turnstile> p = (\<forall>tt. (\<forall>q\<in>H. tt[[q]]) \<longrightarrow> tt[[p]])"

subsection \<open>Proof theory of propositional logic\<close>

lemma thms_mono:
  assumes "G \<subseteq> H" shows "thms(G) \<le> thms(H)"
proof -
  have "G \<turnstile> p \<Longrightarrow> H \<turnstile> p" for p
    by (induction rule: thms.induct) (use assms in \<open>auto intro: thms.intros\<close>)
  then show ?thesis
    by blast
qed

lemma thms_I: "H \<turnstile> p\<rightharpoonup>p"
  \<comment> \<open>Called \<open>I\<close> for Identity Combinator, not for Introduction.\<close>
  by (best intro: thms.K thms.S thms.MP)

subsubsection \<open>Weakening, left and right\<close>

lemma weaken_left: "\<lbrakk>G \<subseteq> H;  G\<turnstile>p\<rbrakk> \<Longrightarrow> H\<turnstile>p"
  \<comment> \<open>Order of premises is convenient with \<open>THEN\<close>\<close>
  by (meson predicate1D thms_mono)

lemma weaken_left_insert: "G \<turnstile> p \<Longrightarrow> insert a G \<turnstile> p"
  by (meson subset_insertI weaken_left)

lemma weaken_left_Un1: "G \<turnstile> p \<Longrightarrow> G \<union> B \<turnstile> p"
  by (rule weaken_left) (rule Un_upper1)

lemma weaken_left_Un2: "G \<turnstile> p \<Longrightarrow> A \<union> G \<turnstile> p"
  by (metis Un_commute weaken_left_Un1)

lemma weaken_right: "H \<turnstile> q \<Longrightarrow> H \<turnstile> p\<rightharpoonup>q"
  using K MP by blast

subsubsection \<open>The deduction theorem\<close>

theorem deduction: "insert p H \<turnstile> q  \<Longrightarrow>  H \<turnstile> p\<rightharpoonup>q"
proof (induct set: thms)
  case (H p)
  then show ?case
    using thms.H thms_I weaken_right by fastforce
qed (metis thms.simps)+

subsubsection \<open>The cut rule\<close>

lemma cut: "insert p H \<turnstile> q \<Longrightarrow> H \<turnstile> p \<Longrightarrow> H \<turnstile> q"
  using MP deduction by blast

lemma thms_falseE: "H \<turnstile> false \<Longrightarrow> H \<turnstile> q"
  by (metis thms.simps)

lemma thms_notE: "H \<turnstile> p \<rightharpoonup> false \<Longrightarrow> H \<turnstile> p \<Longrightarrow> H \<turnstile> q"
  using MP thms_falseE by blast

subsubsection \<open>Soundness of the rules wrt truth-table semantics\<close>

theorem soundness: "H \<turnstile> p \<Longrightarrow> H \<Turnstile> p"
  by (induct set: thms) (auto simp: sat_def)

subsection \<open>Completeness\<close>

subsubsection \<open>Towards the completeness proof\<close>

lemma false_imp: "H \<turnstile> p\<rightharpoonup>false \<Longrightarrow> H \<turnstile> p\<rightharpoonup>q"
  by (metis thms.simps)

lemma imp_false:
  "\<lbrakk>H \<turnstile> p;  H \<turnstile> q\<rightharpoonup>false\<rbrakk> \<Longrightarrow> H \<turnstile> (p\<rightharpoonup>q)\<rightharpoonup>false"
  by (meson MP S weaken_right)

lemma hyps_thms_if: "hyps p tt \<turnstile> (if tt[[p]] then p else p\<rightharpoonup>false)"
  \<comment> \<open>Typical example of strengthening the induction statement.\<close>
proof (induction p)
  case (imp p1 p2)
  then show ?case
    by (metis (full_types) eval_imp false_imp hyps.simps(3) imp_false weaken_left_Un1 weaken_left_Un2 weaken_right)

qed (simp_all add: thms_I thms.H)

lemma sat_thms_p: "{} \<Turnstile> p \<Longrightarrow> hyps p tt \<turnstile> p"
  \<comment> \<open>Key lemma for completeness; yields a set of assumptions
        satisfying \<open>p\<close>\<close>
  by (metis (full_types) empty_iff hyps_thms_if sat_def)

text \<open>
  For proving certain theorems in our new propositional logic.
\<close>

declare deduction [intro!]
declare thms.H [THEN thms.MP, intro]

text \<open>
  The excluded middle in the form of an elimination rule.
\<close>

lemma thms_excluded_middle: "H \<turnstile> (p\<rightharpoonup>q) \<rightharpoonup> ((p\<rightharpoonup>false)\<rightharpoonup>q) \<rightharpoonup> q"
proof -
  have "insert ((p \<rightharpoonup> false) \<rightharpoonup> q) (insert (p \<rightharpoonup> q) H) \<turnstile> (q \<rightharpoonup> false) \<rightharpoonup> false"
    by (best intro: H)
  then show ?thesis
    by (metis deduction thms.simps)
qed

lemma thms_excluded_middle_rule:
  "\<lbrakk>insert p H \<turnstile> q;  insert (p\<rightharpoonup>false) H \<turnstile> q\<rbrakk> \<Longrightarrow> H \<turnstile> q"
  \<comment> \<open>Hard to prove directly because it requires cuts\<close>
  by (rule thms_excluded_middle [THEN thms.MP, THEN thms.MP], auto)

subsection\<open>Completeness -- lemmas for reducing the set of assumptions\<close>

text \<open>
  For the case \<^prop>\<open>hyps p t - insert #v Y \<turnstile> p\<close> we also have \<^prop>\<open>hyps p t - {#v} \<subseteq> hyps p (t-{v})\<close>.
\<close>

lemma hyps_Diff: "hyps p (t-{v}) \<subseteq> insert (#v\<rightharpoonup>false) ((hyps p t)-{#v})"
  by (induct p) auto

text \<open>
  For the case \<^prop>\<open>hyps p t - insert (#v \<rightharpoonup> Fls) Y \<turnstile> p\<close> we also have
  \<^prop>\<open>hyps p t-{#v\<rightharpoonup>Fls} \<subseteq> hyps p (insert v t)\<close>.
\<close>

lemma hyps_insert: "hyps p (insert v t) \<subseteq> insert (#v) (hyps p t-{#v\<rightharpoonup>false})"
  by (induct p) auto

text \<open>Two lemmas for use with \<open>weaken_left\<close>\<close>

lemma insert_Diff_same: "B-C \<subseteq> insert a (B-insert a C)"
  by fast

lemma insert_Diff_subset2: "insert a (B-{c}) - D \<subseteq> insert a (B-insert c D)"
  by fast

text \<open>
  The set \<^term>\<open>hyps p t\<close> is finite, and elements have the form
  \<^term>\<open>#v\<close> or \<^term>\<open>#v\<rightharpoonup>Fls\<close>.
\<close>

lemma hyps_finite: "finite(hyps p t)"
  by (induct p) auto

lemma hyps_subset: "hyps p t \<subseteq> (UN v. {#v, #v\<rightharpoonup>false})"
  by (induct p) auto

lemma Diff_weaken_left: "A \<subseteq> C \<Longrightarrow> A - B \<turnstile> p \<Longrightarrow> C - B \<turnstile> p"
  by (rule Diff_mono [OF _ subset_refl, THEN weaken_left])

subsubsection \<open>Completeness theorem\<close>

text \<open>
  Induction on the finite set of assumptions \<^term>\<open>hyps p t0\<close>.  We
  may repeatedly subtract assumptions until none are left!
\<close>

lemma completeness_0:
  assumes "{} \<Turnstile> p"
  shows "{} \<turnstile> p"
proof -
  { fix t t0
    have "hyps p t - hyps p t0 \<turnstile> p"
      using hyps_finite hyps_subset
    proof (induction arbitrary: t rule: finite_subset_induct)
      case empty
      then show ?case
        by (simp add: assms sat_thms_p)
    next
      case (insert q H)
      then consider v where "q = #v" | v where "q = #v \<rightharpoonup> false"
        by blast
      then show ?case
      proof cases
        case 1
        then show ?thesis
          by (metis (no_types, lifting) insert.IH thms_excluded_middle_rule insert_Diff_same
              insert_Diff_subset2 weaken_left Diff_weaken_left hyps_Diff)
      next
        case 2
        then show ?thesis
          by (metis (no_types, lifting) insert.IH thms_excluded_middle_rule insert_Diff_same
              insert_Diff_subset2 weaken_left Diff_weaken_left hyps_insert)
      qed
    qed
  }
  then show ?thesis
    by (metis Diff_cancel)
qed

text\<open>A semantic analogue of the Deduction Theorem\<close>
lemma sat_imp: "insert p H \<Turnstile> q \<Longrightarrow> H \<Turnstile> p\<rightharpoonup>q"
  by (auto simp: sat_def)

theorem completeness: "finite H \<Longrightarrow> H \<Turnstile> p \<Longrightarrow> H \<turnstile> p"
proof (induction arbitrary: p rule: finite_induct)
  case empty
  then show ?case
    by (simp add: completeness_0)
next
  case insert
  then show ?case
    by (meson H MP insertI1 sat_imp weaken_left_insert)
qed

theorem syntax_iff_semantics: "finite H \<Longrightarrow> (H \<turnstile> p) = (H \<Turnstile> p)"
  by (blast intro: soundness completeness)

end


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

From Misra, "A Logic for Concurrent Programming", 1994
*)

section\<open>Fixed Point of a Program\<close>

theory FP imports UNITY begin

definition FP_Orig :: "'a program => 'a set" where
    "FP_Orig F == \<Union>{A. \<forall>B. F \<in> stable (A \<inter> B)}"

definition FP :: "'a program => 'a set" where
    "FP F == {s. F \<in> stable {s}}"

lemma stable_FP_Orig_Int: "F \<in> stable (FP_Orig F Int B)"
apply (simp only: FP_Orig_def stable_def Int_Union2)
apply (blast intro: constrains_UN)
done

lemma FP_Orig_weakest:
    "(\<And>B. F \<in> stable (A \<inter> B)) \<Longrightarrow> A <= FP_Orig F"
by (simp add: FP_Orig_def stable_def, blast)

lemma stable_FP_Int: "F \<in> stable (FP F \<inter> B)"
proof -
  have "F \<in> stable (\<Union>x\<in>B. FP F \<inter> {x})"
    apply (simp only: Int_insert_right FP_def stable_def)
    apply (rule constrains_UN)
    apply simp
    done
  also have "(\<Union>x\<in>B. FP F \<inter> {x}) = FP F \<inter> B"
    by simp
  finally show ?thesis .
qed

lemma FP_equivalence: "FP F = FP_Orig F"
apply (rule equalityI)
 apply (rule stable_FP_Int [THEN FP_Orig_weakest])
apply (simp add: FP_Orig_def FP_def, clarify)
apply (drule_tac x = "{x}" in spec)
apply (simp add: Int_insert_right)
done

lemma FP_weakest:
    "(\<And>B. F \<in> stable (A Int B)) \<Longrightarrow> A <= FP F"
by (simp add: FP_equivalence FP_Orig_weakest)

lemma Compl_FP:
    "-(FP F) = (UN act: Acts F. -{s. act``{s} <= {s}})"
by (simp add: FP_def stable_def constrains_def, blast)

lemma Diff_FP: "A - (FP F) = (UN act: Acts F. A - {s. act``{s} <= {s}})"
by (simp add: Diff_eq Compl_FP)

lemma totalize_FP [simp]: "FP (totalize F) = FP F"
by (simp add: FP_def)

end


(*  Title:      HOL/HOLCF/IOA/ABP/Lemmas.thy
    Author:     Olaf Müller
*)

theory Lemmas
imports Main
begin

subsection \<open>Logic\<close>

lemma and_de_morgan_and_absorbe: "(\<not>(A\<and>B)) = ((\<not>A)\<and>B\<or> \<not>B)"
  by blast

lemma bool_if_impl_or: "(if C then A else B) \<longrightarrow> (A\<or>B)"
  by auto

lemma exis_elim: "(\<exists>x. x=P \<and> Q(x)) = Q(P)"
  by blast

subsection \<open>Sets\<close>

lemma set_lemmas:
    "f(x) \<in> (\<Union>x. {f(x)})"
    "f x y \<in> (\<Union>x y. {f x y})"
    "\<And>a. (\<forall>x. a \<noteq> f(x)) \<Longrightarrow> a \<notin> (\<Union>x. {f(x)})"
    "\<And>a. (\<forall>x y. a \<noteq> f x y) ==> a \<notin> (\<Union>x y. {f x y})"
  by auto

text \<open>2 Lemmas to add to \<open>set_lemmas\<close>, used also for action handling,
   namely for Intersections and the empty list (compatibility of IOA!).\<close>
lemma singleton_set: "(\<Union>b.{x. x=f(b)}) = (\<Union>b.{f(b)})"
  by blast

lemma de_morgan: "((A\<or>B)=False) = ((\<not>A)\<and>(\<not>B))"
  by blast

subsection \<open>Lists\<close>

lemma cons_not_nil: "l \<noteq> [] \<longrightarrow> (\<exists>x xs. l = (x#xs))"
  by (induct l) simp_all

end


theory SetRel
  imports
    "../GST_Features" "../OPair/CartProd" "../Relations/Relations"
    SetComprehension SetCombinators
begin

(*Developments that use sets and ordered pairs!
    e.g., relations as sets, functions as sets, cartesian product
  The SetRel interface abstracts over the representation of sets and pairs.*)
context CartProd begin

section \<open>Relations and Functions as sets of ordered pairs\<close>

definition setrel_app
  where "setrel_app r a b \<equiv> a : SetMem \<and> b : SetMem \<and> pair a b \<in> r"
definition mk_setrel
  where "mk_setrel x y P \<equiv> Collect (cprod x y) (\<lambda>p. P (fst p) (snd p))"
definition setrel_field
  where "setrel_field r \<equiv> RepFun r fst \<union> RepFun r snd"

theorem GZF_BinRel :
  "class.BinRel_axioms Set (\<in>) (\<subseteq>) SetOf
    setrel_app (SetOf (SetMem * SetMem)) mk_setrel setrel_field
    (\<lambda>x. \<P> (x \<times> x)) SetMem"
proof
  show mkrel_typ : "mk_setrel : Set \<rightarrow> Set \<rightarrow> Any \<rightarrow> SetOf (SetMem * SetMem)"
    unfolding mk_setrel_def
  proof (rule funI, rule funI, rule funI, rule collect_typ_subset)
    fix x y assume "x : Set" "y : Set"
    hence "x : SetOf SetMem" "y : SetOf SetMem" using setofI setmemI by auto
    thus "x \<times> y : SetOf (SetMem * SetMem)" using cprod_setof_prod by auto
  qed

  show "setrel_field : SetOf (SetMem * SetMem) \<rightarrow> Set"
    unfolding setrel_field_def
  by (rule funI, rule un_set[OF repfun_set repfun_set], use setof_set in auto)

  show "(\<lambda>x. \<P> (x \<times> x)) : Set \<rightarrow> SetOf (SetOf (SetMem * SetMem))"
  proof (rule funI, rule setofI, rule pow_set[OF cprod_set],
         auto, rule setofI)
    fix x r assume
      x : "x : Set" and r : "r \<in> \<P> (x \<times> x)"
    thus "r : Set"
      using setof_mem[OF pow_setof[OF cprod_set[OF x x]]]
      by auto
   fix p assume "p \<in> r"
   moreover have "r \<subseteq> x \<times> x"
      using powD[OF cprod_set[OF x x] r] .
   ultimately show "p : SetMem * SetMem"
    using cprod_setof_prod[OF set_setof set_setof, OF x x, THEN setof_mem]
      by auto
  qed

 show "\<forall>x : Set. \<forall>y : Set. \<forall>P.
          \<forall>a b. setrel_app (mk_setrel x y P) a b \<longleftrightarrow>
            (a \<in> x \<and> b \<in> y \<and> P a b \<and> a : SetMem \<and> b : SetMem)"
  proof (rule, rule, rule, rule, rule, rule)
    fix x y P a b assume "x : Set" "y : Set"
    hence rtyp : "mk_setrel x y P : SetOf (SetMem * SetMem)"
      by (rule funE[OF funE[OF funE[OF mkrel_typ]] anyI])

    show "setrel_app (mk_setrel x y P) a b \<Longrightarrow>
      (a \<in> x \<and> b \<in> y \<and> P a b \<and> a : SetMem \<and> b : SetMem)"
    unfolding setrel_app_def proof (auto)
      assume "a : SetMem" "b : SetMem" "<a, b> \<in> mk_setrel x y P"
      hence "<a,b> : Pair" "<a,b> \<in> x \<times> y" "P (fst (pair a b)) (snd (pair a b))"
          using setmem_pair mk_setrel_def collect_iff[OF cprod_set[OF \<open>x : Set\<close> \<open>y : Set\<close>]] by auto
      thus "a \<in> x" "b \<in> y" "P a b" using fst_eq snd_eq cprod_iff_pair[OF \<open>x : Set\<close> \<open>y : Set\<close>] by auto
    qed
    show "a \<in> x \<and> b \<in> y \<and> P a b \<and> a : SetMem \<and> b : SetMem \<Longrightarrow>
      setrel_app (mk_setrel x y P) a b"
      unfolding setrel_app_def mk_setrel_def
    proof (auto intro: setmemI[OF \<open>x : Set\<close>] setmemI[OF \<open>y : Set\<close>],
           rule collectI[OF cprod_set[OF \<open>x : Set\<close> \<open>y : Set\<close>]],
           auto intro: cprodI_pair[OF \<open>x : Set\<close> \<open>y : Set\<close>])
      assume "a \<in> x" "b \<in> y" "P a b"
      moreover hence "pair a b : Pair" using setmemI \<open>x : Set\<close> \<open>y : Set\<close> setmem_pair by auto
      ultimately show "P (\<tau> (pair a b)) (\<pi> (pair a b))"
        using fst_eq snd_eq by auto
    qed
  qed

  show "\<forall>r : SetOf (SetMem * SetMem). \<forall>s : SetOf (SetMem * SetMem).
          (\<forall>a b. setrel_app r a b = setrel_app s a b) \<longrightarrow> r = s"
  proof (rule)+
    fix r s assume
      r: "r : SetOf (SetMem * SetMem)" and
      s: "s : SetOf (SetMem * SetMem)" and
      ab:"\<forall>a b. setrel_app r a b \<longleftrightarrow> setrel_app s a b"
    show "r = s"
    proof (rule equality_iffI[OF setof_set[OF r] setof_set[OF s]])
      fix p show "p \<in> r \<longleftrightarrow> p \<in> s"
      proof
        assume "p \<in> r"
        moreover then obtain a b where
          "p = pair a b" "a : SetMem" "b : SetMem"
          using setof_mem[OF r] by (blast elim: productE)
        ultimately have "setrel_app r a b"
          unfolding setrel_app_def by auto
        hence "setrel_app s a b" using ab by simp
        thus "p \<in> s" unfolding setrel_app_def using ab \<open>p = pair a b\<close> \<open>p \<in> r\<close> by auto
      next
        assume "p \<in> s"
        moreover then obtain a b where
          "p = pair a b" "a : SetMem" "b : SetMem"
          using setof_mem[OF s] by (blast elim: productE)
        ultimately have "setrel_app s a b"
          unfolding setrel_app_def by auto
        hence "setrel_app r a b" using ab by simp
        thus "p \<in> r"
          unfolding setrel_app_def
          using ab \<open>p = pair a b\<close> \<open>p \<in> s\<close> by auto
      qed
    qed
  qed

  show "\<forall>r : SetOf (SetMem * SetMem).
    \<forall>x. (x \<in> setrel_field r) = (\<exists>y. setrel_app r x y \<or> setrel_app r y x)"
  proof (rule, rule)
    fix r x assume rtyp:"r : SetOf (SetMem * SetMem)"
    hence rset:"r : Set" by (rule setof_set)

    show "x \<in> setrel_field r \<longleftrightarrow> (\<exists>y. setrel_app r x y \<or> setrel_app r y x)"
      unfolding setrel_field_def
    proof (rule)
      assume "x \<in> RepFun r \<tau> \<union> RepFun r \<pi>"
      thus "\<exists>y. setrel_app r x y \<or> setrel_app r y x"
      proof (rule unE[OF repfun_set[OF rset] repfun_set[OF rset]])
        assume "x \<in> RepFun r \<tau>"
        then obtain p where p:"p \<in> r" "x = fst p" by (rule repfunE[OF rset])
        hence "p : SetMem * SetMem" using setof_mem[OF rtyp] by auto
        then obtain a b where "p : Pair" "p = pair a b" "a : SetMem" "b : SetMem"
          using setmem_pair by (blast elim: productE)
        thus "\<exists>y. setrel_app r x y \<or> setrel_app r y x"
          unfolding setrel_app_def using p by auto
      next
        assume "x \<in> RepFun r \<pi>"
        then obtain p where p:"p \<in> r" "x = snd p" by (rule repfunE[OF rset])
        hence "p : SetMem * SetMem" using setof_mem[OF rtyp] by auto
        then obtain a b where "p : Pair" "p = pair a b" "a : SetMem" "b : SetMem"
          using setmem_pair by (blast elim: productE)
        thus "\<exists>y. setrel_app r x y \<or> setrel_app r y x"
          unfolding setrel_app_def using p by auto
      qed
    next
      assume "\<exists>y. setrel_app r x y \<or> setrel_app r y x"
      then obtain y where
        "x : SetMem" "y : SetMem" and
        xy:"pair x y \<in> r \<or> pair y x \<in> r"
        unfolding setrel_app_def by blast
      hence fstx:"x = fst (pair x y)" and sndx:"x = snd (pair y x)"
        using fst_eq snd_eq setmem_pair by auto
      show "x \<in> RepFun r fst \<union> RepFun r snd"
        unfolding un_iff[OF repfun_set[OF rset] repfun_set[OF rset]]
      proof (rule disjE[OF xy], rule_tac [1] disjI1 , rule_tac [2] disjI2)
        assume "pair x y \<in> r" thus "x \<in> RepFun r fst"
          using repfunI[OF rset, of "pair x y" fst] fstx \<open>x : SetMem\<close> by auto
      next
        assume "pair y x \<in> r" thus "x \<in> RepFun r snd"
          using repfunI[OF rset, of "pair y x" snd] sndx \<open>x : SetMem\<close> by auto
      qed
    qed
  qed

  show "\<forall>x : Set. \<forall>r : SetOf (SetMem * SetMem).
          (r \<in> \<P> (x \<times> x)) = (setrel_field r \<subseteq> x)"
  proof (rule, rule)
    fix x r assume x : "x : Set" and r : "r : SetOf (SetMem * SetMem)"
    hence r' : "r : Set" using setof_set[OF r] by auto
    show "(r \<in> \<P> (x \<times> x)) \<longleftrightarrow> (setrel_field r \<subseteq> x)"
    proof
      assume "r \<in> \<P> (x \<times> x)"
      hence r_sub : "r \<subseteq> x \<times> x"
        using powD[OF cprod_set[OF x x]] by auto
      show "setrel_field r \<subseteq> x"
      proof
        fix b assume "b \<in> setrel_field r"
        hence "b \<in> RepFun r fst \<or> b \<in> RepFun r snd"
          unfolding setrel_field_def un_iff[OF repfun_set repfun_set, OF r' r'] .
        then obtain p where "p \<in> r" "b = fst p \<or> b = snd p"
          using repfunE[OF r'] by metis
        thus "b \<in> x"
          using fst_set[OF x x] snd_set[OF x x] r_sub by auto
      qed
    next
      assume f_sub:"setrel_field r \<subseteq> x"
      show "r \<in> \<P> (x \<times> x)"
      proof (rule powI[OF r' cprod_set[OF x x]], rule)
        fix p assume "p \<in> r"
        moreover hence
          "p : Pair" "fst p : SetMem" "snd p : SetMem"
          using productD[OF setof_mem[OF r]] by auto
        ultimately have
          "fst p \<in> RepFun r fst" "snd p \<in> RepFun r snd"
          using repfunI[OF r'] by auto
        hence "fst p \<in> x" "snd p \<in> x"
          using f_sub un_iff[OF repfun_set repfun_set, OF r' r']
          unfolding setrel_field_def by auto
        thus "p \<in> x \<times> x"
          using pair_proj_eq[OF \<open>p : Pair\<close>]
            cprodI_pair[OF x x, of \<open>\<tau> p\<close> \<open>\<pi> p\<close>] by auto
      qed
    qed
  qed

  show "SetMem = (\<lambda>b. \<exists>r : SetOf (SetMem * SetMem). \<exists>c. setrel_app r b c \<or> setrel_app r c b)"
  proof -
    have eq:"\<forall>b. b : SetMem \<longleftrightarrow> (\<exists>r : SetOf (SetMem * SetMem). \<exists>c. setrel_app r b c \<or> setrel_app r c b)"
      unfolding setrel_app_def
    proof (auto)
      fix b assume b: "b : SetMem"
      hence bb_smem: "<b,b> : SetMem" and "<b,b> : SetMem * SetMem"
        using pair_setmem[OF smem_pmem smem_pmem, of b b]
              productI[OF setmem_pair, of b b SetMem SetMem] by auto
      hence "{<b,b>} : SetOf (SetMem * SetMem)"
        using setofI[OF sng_set[of \<open><b,b>\<close>], of \<open>SetMem * SetMem\<close>] sng_iff by auto
      thus "\<exists>r : SetOf (SetMem * SetMem).
              \<exists>c. c : SetMem \<and> \<langle>b,c\<rangle> \<in> r \<or> c : SetMem \<and> \<langle>c,b\<rangle> \<in> r "
        using bb_smem b sngI[OF bb_smem]
        unfolding tex_def by auto
    qed
    show ?thesis
      by (rule, insert spec[OF eq], unfold has_ty_def, auto)
  qed
qed

sublocale BinRel
  where BinRel = "SetOf (SetMem * SetMem)"
    and app = setrel_app
    and mkrel = mk_setrel
    and field = setrel_field
    and relspace = \<open>(\<lambda>x. \<P> (x \<times> x))\<close>
    and BinRelMem = SetMem
    and BinRelation_default = GZF_default
  using GZF_BinRel by intro_locales

theorem GZF_Function :
  "class.Function_axioms Set (\<in>) (\<subseteq>) SetOf setrel_app
     FuncRel mk_funrel domain range mk_funspace SetMem FuncRelPred"
  using BinRel_Function .

sublocale Function
  where Function = FuncRel
    and app = setrel_app
    and mkfun = mk_funrel
    and dom = domain
    and ran = range
    and funspace = mk_funspace
    and FunMem = SetMem
    and FunPred = FuncRelPred
  using GZF_Function by intro_locales

end
end


(* Title:     MiniML/Generalize.thy
   Author:    Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "Generalizing type schemes with respect to a context"

theory Generalize
imports Instance
begin

\<comment> \<open>@{text gen}: binding (generalising) the variables which are not free in the context\<close>

type_synonym ctxt = "type_scheme list"

primrec gen :: "[ctxt, typ] => type_scheme" where
  "gen A (TVar n) = (if (n:(free_tv A)) then (FVar n) else (BVar n))"
| "gen A (t1 -> t2) = (gen A t1) =-> (gen A t2)"

\<comment> \<open>executable version of @{text gen}: implementation with @{text free_tv_ML}\<close>

primrec gen_ML_aux :: "[nat list, typ] => type_scheme" where
  "gen_ML_aux A (TVar n) = (if (n: set A) then (FVar n) else (BVar n))"
| "gen_ML_aux A (t1 -> t2) = (gen_ML_aux A t1) =-> (gen_ML_aux A t2)"

definition gen_ML :: "[ctxt, typ] => type_scheme" where
  gen_ML_def: "gen_ML A t = gen_ML_aux (free_tv_ML A) t"

declare equalityE [elim!]

lemma gen_eq_on_free_tv:
    "free_tv A = free_tv B \<Longrightarrow> gen A t = gen B t"
  by (induct t) simp_all

lemma gen_without_effect [simp]:
    "(free_tv t) \<subseteq> (free_tv sch) \<Longrightarrow> gen sch t = (mk_scheme t)"
  by (induct t) auto

lemma free_tv_gen [simp]:
  "free_tv (gen ($ S A) t) = free_tv t Int free_tv ($ S A)"
by (induct t) auto

lemma free_tv_gen_cons [simp]:
  "free_tv (gen ($ S A) t # $ S A) = free_tv ($ S A)"
  by fastforce

lemma bound_tv_gen [simp]:
  "bound_tv (gen A t) = free_tv t - free_tv A"
by (induction t) auto

lemma new_tv_compatible_gen: "new_tv n t \<Longrightarrow> new_tv n (gen A t)"
by (induction t) auto

lemma gen_eq_gen_ML: "gen A t = gen_ML A t"
apply (unfold gen_ML_def)
apply (induct t)
 apply (simp add: free_tv_ML_scheme_list)
apply (simp add: free_tv_ML_scheme_list)
done

lemma gen_subst_commutes [rule_format]:
  "(free_tv S) Int ((free_tv t) - (free_tv A)) = {}
      \<longrightarrow> gen ($ S A) ($ S t) = $ S (gen A t)"
apply (induct t)
 apply (intro strip)
 apply (rename_tac nat)
 apply (case_tac "nat : (free_tv A) ")
  apply (simp (no_asm_simp))
 apply simp
 apply (subgoal_tac "nat \<notin> free_tv S")
  prefer 2 apply (fast)
 apply (simp add: free_tv_subst dom_def)
 apply (cut_tac free_tv_app_subst_scheme_list)
 apply fast
apply simp
apply blast
done

lemma bound_typ_inst_gen [simp]:
  "free_tv(t::typ) \<subseteq> free_tv(A) \<Longrightarrow> bound_typ_inst S (gen A t) = t"
by (induct t) simp_all

lemma gen_bound_typ_instance:
  "gen ($ S A) ($ S t) \<le> $ S (gen A t)"
apply (unfold le_type_scheme_def is_bound_typ_instance)
apply safe
apply (rename_tac "R")
apply (rule_tac x = " (\<lambda>a. bound_typ_inst R (gen ($S A) (S a))) " in exI)
apply (induct_tac "t")
 apply simp
apply simp
done

lemma free_tv_subset_gen_le:
  "free_tv B \<subseteq> free_tv A \<Longrightarrow> gen A t \<le> gen B t"
apply (unfold le_type_scheme_def is_bound_typ_instance)
apply safe
apply (rename_tac "S")
apply (rule_tac x = "\<lambda>b. if b:free_tv A then TVar b else S b" in exI)
apply (induct_tac "t")
 apply fastforce
apply simp
done

lemma gen_t_le_gen_alpha_t [rule_format, simp]:
  "new_tv n A \<longrightarrow>
   gen A t \<le> gen A ($ (\<lambda>x. TVar (if x \<in> free_tv A then x else n + x)) t)"
apply (unfold le_type_scheme_def is_bound_typ_instance)
apply (intro strip)
apply (erule exE)
apply (hypsubst)
apply (rule_tac x = " (\<lambda>x. S (if n \<le> x then x - n else x))" in exI)
apply (induct t)
apply (simp (no_asm))
apply (rename_tac nat S)
apply (case_tac "nat \<in> free_tv A")
apply (simp (no_asm_simp))
apply (simp (no_asm_simp))
apply (subgoal_tac "n \<le> n + nat")
apply (frule_tac t = "A" in new_tv_le)
apply assumption
apply (drule new_tv_not_free_tv)
apply (drule new_tv_not_free_tv)
apply (simp add: diff_add_inverse)
apply (simp add: le_add1)
apply simp
done

end


(*
  File: Arith_Thms.thy
  Author: Bohua Zhan

  Setup for proof steps related to arithmetic, mostly on natural numbers.
*)

section \<open>Setup for arithmetic\<close>

theory Arith_Thms
  imports Order_Thms HOL.Binomial
begin

(* Reducing inequality on natural numbers. *)
theorem reduce_le_plus_consts: "(x::nat) + n1 \<le> y + n2 \<Longrightarrow> x \<le> y + (n2-n1)" by simp
theorem reduce_le_plus_consts': "n1 \<ge> n2 \<Longrightarrow> (x::nat) + n1 \<le> y + n2 \<Longrightarrow> x + (n1-n2) \<le> y" by simp
theorem reduce_less_plus_consts: "(x::nat) + n1 < y + n2 \<Longrightarrow> x < y + (n2-n1)" by simp
theorem reduce_less_plus_consts': "n1 \<ge> n2 \<Longrightarrow> (x::nat) + n1 < y + n2 \<Longrightarrow> x + (n1-n2) < y" by simp

(* To normal form. *)
theorem norm_less_lminus: "(x::nat) - n < y \<Longrightarrow> x \<le> y + (n-1)" by simp
theorem norm_less_lplus:  "(x::nat) + n < y \<Longrightarrow> x + (n+1) \<le> y" by simp
theorem norm_less_rminus: "(x::nat) < y - n \<Longrightarrow> x + (n+1) \<le> y" by simp
theorem norm_less_rplus:  "(x::nat) < y + n \<Longrightarrow> x \<le> y + (n-1)" by simp
theorem norm_less:        "(x::nat) < y     \<Longrightarrow> x + 1 \<le> y"     by simp
theorem norm_le_lminus: "(x::nat) - n \<le> y \<Longrightarrow> x \<le> y + n"  by simp
theorem norm_le_rminus: "(x::nat) \<le> y - n \<Longrightarrow> x \<le> y + 0"  by simp
theorem norm_le: "(x::nat) \<le> y \<Longrightarrow> x \<le> y + 0" by simp
theorem norm_le_lplus0: "(x::nat) + 0 \<le> y \<Longrightarrow> x \<le> y + 0" by simp

(* Transitive resolve. *)
theorem trans_resolve1: "n1 > 0 \<Longrightarrow> (x::nat) + n1 \<le> y \<Longrightarrow> (y::nat) + n2 \<le> x \<Longrightarrow> False" by simp
theorem trans_resolve2: "n1 > n2 \<Longrightarrow> (x::nat) + n1 \<le> y \<Longrightarrow> (y::nat) \<le> x + n2 \<Longrightarrow> False" by simp

(* Transitive. *)
theorem trans1: "(x::nat) + n1 \<le> y \<Longrightarrow> y + n2 \<le> z \<Longrightarrow> x + (n1+n2) \<le> z" by simp
theorem trans2: "(x::nat) \<le> y + n1 \<Longrightarrow> y \<le> z + n2 \<Longrightarrow> x \<le> z + (n1+n2)" by simp
theorem trans3: "(x::nat) + n1 \<le> y \<Longrightarrow> y \<le> z + n2 \<Longrightarrow> x \<le> z + (n2-n1)" by simp
theorem trans4: "n1 > n2 \<Longrightarrow> (x::nat) + n1 \<le> y \<Longrightarrow> y \<le> z + n2 \<Longrightarrow> x + (n1-n2) \<le> z" by simp
theorem trans5: "(x::nat) \<le> y + n1 \<Longrightarrow> y + n2 \<le> z \<Longrightarrow> x \<le> z + (n1-n2)" by simp
theorem trans6: "n2 > n1 \<Longrightarrow> (x::nat) \<le> y + n1 \<Longrightarrow> y + n2 \<le> z \<Longrightarrow> x + (n2-n1) \<le> z" by simp

(* Resolve. *)
theorem single_resolve: "n > 0 \<Longrightarrow> (x::nat) + n \<le> x \<Longrightarrow> False" by simp
theorem single_resolve_const: "n > 0 \<Longrightarrow> (x::nat) + n \<le> 0 \<Longrightarrow> False" by simp

(* Comparison with constants. *)
theorem cv_const1: "(x::nat) + n \<le> y \<Longrightarrow> 0 + (x+n) \<le> y" by simp  (* x is const *)
theorem cv_const2: "(x::nat) + n \<le> y \<Longrightarrow> x \<le> 0 + (y-n)" by simp  (* y is const *)
theorem cv_const3: "y < n \<Longrightarrow> (x::nat) + n \<le> y \<Longrightarrow> x + (n-y) \<le> 0" by simp  (* y is const (contradiction with 0 \<le> x) *)
theorem cv_const4: "(x::nat) \<le> y + n \<Longrightarrow> 0 + (x-n) \<le> y" by simp  (* x is const *)
theorem cv_const5: "(x::nat) \<le> y + n \<Longrightarrow> 0 \<le> y + (n-x)" by simp  (* x is const (trivial) *)
theorem cv_const6: "(x::nat) \<le> y + n \<Longrightarrow> x \<le> 0 + (y+n)" by simp  (* y is const *)

(* Misc *)
theorem nat_eq_to_ineqs: "(x::nat) = y + n \<Longrightarrow> x \<le> y + n \<and> x \<ge> y + n" by simp
theorem nat_ineq_impl_not_eq: "(x::nat) + n \<le> y \<Longrightarrow> n > 0 \<Longrightarrow> x \<noteq> y" by simp
theorem eq_to_ineqs: "(x::nat) \<equiv> y \<Longrightarrow> x \<le> y \<and> y \<le> x" by simp
theorem ineq_to_eqs1: "(x::nat) \<le> y + 0 \<Longrightarrow> y \<le> x + 0 \<Longrightarrow> x = y" by simp

ML_file \<open>arith.ML\<close>
ML_file \<open>order.ML\<close>
ML_file \<open>order_test.ML\<close>

setup \<open>register_wellform_data ("(a::nat) - b", ["a \<ge> b"])\<close>
setup \<open>add_prfstep_check_req ("(a::nat) - b", "(a::nat) \<ge> b")\<close>

(* Normalize any expression to "a - b" form. *)
lemma nat_sub_norm:
  "(a::nat) = a - 0 \<and> a \<ge> 0" by simp

(* Adding and subtracting two normalized expressions. *)
lemma nat_sub1:
  "(a::nat) \<ge> b \<Longrightarrow> c \<ge> d \<Longrightarrow> (a - b) + (c - d) = (a + c) - (b + d) \<and> a + c \<ge> b + d" by simp

lemma nat_sub2:
  "(a::nat) \<ge> b \<Longrightarrow> c \<ge> d \<Longrightarrow> a - b \<ge> c - d \<Longrightarrow> (a - b) - (c - d) = (a + d) - (b + c) \<and> a + d \<ge> b + c" by simp

lemma nat_sub3:
  "(a::nat) \<ge> b \<Longrightarrow> c \<ge> d \<Longrightarrow> (a - b) * (c - d) = (a * c + b * d) - (a * d + b * c) \<and> a * c + b * d \<ge> a * d + b * c"
  by (smt diff_mult_distrib mult.commute mult_le_mono1 nat_sub2)

(* Cancel identical terms on two sides, yielding a normalized expression. *)
lemma nat_sub_combine:
  "(a::nat) + b \<ge> c + b \<Longrightarrow> (a + b) - (c + b) = a - c \<and> a \<ge> c" by simp

lemma nat_sub_combine2:
  "n \<ge> m \<Longrightarrow> (a::nat) + b * n \<ge> c + b * m \<Longrightarrow> (a + b * n) - (c + b * m) = (a + b * (n - m)) - c \<and> a + b * (n - m) \<ge> c \<and> n \<ge> m"
  by (simp add: add.commute right_diff_distrib')

lemma nat_sub_combine3:
  "n \<le> m \<Longrightarrow> (a::nat) + b * n \<ge> c + b * m \<Longrightarrow> (a + b * n) - (c + b * m) = a - (c + b * (m - n)) \<and> a \<ge> c + b * (m - n) \<and> m \<ge> n"
  by (smt add.commute mult.commute nat_diff_add_eq2 nat_le_add_iff1)

ML_file \<open>nat_sub.ML\<close>
ML_file \<open>nat_sub_test.ML\<close>

(* Ordering on Nats. *)
lemma le_neq_implies_less' [forward]: "(m::nat) \<noteq> n \<Longrightarrow> m \<le> n \<Longrightarrow> m < n" by simp
lemma le_zero_to_equal_zero [forward]: "(n::nat) \<le> 0 \<Longrightarrow> n = 0" by simp
lemma less_one_to_equal_zero [forward]: "(n::nat) < 1 \<Longrightarrow> n = 0" by simp
setup \<open>add_backward_prfstep_cond @{thm Nat.mult_le_mono1} [with_cond "?k \<noteq> 1"]\<close>
setup \<open>add_resolve_prfstep @{thm Nat.not_add_less1}\<close>
lemma not_minus_less [resolve]: "\<not>(i::nat) < (i - j)" by simp
lemma nat_le_prod_with_same [backward]: "m \<noteq> 0 \<Longrightarrow> (n::nat) \<le> m * n" by simp
lemma nat_le_prod_with_le [backward1]: "k \<noteq> 0 \<Longrightarrow> (n::nat) \<le> m \<Longrightarrow> (n::nat) \<le> k * m"
  using le_trans nat_le_prod_with_same by blast
lemma nat_plus_le_to_less [backward1]: "b \<noteq> 0 \<Longrightarrow> (a::nat) + b \<le> c \<Longrightarrow> a < c" by simp
lemma nat_plus_le_to_less2 [backward1]: "a \<noteq> 0 \<Longrightarrow> (a::nat) + b \<le> c \<Longrightarrow> b < c" by simp
setup \<open>add_forward_prfstep @{thm add_right_imp_eq}\<close>
setup \<open>add_forward_prfstep @{thm add_left_imp_eq}\<close>

setup \<open>add_rewrite_rule_cond @{thm Nat.le_diff_conv2} [with_term "?i + ?k"]\<close>
lemma nat_less_diff_conv: "(i::nat) < j - k \<Longrightarrow> i + k < j" by simp
setup \<open>add_forward_prfstep_cond @{thm nat_less_diff_conv} [with_cond "?k \<noteq> ?NUMC", with_term "?i + ?k"]\<close>
lemma Nat_le_diff_conv2_same [forward]: "i \<ge> j \<Longrightarrow> (i::nat) \<le> i - j \<Longrightarrow> j = 0" by simp
lemma nat_gt_zero [forward]: "b - a > 0 \<Longrightarrow> b > (a::nat)" by simp
lemma n_minus_1_less_n: "(n::nat) \<ge> 1 \<Longrightarrow> n - 1 < n" by simp
setup \<open>add_forward_prfstep_cond @{thm n_minus_1_less_n} [with_term "?n - 1"]\<close>

(* Monotonicity of ordering *)
setup \<open>add_backward_prfstep @{thm Nat.diff_le_mono}\<close>
setup \<open>add_backward2_prfstep @{thm Nat.diff_less_mono}\<close>
setup \<open>add_backward_prfstep @{thm Nat.mult_le_mono2}\<close>
setup \<open>add_resolve_prfstep @{thm Nat.le_add1}\<close>
setup \<open>add_resolve_prfstep @{thm Nat.le_add2}\<close>
setup \<open>add_backward_prfstep @{thm add_left_mono}\<close>
setup \<open>add_backward_prfstep @{thm add_right_mono}\<close>
lemma add_mono_neutr [backward]: "(0::'a::linordered_ring) \<le> b \<Longrightarrow> a \<le> a + b" by simp
lemma add_mono_neutl [backward]: "(0::'a::linordered_ring) \<le> b \<Longrightarrow> a \<le> b + a" by simp
setup \<open>add_forward_prfstep @{thm add_less_imp_less_left}\<close>
lemma sum_le_zero1 [forward]: "(a::'a::linordered_ring) + b < 0 \<Longrightarrow> a \<ge> 0 \<Longrightarrow> b < 0" by (meson add_less_same_cancel1 less_le_trans)
lemma less_sum1 [backward]: "b > 0 \<Longrightarrow> a < a + (b::nat)" by auto
setup \<open>add_backward_prfstep @{thm Nat.trans_less_add2}\<close>
setup \<open>add_backward_prfstep @{thm Nat.add_less_mono1}\<close>
setup \<open>add_backward1_prfstep @{thm Nat.add_less_mono}\<close>
setup \<open>add_backward1_prfstep @{thm Nat.add_le_mono}\<close>
setup \<open>add_backward1_prfstep @{thm add_increasing2}\<close>
setup \<open>add_backward1_prfstep @{thm add_mono}\<close>
setup \<open>add_backward_prfstep @{thm add_strict_left_mono}\<close>
setup \<open>add_backward1_prfstep @{thm Nat.mult_le_mono}\<close>

(* Addition. *)
theorem nat_add_eq_self_zero [forward]: "(m::nat) = m + n \<Longrightarrow> n = 0" by simp
theorem nat_add_eq_self_zero' [forward]: "(m::nat) = n + m \<Longrightarrow> n = 0" by simp
theorem nat_mult_2: "(a::nat) + a = 2 * a" by simp
setup \<open>add_rewrite_rule_cond @{thm nat_mult_2} [with_cond "?a \<noteq> 0"]\<close>
theorem plus_one_non_zero [resolve]: "\<not>(n::nat) + 1 = 0" by simp

(* Diff. *)
lemma nat_same_minus_ge [forward]: "(c::nat) - a \<ge> c - b \<Longrightarrow> a \<le> c \<Longrightarrow> a \<le> b" by arith
lemma diff_eq_zero [forward]: "(k::nat) \<le> j \<Longrightarrow> j - k = 0 \<Longrightarrow> j = k" by simp
lemma diff_eq_zero' [forward]: "(k::nat) \<le> j \<Longrightarrow> j - k + i = j \<Longrightarrow> k = i" by simp

(* Divides. *)
theorem dvd_defD1 [resolve]: "(a::nat) dvd b \<Longrightarrow> \<exists>k. b = a * k" using dvdE by blast
theorem dvd_defD2 [resolve]: "(a::nat) dvd b \<Longrightarrow> \<exists>k. b = k * a" by (metis dvd_mult_div_cancel mult.commute)
setup \<open>add_forward_prfstep @{thm Nat.dvd_imp_le}\<close>
theorem dvd_ineq2 [forward]: "(k::nat) dvd n \<Longrightarrow> n > 0 \<Longrightarrow> k \<ge> 1" by (simp add: Suc_leI dvd_pos_nat)

setup \<open>add_forward_prfstep_cond @{thm dvd_trans} (with_conds ["?a \<noteq> ?b", "?b \<noteq> ?c", "?a \<noteq> ?c"])\<close>
setup \<open>add_forward_prfstep_cond @{thm Nat.dvd_antisym} [with_cond "?m \<noteq> ?n"]\<close>
theorem dvd_cancel [backward1]: "c > 0 \<Longrightarrow> (a::nat) * c dvd b * c \<Longrightarrow> a dvd b" by simp
setup \<open>add_forward_prfstep (equiv_forward_th @{thm dvd_add_right_iff})\<close>

(* Divisibility: existence. *)
setup \<open>add_resolve_prfstep @{thm dvd_refl}\<close>
theorem exists_n_dvd_n [backward]: "P (n::nat) \<Longrightarrow> \<exists>k. k dvd n \<and> P k" using dvd_refl by blast
setup \<open>add_resolve_prfstep @{thm one_dvd}\<close>

theorem any_n_dvd_0 [forward]: "\<not> (\<exists> k. k dvd (0::nat) \<and> P k) \<Longrightarrow> \<not> (\<exists> k. P k)" by simp

theorem n_dvd_one: "(n::nat) dvd 1 \<Longrightarrow> n = 1" by simp
setup \<open>add_forward_prfstep_cond @{thm n_dvd_one} [with_cond "?n \<noteq> 1"]\<close>

(* Products. *)
setup \<open>add_rewrite_rule @{thm mult_zero_left}\<close>
lemma prod_ineqs1 [forward]: "(m::nat) * k > 0 \<Longrightarrow> m > 0 \<and> k > 0" by simp
lemma prod_ineqs2 [backward]: "(k::nat) > 0 \<Longrightarrow> m \<le> m * k" by simp

theorem prod_cancel: "(a::nat) * b = a * c \<Longrightarrow> a > 0 \<Longrightarrow> b = c" by auto
setup \<open>add_forward_prfstep_cond @{thm prod_cancel} [with_cond "?b \<noteq> ?c"]\<close>

theorem mult_n1n: "(n::nat) = m * n \<Longrightarrow> n > 0 \<Longrightarrow> m = 1" by auto
setup \<open>add_forward_prfstep_cond @{thm mult_n1n} [with_cond "?m \<noteq> 1"]\<close>

theorem prod_is_one [forward]: "(x::nat) * y = 1 \<Longrightarrow> x = 1" by simp

theorem prod_dvd_intro [backward]: "(k::nat) dvd m \<or> k dvd n \<Longrightarrow> k dvd m * n"
  using dvd_mult dvd_mult2 by blast

(* Definition of gcd. *)
setup \<open>add_forward_prfstep_cond @{thm gcd_dvd1} [with_term "gcd ?a ?b"]\<close>
setup \<open>add_forward_prfstep_cond @{thm gcd_dvd2} [with_term "gcd ?a ?b"]\<close>

(* Coprimality. *)
setup \<open>add_rewrite_rule_bidir @{thm coprime_iff_gcd_eq_1}\<close>
lemma coprime_exp [backward]: "coprime d a \<Longrightarrow> coprime (d::nat) (a ^ n)" by simp
setup \<open>add_backward_prfstep @{thm coprime_exp}\<close>
setup \<open>add_rewrite_rule @{thm gcd.commute}\<close>
lemma coprime_dvd_mult [backward1]: "coprime (a::nat) b \<Longrightarrow> a dvd c * b \<Longrightarrow> a dvd c"
  by (metis coprime_dvd_mult_left_iff)
lemma coprime_dvd_mult' [backward1]: "coprime (a::nat) b \<Longrightarrow> a dvd b * c \<Longrightarrow> a dvd c"
  by (metis coprime_dvd_mult_right_iff)

theorem coprime_dvd [forward]:
  "coprime (a::nat) b \<Longrightarrow> p dvd a \<Longrightarrow> p > 1 \<Longrightarrow> \<not> p dvd b"
  using coprime_common_divisor_nat by blast

(* Powers. *)
setup \<open>add_rewrite_rule @{thm power_0}\<close>
theorem power_ge_0 [rewrite]: "m \<noteq> 0 \<Longrightarrow> p ^ m = p * (p ^ (m - 1))" by (simp add: power_eq_if)
setup \<open>add_rewrite_rule_cond @{thm power_one} [with_cond "?n \<noteq> 0"]\<close>
setup \<open>add_rewrite_rule_cond @{thm power_one_right} [with_cond "?a \<noteq> 1"]\<close>
setup \<open>add_gen_prfstep ("power_case_intro",
  [WithTerm @{term_pat "?p ^ (?FREE::nat)"}, CreateCase @{term_pat "(?FREE::nat) = 0"}])\<close>

lemma one_is_power_of_any [resolve]: "\<exists>i. (1::nat) = a ^ i" by (metis power.simps(1))

setup \<open>add_rewrite_rule @{thm power_Suc}\<close>

theorem power_dvd [forward]: "(p::nat)^n dvd a \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> p dvd a" using dvd_power dvd_trans by blast

theorem power_eq_one: "(b::nat) ^ n = 1 \<Longrightarrow> b = 1 \<or> n = 0"
  by (metis One_nat_def Suc_lessI nat_zero_less_power_iff power_0 power_inject_exp)
setup \<open>add_forward_prfstep_cond @{thm power_eq_one} (with_conds ["?b \<noteq> 1", "?n \<noteq> 0"])\<close>

(* Factorial. *)
theorem fact_ge_1_nat: "fact (n::nat) \<ge> (1::nat)" by simp
setup \<open>add_forward_prfstep_cond @{thm fact_ge_1_nat} [with_term "fact ?n"]\<close>
setup \<open>add_backward1_prfstep @{thm dvd_fact}\<close>

(* Successor function. *)
setup \<open>add_rewrite_rule @{thm Nat.Suc_eq_plus1}\<close>
setup \<open>add_backward_prfstep @{thm Nat.gr0_implies_Suc}\<close>

(* Cases *)
setup \<open>fold add_rewrite_rule @{thms Nat.nat.case}\<close>

(* Induction. *)
lemma nat_cases: "P 0 \<Longrightarrow> (\<And>n. P (Suc n)) \<Longrightarrow> P n" using nat_induct by auto

(* div *)
declare times_div_less_eq_dividend [resolve]

setup \<open>
  add_var_induct_rule @{thm nat_induct} #>
  add_strong_induct_rule @{thm nat_less_induct} #>
  add_cases_rule @{thm nat_cases}
\<close>

end