(*
Title: Powers of 2
Author: Jose Manuel Rodriguez Caballero

Miscellany about powers of 2. Our main result will be the following theorem:

\<exists>! f :: nat \<Rightarrow> nat. \<exists>! g :: nat \<Rightarrow> nat. (\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )) )

(This code  was verified in Isabelle2018)

*)

theory PowOfTwo

imports Complex_Main

begin

lemma TrapezoidalNumbersNec3: "\<not>(\<exists> r. 2*(n::nat) = 2^r) \<Longrightarrow> \<not>(\<exists> r. n = 2^r)"
  by (metis power_commutes semiring_normalization_rules(28))

lemma TrapezoidalNumbersNec2_5base:
  fixes d r :: nat
  shows "d dvd 2 ^ 0 \<Longrightarrow> \<exists>k. d = 2 ^ k"
  by (metis One_nat_def Suc_leI dvd_imp_le dvd_pos_nat le_antisym less_numeral_extra(1) nat_power_eq_Suc_0_iff)

lemma TrapezoidalNumbersNec2_5recA1729:
  fixes t d r :: nat
  assumes \<open>\<forall>d. odd t \<and> d * t = 2 ^ r \<longrightarrow> t = 1\<close>
    and \<open>odd t\<close> and \<open> d * t = 2 ^ Suc r \<close>
  shows \<open>t = 1\<close>
proof-
  have \<open>even d\<close>
    by (metis \<open>d * t = 2 ^ Suc r\<close> \<open>odd t\<close> even_mult_iff even_numeral even_power zero_less_Suc)
  then obtain e :: nat where \<open>2*e = d\<close>
    by blast
  have \<open> e * t = 2 ^ r\<close>
    using \<open>2 * e = d\<close> \<open>d * t = 2 ^ Suc r\<close> by auto
  have \<open> t = 1 \<close>
    using \<open>e * t = 2 ^ r\<close> assms(1) assms(2) by blast
  show ?thesis
    by (simp add: \<open>t = 1\<close>)
qed

lemma TrapezoidalNumbersNec2_5recA:
  "\<forall> d::nat. (odd t \<and> d*(t::nat) = 2^(r::nat) \<longrightarrow> t = 1)"
proof (induction r)
  case 0
  thus ?case
    by simp
next
  case (Suc r)
  thus ?case
    using TrapezoidalNumbersNec2_5recA1729 by blast
qed

lemma TrapezoidalNumbersNec2_5rec:
  fixes d r :: nat
  shows "(d dvd 2 ^ r \<Longrightarrow> \<exists>k. d = 2 ^ k) \<Longrightarrow> ( d dvd 2 ^ Suc r \<Longrightarrow> \<exists>k. d = 2 ^ k)"
proof (cases "d = 2^(Suc r)")
  case True
  thus ?thesis by blast
next
  case False
  assume "d dvd 2 ^ r \<Longrightarrow> \<exists>k. d = 2 ^ k"
  assume "d dvd 2 ^ Suc r"
  from \<open>d dvd 2 ^ Suc r\<close> obtain t::nat where \<open>d*t = 2 ^ Suc r\<close>
    by (metis dvdE)
  hence \<open>t \<ge> 2\<close>
    by (metis False One_nat_def Suc_leI le_antisym mult_1_right nat_one_le_power not_less_eq_eq numeral_2_eq_2 one_le_mult_iff pos2)
  have \<open>t dvd  2 ^ Suc r\<close>
    by (metis \<open>d * t = 2 ^ Suc r\<close> dvd_triv_right)
  from  \<open>d*t = 2 ^ Suc r\<close> have "even t \<or> even d"
    by (metis False One_nat_def TrapezoidalNumbersNec2_5recA mult.right_neutral)
  thus ?thesis
  proof (cases "even t")
    case True
    thus ?thesis
    proof -
      obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
        "t = Suc (Suc 0) * nn t (Suc (Suc 0))"
        by (metis True dvd_def numeral_2_eq_2)
      hence "Suc (Suc 0) * 2 ^ r = d * (Suc (Suc 0) * nn t (Suc (Suc 0)))"
        by (simp add: \<open>d * t = 2 ^ Suc r\<close>)
      hence "\<exists>n. 2 ^ r = d * n"
        by (metis Suc_neq_Zero mult_left_cancel semiring_normalization_rules(19))
      thus ?thesis
        using \<open>d dvd 2 ^ r \<Longrightarrow> \<exists>k. d = 2 ^ k\<close> dvd_def by blast
    qed
  next
    case False
    hence \<open>odd t\<close> by simp
    thus ?thesis
      by (metis TrapezoidalNumbersNec2_5recA \<open>d * t = 2 ^ Suc r\<close> mult_1_right)
  qed
qed

lemma TrapezoidalNumbersNec2_5:
  fixes d r :: nat
  shows "d dvd 2^r \<Longrightarrow> \<exists> k. d = 2^k"
proof (induction r)
  case 0
  thus ?case
    using TrapezoidalNumbersNec2_5base by blast
next
  case (Suc r)
  thus ?case
    using TrapezoidalNumbersNec2_5rec by blast
qed

lemma TrapezoidalNumbersNec2_4:
  fixes d r :: nat
  assumes "d dvd 2^r"  and "d \<noteq> 2^r"
  shows "\<exists> k. d = 2^k \<and> k < r"
  by (metis TrapezoidalNumbersNec2_5 antisym_conv3 assms(1) assms(2) nat_dvd_not_less nat_power_less_imp_less pos2 zero_less_power)

lemma TrapezoidalNumbersNec2_3:
  fixes d r :: nat
  assumes "d dvd 2^r" and "d \<ge> 2"
  shows "even d"
proof (cases "d = 2^r")
  case True
  show ?thesis
    by (metis True assms(2) even_power gcd_nat.order_iff_strict le_add1 le_antisym not_gr0 one_add_one power_0)
next
  case False
  then obtain k where "d = 2^k" and "k < r"
    using TrapezoidalNumbersNec2_4 assms(1) by blast
  from \<open>d = 2^k\<close> \<open>k < r\<close> \<open>d \<ge> 2\<close> have "k \<ge> 1"
    by (metis one_less_numeral_iff power_increasing_iff power_one_right semiring_norm(76))
  from \<open>k \<ge> 1\<close> \<open>d = 2^k\<close> show ?thesis by auto
qed

lemma TrapezoidalNumbersNec2_2: "\<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d \<Longrightarrow>  \<not> (\<exists> r. n = 2^r)"
proof (rule classical)
  assume "\<not> (\<not> (\<exists> r. n = 2^r))"
  hence "\<exists> r. n = 2^r" by simp
  then obtain r :: nat where "n = 2^r" by blast
  assume "\<exists> d. d \<ge> 2 \<and> d dvd (n::nat) \<and> odd d"
  then obtain d::nat where "d \<ge> 2" and "d dvd n" and "odd d" by blast
  have "d dvd 2^r"
    using \<open>d dvd n\<close> \<open>n = 2 ^ r\<close> by blast
  have "even d"
    using TrapezoidalNumbersNec2_3 \<open>2 \<le> d\<close> \<open>d dvd 2 ^ r\<close> by blast
  from \<open>even d\<close> \<open>odd d\<close> show ?thesis by blast
qed

lemma TrapezoidalNumbersSuf_1C_base: "n \<noteq> 0 \<Longrightarrow> odd n \<Longrightarrow> ( \<exists> r t.  n = 2^r*t \<and> odd t )"
proof-
  assume \<open>n \<noteq> 0\<close>
  assume \<open>odd n\<close>
  have \<open>n = 2^0 * n\<close>
    by simp
  show ?thesis
    using \<open>n = 2 ^ 0 * n\<close> \<open>odd n\<close> by blast
qed

lemma TrapezoidalNumbersSuf_1C_BOUNDEDNonQ: "\<forall>  n. (n \<le> (N::nat) \<longrightarrow> (n \<noteq> 0 \<longrightarrow>  ( \<exists> r t.  n = 2^r*t \<and> odd t ) ))"
proof (induction N)
  case 0
  thus ?case
    by blast
next
  case (Suc N)
  have \<open>\<exists> r t.  Suc N = 2^r*t \<and> odd t\<close>
  proof (cases \<open>odd (Suc N)\<close>)
    case True
    thus ?thesis
      using TrapezoidalNumbersSuf_1C_base by blast
  next
    case False
    hence \<open>even (Suc N)\<close>
      by auto
    obtain m where \<open>2*m = Suc N\<close>
      by (metis \<open>even (Suc N)\<close> dvdE)
    from \<open>2*m = Suc N\<close> have \<open>m \<le> N\<close>
      by linarith
    hence \<open> \<exists> r t.  m = 2^r*t \<and> odd t \<close>
      using Suc.IH \<open>2 * m = Suc N\<close> by auto
    thus ?thesis
      by (metis \<open>2 * m = Suc N\<close> power_commutes semiring_normalization_rules(18) semiring_normalization_rules(28))
  qed
  thus ?case
    by (simp add: Suc.IH le_Suc_eq)
qed

lemma ParityDescomposition:
  fixes n::nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open>\<exists> k t :: nat. n = (2::nat)^k*t \<and> odd t\<close>
  using TrapezoidalNumbersSuf_1C_BOUNDEDNonQ assms le_eq_less_or_eq by auto

lemma Pow2Odd:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close> and \<open>\<forall> d. d \<ge> 2 \<and> d dvd n \<longrightarrow> even d\<close>
  shows \<open>\<exists> k :: nat. n = 2^k\<close>
proof-
  obtain u v :: nat where \<open>n = 2^u * v\<close> and \<open>odd v\<close>
    using ParityDescomposition assms(1) by blast
  from \<open>n = 2^u * v\<close> have \<open>v dvd n\<close>
    by simp
  from  \<open>v dvd n\<close> \<open>odd v\<close>  \<open>\<forall> d. d \<ge> 2 \<and> d dvd n \<longrightarrow> even d\<close>
  have \<open>v = 1\<close>
    by (metis One_nat_def Suc_leI add.commute add.right_neutral add_right_mono neq0_conv odd_two_times_div_two_succ one_add_one)
  thus ?thesis
    by (simp add: \<open>n = 2 ^ u * v\<close>)
qed

(* ---  *)

lemma preExistenceUniquenessEvenPart:
  \<open>\<forall> n::nat. \<exists> u v :: nat. ( n \<ge> 1 \<longrightarrow> n = 2^u*v \<and> odd v )\<close>
  by (simp add: ParityDescomposition)

lemma preExistenceEvenPart:
  \<open>\<exists> f g :: nat \<Rightarrow> nat. \<forall> n::nat. ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )\<close>
  using preExistenceUniquenessEvenPart by metis

lemma ExistenceEvenPart:
  \<open>\<exists> f :: nat \<Rightarrow> nat. \<exists> g :: nat \<Rightarrow> nat. \<forall> n::nat. (f 0 = 0) \<and> (g 0 = 1) \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )\<close>
proof-
  obtain f g :: \<open>nat \<Rightarrow> nat\<close> where
    \<open> \<forall> n::nat. ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )\<close>
    using preExistenceEvenPart by blast

  obtain ff :: \<open>nat \<Rightarrow> nat\<close> where
    \<open>ff \<equiv> \<lambda> n. (if n = 0 then 0 else f n)\<close>
    by simp

  obtain gg :: \<open>nat \<Rightarrow> nat\<close> where
    \<open>gg \<equiv> \<lambda> n. (if n = 0 then 1 else g n)\<close>
    by simp

  from \<open> \<forall> n::nat. ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )\<close>
    \<open>ff \<equiv> \<lambda> n. (if n = 0 then 0 else f n)\<close> \<open>gg \<equiv> \<lambda> n. (if n = 0 then 1 else g n)\<close>
  show ?thesis
    by (smt \<open>\<And>thesis. (\<And>ff. ff \<equiv> \<lambda>n. if n = 0 then 0 else f n \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>\<And>thesis. (\<And>gg. gg \<equiv> \<lambda>n. if n = 0 then 1 else g n \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> not_one_le_zero)
qed

lemma preUniqEvenPartS0:
  fixes f ff  g gg  :: \<open>nat \<Rightarrow> nat\<close> and n :: nat
  assumes \<open>n = 0\<close> and  \<open>f 0 = 0\<close> and \<open>g 0 = 1\<close> and \<open> n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) \<close>
    and \<open>ff 0 = 0\<close> and \<open>gg 0 = 1\<close> and \<open> n \<ge> 1 \<longrightarrow> n = 2^(ff n)*(gg n) \<and> odd (gg n)\<close>
  shows \<open>f n = ff n \<and> g n = gg n\<close>
  by (simp add: assms(1) assms(2) assms(3) assms(5) assms(6))

lemma preUniqnessOddEven_OddPartOneSide :
  fixes uu v vv :: nat
  assumes  \<open>odd v\<close> and \<open>odd vv\<close> and \<open>v = 2^uu*vv\<close>
  shows \<open>v = vv\<close>
  using assms(1) assms(3) by auto

lemma preUniqnessOddEven_OddPart :
  fixes u uu v vv :: nat
  assumes \<open>u \<le> uu\<close> and \<open>odd v\<close> and \<open>odd vv\<close> and \<open>2^u*v = 2^uu*vv\<close>
  shows \<open>v = vv\<close>
proof-
  from  \<open>u \<le> uu\<close> obtain k :: nat where \<open>u + k = uu\<close>
    using le_Suc_ex by blast
  from \<open>2^u*v = 2^uu*vv\<close> \<open>u + k = uu\<close>
  have \<open>v = 2^k*vv\<close>
    by (smt Groups.mult_ac(1) nonzero_mult_div_cancel_left power_add power_eq_0_iff rel_simps(76))
  thus ?thesis using \<open>odd v\<close> \<open>odd vv\<close>
    using preUniqnessOddEven_OddPartOneSide by blast
qed

lemma UniqnessOddEven_OddPart :
  fixes u uu v vv :: nat
  assumes \<open>odd v\<close> and \<open>odd vv\<close> and \<open>2^u*v = 2^uu*vv\<close>
  shows \<open>v = vv\<close>
  by (metis assms(1) assms(2) assms(3) nat_le_linear preUniqnessOddEven_OddPart)

lemma UniqnessOddEven_EvenPart :
  fixes u uu v vv :: nat
  assumes \<open>odd v\<close> and \<open>odd vv\<close> and \<open>2^u*v = 2^uu*vv\<close>
  shows \<open>u = uu\<close>
  by (metis One_nat_def UniqnessOddEven_OddPart assms(1) assms(2) assms(3) even_zero lessI mult_cancel_right numeral_2_eq_2 power_inject_exp)

lemma UniqnessOddEven :
  fixes u uu v vv :: nat
  assumes \<open>odd v\<close> and \<open>odd vv\<close> and \<open>2^u*v = 2^uu*vv\<close>
  shows \<open>u = uu \<and> v = vv\<close>
  using UniqnessOddEven_EvenPart UniqnessOddEven_OddPart assms(1) assms(2) assms(3) by blast

lemma preUniqEvenPartS1:
  fixes f ff  g gg  :: \<open>nat \<Rightarrow> nat\<close> and n :: nat
  assumes \<open>n \<ge> 1\<close> and  \<open>f 0 = 0\<close> and \<open>g 0 = 1\<close> and \<open> n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) \<close>
    and \<open>ff 0 = 0\<close> and \<open>gg 0 = 1\<close> and \<open> n \<ge> 1 \<longrightarrow> n = 2^(ff n)*(gg n) \<and> odd (gg n)\<close>
  shows \<open>f n = ff n \<and> g n = gg n\<close>
  by (metis UniqnessOddEven assms(1) assms(4) assms(7))

lemma preUniqEvenPartS:
  fixes f ff  g gg  :: \<open>nat \<Rightarrow> nat\<close> and n :: nat
  assumes \<open>f 0 = 0\<close> and \<open>g 0 = 1\<close> and \<open> n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) \<close>
    and \<open>ff 0 = 0\<close> and \<open>gg 0 = 1\<close> and \<open> n \<ge> 1 \<longrightarrow> n = 2^(ff n)*(gg n) \<and> odd (gg n)\<close>
  shows \<open>f n = ff n \<and> g n = gg n\<close>
  by (metis assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) dvd_imp_le neq0_conv one_dvd preUniqEvenPartS1)

lemma preUniqEvenPartSQE:
  fixes f ff  g gg  :: \<open>nat \<Rightarrow> nat\<close>
  shows \<open>(\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) ))
\<and> (ff 0 = 0 \<and> gg 0 = 1 \<and> (n \<ge> 1 \<longrightarrow> n = 2^(ff n)*(gg n) \<and> odd (gg n) )) ) \<Longrightarrow> (f  = ff ) \<and> (g  = gg ) \<close>
  using preUniqEvenPartS by blast

lemma preUniqEvenPartSQEG:
  fixes f ff  :: \<open>nat \<Rightarrow> nat\<close>
  shows \<open>\<exists>! g :: nat \<Rightarrow> nat. (\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) ))
\<and> (ff 0 = 0 \<and> g 0 = 1 \<and> (n \<ge> 1 \<longrightarrow> n = 2^(ff n)*(g n) \<and> odd (g n) )) ) \<Longrightarrow> (f = ff ) \<close>
  using preUniqEvenPartSQE by blast

lemma preUniqEvenPartSQEGD:
  fixes f ff  :: \<open>nat \<Rightarrow> nat\<close>
  assumes \<open>\<exists>! g :: nat \<Rightarrow> nat. (\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )) )
\<and> (\<forall> n. (ff 0 = 0 \<and> g 0 = 1 \<and> (n \<ge> 1 \<longrightarrow> n = 2^(ff n)*(g n) \<and> odd (g n) )) )\<close>
  shows \<open>f = ff\<close>
  by (metis assms preUniqEvenPartSQE)

lemma preUniqEvenPartSQEGX:
  \<open>\<exists> f :: nat \<Rightarrow> nat. \<exists>! g :: nat \<Rightarrow> nat. (\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )) ) \<close>
  by (smt ExistenceEvenPart preUniqEvenPartSQE)

lemma UniqEvenPartXrferew4:
  \<open>\<exists>f. \<exists>!g. f 0 = 0 \<and>
             g 0 = Suc 0 \<and>
             (\<forall>n\<ge>Suc 0. n = 2 ^ f n * g n \<and> odd (g n))\<close>
  using preUniqEvenPartSQEGX by auto

lemma preUniqEvenPartXr43ur93n:
  fixes f y g ga :: \<open>nat \<Rightarrow> nat\<close> and n :: nat
  assumes
    \<open> \<forall>y y'.
          y 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ f n * y n \<and> odd (y n)) \<and>
          y' 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ f n * y' n \<and> odd (y' n)) \<longrightarrow>
          y = y'\<close>
    and
    \<open> \<forall>ya y'.
          ya 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ y n * ya n \<and> odd (ya n)) \<and>
          y' 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ y n * y' n \<and> odd (y' n)) \<longrightarrow>
          ya = y'\<close>and
    \<open>f 0 = 0\<close> and
    \<open>y 0 = 0\<close> and
    \<open>g 0 = Suc 0\<close> and
    \<open> \<forall>n\<ge>Suc 0. n = 2 ^ f n * g n \<and> odd (g n)\<close> and
    \<open> ga 0 = Suc 0\<close> and
    \<open> \<forall>n\<ge>Suc 0. n = 2 ^ y n * ga n \<and> odd (ga n)\<close>
  shows \<open> f n = y n\<close>
proof(cases \<open>n = 0\<close>)
  case True
  thus ?thesis
    by (simp add: assms(3) assms(4))
next
  case False
  hence \<open>n \<ge> Suc 0\<close>
    using not_less_eq_eq by blast
  thus ?thesis
    using One_nat_def assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) preUniqEvenPartS by presburger
qed

lemma preUniqEvenPartXr43ur93:
  fixes f y g ga :: \<open>nat \<Rightarrow> nat\<close>
  assumes
    \<open> \<forall>y y'.
          y 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ f n * y n \<and> odd (y n)) \<and>
          y' 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ f n * y' n \<and> odd (y' n)) \<longrightarrow>
          y = y'\<close>
    and
    \<open> \<forall>ya y'.
          ya 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ y n * ya n \<and> odd (ya n)) \<and>
          y' 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ y n * y' n \<and> odd (y' n)) \<longrightarrow>
          ya = y'\<close>and
    \<open>f 0 = 0\<close> and
    \<open>y 0 = 0\<close> and
    \<open>g 0 = Suc 0\<close> and
    \<open> \<forall>n\<ge>Suc 0. n = 2 ^ f n * g n \<and> odd (g n)\<close> and
    \<open> ga 0 = Suc 0\<close> and
    \<open> \<forall>n\<ge>Suc 0. n = 2 ^ y n * ga n \<and> odd (ga n)\<close>
  shows \<open> f = y\<close>
proof (rule classical)
  assume \<open>\<not>(f = y)\<close>
  then obtain n where \<open>f n \<noteq> y n \<close>
    by (meson ext)
  from preUniqEvenPartXr43ur93n have \<open>f n = y n\<close>
    using One_nat_def assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) preUniqEvenPartS by presburger
  from  \<open>f n \<noteq> y n \<close>  \<open>f n = y n\<close>  have False
    by blast
  thus ?thesis by blast
qed

lemma UniqEvenPartXr43ur93: \<open>\<And>f y g ga.
       \<forall>y y'.
          y 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ f n * y n \<and> odd (y n)) \<and>
          y' 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ f n * y' n \<and> odd (y' n)) \<longrightarrow>
          y = y' \<Longrightarrow>
       \<forall>ya y'.
          ya 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ y n * ya n \<and> odd (ya n)) \<and>
          y' 0 = Suc 0 \<and>
          (\<forall>n\<ge>Suc 0. n = 2 ^ y n * y' n \<and> odd (y' n)) \<longrightarrow>
          ya = y' \<Longrightarrow>
       f 0 = 0 \<Longrightarrow>
       y 0 = 0 \<Longrightarrow>
       g 0 = Suc 0 \<Longrightarrow>
       \<forall>n\<ge>Suc 0. n = 2 ^ f n * g n \<and> odd (g n) \<Longrightarrow>
       ga 0 = Suc 0 \<Longrightarrow>
       \<forall>n\<ge>Suc 0. n = 2 ^ y n * ga n \<and> odd (ga n) \<Longrightarrow> f = y\<close>
  using preUniqEvenPartXr43ur93 by auto

theorem UniqEvenPart:
  \<open>\<exists>! f :: nat \<Rightarrow> nat. \<exists>! g :: nat \<Rightarrow> nat. (\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )) ) \<close>
  apply (auto)
  using UniqEvenPartXrferew4 apply blast
  using UniqEvenPartXr43ur93 apply auto
  done

(* --- *)

definition OddPart :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>OddPart \<equiv> \<lambda> n. (if n = 0 then 1 else  Max {d |d :: nat.  d dvd n \<and> odd d} )\<close>

definition Exp2 :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>Exp2 \<equiv> \<lambda> n. (if n = 0 then 0 else Max {k |k :: nat.  (2^k) dvd n})\<close>

lemma preExp2OddPartChar1:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open> odd (OddPart n) \<close>
proof-
  from \<open>n \<ge> 1\<close> have \<open>\<not> (n = 0)\<close> by simp
  then obtain S :: \<open>nat set\<close> where \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>
    by blast
  from  \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>  \<open>n \<ge> 1\<close> have \<open>S \<noteq> {}\<close> by auto
  from  \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>  \<open>n \<ge> 1\<close> have \<open>finite S\<close> by auto
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> obtain d :: nat where \<open>d = Max S\<close>
    by blast
  from \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close> \<open>d = Max S\<close>  have \<open>d = OddPart n\<close>
    using OddPart_def
    using \<open>n \<noteq> 0\<close> by presburger
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> \<open>d = Max S\<close> have \<open> d dvd n \<and> odd d \<close>
    using Max_in \<open>S = {d |d. d dvd n \<and> odd d}\<close> by auto
  hence \<open>odd d\<close> by blast
  from \<open>odd d\<close>  \<open>d = OddPart n\<close> show ?thesis
    by blast
qed

lemma Exp2L1QQ:
  \<open>(n :: nat) \<ge> 1 \<Longrightarrow> {e |e :: nat.  2^e dvd n} \<noteq> {}\<close>
  by (metis One_nat_def ParityDescomposition dvd_triv_left empty_Collect_eq)

lemma Exp2L1QQQ:
  \<open>(n :: nat) \<ge> 1 \<Longrightarrow> finite {e |e :: nat.  2^e dvd n}\<close>
proof(rule classical)
  assume \<open>n \<ge> 1\<close>
  assume \<open>\<not> (finite {e |e :: nat.  2^e dvd n})\<close>
  hence \<open>infinite {e |e :: nat.  2^e dvd n}\<close>
    by blast
  obtain e :: nat where \<open>e \<in> {e |e :: nat.  2^e dvd n}\<close> and \<open>e > n\<close>
    by (metis \<open>infinite {e |e. 2 ^ e dvd n}\<close> finite_nat_set_iff_bounded_le not_le)
  from \<open>e \<in> {e |e :: nat.  2^e dvd n}\<close> have \<open>2^e dvd n\<close>
    by simp
  from \<open>e > n\<close> have \<open>2^e > n \<close>
    using less_trans of_nat_less_two_power by auto
  from \<open>n \<ge> 1\<close> \<open>2^e dvd n\<close> \<open>2^e > n \<close>  have False
    by auto
  thus ?thesis
    by simp
qed

lemma Exp2L1:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open> 2^(Exp2 n) dvd n \<close>
proof-
  from \<open>n \<ge> 1\<close> have \<open>\<not> (n = 0)\<close> by simp
  then obtain S :: \<open>nat set\<close> where \<open>S = {e |e :: nat.  2^e dvd n}\<close>
    by blast
  from  \<open>S = {e |e :: nat.  2^e dvd n}\<close> \<open>n \<ge> 1\<close> have \<open>S \<noteq> {}\<close>
    by (metis empty_Collect_eq one_dvd power_0)
  from  \<open>S = {e |e :: nat.  2^e dvd n}\<close> \<open>n \<ge> 1\<close> have \<open>finite S\<close>
    using Exp2L1QQQ by auto
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> obtain e :: nat where \<open>e = Max S\<close>
    by blast
  have \<open>2^e dvd n\<close>
    using Max_in \<open>S = {e |e. 2 ^ e dvd n}\<close> \<open>S \<noteq> {}\<close> \<open>e = Max S\<close> \<open>finite S\<close> by auto
  thus ?thesis
    by (metis  Exp2_def \<open>S = {e |e. 2 ^ e dvd n}\<close> \<open>e = Max S\<close> \<open>n \<noteq> 0\<close>)
qed

lemma Exp2L2:
  fixes n e :: nat
  assumes \<open>n \<ge> 1\<close> \<open> 2^e dvd n\<close>
  shows \<open> e \<le> Exp2 n \<close>
proof-
  from \<open>n \<ge> 1\<close> have \<open>\<not> (n = 0)\<close> by simp
  then obtain S :: \<open>nat set\<close> where \<open>S = {e |e :: nat.  2^e dvd n}\<close>
    by blast
  from  \<open>S = {e |e :: nat.  2^e dvd n}\<close> \<open>n \<ge> 1\<close> have \<open>S \<noteq> {}\<close>
    by (metis empty_Collect_eq one_dvd power_0)
  from  \<open>S = {e |e :: nat.  2^e dvd n}\<close> \<open>n \<ge> 1\<close> have \<open>finite S\<close>
    using Exp2L1QQQ by auto
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> obtain ee :: nat where \<open>ee = Max S\<close>
    by blast
  have \<open>ee = Exp2 n\<close>
    using Exp2_def \<open>S = {e |e. 2 ^ e dvd n}\<close> \<open>ee = Max S\<close> \<open>n \<noteq> 0\<close> by presburger
  have \<open>e \<in> S\<close>
    using \<open>S = {e |e. 2 ^ e dvd n}\<close> assms(2) by blast
  have \<open>e \<le> ee\<close>
    by (simp add: \<open>e \<in> S\<close> \<open>ee = Max S\<close> \<open>finite S\<close>)
  hence \<open>e \<le> Exp2 n\<close> using \<open>ee = Exp2 n\<close>
    by blast
  thus ?thesis by blast
qed

lemma preExp2OddPartChar2XA:
  fixes n k :: nat
  assumes \<open>n \<ge> 1\<close> and \<open>n = 2^(Exp2 n)*k\<close>
  shows \<open> odd k  \<close>
proof (rule classical)
  assume \<open>\<not> (odd k)\<close>
  hence \<open>even k\<close> by blast
  then obtain t :: nat where \<open>k = 2*t\<close> by blast
  hence \<open>n = 2^((Exp2 n)+1)*t\<close>
    using assms(2) by auto
  hence \<open>2^((Exp2 n)+1) dvd n\<close>
    by (metis dvd_triv_left)
  hence \<open>(Exp2 n)+1 \<le> Exp2 n\<close>
    using Exp2L2 assms(1) by blast
  hence False
    by simp
  thus ?thesis
    by simp
qed

lemma preExp2OddPartChar2X1:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open>\<exists> k :: nat.  n = 2^(Exp2 n)*k \<and> odd k \<close>
  by (meson Exp2L1 assms dvdE preExp2OddPartChar2XA)

lemma OddPartL1:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open> (OddPart n) dvd n \<close>
proof-
  from \<open>n \<ge> 1\<close> have \<open>\<not> (n = 0)\<close> by simp
  then obtain S :: \<open>nat set\<close> where \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>
    by blast
  from  \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>  \<open>n \<ge> 1\<close> have \<open>S \<noteq> {}\<close> by auto
  from  \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>  \<open>n \<ge> 1\<close> have \<open>finite S\<close> by auto
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> obtain d :: nat where \<open>d = Max S\<close>
    by blast
  from \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close> \<open>d = Max S\<close>  have \<open>d = OddPart n\<close>
    using OddPart_def
    using \<open>n \<noteq> 0\<close> by presburger
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> \<open>d = Max S\<close> have \<open> d dvd n \<and> odd d \<close>
    using Max_in \<open>S = {d |d. d dvd n \<and> odd d}\<close> by auto
  hence \<open>d dvd n\<close> by blast
  thus ?thesis using \<open>d = Max S\<close>
    using \<open>d = OddPart n\<close> by auto
qed

lemma OddPartL1X1:
  fixes n k :: nat
  assumes \<open>n \<ge> 1\<close> and \<open>odd k\<close> and \<open>k dvd n\<close>
  shows \<open>k \<le> (OddPart n)\<close>
proof-
  from \<open>n \<ge> 1\<close> have \<open>\<not> (n = 0)\<close> by simp
  then obtain S :: \<open>nat set\<close> where \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>
    by blast
  from  \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>  \<open>n \<ge> 1\<close> have \<open>S \<noteq> {}\<close> by auto
  from  \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close>  \<open>n \<ge> 1\<close> have \<open>finite S\<close> by auto
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> obtain d :: nat where \<open>d = Max S\<close>
    by blast
  from \<open>S = {d |d :: nat.  d dvd n \<and> odd d}\<close> \<open>d = Max S\<close>  have \<open>d = OddPart n\<close>
    using OddPart_def
    using \<open>n \<noteq> 0\<close> by presburger
  from \<open>S \<noteq> {}\<close> \<open>finite S\<close> \<open>d = Max S\<close> have \<open> d dvd n \<and> odd d \<close>
    using Max_in \<open>S = {d |d. d dvd n \<and> odd d}\<close> by auto
  hence \<open>odd d\<close> by blast
  have \<open>k \<le> d\<close>
    using Max_ge \<open>S = {d |d. d dvd n \<and> odd d}\<close> \<open>d = Max S\<close> \<open>finite S\<close> assms(2) assms(3) by blast
  thus ?thesis
    by (simp add: \<open>d = OddPart n\<close>)
qed

lemma OddPartL2S:
  fixes n d k :: nat
  assumes \<open>n \<ge> 1\<close> and \<open>n = d * (OddPart n)\<close> and \<open>k dvd d\<close> and \<open>odd k\<close>
  shows \<open>k = 1\<close>
proof(rule classical)
  assume \<open>\<not>(k = 1)\<close>
  hence \<open>k = 0 \<or> k \<ge> 2\<close>
    by linarith
  have \<open>k \<noteq> 0\<close>
    using assms(4) by presburger
  hence \<open>k \<ge> 2\<close>
    using \<open>k = 0 \<or> 2 \<le> k\<close> by blast
  obtain w :: nat where \<open>w = k * (OddPart n)\<close>
    by blast
  have \<open>w dvd n\<close>
    by (metis \<open>w = k * OddPart n\<close> assms(2) assms(3) dvd_times_right_cancel_iff gcd_nat.order_iff_strict mult_cancel_right)
  have \<open>odd w\<close>
    using \<open>w = k * OddPart n\<close> assms(1) assms(4) even_mult_iff preExp2OddPartChar1 by blast
  have \<open>w > OddPart n\<close>
    by (metis OddPart_def \<open>k \<noteq> 0\<close> \<open>k \<noteq> 1\<close> \<open>w = k * OddPart n\<close> \<open>w dvd n\<close> dvd_div_mult_self less_one  mult_cancel_right mult_is_0 mult_le_mono1 nat_mult_1 nat_neq_iff not_le semiring_normalization_rules(11))
  have \<open>w \<le> OddPart n\<close>
    using OddPartL1X1 \<open>odd w\<close> \<open>w dvd n\<close> assms(1) by blast
  from  \<open>w > OddPart n\<close> \<open>w \<le> OddPart n\<close>  have False by simp
  thus ?thesis by blast
qed

lemma OddPartL2:
  fixes n d :: nat
  assumes \<open>n \<ge> 1\<close> and \<open>n = d * (OddPart n)\<close>
  shows \<open>\<forall> k :: nat. k dvd d \<and> odd k \<longrightarrow> k = 1\<close>
  using OddPartL2S assms(1) assms(2) by blast

lemma DFSFSfre34:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close> \<open>\<forall> k :: nat. k dvd n \<and> odd k \<longrightarrow> k = 1\<close>
  shows \<open> \<exists> e::nat. n = 2^e\<close>
  using Pow2Odd
  using assms(1) assms(2) numeral_le_one_iff semiring_norm(69) by blast

lemma OddPartL3:
  fixes n d :: nat
  assumes \<open>n \<ge> 1\<close> and \<open>n = d * (OddPart n)\<close>
  shows \<open> \<exists> e::nat. d = 2^e\<close>
proof-
  from  \<open>n \<ge> 1\<close>  \<open>n = d * (OddPart n)\<close>
  have \<open>\<forall> k :: nat. k dvd d \<and> odd k \<longrightarrow> k = 1\<close>
    using OddPartL2 by blast
  thus ?thesis using DFSFSfre34 \<open>n \<ge> 1\<close>
    by (metis assms(2) dvd_imp_le mult_is_0 neq0_conv one_dvd)
qed

lemma preExp2OddPartChar2X2:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open>\<exists> e :: nat.  n = 2^e*(OddPart n) \<close>
proof-
  have \<open>(OddPart n) dvd n\<close>
    using OddPartL1 assms by blast
  then obtain d :: nat where \<open>n = d * (OddPart n)\<close>
    by (metis dvd_div_mult_self)
  then obtain e :: nat where \<open>d = 2^e\<close>
    using OddPartL3 assms by blast
  thus ?thesis
    using \<open>n = d * OddPart n\<close> by blast
qed

lemma preExp2OddPartChar2:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open> n = 2^(Exp2 n)*(OddPart n) \<close>
proof-
  obtain k :: nat where \<open>n = 2^(Exp2 n)*k\<close> and \<open>odd k\<close>
    using assms preExp2OddPartChar2X1 by blast
  obtain e :: nat where \<open>n = 2^e*(OddPart n)\<close> and \<open>odd (OddPart n)\<close>
    using assms preExp2OddPartChar2X2 preExp2OddPartChar1 by presburger
  from  \<open>n = 2^(Exp2 n)*k\<close> \<open>n = 2^e*(OddPart n)\<close> \<open>odd k\<close> \<open>odd (OddPart n)\<close>
  have \<open>(OddPart n) = k\<close>
    by (metis UniqnessOddEven)
  hence \<open>2^(Exp2 n) = 2^e\<close>
    by (metis UniqnessOddEven \<open>n = 2 ^ Exp2 n * k\<close> \<open>n = 2 ^ e * OddPart n\<close> \<open>odd (OddPart n)\<close>)
  thus ?thesis
    by (smt \<open>n = 2 ^ e * OddPart n\<close>)
qed

lemma preExp2OddPartChar:
  fixes n :: nat
  assumes \<open>n \<ge> 1\<close>
  shows \<open> n = 2^(Exp2 n)*(OddPart n) \<and> odd (OddPart n)  \<close>
  using assms preExp2OddPartChar1 preExp2OddPartChar2 by blast

corollary Exp2OddPartChar:
  \<open> (\<forall> n. (Exp2 0 = 0 \<and> OddPart 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(Exp2 n)*(OddPart n) \<and> odd (OddPart n) )) ) \<close>
  using  preExp2OddPartChar
  by (simp add: Exp2_def OddPart_def)

corollary CoroUniqEvenPart:
  fixes f g :: \<open>nat \<Rightarrow> nat\<close>
  assumes \<open>(\<forall> n. (f 0 = 0 \<and> g 0 = 1 \<and> ( n \<ge> 1 \<longrightarrow> n = 2^(f n)*(g n) \<and> odd (g n) )) ) \<close>
  shows \<open>f = Exp2 \<and> g = OddPart\<close>
  using UniqEvenPart Exp2OddPartChar
  by (metis (no_types, hide_lams) Exp2_def OddPart_def assms preUniqEvenPartSQE)

lemma Exp2ValueAt1: \<open>Exp2 (1::nat) = 0\<close>
proof-
  have \<open>(1::nat) = 2^(Exp2 (1::nat))*OddPart (1::nat)\<close>
    using preExp2OddPartChar by blast
  thus ?thesis
    by simp
qed

lemma OddPartValueAt1: \<open>OddPart (1::nat) = 1\<close>
proof-
  have \<open>(1::nat) = 2^(Exp2 (1::nat))*OddPart (1::nat)\<close>
    using preExp2OddPartChar by blast
  thus ?thesis
    by simp
qed

lemma OddDivPow2:
  \<open>(n::nat) \<ge> 1 \<Longrightarrow> (\<forall> d. d dvd n \<and> odd d \<longrightarrow> d = 1) \<longleftrightarrow> (\<exists> k. n = 2^k)\<close>
  using DFSFSfre34 TrapezoidalNumbersNec2_5recA dvd_div_mult_self by blast

end


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

datatype Nat = Z | S "Nat"

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

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 x y z) = (plus x (plus y z)))"
  oops

end


(*  Title:      HOL/Metis_Examples/Sets.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring typed set theory.
*)

section \<open>Metis Example Featuring Typed Set Theory\<close>

theory Sets
imports Main
begin

declare [[metis_new_skolem]]

lemma "EX x X. ALL y. EX z Z. (~P(y,y) | P(x,x) | ~S(z,x)) &
               (S(x,y) | ~S(y,z) | Q(Z,Z))  &
               (Q(X,y) | ~Q(y,Z) | S(X,X))"
by metis

lemma "P(n::nat) ==> ~P(0) ==> n ~= 0"
by metis

sledgehammer_params [isar_proofs, compress = 1]

(*multiple versions of this example*)
lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>1 \<union> x\<^sub>2" by (metis Un_commute Un_upper2)
  have F2a: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<longrightarrow> x\<^sub>2 = x\<^sub>2 \<union> x\<^sub>1" by (metis Un_commute subset_Un_eq)
  have F2: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis F2a subset_Un_eq)
  { assume "\<not> Z \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
  moreover
  { assume AA1: "Y \<union> Z \<noteq> X"
    { assume "\<not> Y \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1) }
    moreover
    { assume AAA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
      { assume "\<not> Z \<subseteq> X"
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      moreover
      { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
        hence "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z" by (metis Un_subset_iff)
        hence "Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> Y \<union> Z" by (metis F2)
        hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1)
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AAA1) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1) }
  moreover
  { assume "\<exists>x\<^sub>1::'a set. (Z \<subseteq> x\<^sub>1 \<and> Y \<subseteq> x\<^sub>1) \<and> \<not> X \<subseteq> x\<^sub>1"
    { assume "\<not> Y \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1) }
    moreover
    { assume AAA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
      { assume "\<not> Z \<subseteq> X"
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      moreover
      { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
        hence "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z" by (metis Un_subset_iff)
        hence "Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> Y \<union> Z" by (metis F2)
        hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1)
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AAA1) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by blast }
  moreover
  { assume "\<not> Y \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by metis
qed

sledgehammer_params [isar_proofs, compress = 2]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis Un_commute subset_Un_eq)
  { assume AA1: "\<exists>x\<^sub>1::'a set. (Z \<subseteq> x\<^sub>1 \<and> Y \<subseteq> x\<^sub>1) \<and> \<not> X \<subseteq> x\<^sub>1"
    { assume AAA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
      { assume "\<not> Z \<subseteq> X"
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      moreover
      { assume "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z"
        hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1 Un_commute Un_upper2)
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AAA1 Un_subset_iff) }
    moreover
    { assume "\<not> Y \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 Un_subset_iff) }
  moreover
  { assume "\<not> Z \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
  moreover
  { assume "\<not> Y \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2) }
  moreover
  { assume AA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
    { assume "\<not> Z \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
    moreover
    { assume "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z"
      hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1 Un_commute Un_upper2)
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 Un_subset_iff) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by metis
qed

sledgehammer_params [isar_proofs, compress = 3]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1a: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<longrightarrow> x\<^sub>2 = x\<^sub>2 \<union> x\<^sub>1" by (metis Un_commute subset_Un_eq)
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis F1a subset_Un_eq)
  { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1 Un_commute Un_subset_iff Un_upper2) }
  moreover
  { assume AA1: "\<exists>x\<^sub>1::'a set. (Z \<subseteq> x\<^sub>1 \<and> Y \<subseteq> x\<^sub>1) \<and> \<not> X \<subseteq> x\<^sub>1"
    { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1 Un_commute Un_subset_iff Un_upper2) }
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 Un_commute Un_subset_iff Un_upper2) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2)
qed

sledgehammer_params [isar_proofs, compress = 4]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis Un_commute subset_Un_eq)
  { assume "\<not> Y \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2) }
  moreover
  { assume AA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
    { assume "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 F1 Un_commute Un_subset_iff Un_upper2) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_subset_iff Un_upper2)
qed

sledgehammer_params [isar_proofs, compress = 1]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
by (metis Un_least Un_upper1 Un_upper2 set_eq_subset)

lemma "(X = Y \<inter> Z) = (X \<subseteq> Y \<and> X \<subseteq> Z \<and> (\<forall>V. V \<subseteq> Y \<and> V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
by (metis Int_greatest Int_lower1 Int_lower2 subset_antisym)

lemma fixedpoint: "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
by metis

lemma (* fixedpoint: *) "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
proof -
  assume "\<exists>!x::'a. f (g x) = x"
  thus "\<exists>!y::'b. g (f y) = y" by metis
qed

lemma (* singleton_example_2: *)
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
by (metis Set.subsetI Union_upper insertCI set_eq_subset)

lemma (* singleton_example_2: *)
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
by (metis Set.subsetI Union_upper insert_iff set_eq_subset)

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
proof -
  assume "\<forall>x \<in> S. \<Union>S \<subseteq> x"
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> \<Union>S \<and> x\<^sub>1 \<in> S \<longrightarrow> x\<^sub>1 = \<Union>S" by (metis set_eq_subset)
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<in> S \<longrightarrow> x\<^sub>1 = \<Union>S" by (metis Union_upper)
  hence "\<forall>x\<^sub>1::('a set) set. \<Union>S \<in> x\<^sub>1 \<longrightarrow> S \<subseteq> x\<^sub>1" by (metis subsetI)
  hence "\<forall>x\<^sub>1::('a set) set. S \<subseteq> insert (\<Union>S) x\<^sub>1" by (metis insert_iff)
  thus "\<exists>z. S \<subseteq> {z}" by metis
qed

text \<open>
  From W. W. Bledsoe and Guohui Feng, SET-VAR. JAR 11 (3), 1993, pages
  293-314.
\<close>

(* Notes: (1) The numbering doesn't completely agree with the paper.
   (2) We must rename set variables to avoid type clashes. *)
lemma "\<exists>B. (\<forall>x \<in> B. x \<le> (0::int))"
      "D \<in> F \<Longrightarrow> \<exists>G. \<forall>A \<in> G. \<exists>B \<in> F. A \<subseteq> B"
      "P a \<Longrightarrow> \<exists>A. (\<forall>x \<in> A. P x) \<and> (\<exists>y. y \<in> A)"
      "a < b \<and> b < (c::int) \<Longrightarrow> \<exists>B. a \<notin> B \<and> b \<in> B \<and> c \<notin> B"
      "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
      "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
      "\<exists>A. a \<notin> A"
      "(\<forall>C. (0, 0) \<in> C \<and> (\<forall>x y. (x, y) \<in> C \<longrightarrow> (Suc x, Suc y) \<in> C) \<longrightarrow> (n, m) \<in> C) \<and> Q n \<longrightarrow> Q m"
       apply (metis all_not_in_conv)
      apply (metis all_not_in_conv)
     apply (metis mem_Collect_eq)
    apply (metis less_le singleton_iff)
   apply (metis mem_Collect_eq)
  apply (metis mem_Collect_eq)
 apply (metis all_not_in_conv)
by (metis pair_in_Id_conv)

end


(*  Title:      ZF/Nat_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*The Natural numbers As a Least Fixed Point*}

theory Nat_ZF imports OrdQuant Bool begin

definition
  nat :: i  where
    "nat == lfp(Inf, %X. {0} \<union> {succ(i). i \<in> X})"

definition
  quasinat :: "i => o"  where
    "quasinat(n) == n=0 | (\<exists>m. n = succ(m))"

definition
  (*Has an unconditional succ case, which is used in "recursor" below.*)
  nat_case :: "[i, i=>i, i]=>i"  where
    "nat_case(a,b,k) == THE y. k=0 & y=a | (\<exists>x. k=succ(x) & y=b(x))"

definition
  nat_rec :: "[i, i, [i,i]=>i]=>i"  where
    "nat_rec(k,a,b) ==
          wfrec(Memrel(nat), k, %n f. nat_case(a, %m. b(m, f`m), n))"

  (*Internalized relations on the naturals*)

definition
  Le :: i  where
    "Le == {<x,y>:nat*nat. x \<le> y}"

definition
  Lt :: i  where
    "Lt == {<x, y>:nat*nat. x < y}"

definition
  Ge :: i  where
    "Ge == {<x,y>:nat*nat. y \<le> x}"

definition
  Gt :: i  where
    "Gt == {<x,y>:nat*nat. y < x}"

definition
  greater_than :: "i=>i"  where
    "greater_than(n) == {i \<in> nat. n < i}"

text{*No need for a less-than operator: a natural number is its list of
predecessors!*}

lemma nat_bnd_mono: "bnd_mono(Inf, %X. {0} \<union> {succ(i). i \<in> X})"
apply (rule bnd_monoI)
apply (cut_tac infinity, blast, blast)
done

(* @{term"nat = {0} \<union> {succ(x). x \<in> nat}"} *)
lemmas nat_unfold = nat_bnd_mono [THEN nat_def [THEN def_lfp_unfold]]

(** Type checking of 0 and successor **)

lemma nat_0I [iff,TC]: "0 \<in> nat"
apply (subst nat_unfold)
apply (rule singletonI [THEN UnI1])
done

lemma nat_succI [intro!,TC]: "n \<in> nat ==> succ(n) \<in> nat"
apply (subst nat_unfold)
apply (erule RepFunI [THEN UnI2])
done

lemma nat_1I [iff,TC]: "1 \<in> nat"
by (rule nat_0I [THEN nat_succI])

lemma nat_2I [iff,TC]: "2 \<in> nat"
by (rule nat_1I [THEN nat_succI])

lemma bool_subset_nat: "bool \<subseteq> nat"
by (blast elim!: boolE)

lemmas bool_into_nat = bool_subset_nat [THEN subsetD]

subsection{*Injectivity Properties and Induction*}

(*Mathematical induction*)
lemma nat_induct [case_names 0 succ, induct set: nat]:
    "[| n \<in> nat;  P(0);  !!x. [| x \<in> nat;  P(x) |] ==> P(succ(x)) |] ==> P(n)"
by (erule def_induct [OF nat_def nat_bnd_mono], blast)

lemma natE:
 assumes "n \<in> nat"
 obtains ("0") "n=0" | (succ) x where "x \<in> nat" "n=succ(x)"
using assms
by (rule nat_unfold [THEN equalityD1, THEN subsetD, THEN UnE]) auto

lemma nat_into_Ord [simp]: "n \<in> nat ==> Ord(n)"
by (erule nat_induct, auto)

(* @{term"i \<in> nat ==> 0 \<le> i"}; same thing as @{term"0<succ(i)"}  *)
lemmas nat_0_le = nat_into_Ord [THEN Ord_0_le]

(* @{term"i \<in> nat ==> i \<le> i"}; same thing as @{term"i<succ(i)"}  *)
lemmas nat_le_refl = nat_into_Ord [THEN le_refl]

lemma Ord_nat [iff]: "Ord(nat)"
apply (rule OrdI)
apply (erule_tac [2] nat_into_Ord [THEN Ord_is_Transset])
apply (unfold Transset_def)
apply (rule ballI)
apply (erule nat_induct, auto)
done

lemma Limit_nat [iff]: "Limit(nat)"
apply (unfold Limit_def)
apply (safe intro!: ltI Ord_nat)
apply (erule ltD)
done

lemma naturals_not_limit: "a \<in> nat ==> ~ Limit(a)"
by (induct a rule: nat_induct, auto)

lemma succ_natD: "succ(i): nat ==> i \<in> nat"
by (rule Ord_trans [OF succI1], auto)

lemma nat_succ_iff [iff]: "succ(n): nat \<longleftrightarrow> n \<in> nat"
by (blast dest!: succ_natD)

lemma nat_le_Limit: "Limit(i) ==> nat \<le> i"
apply (rule subset_imp_le)
apply (simp_all add: Limit_is_Ord)
apply (rule subsetI)
apply (erule nat_induct)
 apply (erule Limit_has_0 [THEN ltD])
apply (blast intro: Limit_has_succ [THEN ltD] ltI Limit_is_Ord)
done

(* [| succ(i): k;  k \<in> nat |] ==> i \<in> k *)
lemmas succ_in_naturalD = Ord_trans [OF succI1 _ nat_into_Ord]

lemma lt_nat_in_nat: "[| m<n;  n \<in> nat |] ==> m \<in> nat"
apply (erule ltE)
apply (erule Ord_trans, assumption, simp)
done

lemma le_in_nat: "[| m \<le> n; n \<in> nat |] ==> m \<in> nat"
by (blast dest!: lt_nat_in_nat)

subsection{*Variations on Mathematical Induction*}

(*complete induction*)

lemmas complete_induct = Ord_induct [OF _ Ord_nat, case_names less, consumes 1]

lemmas complete_induct_rule =
        complete_induct [rule_format, case_names less, consumes 1]

lemma nat_induct_from_lemma [rule_format]:
    "[| n \<in> nat;  m \<in> nat;
        !!x. [| x \<in> nat;  m \<le> x;  P(x) |] ==> P(succ(x)) |]
     ==> m \<le> n \<longrightarrow> P(m) \<longrightarrow> P(n)"
apply (erule nat_induct)
apply (simp_all add: distrib_simps le0_iff le_succ_iff)
done

(*Induction starting from m rather than 0*)
lemma nat_induct_from:
    "[| m \<le> n;  m \<in> nat;  n \<in> nat;
        P(m);
        !!x. [| x \<in> nat;  m \<le> x;  P(x) |] ==> P(succ(x)) |]
     ==> P(n)"
apply (blast intro: nat_induct_from_lemma)
done

(*Induction suitable for subtraction and less-than*)
lemma diff_induct [case_names 0 0_succ succ_succ, consumes 2]:
    "[| m \<in> nat;  n \<in> nat;
        !!x. x \<in> nat ==> P(x,0);
        !!y. y \<in> nat ==> P(0,succ(y));
        !!x y. [| x \<in> nat;  y \<in> nat;  P(x,y) |] ==> P(succ(x),succ(y)) |]
     ==> P(m,n)"
apply (erule_tac x = m in rev_bspec)
apply (erule nat_induct, simp)
apply (rule ballI)
apply (rename_tac i j)
apply (erule_tac n=j in nat_induct, auto)
done

(** Induction principle analogous to trancl_induct **)

lemma succ_lt_induct_lemma [rule_format]:
     "m \<in> nat ==> P(m,succ(m)) \<longrightarrow> (\<forall>x\<in>nat. P(m,x) \<longrightarrow> P(m,succ(x))) \<longrightarrow>
                 (\<forall>n\<in>nat. m<n \<longrightarrow> P(m,n))"
apply (erule nat_induct)
 apply (intro impI, rule nat_induct [THEN ballI])
   prefer 4 apply (intro impI, rule nat_induct [THEN ballI])
apply (auto simp add: le_iff)
done

lemma succ_lt_induct:
    "[| m<n;  n \<in> nat;
        P(m,succ(m));
        !!x. [| x \<in> nat;  P(m,x) |] ==> P(m,succ(x)) |]
     ==> P(m,n)"
by (blast intro: succ_lt_induct_lemma lt_nat_in_nat)

subsection{*quasinat: to allow a case-split rule for @{term nat_case}*}

text{*True if the argument is zero or any successor*}

lemma [iff]: "quasinat(succ(x))"
by (simp add: quasinat_def)

lemma nat_imp_quasinat: "n \<in> nat ==> quasinat(n)"
by (erule natE, simp_all)

lemma non_nat_case: "~ quasinat(x) ==> nat_case(a,b,x) = 0"
by (simp add: quasinat_def nat_case_def)

lemma nat_cases_disj: "k=0 | (\<exists>y. k = succ(y)) | ~ quasinat(k)"
apply (case_tac "k=0", simp)
apply (case_tac "\<exists>m. k = succ(m)")
apply (simp_all add: quasinat_def)
done

lemma nat_cases:
     "[|k=0 ==> P;  !!y. k = succ(y) ==> P; ~ quasinat(k) ==> P|] ==> P"
by (insert nat_cases_disj [of k], blast)

(** nat_case **)

lemma nat_case_0 [simp]: "nat_case(a,b,0) = a"
by (simp add: nat_case_def)

lemma nat_case_succ [simp]: "nat_case(a,b,succ(n)) = b(n)"
by (simp add: nat_case_def)

lemma nat_case_type [TC]:
    "[| n \<in> nat;  a \<in> C(0);  !!m. m \<in> nat ==> b(m): C(succ(m)) |]
     ==> nat_case(a,b,n) \<in> C(n)"
by (erule nat_induct, auto)

lemma split_nat_case:
  "P(nat_case(a,b,k)) \<longleftrightarrow>
   ((k=0 \<longrightarrow> P(a)) & (\<forall>x. k=succ(x) \<longrightarrow> P(b(x))) & (~ quasinat(k) \<longrightarrow> P(0)))"
apply (rule nat_cases [of k])
apply (auto simp add: non_nat_case)
done

subsection{*Recursion on the Natural Numbers*}

(** nat_rec is used to define eclose and transrec, then becomes obsolete.
    The operator rec, from arith.thy, has fewer typing conditions **)

lemma nat_rec_0: "nat_rec(0,a,b) = a"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (rule nat_case_0)
done

lemma nat_rec_succ: "m \<in> nat ==> nat_rec(succ(m),a,b) = b(m, nat_rec(m,a,b))"
apply (rule nat_rec_def [THEN def_wfrec, THEN trans])
 apply (rule wf_Memrel)
apply (simp add: vimage_singleton_iff)
done

(** The union of two natural numbers is a natural number -- their maximum **)

lemma Un_nat_type [TC]: "[| i \<in> nat; j \<in> nat |] ==> i \<union> j \<in> nat"
apply (rule Un_least_lt [THEN ltD])
apply (simp_all add: lt_def)
done

lemma Int_nat_type [TC]: "[| i \<in> nat; j \<in> nat |] ==> i \<inter> j \<in> nat"
apply (rule Int_greatest_lt [THEN ltD])
apply (simp_all add: lt_def)
done

(*needed to simplify unions over nat*)
lemma nat_nonempty [simp]: "nat \<noteq> 0"
by blast

text{*A natural number is the set of its predecessors*}
lemma nat_eq_Collect_lt: "i \<in> nat ==> {j\<in>nat. j<i} = i"
apply (rule equalityI)
apply (blast dest: ltD)
apply (auto simp add: Ord_mem_iff_lt)
apply (blast intro: lt_trans)
done

lemma Le_iff [iff]: "<x,y> \<in> Le \<longleftrightarrow> x \<le> y & x \<in> nat & y \<in> nat"
by (force simp add: Le_def)

end


(*  Title:      HOL/HOLCF/Tutorial/Fixrec_ex.thy
    Author:     Brian Huffman
*)

section \<open>Fixrec package examples\<close>

theory Fixrec_ex
imports HOLCF
begin

subsection \<open>Basic \<open>fixrec\<close> examples\<close>

text \<open>
  Fixrec patterns can mention any constructor defined by the domain
  package, as well as any of the following built-in constructors:
  Pair, spair, sinl, sinr, up, ONE, TT, FF.
\<close>

text \<open>Typical usage is with lazy constructors.\<close>

fixrec down :: "'a u \<rightarrow> 'a"
where "down\<cdot>(up\<cdot>x) = x"

text \<open>With strict constructors, rewrite rules may require side conditions.\<close>

fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"

text \<open>Lifting can turn a strict constructor into a lazy one.\<close>

fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"

text \<open>Fixrec also works with the HOL pair constructor.\<close>

fixrec down2 :: "'a u \<times> 'b u \<rightarrow> 'a \<times> 'b"
where "down2\<cdot>(up\<cdot>x, up\<cdot>y) = (x, y)"

subsection \<open>Examples using \<open>fixrec_simp\<close>\<close>

text \<open>A type of lazy lists.\<close>

domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")

text \<open>A zip function for lazy lists.\<close>

text \<open>Notice that the patterns are not exhaustive.\<close>

fixrec
  lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
where
  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip\<cdot>xs\<cdot>ys)"
| "lzip\<cdot>lNil\<cdot>lNil = lNil"

text \<open>\<open>fixrec_simp\<close> is useful for producing strictness theorems.\<close>
text \<open>Note that pattern matching is done in left-to-right order.\<close>

lemma lzip_stricts [simp]:
  "lzip\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "lzip\<cdot>lNil\<cdot>\<bottom> = \<bottom>"
  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

text \<open>\<open>fixrec_simp\<close> can also produce rules for missing cases.\<close>

lemma lzip_undefs [simp]:
  "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = \<bottom>"
  "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = \<bottom>"
by fixrec_simp+

subsection \<open>Pattern matching with bottoms\<close>

text \<open>
  As an alternative to using \<open>fixrec_simp\<close>, it is also possible
  to use bottom as a constructor pattern.  When using a bottom
  pattern, the right-hand-side must also be bottom; otherwise, \<open>fixrec\<close> will not be able to prove the equation.
\<close>

fixrec
  from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
where
  "from_sinr_up\<cdot>\<bottom> = \<bottom>"
| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"

text \<open>
  If the function is already strict in that argument, then the bottom
  pattern does not change the meaning of the function.  For example,
  in the definition of \<^term>\<open>from_sinr_up\<close>, the first equation is
  actually redundant, and could have been proven separately by
  \<open>fixrec_simp\<close>.
\<close>

text \<open>
  A bottom pattern can also be used to make a function strict in a
  certain argument, similar to a bang-pattern in Haskell.
\<close>

fixrec
  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
where
  "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"

subsection \<open>Skipping proofs of rewrite rules\<close>

text \<open>Another zip function for lazy lists.\<close>

text \<open>
  Notice that this version has overlapping patterns.
  The second equation cannot be proved as a theorem
  because it only applies when the first pattern fails.
\<close>

fixrec
  lzip2 :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
where
  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot>(x, y)\<cdot>(lzip2\<cdot>xs\<cdot>ys)"
| (unchecked) "lzip2\<cdot>xs\<cdot>ys = lNil"

text \<open>
  Usually fixrec tries to prove all equations as theorems.
  The "unchecked" option overrides this behavior, so fixrec
  does not attempt to prove that particular equation.
\<close>

text \<open>Simp rules can be generated later using \<open>fixrec_simp\<close>.\<close>

lemma lzip2_simps [simp]:
  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil = lNil"
  "lzip2\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys) = lNil"
  "lzip2\<cdot>lNil\<cdot>lNil = lNil"
by fixrec_simp+

lemma lzip2_stricts [simp]:
  "lzip2\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom> = \<bottom>"
by fixrec_simp+

subsection \<open>Mutual recursion with \<open>fixrec\<close>\<close>

text \<open>Tree and forest types.\<close>

domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
and    'a forest = Empty | Trees (lazy "'a tree") "'a forest"

text \<open>
  To define mutually recursive functions, give multiple type signatures
  separated by the keyword \<open>and\<close>.
\<close>

fixrec
  map_tree :: "('a \<rightarrow> 'b) \<rightarrow> ('a tree \<rightarrow> 'b tree)"
and
  map_forest :: "('a \<rightarrow> 'b) \<rightarrow> ('a forest \<rightarrow> 'b forest)"
where
  "map_tree\<cdot>f\<cdot>(Leaf\<cdot>x) = Leaf\<cdot>(f\<cdot>x)"
| "map_tree\<cdot>f\<cdot>(Branch\<cdot>ts) = Branch\<cdot>(map_forest\<cdot>f\<cdot>ts)"
| "map_forest\<cdot>f\<cdot>Empty = Empty"
| "ts \<noteq> \<bottom> \<Longrightarrow>
    map_forest\<cdot>f\<cdot>(Trees\<cdot>t\<cdot>ts) = Trees\<cdot>(map_tree\<cdot>f\<cdot>t)\<cdot>(map_forest\<cdot>f\<cdot>ts)"

lemma map_tree_strict [simp]: "map_tree\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma map_forest_strict [simp]: "map_forest\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

(*
  Theorems generated:
  @{text map_tree_def}  @{thm map_tree_def}
  @{text map_forest_def}  @{thm map_forest_def}
  @{text map_tree.unfold}  @{thm map_tree.unfold}
  @{text map_forest.unfold}  @{thm map_forest.unfold}
  @{text map_tree.simps}  @{thm map_tree.simps}
  @{text map_forest.simps}  @{thm map_forest.simps}
  @{text map_tree_map_forest.induct}  @{thm map_tree_map_forest.induct}
*)

subsection \<open>Looping simp rules\<close>

text \<open>
  The defining equations of a fixrec definition are declared as simp
  rules by default.  In some cases, especially for constants with no
  arguments or functions with variable patterns, the defining
  equations may cause the simplifier to loop.  In these cases it will
  be necessary to use a \<open>[simp del]\<close> declaration.
\<close>

fixrec
  repeat :: "'a \<rightarrow> 'a llist"
where
  [simp del]: "repeat\<cdot>x = lCons\<cdot>x\<cdot>(repeat\<cdot>x)"

text \<open>
  We can derive other non-looping simp rules for \<^const>\<open>repeat\<close> by
  using the \<open>subst\<close> method with the \<open>repeat.simps\<close> rule.
\<close>

lemma repeat_simps [simp]:
  "repeat\<cdot>x \<noteq> \<bottom>"
  "repeat\<cdot>x \<noteq> lNil"
  "repeat\<cdot>x = lCons\<cdot>y\<cdot>ys \<longleftrightarrow> x = y \<and> repeat\<cdot>x = ys"
by (subst repeat.simps, simp)+

lemma llist_case_repeat [simp]:
  "llist_case\<cdot>z\<cdot>f\<cdot>(repeat\<cdot>x) = f\<cdot>x\<cdot>(repeat\<cdot>x)"
by (subst repeat.simps, simp)

text \<open>
  For mutually-recursive constants, looping might only occur if all
  equations are in the simpset at the same time.  In such cases it may
  only be necessary to declare \<open>[simp del]\<close> on one equation.
\<close>

fixrec
  inf_tree :: "'a tree" and inf_forest :: "'a forest"
where
  [simp del]: "inf_tree = Branch\<cdot>inf_forest"
| "inf_forest = Trees\<cdot>inf_tree\<cdot>(Trees\<cdot>inf_tree\<cdot>Empty)"

subsection \<open>Using \<open>fixrec\<close> inside locales\<close>

locale test =
  fixes foo :: "'a \<rightarrow> 'a"
  assumes foo_strict: "foo\<cdot>\<bottom> = \<bottom>"
begin

fixrec
  bar :: "'a u \<rightarrow> 'a"
where
  "bar\<cdot>(up\<cdot>x) = foo\<cdot>x"

lemma bar_strict: "bar\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

end

end


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

Reachability in Directed Graphs.  From Chandy and Misra, section 6.4.
[this example took only four days!]
*)

theory Reach imports "../UNITY_Main" begin

typedecl vertex

type_synonym state = "vertex=>bool"

consts
  init ::  "vertex"

  edges :: "(vertex*vertex) set"

definition asgt :: "[vertex,vertex] => (state*state) set"
  where "asgt u v = {(s,s'). s' = s(v:= s u | s v)}"

definition Rprg :: "state program"
  where "Rprg = mk_total_program ({%v. v=init}, \<Union>(u,v)\<in>edges. {asgt u v}, UNIV)"

definition reach_invariant :: "state set"
  where "reach_invariant = {s. (\<forall>v. s v --> (init, v) \<in> edges^*) & s init}"

definition fixedpoint :: "state set"
  where "fixedpoint = {s. \<forall>(u,v)\<in>edges. s u --> s v}"

definition metric :: "state => nat"
  where "metric s = card {v. ~ s v}"

text\<open>*We assume that the set of vertices is finite\<close>
axiomatization where
  finite_graph:  "finite (UNIV :: vertex set)"

(*TO SIMPDATA.ML??  FOR CLASET??  *)
lemma ifE [elim!]:
    "[| if P then Q else R;
        [| P;   Q |] ==> S;
        [| ~ P; R |] ==> S |] ==> S"
by (simp split: if_split_asm)

declare Rprg_def [THEN def_prg_Init, simp]

declare asgt_def [THEN def_act_simp,simp]

text\<open>All vertex sets are finite\<close>
declare finite_subset [OF subset_UNIV finite_graph, iff]

declare reach_invariant_def [THEN def_set_simp, simp]

lemma reach_invariant: "Rprg \<in> Always reach_invariant"
apply (rule AlwaysI, force)
apply (unfold Rprg_def, safety)
apply (blast intro: rtrancl_trans)
done

(*** Fixedpoint ***)

(*If it reaches a fixedpoint, it has found a solution*)
lemma fixedpoint_invariant_correct:
     "fixedpoint \<inter> reach_invariant = { %v. (init, v) \<in> edges^* }"
apply (unfold fixedpoint_def)
apply (rule equalityI)
apply (auto intro!: ext)
apply (erule rtrancl_induct, auto)
done

lemma lemma1:
     "FP Rprg \<subseteq> fixedpoint"
apply (simp add: FP_def fixedpoint_def Rprg_def mk_total_program_def)
apply (auto simp add: stable_def constrains_def)
apply (drule bspec, assumption)
apply (simp add: Image_singleton image_iff)
apply (drule fun_cong, auto)
done

lemma lemma2:
     "fixedpoint \<subseteq> FP Rprg"
apply (simp add: FP_def fixedpoint_def Rprg_def mk_total_program_def)
apply (auto intro!: ext simp add: stable_def constrains_def)
done

lemma FP_fixedpoint: "FP Rprg = fixedpoint"
by (rule equalityI [OF lemma1 lemma2])

(*If we haven't reached a fixedpoint then there is some edge for which u but
  not v holds.  Progress will be proved via an ENSURES assertion that the
  metric will decrease for each suitable edge.  A union over all edges proves
  a LEADSTO assertion that the metric decreases if we are not at a fixedpoint.
  *)

lemma Compl_fixedpoint: "- fixedpoint = (\<Union>(u,v)\<in>edges. {s. s u & ~ s v})"
apply (simp add: FP_fixedpoint [symmetric] Rprg_def mk_total_program_def)
apply (rule subset_antisym)
apply (auto simp add: Compl_FP UN_UN_flatten)
 apply (rule fun_upd_idem, force)
apply (force intro!: rev_bexI simp add: fun_upd_idem_iff)
done

lemma Diff_fixedpoint:
     "A - fixedpoint = (\<Union>(u,v)\<in>edges. A \<inter> {s. s u & ~ s v})"
by (simp add: Diff_eq Compl_fixedpoint, blast)

(*** Progress ***)

lemma Suc_metric: "~ s x ==> Suc (metric (s(x:=True))) = metric s"
apply (unfold metric_def)
apply (subgoal_tac "{v. ~ (s (x:=True)) v} = {v. ~ s v} - {x}")
 prefer 2 apply force
apply (simp add: card_Suc_Diff1 del:card_Diff_insert)
done

lemma metric_less [intro!]: "~ s x ==> metric (s(x:=True)) < metric s"
by (erule Suc_metric [THEN subst], blast)

lemma metric_le: "metric (s(y:=s x | s y)) \<le> metric s"
  by (cases "s x --> s y") (auto intro: less_imp_le simp add: fun_upd_idem)

lemma LeadsTo_Diff_fixedpoint:
     "Rprg \<in> ((metric-`{m}) - fixedpoint) LeadsTo (metric-`(lessThan m))"
apply (simp (no_asm) add: Diff_fixedpoint Rprg_def)
apply (rule LeadsTo_UN, auto)
apply (ensures_tac "asgt a b")
 prefer 2 apply blast
apply (simp (no_asm_use) add: linorder_not_less)
apply (drule metric_le [THEN order_antisym])
apply (auto elim: less_not_refl3 [THEN [2] rev_notE])
done

lemma LeadsTo_Un_fixedpoint:
     "Rprg \<in> (metric-`{m}) LeadsTo (metric-`(lessThan m) \<union> fixedpoint)"
apply (rule LeadsTo_Diff [OF LeadsTo_Diff_fixedpoint [THEN LeadsTo_weaken_R]
                             subset_imp_LeadsTo], auto)
done

(*Execution in any state leads to a fixedpoint (i.e. can terminate)*)
lemma LeadsTo_fixedpoint: "Rprg \<in> UNIV LeadsTo fixedpoint"
apply (rule LessThan_induct, auto)
apply (rule LeadsTo_Un_fixedpoint)
done

lemma LeadsTo_correct: "Rprg \<in> UNIV LeadsTo { %v. (init, v) \<in> edges^* }"
apply (subst fixedpoint_invariant_correct [symmetric])
apply (rule Always_LeadsTo_weaken [OF reach_invariant LeadsTo_fixedpoint], auto)
done

end


(*  Title:      HOL/IOA/Asig.thy
    Author:     Tobias Nipkow & Konrad Slind
    Copyright   1994  TU Muenchen
*)

section \<open>Action signatures\<close>

theory Asig
imports Main
begin

type_synonym 'a signature = "('a set \<times> 'a set \<times> 'a set)"

definition "inputs" :: "'action signature \<Rightarrow> 'action set"
  where asig_inputs_def: "inputs \<equiv> fst"

definition "outputs" :: "'action signature \<Rightarrow> 'action set"
  where asig_outputs_def: "outputs \<equiv> (fst \<circ> snd)"

definition "internals" :: "'action signature \<Rightarrow> 'action set"
  where asig_internals_def: "internals \<equiv> (snd \<circ> snd)"

definition "actions" :: "'action signature \<Rightarrow> 'action set"
  where actions_def: "actions(asig) \<equiv> (inputs(asig) \<union> outputs(asig) \<union> internals(asig))"

definition externals :: "'action signature \<Rightarrow> 'action set"
  where externals_def: "externals(asig) \<equiv> (inputs(asig) \<union> outputs(asig))"

definition is_asig :: "'action signature => bool"
  where "is_asig(triple) \<equiv>
    ((inputs(triple) \<inter> outputs(triple) = {})    \<and>
     (outputs(triple) \<inter> internals(triple) = {}) \<and>
     (inputs(triple) \<inter> internals(triple) = {}))"

definition mk_ext_asig :: "'action signature \<Rightarrow> 'action signature"
  where "mk_ext_asig(triple) \<equiv> (inputs(triple), outputs(triple), {})"

lemmas asig_projections = asig_inputs_def asig_outputs_def asig_internals_def

lemma int_and_ext_is_act: "\<lbrakk>a\<notin>internals(S); a\<notin>externals(S)\<rbrakk> \<Longrightarrow> a\<notin>actions(S)"
  apply (simp add: externals_def actions_def)
  done

lemma ext_is_act: "a\<in>externals(S) \<Longrightarrow> a\<in>actions(S)"
  apply (simp add: externals_def actions_def)
  done

end