theory Teoreme
imports Complex_Main
begin

(* 108. Simetricna razlika skupova definise na sledeci nacin: *)
 fun simetricnaRazlika :: "nat set => nat set => nat set" where
  "simetricnaRazlika A B = (A - B) \<union> (B - A)"

(* a) *)
lemma "simetricnaRazlika A B = (A \<union> B) - (A \<inter> B)" (is "?levo = ?desno")
proof
  show "?levo \<subseteq> ?desno"
    proof
      fix x
      assume "x \<in> ?levo"
          hence "(x \<in> A-B) \<or> (x \<in> B-A)"
            by auto
          hence "(x \<in> A \<and> x \<notin> B) \<or> (x \<in> B \<and> x \<notin> A)"
            by auto
          hence "(x \<in> A \<union> B) \<and> (x \<notin> (A \<inter> B))"
            by auto
          thus "x \<in> ?desno"
            by auto
     qed
next
  show "?desno \<subseteq> ?levo"
    proof
      fix x
      assume "x \<in> ?desno"
        hence "x \<in> (A \<union> B) \<and> x \<notin> (A \<inter> B)"
          by auto
        hence "(x \<in> A \<or> x \<in> B) \<and> (x \<in> -A \<or> x \<in> -B)"
          by auto
        hence "(x \<in> A-B) \<or> (x \<in> B-A)"
          by auto
        thus "x \<in> ?levo"
          by auto
  qed
qed

(* b) *)
lemma "simetricnaRazlika A B = simetricnaRazlika B A" (is "?levo = ?desno")
proof
  show "?levo \<subseteq> ?desno"
  (*i ovo je moglo by auto, ali je uradjeno ovako cisto kao mali primer*)
  proof
    fix x
    assume "x \<in> ?levo"
      hence "x \<in> A - B \<or> x \<in> B - A"
        by auto
      thus "x \<in> ?desno"
        by auto
   qed
next
  show "?desno \<subseteq> ?levo"
    by auto
  qed

(* v) *)
lemma "simetricnaRazlika A A = {}" (is "?levo = ?desno")
  proof
    show "?levo \<subseteq> ?desno"
    proof
      fix x
      assume "x \<in> ?levo"
        hence "x \<in> A-A"
          by auto
        thus "x \<in> ?desno"
          by auto
     qed
next
  show "?desno \<subseteq> ?levo"
  proof
    fix x
    assume "x \<in> ?desno"
      hence "x \<in> A-A"
        by auto
  qed
qed

(* g) *)
lemma "simetricnaRazlika A (simetricnaRazlika B C) = simetricnaRazlika (simetricnaRazlika A B) C"
    by auto

(* d) *)
lemma "simetricnaRazlika A (simetricnaRazlika A B) = B"
  by auto

(* dj) *)
lemma "A \<union> B = simetricnaRazlika (simetricnaRazlika A B) (A \<inter> B)"
  by auto

(* e) *)
lemma "A \<inter> simetricnaRazlika B C = simetricnaRazlika (A \<inter> B) (A \<inter> C)"
  by auto

(* 38. *)
(* g) *)
lemma "A - (B \<inter> C) = (A - B) \<union> (A - C)" (is "?levo = ?desno")
proof
  show "?levo \<subseteq> ?desno"
    proof
    fix x
    assume "x \<in> ?levo"
      hence "x \<in> A \<and> x \<notin> (B \<inter> C)"
        by auto
      hence "x \<in> A \<and> (x \<notin> B \<or> x \<notin> C)"
        by auto
      hence "x \<in> A \<and> x \<notin> B \<or> x \<in> A \<and> x \<notin> C"
        by auto
      thus "x \<in> ?desno"
        by auto
    qed
next
  show "?desno \<subseteq> ?levo"
  proof
    fix x
    assume "x \<in> ?desno"
    hence "x \<in> A-B \<or> x \<in> A-C"
      by auto
    hence "x \<in> A \<and> (x \<notin> B \<or> x \<notin> C)"
      by auto
    thus "x \<in> ?levo"
      by auto
  qed
qed

(* dj) *)
lemma "A \<inter> (B-C) = (A \<inter> B) - (A \<inter> C)" (is "?levo = ?desno")
proof
  show "?levo \<subseteq> ?desno"
  proof
    fix x
    assume "x \<in> ?levo"
    hence "x \<in> A \<and> x \<in> B \<and> x \<notin> C"
      by auto
    hence "x \<in> A \<inter> B \<and> x \<notin> A \<inter> C"
      by auto
    thus "x \<in> ?desno"
      by auto
   qed
next
  show "?desno \<subseteq> ?levo"
  proof
    fix x
    assume "x \<in> ?desno"
    hence "x \<in> A \<inter> B \<and> x \<notin> A \<inter> C"
      by auto
    hence "x \<in> A \<and> x \<in> B \<and> x \<notin> C"
      by auto
    thus "x \<in> ?levo"
      by auto
  qed
qed

(* z) *)
lemma "A - (B - C) = (A-B) \<union> (A \<inter> C)" (is "?levo = ?desno")
proof
  show "?levo \<subseteq> ?desno"
  proof
    fix x
    assume "x \<in> ?levo"
      hence "x \<in> A \<and> x \<notin> (B - C)"
        by auto
      hence "x \<in> A \<and> (x \<notin> B \<or> x \<in> C)"
        by auto
      hence "x \<in> A \<and> x \<notin> B \<or> x \<in> A \<and> x \<in> C"
        by metis
      thus "x \<in> ?desno"
        by auto
  qed
next
  show "?desno \<subseteq> ?levo"
  proof
      fix x
      assume "x \<in> ?desno"
      hence "x \<in> A \<and> x \<notin> B \<or> x \<in> A \<and> x \<in> C"
        by auto
      hence "x \<in> A \<and> x \<notin> B-C"
        by auto
      thus "x \<in> ?levo"
        by auto
  qed
qed

(* 37. *)
(* a) *)
lemma "A \<union> (-A \<inter> B) = A \<union> B" (is "?levo = ?desno")
proof
  show "?levo \<subseteq> ?desno"
  proof
    fix x
    assume "x \<in> ?levo"
      hence "x \<in> A \<or> x \<in> (-A \<inter> B)"
        by auto
      hence "(x \<in> A \<or> x \<notin> A) \<and> (x \<in> A \<or> x \<in> B)"
        by auto
      thus "x \<in> A \<union> B"
        by auto
   qed
next
  show "?desno \<subseteq> ?levo"
  proof
    fix x
    assume "x \<in> ?desno"
      hence "x \<in> A \<or> x \<in> B"
        by auto
      hence "x \<in> A \<or> x \<in> (-A \<inter> B)"
        by auto
      thus "x \<in> A \<union> (-A \<inter> B)"
        by auto
   qed
qed

(* 43. *)
(* a) *)

lemma "(A ∪ B) × C = (A × C) ∪ (B × C)" (is "?levo = ?desno")
proof
  show "?levo ⊆ ?desno"
  proof
    fix z
    assume *: "z ∈ (A ∪ B) × C"
    obtain x y where z: "z = (x, y)"
      by (cases z) auto
      have "(x, y) ∈ ?levo"
      using * z
      by auto
    hence "x ∈ A ∪ B ∧ y ∈ C"
      by (metis `(x, y) ∈ (A ∪ B) × C` mem_Sigma_iff)
    hence "(x ∈ A ∨ x ∈ B) ∧ y ∈ C"
      by auto
    hence "(x ∈ A ∧ y ∈ C) ∨ (x ∈ B ∧ y ∈ C)"
      by auto
    hence "(x, y) ∈ A × C ∨ (x, y) ∈ B × C"
      by auto
    hence "(x, y) ∈ A × C ∪ B × C"
      by auto
    hence "(x, y) ∈ A × C ∪ B × C"
      by (metis Sigma_Un_distrib1 `(x, y) ∈ (A ∪ B) × C`)
    hence "(x, y) ∈ ?desno"
      by metis
    thus "z \<in> ?desno"
     using * z
     by auto
qed
next
show "?desno ⊆ ?levo"
 proof
    fix z
    assume *: "z ∈ ?desno"
    obtain x y where z: "z = (x, y)"
      by (cases z) auto
    have "(x, y) ∈ ?desno"
      using * z
      by auto
    hence "x ∈ A ∧ y ∈ C ∨ x ∈ B ∧ y ∈ C"
      by auto
    hence "x ∈ A ∨ x ∈ B ∧ y ∈ C"
      by auto
    hence "(x, y) ∈ (A ∪ B) × C"
      by (metis "*" Sigma_Un_distrib1 z)
    thus "z \<in> ?levo"
     using * z
     by auto
   qed
qed

(* v) *)
lemma "(A - B) × C = (A × C) - (B × C)" (is "?levo = ?desno")
proof
  show "?levo ⊆ ?desno"
  proof
    fix z
      assume *: "z ∈ ?levo"
      obtain x y where z: "z = (x, y)"
        by (cases z) auto
      have "(x, y) ∈ ?levo"
        using * z
        by auto
      hence "x ∈ A ∧ x ∉ B ∧ y ∈ C"
        by auto
      hence "(x, y) ∈ ?desno"
        by auto
      thus "z ∈ ?desno"
        using * z
        by auto
    qed
next
show "?desno ⊆ ?levo"
proof
    fix z
    assume *: "z ∈ ?desno"
    obtain x y where z: "z = (x, y)"
      by (cases z) auto
    have "(x, y) ∈ ?desno"
      using * z
      by auto
   hence "x ∈ A ∧ y ∈ C ∧ ¬ (x ∈ B ∧ y ∈ C)"
    by auto
   hence "(x, y) ∈ ?levo"
    by auto
   thus "z ∈ ?levo"
    using z *
    by auto
  qed
qed

(* 123. *)
(* a) *)

(* Dokaz injektivnosti funkcije f po slucajevima *)
definition W :: "real set" where "W = {x. 0 ≤ x ∧ x ≤ 1}"
definition f :: "real ⇒ real" where
 "f x = (if x ∈ W then x^2 + 1 else x + 1)"

(* x1 i x2 su oba u skupu W *)
lemma "∀ x1 ∈ W. ∀ x2 ∈ W. f x1 = f x2 ⟶ x1 = x2"
proof safe
  fix x1::real
  fix x2::real
  assume *: "f x1 = f x2" and "x1 ∈ W" and "x2 ∈ W"
    hence "x1^2 + 1 = x2^2 + 1"
      using *
      unfolding f_def
      by auto
    hence "x1^2 = x2^2"
      by auto
    thus "x1 = x2"
       using `f x1 = f x2`
       using `x1 ∈ W` and `x2 ∈ W`
       unfolding W_def
       apply auto
       by (metis power2_eq_imp_eq)
qed

(* nijedan od x1 i x2 nije u skupu W *)
lemma "x1 ∉ W ∧ x2 ∉ W ∧ f x1 = f x2 ⟶ x1 = x2"
proof safe
  fix x1::real
  fix x2::real
assume *: "f x1 = f x2" and "x1 ∉ W" and "x2 ∉ W"
  hence "x1 + 1 = x2 + 1"
    using *
    unfolding f_def
    by auto
  thus "x1 = x2"
    by auto
qed

(* jedan od x1 i x2, recimo x1, je u W, a drugi nije,
ovde ne mozemo ni imati iste slike za x1 i x2, a evo i zasto *)
lemma kvadrat: shows "x \<in> W \<longrightarrow> x^2 \<in> W"
proof safe
  assume "x \<in> W"
  thus "x^2 \<in> W"
    unfolding f_def
    unfolding W_def
    by (auto simp add: Power.linordered_idom_class.abs_square_le_1)
qed

lemma "x1 \<in> W \<and> x2 \<notin> W \<longrightarrow> f x1 \<noteq> f x2"
proof safe
  fix x1::real
  fix x2::real
  assume *: "x1 \<in> W" and "x2 \<notin> W"
  hence "f x1 = x1^2+1"
    using `x1 \<in> W`
    unfolding f_def
    by (auto simp add:f_def)
  also have "x1^2 \<in> W"
    using kvadrat `x1 \<in> W`
    by auto
  hence "(x1^2 + 1) \<in> {x. 1 \<le> x \<and> x \<le> 2}"
    using kvadrat `x1 \<in> W`
    by (auto simp add: W_def)
  hence "f x1 \<in> {x. 1 \<le> x \<and> x \<le> 2}"
    using `x1 \<in> W`
    by (auto simp add: f_def W_def)
  have "(x2 + 1 >  2 \<or> x2 + 1 < 1)"
    using `x2 \<notin> W`
    by (auto simp add:W_def)
  hence "(x2 + 1 \<notin> {x. 1 \<le> x \<and> x \<le> 2})"
    using `x2 \<notin> W`
    by auto
  hence "f x2 \<notin> {x. 1 \<le> x \<and> x \<le> 2}"
    using `x2 \<notin> W`
    by (auto simp add: f_def W_def)
  thus " x1 \<in> W \<Longrightarrow> x2 \<notin> W \<Longrightarrow> f x1 = f x2 \<Longrightarrow> False"
    using `x2 \<notin> W` `x1 \<in> W` `x1^2 \<in> W`
    by (auto simp add: W_def f_def)
qed

(* dokaz surjektivnosti funkcije f po slucajevima: *)
definition skup1 :: "real set" where "skup1 = {x. 1 ≤ x ∧ x ≤ 2}"

lemma "x \<in> W \<longrightarrow> f x \<in> skup1"
  proof
    fix x::real
    assume "x \<in> W"
    obtain y where "y = f x"
      by auto
    hence "y = x^2 +1"
      using `x \<in> W`
      unfolding f_def
      by auto
    hence "y \<in> skup1"
      unfolding skup1_def
      using `y = f x`
      by (smt W_def ‹x ∈ W› mem_Collect_eq one_power2 power_mono zero_le_power2)
    thus "f x \<in> skup1"
     by (simp add: ‹y = f x›)
 qed

definition skup2 :: "real set" where "skup2 = {x. x < 1 \<or> x > 2}"

lemma "x \<notin> W \<longrightarrow> f x \<in> skup2"
proof
    fix x::real
    assume "x \<notin> W"
    hence "x < 0 \<or> x > 1"
      unfolding W_def
      by auto
    obtain y where "y = f x"
      by auto
    hence "y = x + 1"
      using `x \<notin> W`
      unfolding f_def
      by auto
    hence "y \<in> skup2"
      unfolding skup2_def
      using `y = f x`
      by (simp add: ‹y = f x› ‹x < 0 ∨ 1 < x›)
    thus "f x \<in> skup2"
      sledgehammer
      by (simp add: ‹y = f x›)
  qed


theory Part_2 imports Main
begin

(* 2.1 *)

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

(* 2.2 *)

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

theorem nat_add_associative [simp] : "add m (add n p) = add (add m n) p"
  apply(induction m)
   apply(auto)
  done

lemma zero_commutative [simp] : "add n 0 = add 0 n"
  apply(induction n)
   apply(auto)
  done

lemma suc_associative [simp] : "add m (Suc n) = Suc (add m n)"
  apply(induction m)
   apply(auto)
  done

theorem nat_add_commutative : "add m n = add n m"
  apply(induction n)
   apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
"double a = a + a"

lemma double_is_add : "double m = m + m"
  apply(induction m)
  apply(auto)
  done

(* 2.3 *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count a [] = 0" |
"count a (x#xs) = (if a = x then (1 + count a xs) else (count a xs))"

theorem count_lte_length : "count x xs \<le> length xs"
  apply(induction xs)
   apply(auto)
  done

(* 2.4 *)

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] a = [a]" |
"snoc (x#xs) a = x # (snoc xs a)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x#xs) = snoc (reverse xs) x"

lemma reverse_snoc [simp] : "reverse (snoc xs a) = a # reverse xs"
  apply(induction xs)
   apply(auto)
  done

theorem reverse_reverse : "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  done

(* 2.5 *)

fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto m = m + sum_upto (m - 1)"

theorem triangle_number : "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
   apply(auto)
  done

end


(*  Title:      HOL/Factorial.thy
    Author:     Jacques D. Fleuriot
    Author:     Lawrence C Paulson
    Author:     Jeremy Avigad
    Author:     Chaitanya Mangla
    Author:     Manuel Eberl
*)

section \<open>Factorial Function, Rising Factorials\<close>

theory Factorial
  imports Groups_List
begin

subsection \<open>Factorial Function\<close>

context semiring_char_0
begin

definition fact :: "nat \<Rightarrow> 'a"
  where fact_prod: "fact n = of_nat (\<Prod>{1..n})"

lemma fact_prod_Suc: "fact n = of_nat (prod Suc {0..<n})"
  unfolding fact_prod using atLeast0LessThan prod.atLeast1_atMost_eq by auto

lemma fact_prod_rev: "fact n = of_nat (\<Prod>i = 0..<n. n - i)"
proof -
  have "prod Suc {0..<n} = \<Prod>{1..n}"
    by (simp add: atLeast0LessThan prod.atLeast1_atMost_eq)
  then have "prod Suc {0..<n} = prod ((-) (n + 1)) {1..n}"
    using prod.atLeastAtMost_rev [of "\<lambda>i. i" 1 n] by presburger
  then show ?thesis
    unfolding fact_prod_Suc by (simp add: atLeast0LessThan prod.atLeast1_atMost_eq)
qed

lemma fact_0 [simp]: "fact 0 = 1"
  by (simp add: fact_prod)

lemma fact_1 [simp]: "fact 1 = 1"
  by (simp add: fact_prod)

lemma fact_Suc_0 [simp]: "fact (Suc 0) = 1"
  by (simp add: fact_prod)

lemma fact_Suc [simp]: "fact (Suc n) = of_nat (Suc n) * fact n"
  by (simp add: fact_prod atLeastAtMostSuc_conv algebra_simps)

lemma fact_2 [simp]: "fact 2 = 2"
  by (simp add: numeral_2_eq_2)

lemma fact_split: "k \<le> n \<Longrightarrow> fact n = of_nat (prod Suc {n - k..<n}) * fact (n - k)"
  by (simp add: fact_prod_Suc prod.union_disjoint [symmetric]
    ivl_disj_un ac_simps of_nat_mult [symmetric])

end

lemma of_nat_fact [simp]: "of_nat (fact n) = fact n"
  by (simp add: fact_prod)

lemma of_int_fact [simp]: "of_int (fact n) = fact n"
  by (simp only: fact_prod of_int_of_nat_eq)

lemma fact_reduce: "n > 0 \<Longrightarrow> fact n = of_nat n * fact (n - 1)"
  by (cases n) auto

lemma fact_nonzero [simp]: "fact n \<noteq> (0::'a::{semiring_char_0,semiring_no_zero_divisors})"
  apply (induct n)
  apply auto
  using of_nat_eq_0_iff
  apply fastforce
  done

lemma fact_mono_nat: "m \<le> n \<Longrightarrow> fact m \<le> (fact n :: nat)"
  by (induct n) (auto simp: le_Suc_eq)

lemma fact_in_Nats: "fact n \<in> \<nat>"
  by (induct n) auto

lemma fact_in_Ints: "fact n \<in> \<int>"
  by (induct n) auto

context
  assumes "SORT_CONSTRAINT('a::linordered_semidom)"
begin

lemma fact_mono: "m \<le> n \<Longrightarrow> fact m \<le> (fact n :: 'a)"
  by (metis of_nat_fact of_nat_le_iff fact_mono_nat)

lemma fact_ge_1 [simp]: "fact n \<ge> (1 :: 'a)"
  by (metis le0 fact_0 fact_mono)

lemma fact_gt_zero [simp]: "fact n > (0 :: 'a)"
  using fact_ge_1 less_le_trans zero_less_one by blast

lemma fact_ge_zero [simp]: "fact n \<ge> (0 :: 'a)"
  by (simp add: less_imp_le)

lemma fact_not_neg [simp]: "\<not> fact n < (0 :: 'a)"
  by (simp add: not_less_iff_gr_or_eq)

lemma fact_le_power: "fact n \<le> (of_nat (n^n) :: 'a)"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have *: "fact n \<le> (of_nat (Suc n ^ n) ::'a)"
    by (rule order_trans) (simp add: power_mono del: of_nat_power)
  have "fact (Suc n) = (of_nat (Suc n) * fact n ::'a)"
    by (simp add: algebra_simps)
  also have "\<dots> \<le> of_nat (Suc n) * of_nat (Suc n ^ n)"
    by (simp add: * ordered_comm_semiring_class.comm_mult_left_mono del: of_nat_power)
  also have "\<dots> \<le> of_nat (Suc n ^ Suc n)"
    by (metis of_nat_mult order_refl power_Suc)
  finally show ?case .
qed

end

lemma fact_less_mono_nat: "0 < m \<Longrightarrow> m < n \<Longrightarrow> fact m < (fact n :: nat)"
  by (induct n) (auto simp: less_Suc_eq)

lemma fact_less_mono: "0 < m \<Longrightarrow> m < n \<Longrightarrow> fact m < (fact n :: 'a::linordered_semidom)"
  by (metis of_nat_fact of_nat_less_iff fact_less_mono_nat)

lemma fact_ge_Suc_0_nat [simp]: "fact n \<ge> Suc 0"
  by (metis One_nat_def fact_ge_1)

lemma dvd_fact: "1 \<le> m \<Longrightarrow> m \<le> n \<Longrightarrow> m dvd fact n"
  by (induct n) (auto simp: dvdI le_Suc_eq)

lemma fact_ge_self: "fact n \<ge> n"
  by (cases "n = 0") (simp_all add: dvd_imp_le dvd_fact)

lemma fact_dvd: "n \<le> m \<Longrightarrow> fact n dvd (fact m :: 'a::linordered_semidom)"
  by (induct m) (auto simp: le_Suc_eq)

lemma fact_mod: "m \<le> n \<Longrightarrow> fact n mod (fact m :: 'a::{semidom_modulo, linordered_semidom}) = 0"
  by (simp add: mod_eq_0_iff_dvd fact_dvd)

lemma fact_div_fact:
  assumes "m \<ge> n"
  shows "fact m div fact n = \<Prod>{n + 1..m}"
proof -
  obtain d where "d = m - n"
    by auto
  with assms have "m = n + d"
    by auto
  have "fact (n + d) div (fact n) = \<Prod>{n + 1..n + d}"
  proof (induct d)
    case 0
    show ?case by simp
  next
    case (Suc d')
    have "fact (n + Suc d') div fact n = Suc (n + d') * fact (n + d') div fact n"
      by simp
    also from Suc.hyps have "\<dots> = Suc (n + d') * \<Prod>{n + 1..n + d'}"
      unfolding div_mult1_eq[of _ "fact (n + d')"] by (simp add: fact_mod)
    also have "\<dots> = \<Prod>{n + 1..n + Suc d'}"
      by (simp add: atLeastAtMostSuc_conv)
    finally show ?case .
  qed
  with \<open>m = n + d\<close> show ?thesis by simp
qed

lemma fact_num_eq_if: "fact m = (if m = 0 then 1 else of_nat m * fact (m - 1))"
  by (cases m) auto

lemma fact_div_fact_le_pow:
  assumes "r \<le> n"
  shows "fact n div fact (n - r) \<le> n ^ r"
proof -
  have "r \<le> n \<Longrightarrow> \<Prod>{n - r..n} = (n - r) * \<Prod>{Suc (n - r)..n}" for r
    by (subst prod.insert[symmetric]) (auto simp: atLeastAtMost_insertL)
  with assms show ?thesis
    by (induct r rule: nat.induct) (auto simp add: fact_div_fact Suc_diff_Suc mult_le_mono)
qed

lemma prod_Suc_fact: "prod Suc {0..<n} = fact n"
  by (simp add: fact_prod_Suc)

lemma prod_Suc_Suc_fact: "prod Suc {Suc 0..<n} = fact n"
proof (cases "n = 0")
  case True
  then show ?thesis by simp
next
  case False
  have "prod Suc {Suc 0..<n} = Suc 0 * prod Suc {Suc 0..<n}"
    by simp
  also have "\<dots> = prod Suc (insert 0 {Suc 0..<n})"
    by simp
  also have "insert 0 {Suc 0..<n} = {0..<n}"
    using False by auto
  finally show ?thesis
    by (simp add: fact_prod_Suc)
qed

lemma fact_numeral: "fact (numeral k) = numeral k * fact (pred_numeral k)"
  \<comment> \<open>Evaluation for specific numerals\<close>
  by (metis fact_Suc numeral_eq_Suc of_nat_numeral)

subsection \<open>Pochhammer's symbol: generalized rising factorial\<close>

text \<open>See \<^url>\<open>https://en.wikipedia.org/wiki/Pochhammer_symbol\<close>.\<close>

context comm_semiring_1
begin

definition pochhammer :: "'a \<Rightarrow> nat \<Rightarrow> 'a"
  where pochhammer_prod: "pochhammer a n = prod (\<lambda>i. a + of_nat i) {0..<n}"

lemma pochhammer_prod_rev: "pochhammer a n = prod (\<lambda>i. a + of_nat (n - i)) {1..n}"
  using prod.atLeastLessThan_rev_at_least_Suc_atMost [of "\<lambda>i. a + of_nat i" 0 n]
  by (simp add: pochhammer_prod)

lemma pochhammer_Suc_prod: "pochhammer a (Suc n) = prod (\<lambda>i. a + of_nat i) {0..n}"
  by (simp add: pochhammer_prod atLeastLessThanSuc_atLeastAtMost)

lemma pochhammer_Suc_prod_rev: "pochhammer a (Suc n) = prod (\<lambda>i. a + of_nat (n - i)) {0..n}"
  using prod.atLeast_Suc_atMost_Suc_shift
  by (simp add: pochhammer_prod_rev prod.atLeast_Suc_atMost_Suc_shift del: prod.cl_ivl_Suc)

lemma pochhammer_0 [simp]: "pochhammer a 0 = 1"
  by (simp add: pochhammer_prod)

lemma pochhammer_1 [simp]: "pochhammer a 1 = a"
  by (simp add: pochhammer_prod lessThan_Suc)

lemma pochhammer_Suc0 [simp]: "pochhammer a (Suc 0) = a"
  by (simp add: pochhammer_prod lessThan_Suc)

lemma pochhammer_Suc: "pochhammer a (Suc n) = pochhammer a n * (a + of_nat n)"
  by (simp add: pochhammer_prod atLeast0_lessThan_Suc ac_simps)

end

lemma pochhammer_nonneg:
  fixes x :: "'a :: linordered_semidom"
  shows "x > 0 \<Longrightarrow> pochhammer x n \<ge> 0"
  by (induction n) (auto simp: pochhammer_Suc intro!: mult_nonneg_nonneg add_nonneg_nonneg)

lemma pochhammer_pos:
  fixes x :: "'a :: linordered_semidom"
  shows "x > 0 \<Longrightarrow> pochhammer x n > 0"
  by (induction n) (auto simp: pochhammer_Suc intro!: mult_pos_pos add_pos_nonneg)

context comm_semiring_1
begin

lemma pochhammer_of_nat: "pochhammer (of_nat x) n = of_nat (pochhammer x n)"
  by (simp add: pochhammer_prod Factorial.pochhammer_prod)

end

context comm_ring_1
begin

lemma pochhammer_of_int: "pochhammer (of_int x) n = of_int (pochhammer x n)"
  by (simp add: pochhammer_prod Factorial.pochhammer_prod)

end

lemma pochhammer_rec: "pochhammer a (Suc n) = a * pochhammer (a + 1) n"
  by (simp add: pochhammer_prod prod.atLeast0_lessThan_Suc_shift ac_simps del: prod.op_ivl_Suc)

lemma pochhammer_rec': "pochhammer z (Suc n) = (z + of_nat n) * pochhammer z n"
  by (simp add: pochhammer_prod prod.atLeast0_lessThan_Suc ac_simps)

lemma pochhammer_fact: "fact n = pochhammer 1 n"
  by (simp add: pochhammer_prod fact_prod_Suc)

lemma pochhammer_of_nat_eq_0_lemma: "k > n \<Longrightarrow> pochhammer (- (of_nat n :: 'a:: idom)) k = 0"
  by (auto simp add: pochhammer_prod)

lemma pochhammer_of_nat_eq_0_lemma':
  assumes kn: "k \<le> n"
  shows "pochhammer (- (of_nat n :: 'a::{idom,ring_char_0})) k \<noteq> 0"
proof (cases k)
  case 0
  then show ?thesis by simp
next
  case (Suc h)
  then show ?thesis
    apply (simp add: pochhammer_Suc_prod)
    using Suc kn
    apply (auto simp add: algebra_simps)
    done
qed

lemma pochhammer_of_nat_eq_0_iff:
  "pochhammer (- (of_nat n :: 'a::{idom,ring_char_0})) k = 0 \<longleftrightarrow> k > n"
  (is "?l = ?r")
  using pochhammer_of_nat_eq_0_lemma[of n k, where ?'a='a]
    pochhammer_of_nat_eq_0_lemma'[of k n, where ?'a = 'a]
  by (auto simp add: not_le[symmetric])

lemma pochhammer_0_left:
  "pochhammer 0 n = (if n = 0 then 1 else 0)"
  by (induction n) (simp_all add: pochhammer_rec)

lemma pochhammer_eq_0_iff: "pochhammer a n = (0::'a::field_char_0) \<longleftrightarrow> (\<exists>k < n. a = - of_nat k)"
  by (auto simp add: pochhammer_prod eq_neg_iff_add_eq_0)

lemma pochhammer_eq_0_mono:
  "pochhammer a n = (0::'a::field_char_0) \<Longrightarrow> m \<ge> n \<Longrightarrow> pochhammer a m = 0"
  unfolding pochhammer_eq_0_iff by auto

lemma pochhammer_neq_0_mono:
  "pochhammer a m \<noteq> (0::'a::field_char_0) \<Longrightarrow> m \<ge> n \<Longrightarrow> pochhammer a n \<noteq> 0"
  unfolding pochhammer_eq_0_iff by auto

lemma pochhammer_minus:
  "pochhammer (- b) k = ((- 1) ^ k :: 'a::comm_ring_1) * pochhammer (b - of_nat k + 1) k"
proof (cases k)
  case 0
  then show ?thesis by simp
next
  case (Suc h)
  have eq: "((- 1) ^ Suc h :: 'a) = (\<Prod>i = 0..h. - 1)"
    using prod_constant [where A="{0.. h}" and y="- 1 :: 'a"]
    by auto
  with Suc show ?thesis
    using pochhammer_Suc_prod_rev [of "b - of_nat k + 1"]
    by (auto simp add: pochhammer_Suc_prod prod.distrib [symmetric] eq of_nat_diff simp del: prod_constant)
qed

lemma pochhammer_minus':
  "pochhammer (b - of_nat k + 1) k = ((- 1) ^ k :: 'a::comm_ring_1) * pochhammer (- b) k"
  by (simp add: pochhammer_minus)

lemma pochhammer_same: "pochhammer (- of_nat n) n =
    ((- 1) ^ n :: 'a::{semiring_char_0,comm_ring_1,semiring_no_zero_divisors}) * fact n"
  unfolding pochhammer_minus
  by (simp add: of_nat_diff pochhammer_fact)

lemma pochhammer_product': "pochhammer z (n + m) = pochhammer z n * pochhammer (z + of_nat n) m"
proof (induct n arbitrary: z)
  case 0
  then show ?case by simp
next
  case (Suc n z)
  have "pochhammer z (Suc n) * pochhammer (z + of_nat (Suc n)) m =
      z * (pochhammer (z + 1) n * pochhammer (z + 1 + of_nat n) m)"
    by (simp add: pochhammer_rec ac_simps)
  also note Suc[symmetric]
  also have "z * pochhammer (z + 1) (n + m) = pochhammer z (Suc (n + m))"
    by (subst pochhammer_rec) simp
  finally show ?case
    by simp
qed

lemma pochhammer_product:
  "m \<le> n \<Longrightarrow> pochhammer z n = pochhammer z m * pochhammer (z + of_nat m) (n - m)"
  using pochhammer_product'[of z m "n - m"] by simp

lemma pochhammer_times_pochhammer_half:
  fixes z :: "'a::field_char_0"
  shows "pochhammer z (Suc n) * pochhammer (z + 1/2) (Suc n) = (\<Prod>k=0..2*n+1. z + of_nat k / 2)"
proof (induct n)
  case 0
  then show ?case
    by (simp add: atLeast0_atMost_Suc)
next
  case (Suc n)
  define n' where "n' = Suc n"
  have "pochhammer z (Suc n') * pochhammer (z + 1 / 2) (Suc n') =
      (pochhammer z n' * pochhammer (z + 1 / 2) n') * ((z + of_nat n') * (z + 1/2 + of_nat n'))"
    (is "_ = _ * ?A")
    by (simp_all add: pochhammer_rec' mult_ac)
  also have "?A = (z + of_nat (Suc (2 * n + 1)) / 2) * (z + of_nat (Suc (Suc (2 * n + 1))) / 2)"
    (is "_ = ?B")
    by (simp add: field_simps n'_def)
  also note Suc[folded n'_def]
  also have "(\<Prod>k=0..2 * n + 1. z + of_nat k / 2) * ?B = (\<Prod>k=0..2 * Suc n + 1. z + of_nat k / 2)"
    by (simp add: atLeast0_atMost_Suc)
  finally show ?case
    by (simp add: n'_def)
qed

lemma pochhammer_double:
  fixes z :: "'a::field_char_0"
  shows "pochhammer (2 * z) (2 * n) = of_nat (2^(2*n)) * pochhammer z n * pochhammer (z+1/2) n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "pochhammer (2 * z) (2 * (Suc n)) = pochhammer (2 * z) (2 * n) *
      (2 * (z + of_nat n)) * (2 * (z + of_nat n) + 1)"
    by (simp add: pochhammer_rec' ac_simps)
  also note Suc
  also have "of_nat (2 ^ (2 * n)) * pochhammer z n * pochhammer (z + 1/2) n *
        (2 * (z + of_nat n)) * (2 * (z + of_nat n) + 1) =
      of_nat (2 ^ (2 * (Suc n))) * pochhammer z (Suc n) * pochhammer (z + 1/2) (Suc n)"
    by (simp add: field_simps pochhammer_rec')
  finally show ?case .
qed

lemma fact_double:
  "fact (2 * n) = (2 ^ (2 * n) * pochhammer (1 / 2) n * fact n :: 'a::field_char_0)"
  using pochhammer_double[of "1/2::'a" n] by (simp add: pochhammer_fact)

lemma pochhammer_absorb_comp: "(r - of_nat k) * pochhammer (- r) k = r * pochhammer (-r + 1) k"
  (is "?lhs = ?rhs")
  for r :: "'a::comm_ring_1"
proof -
  have "?lhs = - pochhammer (- r) (Suc k)"
    by (subst pochhammer_rec') (simp add: algebra_simps)
  also have "\<dots> = ?rhs"
    by (subst pochhammer_rec) simp
  finally show ?thesis .
qed

subsection \<open>Misc\<close>

lemma fact_code [code]:
  "fact n = (of_nat (fold_atLeastAtMost_nat ((*)) 2 n 1) :: 'a::semiring_char_0)"
proof -
  have "fact n = (of_nat (\<Prod>{1..n}) :: 'a)"
    by (simp add: fact_prod)
  also have "\<Prod>{1..n} = \<Prod>{2..n}"
    by (intro prod.mono_neutral_right) auto
  also have "\<dots> = fold_atLeastAtMost_nat ((*)) 2 n 1"
    by (simp add: prod_atLeastAtMost_code)
  finally show ?thesis .
qed

lemma pochhammer_code [code]:
  "pochhammer a n =
    (if n = 0 then 1
     else fold_atLeastAtMost_nat (\<lambda>n acc. (a + of_nat n) * acc) 0 (n - 1) 1)"
  by (cases n)
    (simp_all add: pochhammer_prod prod_atLeastAtMost_code [symmetric]
      atLeastLessThanSuc_atLeastAtMost)

end


(*  Title:      CCL/Lfp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>The Knaster-Tarski Theorem\<close>

theory Lfp
imports Set
begin

definition
  lfp :: "['a set\<Rightarrow>'a set] \<Rightarrow> 'a set" where \<comment> "least fixed point"
  "lfp(f) == Inter({u. f(u) <= u})"

(* lfp(f) is the greatest lower bound of {u. f(u) <= u} *)

lemma lfp_lowerbound: "f(A) <= A \<Longrightarrow> lfp(f) <= A"
  unfolding lfp_def by blast

lemma lfp_greatest: "(\<And>u. f(u) <= u \<Longrightarrow> A<=u) \<Longrightarrow> A <= lfp(f)"
  unfolding lfp_def by blast

lemma lfp_lemma2: "mono(f) \<Longrightarrow> f(lfp(f)) <= lfp(f)"
  by (rule lfp_greatest, rule subset_trans, drule monoD, rule lfp_lowerbound, assumption+)

lemma lfp_lemma3: "mono(f) \<Longrightarrow> lfp(f) <= f(lfp(f))"
  by (rule lfp_lowerbound, frule monoD, drule lfp_lemma2, assumption+)

lemma lfp_Tarski: "mono(f) \<Longrightarrow> lfp(f) = f(lfp(f))"
  by (rule equalityI lfp_lemma2 lfp_lemma3 | assumption)+

(*** General induction rule for least fixed points ***)

lemma induct:
  assumes lfp: "a: lfp(f)"
    and mono: "mono(f)"
    and indhyp: "\<And>x. \<lbrakk>x: f(lfp(f) Int {x. P(x)})\<rbrakk> \<Longrightarrow> P(x)"
  shows "P(a)"
  apply (rule_tac a = a in Int_lower2 [THEN subsetD, THEN CollectD])
  apply (rule lfp [THEN [2] lfp_lowerbound [THEN subsetD]])
  apply (rule Int_greatest, rule subset_trans, rule Int_lower1 [THEN mono [THEN monoD]],
    rule mono [THEN lfp_lemma2], rule CollectI [THEN subsetI], rule indhyp, assumption)
  done

(** Definition forms of lfp_Tarski and induct, to control unfolding **)

lemma def_lfp_Tarski: "\<lbrakk>h == lfp(f); mono(f)\<rbrakk> \<Longrightarrow> h = f(h)"
  apply unfold
  apply (drule lfp_Tarski)
  apply assumption
  done

lemma def_induct: "\<lbrakk>A == lfp(f);  a:A;  mono(f); \<And>x. x: f(A Int {x. P(x)}) \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> P(a)"
  apply (rule induct [of concl: P a])
    apply simp
   apply assumption
  apply blast
  done

(*Monotonicity of lfp!*)
lemma lfp_mono: "\<lbrakk>mono(g); \<And>Z. f(Z) <= g(Z)\<rbrakk> \<Longrightarrow> lfp(f) <= lfp(g)"
  apply (rule lfp_lowerbound)
  apply (rule subset_trans)
   apply (erule meta_spec)
  apply (erule lfp_lemma2)
  done

end


(*  Title:       Binary Search Trees, Tactic-Style
    Author:      Viktor Kuncak, MIT CSAIL, November 2003
    Maintainer:  Larry Paulson <Larry.Paulson at cl.cam.ac.uk>
    License:     LGPL
*)

section \<open>Tactic-Style Reasoning for Binary Tree Operations\<close>
theory BinaryTree_TacticStyle imports Main begin

text \<open>This example theory illustrates automated proofs of correctness
   for binary tree operations using tactic-style reasoning.
   The current proofs for remove operation are by Tobias Nipkow,
   some modifications and the remaining tree operations are
   by Viktor Kuncak.\<close>

(*============================================================*)
section \<open>Definition of a sorted binary tree\<close>
(*============================================================*)

datatype tree = Tip | Nd tree nat tree

primrec set_of :: "tree => nat set"
\<comment> \<open>The set of nodes stored in a tree.\<close>
where
  "set_of Tip = {}"
| "set_of(Nd l x r) = set_of l Un set_of r  Un {x}"

primrec sorted :: "tree => bool"
\<comment> \<open>Tree is sorted\<close>
where
  "sorted Tip = True"
| "sorted(Nd l y r) =
    (sorted l & sorted r & (\<forall>x \<in> set_of l. x < y) & (\<forall>z \<in> set_of r. y < z))"

(*============================================================*)
section \<open>Tree Membership\<close>
(*============================================================*)

primrec
  memb :: "nat => tree => bool"
where
  "memb e Tip = False"
| "memb e (Nd t1 x t2) =
   (if e < x then memb e t1
    else if x < e then memb e t2
    else True)"

lemma member_set: "sorted t --> memb e t = (e : set_of t)"
by (induct t) auto

(*============================================================*)
section \<open>Insertion operation\<close>
(*============================================================*)

primrec binsert :: "nat => tree => tree"
\<comment> \<open>Insert a node into sorted tree.\<close>
where
  "binsert x Tip = (Nd Tip x Tip)"
| "binsert x (Nd t1 y t2) = (if x < y then
                                 (Nd (binsert x t1) y t2)
                             else
                               (if y < x then
                                 (Nd t1 y (binsert x t2))
                                else (Nd t1 y t2)))"

theorem set_of_binsert [simp]: "set_of (binsert x t) = set_of t Un {x}"
by (induct t) auto

theorem binsert_sorted: "sorted t --> sorted (binsert x t)"
by (induct t) (auto simp add: set_of_binsert)

corollary binsert_spec:  (* summary specification of binsert *)
"sorted t ==>
   sorted (binsert x t) &
   set_of (binsert x t) = set_of t Un {x}"
by (simp add: binsert_sorted)

(*============================================================*)
section \<open>Remove operation\<close>
(*============================================================*)

primrec
  rm :: "tree => nat" \<comment> \<open>find the rightmost element in the tree\<close>
where
  "rm(Nd l x r) = (if r = Tip then x else rm r)"
primrec
  rem :: "tree => tree" \<comment> \<open>find the tree without the rightmost element\<close>
where
  "rem(Nd l x r) = (if r=Tip then l else Nd l x (rem r))"

primrec
  remove:: "nat => tree => tree" \<comment> \<open>remove a node from sorted tree\<close>
where
  "remove x Tip = Tip"
| "remove x (Nd l y r) =
    (if x < y then Nd (remove x l) y r else
     if y < x then Nd l y (remove x r) else
     if l = Tip then r
     else Nd (rem l) (rm l) r)"

lemma rm_in_set_of: "t ~= Tip ==> rm t : set_of t"
by (induct t) auto

lemma set_of_rem: "t ~= Tip ==> set_of t = set_of(rem t) Un {rm t}"
by (induct t) auto

lemma sorted_rem: "[| t ~= Tip; x \<in> set_of(rem t); sorted t |] ==> x < rm t"
by (induct t) (auto simp add:set_of_rem split:if_splits)

theorem set_of_remove [simp]: "sorted t ==> set_of(remove x t) = set_of t - {x}"
apply(induct t)
 apply simp
apply simp
apply(rule conjI)
 apply fastforce
apply(rule impI)
apply(rule conjI)
 apply fastforce
apply(fastforce simp:set_of_rem)
done

theorem remove_sorted: "sorted t ==> sorted(remove x t)"
by (induct t) (auto intro: less_trans rm_in_set_of sorted_rem)

corollary remove_spec: \<comment> \<open>summary specification of remove\<close>
"sorted t ==>
   sorted (remove x t) &
   set_of (remove x t) = set_of t - {x}"
by (simp add: remove_sorted)

text \<open>Finally, note that rem and rm can be computed
        using a single tree traversal given by remrm.\<close>

primrec remrm :: "tree => tree * nat"
where
"remrm(Nd l x r) = (if r=Tip then (l,x) else
                    let (r',y) = remrm r in (Nd l x r',y))"

lemma "t ~= Tip ==> remrm t = (rem t, rm t)"
by (induct t) (auto simp:Let_def)

text \<open>We can test this implementation by generating code.\<close>

definition "test = memb 4 (remove (3::nat) (binsert 4 (binsert 3 Tip)))"

export_code test
  in SML module_name BinaryTree_TacticStyle_Code file \<open>BinaryTree_TacticStyle_Code.ML\<close>

end


section \<open>Challenge 1.B\<close>
theory Challenge1B
  imports  Challenge1A "HOL-Library.Multiset" "Eval_Base.Eval_Base"
begin

(* TODO: Move *)
lemma mset_concat:
  "mset (concat xs) = fold (+) (map mset xs) {#}"
proof -
  have "mset (concat xs) + a = fold (+) (map mset xs) a" for a
  proof2 (induction xs arbitrary: a)
    case Nil
    then show ?case
      by auto
  next
    case (Cons x xs)
    show ?case
      using Cons.IH[of "mset x + a", symmetric] by simp
  qed
  from this[of "{#}"] show ?thesis
    by auto
qed

subsection \<open>Merging Two Segments\<close>

fun merge :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "merge [] l2 = l2"
 | "merge l1 [] = l1"
 | "merge (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (merge l1 (x2 # l2)) else x2 # (merge (x1 # l1) l2))"

lemma merge_correct:
  assumes "sorted l1"
  assumes "sorted l2"
  shows "
    sorted (merge l1 l2)
  \<and> mset (merge l1 l2) = mset l1 + mset l2
  \<and> set (merge l1 l2) = set l1 \<union> set l2"
  using assms
proof2 (induction l1 arbitrary: l2)
  case Nil thus ?case
    by simp
next
  case (Cons x1 l1 l2)
  note IH = Cons.IH

  show ?case
    using Cons.prems
  proof2 (induction l2)
    case Nil then show ?case
      by simp
  next
    case (Cons x2 l2)
    then show ?case
      using IH by (force split: if_split_asm)
  qed
qed

subsection \<open>Merging a List of Segments\<close>

function merge_list :: "'a::{linorder} list list \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
   "merge_list [] [] = []"
 | "merge_list [] [l] = l"
 | "merge_list (la # acc2) [] = merge_list [] (la # acc2)"
 | "merge_list (la # acc2) [l] = merge_list [] (l # la # acc2)"
 | "merge_list acc2 (l1 # l2 # ls) =
    merge_list ((merge l1 l2) # acc2) ls"
by pat_completeness simp_all
termination by (relation "measure (\<lambda>(acc, ls). 3 * length acc + 2 * length ls)"; simp)

lemma merge_list_correct:
assumes "\<And>l. l \<in> set ls \<Longrightarrow> sorted l"
assumes "\<And>l. l \<in> set as \<Longrightarrow> sorted l"
shows "
  sorted (merge_list as ls)
\<and> mset (merge_list as ls) = mset (concat (as @ ls))
\<and> set (merge_list as ls) = set (concat (as @ ls))"
using assms
proof2 (induction as ls rule: merge_list.induct)
next
  case (4 la acc2 l)
  then show ?case
    by (auto simp: algebra_simps)
next
  case (5 acc2 l1 l2 ls)
  have "sorted (merge_list (merge l1 l2 # acc2) ls)
    \<and> mset (merge_list (merge l1 l2 # acc2) ls) = mset (concat ((merge l1 l2 # acc2) @ ls))
    \<and> set (merge_list (merge l1 l2 # acc2) ls) = set (concat ((merge l1 l2 # acc2) @ ls))"
    using 5(2-) merge_correct[of l1 l2] by (intro 5(1)) auto
  then show ?case
    using merge_correct[of l1 l2] 5(2-) by auto
qed simp+

subsection \<open>GHC-Sort\<close>

definition
  "ghc_sort xs = merge_list [] (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))"

lemma decr_sorted:
  assumes "decr xs"
  shows "sorted (rev xs)"
  using assms apply2 (induction xs rule: decr.induct) by(auto simp: sorted_append)

lemma incr_sorted:
  assumes "incr xs"
  shows "sorted xs"
  using assms apply2 (induction xs rule: incr.induct) by auto

lemma reverse_phase_sorted:
  "\<forall>ys \<in> set (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)). sorted ys"
  using cuts_incr_decr by (auto intro: decr_sorted incr_sorted)

lemma reverse_phase_elements:
  "set (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))) = set xs"
proof -
  have "set (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)))
    = set (concat (cuts xs))"
    by auto
  also have "\<dots> = set xs"
    by (simp add: concat_cuts)
  finally show ?thesis .
qed

lemma reverse_phase_permutation:
  "mset (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs))) = mset xs"
proof -
  have "mset (concat (map (\<lambda>ys. if decr ys then rev ys else ys) (cuts xs)))
    = mset (concat (cuts xs))"
    unfolding mset_concat by (auto simp: comp_def intro!: arg_cong2[where f = "fold (+)"])
  also have "\<dots> = mset xs"
    by (simp add: concat_cuts)
  finally show ?thesis .
qed

subsection \<open>Correctness Lemmas\<close>
text \<open>The result is sorted and a permutation of the original elements.\<close>

theorem sorted_ghc_sort:
  "sorted (ghc_sort xs)"
  unfolding ghc_sort_def using reverse_phase_sorted
  by (intro merge_list_correct[THEN conjunct1]) auto

theorem permutation_ghc_sort:
  "mset (ghc_sort xs) = mset xs"
  unfolding ghc_sort_def
  apply (subst merge_list_correct[THEN conjunct2])
  subgoal
    using reverse_phase_sorted by auto
  subgoal
    using reverse_phase_sorted by auto
  apply (subst (2) reverse_phase_permutation[symmetric])
  apply simp
  done

corollary elements_ghc_sort: "set (ghc_sort xs) = set xs"
  using permutation_ghc_sort by (metis set_mset_mset)

subsection \<open>Executable Code\<close>
(*
export_code ghc_sort checking SML Scala OCaml? Haskell?
*)
value [code] "ghc_sort [1,2,7,3,5,6,9,8,4]"

end


section \<open>Minimum and Maximum of Potentially Infinite Sets\<close>

theory Minimum_Maximum
  imports Main
begin

text \<open>We define minima and maxima of sets. In contrast
  to the existing @{const Min} and @{const Max} operators,
  these operators are not restricted to finite sets \<close>

definition Maximum :: "'a :: linorder set \<Rightarrow> 'a" where
  "Maximum S = (THE x. x \<in> S \<and> (\<forall> y \<in> S. y \<le> x))"
definition Minimum :: "'a :: linorder set \<Rightarrow> 'a" where
  "Minimum S = (THE x. x \<in> S \<and> (\<forall> y \<in> S. x \<le> y))"

definition has_Maximum where "has_Maximum S = (\<exists> x. x \<in> S \<and> (\<forall> y \<in> S. y \<le> x))"
definition has_Minimum where "has_Minimum S = (\<exists> x. x \<in> S \<and> (\<forall> y \<in> S. x \<le> y))"

lemma eqMaximumI:
  assumes "x \<in> S"
  and "\<And> y. y \<in> S \<Longrightarrow> y \<le> x"
shows "Maximum S = x"
  unfolding Maximum_def
  by (standard, insert assms, auto, fastforce)

lemma eqMinimumI:
  assumes "x \<in> S"
  and "\<And> y. y \<in> S \<Longrightarrow> x \<le> y"
shows "Minimum S = x"
  unfolding Minimum_def
  by (standard, insert assms, auto, fastforce)

lemma has_MaximumD:
  assumes "has_Maximum S"
  shows "Maximum S \<in> S"
    "x \<in> S \<Longrightarrow> x \<le> Maximum S"
proof -
  from assms[unfolded has_Maximum_def]
  obtain m where *: "m \<in> S" "\<And> y. y \<in> S \<Longrightarrow> y \<le> m" by auto
  have id: "Maximum S = m"
    by (rule eqMaximumI, insert *, auto)
  from * id show "Maximum S \<in> S" "x \<in> S \<Longrightarrow> x \<le> Maximum S" by auto
qed

lemma has_MinimumD:
  assumes "has_Minimum S"
  shows "Minimum S \<in> S"
    "x \<in> S \<Longrightarrow> Minimum S \<le> x"
proof -
  from assms[unfolded has_Minimum_def]
  obtain m where *: "m \<in> S" "\<And> y. y \<in> S \<Longrightarrow> m \<le> y" by auto
  have id: "Minimum S = m"
    by (rule eqMinimumI, insert *, auto)
  from * id show "Minimum S \<in> S" "x \<in> S \<Longrightarrow> Minimum S \<le> x" by auto
qed

text \<open>On non-empty finite sets, @{const Minimum} and @{const Min}
  coincide, and similarly @{const Maximum} and @{const Max}.\<close>

lemma Minimum_Min: assumes "finite S" "S \<noteq> {}"
  shows "Minimum S = Min S"
  by (rule eqMinimumI, insert assms, auto)

lemma Maximum_Max: assumes "finite S" "S \<noteq> {}"
  shows "Maximum S = Max S"
  by (rule eqMaximumI, insert assms, auto)

end


theory Ch4
  imports Main
begin

(* 4.1 *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node l x r) = {x} \<union> set l \<union> set r"

value "set (Node Tip (1::nat) (Node (Node Tip 1 Tip) 4 Tip))"

fun cmpt :: "int tree \<Rightarrow> (int \<Rightarrow> bool) \<Rightarrow> bool" where
"cmpt Tip _ = True" |
"cmpt (Node l x r) p = ((cmpt l p) \<and> (cmpt r p) \<and> (p x))"

fun ord :: "int tree \<Rightarrow> bool" where
"ord Tip = True" |
"ord (Node l x r) = (ord l \<and> ord r \<and> (\<forall>z \<in> set l. z \<le> x) \<and> (\<forall>z \<in> set r. z \<ge> x))"

value "ord Tip"
value "ord (Node (Node Tip 1 Tip) 2 (Node Tip 3 Tip))"
value "ord (Node (Node Tip 3 Tip) 2 (Node Tip 3 Tip)) = False"
value "ord (Node (Node Tip 2 Tip) 2 (Node Tip 3 Tip))"

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins x Tip = Node Tip x Tip" |
"ins x (Node l a r) = (if x = a then (Node l a r) else
                       if x < a then (Node (ins x l) a r) else
                                     (Node l a (ins x r)))"

value "ins 0 (ins 3 (Node (Node Tip 1 Tip) 4 (Node Tip 8 Tip)))"
value "ord (ins 0 (ins 3 (Node (Node Tip 1 Tip) 4 (Node Tip 8 Tip))))"

lemma "ord t \<Longrightarrow> ord (ins i t)"
  apply (induction t)
  apply auto
  done

(* аксиома? x > a \<and> \<forall> y \<in> S. x > y \<Longrightarrow> \<forall> z \<in> (S \<union> {x}). z > a *)

(* 4.2 *)

inductive pal :: "'a list \<Rightarrow> bool" where
pE: "pal []" |
pS: "pal [a]" |
pC: "pal xs \<Longrightarrow> pal (a # xs @ [a])"

lemma "pal xs \<Longrightarrow> rev xs = xs"
  apply(induction rule: pal.induct)
  apply(auto)
  done

(* 4.3 *)

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

lemma starflip[simp]: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
  apply(rule step)
  apply(simp)
  apply(rule refl)
  apply(simp add: step)
  done

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

lemma star'flip[simp]: "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
  apply(auto intro: step' refl')
(*
  apply(rule step')
  apply(rule refl')
  apply(simp)
  apply(simp add: refl' step')
*)
  done

lemma "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule: star.induct)
  apply(auto intro: step refl refl')
  done

(* 4.4 *)

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

lemma "iter r n x y \<Longrightarrow> star r x y"
  apply(induction rule: iter.induct)
  apply(auto intro: step refl)
  done

lemma "star r x y \<Longrightarrow> \<exists> n. iter r n x y"
  apply(induction rule: star.induct)
  apply(auto intro: iter0 itern)
  done

(* 4.5 *)

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
S0:  "S Nil" |
aSb: "S s \<Longrightarrow> S (a # s @ [b])" |
SS:  "S x \<Longrightarrow> S y \<Longrightarrow> S (x @ y)"

inductive T :: "alpha list \<Rightarrow> bool" where
T0:   "T Nil" |
TaTb: "T x \<Longrightarrow> T y \<Longrightarrow> T (x @ a # y @ [b])"

lemma TS: "T w \<Longrightarrow> S w"
  apply(induction rule: T.induct)
  apply(rule S0)
  apply(rule SS)
  apply(simp)
  apply(rule aSb)
  apply(simp)
  (* apply(auto intro: S0 aSb SS) *)
  done

lemma aTb: "T x \<Longrightarrow> T (a # x @ [b])"
  (* try found it *)
  by (metis Cons_eq_appendI T.simps self_append_conv2)

lemma TT: "T y \<Longrightarrow> T x \<Longrightarrow> T (x @ y)"
  apply(induction rule: T.induct)
  apply(auto intro: TaTb T0)
  by (metis T.simps append_eq_appendI)

lemma ST: "S w \<Longrightarrow> T w"
  apply(induction rule: S.induct)
  apply(rule T0)
  apply(rule aTb)
  apply(simp)
  apply(rule TT)
  apply(simp)
  apply(simp)
  done

(* 4.6 *)

(* aexp and aval *)
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x ) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

(* aval_rel даёт конфликт *)
inductive iaval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
iaN: "iaval (N n) s n" |
iaV: "iaval (V v) s (s v) " |
iaP: "iaval xl s vl \<Longrightarrow> iaval xr s vr \<Longrightarrow> iaval (Plus xl xr) s (vl + vr)"

lemma iaa: "iaval e s v \<Longrightarrow> aval e s = v"
  apply(induction rule: iaval.induct)
  apply(auto intro: iaN iaV iaP)
  done

lemma aia: "aval e s = v \<Longrightarrow> iaval e s v"
  apply(induction e arbitrary: v)
  apply(auto)
  apply(rule iaN)
  apply(rule iaV)
  apply(rule iaP)
  apply(auto)
  done

(* 4.7 *)

datatype instr = LOADI val | LOAD vname | ADD
type_synonym stack = "val list"

abbreviation hd2 where
"hd2 xs \<equiv> hd (tl xs)"

abbreviation tl2 where
"tl2 xs \<equiv> tl (tl xs)"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 (LOAD x) s stk = Some (s(x) # stk)" |
"exec1 ADD _ stk =
 (case stk of
  (x # y # xs) \<Rightarrow> Some ((hd2 stk + hd stk) # tl2 stk) |
  (xs) \<Rightarrow> None)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk =
 (case (exec1 i s stk) of
  Some res \<Rightarrow> exec is s res |
  None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

(*
inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
ok_0: "ok n [] n" |
ok_LI: "ok n is n' \<Longrightarrow> ok n (is @ [LOADI k]) (Suc n')" |
ok_L: "ok n is n' \<Longrightarrow> ok n (is @ [LOAD x]) (Suc n')" |
ok_A: "ok n is (Suc (Suc n')) \<Longrightarrow> ok n (is @ [ADD]) (Suc n')"
*)

(* can't use stack instead of instr list? *)
inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
okNil:   "ok n Nil n" |
okLOADI: "ok n [LoadI i] (Suc n)" |
okLOAD:  "ok n [Load x] (Suc n)" |
okADD:   "ok (Suc (Suc n)) [ADD] (Suc n)" |
okConc:  "ok p s1 q \<Longrightarrow> ok q s2 r \<Longrightarrow> ok p (s1 @ s2) r"

lemma "ok n ii n' \<Longrightarrow> length stk = n \<Longrightarrow> length (exec ii s stk) = n'"

end


(*  Title:      HOL/Types_To_Sets/Examples/Finite.thy
    Author:     Ondřej Kunčar, TU München
*)

theory Finite
  imports "../Types_To_Sets" Prerequisites
begin

section \<open>The Type-Based Theorem\<close>

text\<open>This example file shows how we perform the relativization in presence of axiomatic
  type classes: we internalize them.\<close>

definition injective :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "injective f \<equiv> (\<forall>x y. f x = f y \<longrightarrow> x = y)"

text\<open>We want to relativize the following type-based theorem using the type class finite.\<close>

lemma type_based: "\<exists>f :: 'a::finite \<Rightarrow> nat. injective f"
  unfolding injective_def
  using finite_imp_inj_to_nat_seg[of "UNIV::'a set", unfolded inj_on_def] by auto

section \<open>Definitions and Setup for The Relativization\<close>

text\<open>We have to define what being injective on a set means.\<close>

definition injective_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "injective_on A f \<equiv> \<forall>x \<in> A. \<forall>y \<in> A. f x = f y \<longrightarrow> x = y"

text\<open>The predicate injective_on is the relativization of the predicate injective.\<close>

lemma injective_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total T"
  assumes [transfer_rule]: "bi_unique T"
  shows "((T ===> op =) ===> op=) (injective_on (Collect(Domainp T))) injective"
  unfolding injective_on_def[abs_def] injective_def[abs_def] by transfer_prover

text\<open>Similarly, we define the relativization of the internalization
     of the type class finite, class.finite\<close>

definition finite_on :: "'a set => bool" where "finite_on A = finite A"

lemma class_finite_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total (T::'a\<Rightarrow>'b\<Rightarrow>bool)"
  assumes [transfer_rule]: "bi_unique T"
  shows "op= (finite_on (Collect(Domainp T))) (class.finite TYPE('b))"
  unfolding finite_on_def class.finite_def by transfer_prover

text\<open>The aforementioned development can be automated. The main part is already automated
     by the transfer_prover.\<close>

section \<open>The Relativization to The Set-Based Theorem\<close>

lemmas internalized = type_based[internalize_sort "'a::finite"]
text\<open>We internalized the type class finite and thus reduced the task to the
  original relativization algorithm.\<close>
thm internalized

text\<open>This is the set-based variant.\<close>

lemma set_based:
  assumes "(A::'a set) \<noteq> {}"
  shows "finite_on A \<longrightarrow> (\<exists>f :: 'a \<Rightarrow> nat. injective_on A f)"
proof -
  {
    text\<open>We define the type 'b to be isomorphic to A.\<close>
    assume T: "\<exists>(Rep :: 'b \<Rightarrow> 'a) Abs. type_definition Rep Abs A"
    from T obtain rep :: "'b \<Rightarrow> 'a" and abs :: "'a \<Rightarrow> 'b" where t: "type_definition rep abs A"
      by auto

    text\<open>Setup for the Transfer tool.\<close>
    define cr_b where "cr_b == \<lambda>r a. r = rep a"
    note type_definition_Domainp[OF t cr_b_def, transfer_domain_rule]
    note typedef_right_total[OF t cr_b_def, transfer_rule]
    note typedef_bi_unique[OF t cr_b_def, transfer_rule]

    have ?thesis
      text\<open>Relativization by the Transfer tool.\<close>
      using internalized[where 'a = 'b, untransferred, simplified]
      by blast
  } note * = this[cancel_type_definition, OF assms] text\<open>We removed the definition of 'b.\<close>

  show ?thesis by (rule *)
qed

text\<open>The Final Result. We can compare the type-based and the set-based statement.\<close>
thm type_based set_based

end


(*  Title:      HOL/Imperative_HOL/ex/Sorted_List.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section {* Sorted lists as representation of finite sets *}

theory Sorted_List
imports Main
begin

text {* Merge function for two distinct sorted lists to get compound distinct sorted list *}

fun merge :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "merge (x#xs) (y#ys) =
  (if x < y then x # merge xs (y#ys) else (if x > y then y # merge (x#xs) ys else x # merge xs ys))"
| "merge xs [] = xs"
| "merge [] ys = ys"

text {* The function package does not derive automatically the more general rewrite rule as follows: *}
lemma merge_Nil[simp]: "merge [] ys = ys"
by (cases ys) auto

lemma set_merge[simp]: "set (merge xs ys) = set xs \<union> set ys"
by (induct xs ys rule: merge.induct, auto)

lemma sorted_merge[simp]:
     "List.sorted (merge xs ys) = (List.sorted xs \<and> List.sorted ys)"
by (induct xs ys rule: merge.induct, auto simp add: sorted_Cons)

lemma distinct_merge[simp]: "\<lbrakk> distinct xs; distinct ys; List.sorted xs; List.sorted ys \<rbrakk> \<Longrightarrow> distinct (merge xs ys)"
by (induct xs ys rule: merge.induct, auto simp add: sorted_Cons)

text {* The remove function removes an element from a sorted list *}

primrec remove :: "('a :: linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "remove a [] = []"
  |  "remove a (x#xs) = (if a > x then (x # remove a xs) else (if a = x then xs else x#xs))"

lemma remove': "sorted xs \<and> distinct xs \<Longrightarrow> sorted (remove a xs) \<and> distinct (remove a xs) \<and> set (remove a xs) = set xs - {a}"
apply (induct xs)
apply (auto simp add: sorted_Cons)
done

lemma set_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> set (remove a xs) = set xs - {a}"
using remove' by auto

lemma sorted_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> sorted (remove a xs)"
using remove' by auto

lemma distinct_remove[simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> distinct (remove a xs)"
using remove' by auto

lemma remove_insort_cancel: "remove a (insort a xs) = xs"
apply (induct xs)
apply simp
apply auto
done

lemma remove_insort_commute: "\<lbrakk> a \<noteq> b; sorted xs \<rbrakk> \<Longrightarrow> remove b (insort a xs) = insort a (remove b xs)"
apply (induct xs)
apply auto
apply (auto simp add: sorted_Cons)
apply (case_tac xs)
apply auto
done

lemma notinset_remove: "x \<notin> set xs \<Longrightarrow> remove x xs = xs"
apply (induct xs)
apply auto
done

lemma remove1_eq_remove:
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow> remove1 x xs = remove x xs"
apply (induct xs)
apply (auto simp add: sorted_Cons)
apply (subgoal_tac "x \<notin> set xs")
apply (simp add: notinset_remove)
apply fastforce
done

lemma sorted_remove1:
  "sorted xs \<Longrightarrow> sorted (remove1 x xs)"
apply (induct xs)
apply (auto simp add: sorted_Cons)
done

subsection {* Efficient member function for sorted lists *}

primrec smember :: "'a list \<Rightarrow> 'a::linorder \<Rightarrow> bool" where
  "smember [] x \<longleftrightarrow> False"
| "smember (y#ys) x \<longleftrightarrow> x = y \<or> (x > y \<and> smember ys x)"

lemma "sorted xs \<Longrightarrow> smember xs x \<longleftrightarrow> (x \<in> set xs)"
  by (induct xs) (auto simp add: sorted_Cons)

end


(*  Title:      HOL/Lattice/Bounds.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section {* Bounds *}

theory Bounds imports Orders begin

hide_const (open) inf sup

subsection {* Infimum and supremum *}

text {*
  Given a partial order, we define infimum (greatest lower bound) and
  supremum (least upper bound) wrt.\ @{text \<sqsubseteq>} for two and for any
  number of elements.
*}

definition
  is_inf :: "'a::partial_order \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_inf x y inf = (inf \<sqsubseteq> x \<and> inf \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> inf))"

definition
  is_sup :: "'a::partial_order \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_sup x y sup = (x \<sqsubseteq> sup \<and> y \<sqsubseteq> sup \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> sup \<sqsubseteq> z))"

definition
  is_Inf :: "'a::partial_order set \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_Inf A inf = ((\<forall>x \<in> A. inf \<sqsubseteq> x) \<and> (\<forall>z. (\<forall>x \<in> A. z \<sqsubseteq> x) \<longrightarrow> z \<sqsubseteq> inf))"

definition
  is_Sup :: "'a::partial_order set \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_Sup A sup = ((\<forall>x \<in> A. x \<sqsubseteq> sup) \<and> (\<forall>z. (\<forall>x \<in> A. x \<sqsubseteq> z) \<longrightarrow> sup \<sqsubseteq> z))"

text {*
  These definitions entail the following basic properties of boundary
  elements.
*}

lemma is_infI [intro?]: "inf \<sqsubseteq> x \<Longrightarrow> inf \<sqsubseteq> y \<Longrightarrow>
    (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> inf) \<Longrightarrow> is_inf x y inf"
  by (unfold is_inf_def) blast

lemma is_inf_greatest [elim?]:
    "is_inf x y inf \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> inf"
  by (unfold is_inf_def) blast

lemma is_inf_lower [elim?]:
    "is_inf x y inf \<Longrightarrow> (inf \<sqsubseteq> x \<Longrightarrow> inf \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_inf_def) blast

lemma is_supI [intro?]: "x \<sqsubseteq> sup \<Longrightarrow> y \<sqsubseteq> sup \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> sup \<sqsubseteq> z) \<Longrightarrow> is_sup x y sup"
  by (unfold is_sup_def) blast

lemma is_sup_least [elim?]:
    "is_sup x y sup \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> sup \<sqsubseteq> z"
  by (unfold is_sup_def) blast

lemma is_sup_upper [elim?]:
    "is_sup x y sup \<Longrightarrow> (x \<sqsubseteq> sup \<Longrightarrow> y \<sqsubseteq> sup \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_sup_def) blast

lemma is_InfI [intro?]: "(\<And>x. x \<in> A \<Longrightarrow> inf \<sqsubseteq> x) \<Longrightarrow>
    (\<And>z. (\<forall>x \<in> A. z \<sqsubseteq> x) \<Longrightarrow> z \<sqsubseteq> inf) \<Longrightarrow> is_Inf A inf"
  by (unfold is_Inf_def) blast

lemma is_Inf_greatest [elim?]:
    "is_Inf A inf \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x) \<Longrightarrow> z \<sqsubseteq> inf"
  by (unfold is_Inf_def) blast

lemma is_Inf_lower [dest?]:
    "is_Inf A inf \<Longrightarrow> x \<in> A \<Longrightarrow> inf \<sqsubseteq> x"
  by (unfold is_Inf_def) blast

lemma is_SupI [intro?]: "(\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> sup) \<Longrightarrow>
    (\<And>z. (\<forall>x \<in> A. x \<sqsubseteq> z) \<Longrightarrow> sup \<sqsubseteq> z) \<Longrightarrow> is_Sup A sup"
  by (unfold is_Sup_def) blast

lemma is_Sup_least [elim?]:
    "is_Sup A sup \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> x \<sqsubseteq> z) \<Longrightarrow> sup \<sqsubseteq> z"
  by (unfold is_Sup_def) blast

lemma is_Sup_upper [dest?]:
    "is_Sup A sup \<Longrightarrow> x \<in> A \<Longrightarrow> x \<sqsubseteq> sup"
  by (unfold is_Sup_def) blast

subsection {* Duality *}

text {*
  Infimum and supremum are dual to each other.
*}

theorem dual_inf [iff?]:
    "is_inf (dual x) (dual y) (dual sup) = is_sup x y sup"
  by (simp add: is_inf_def is_sup_def dual_all [symmetric] dual_leq)

theorem dual_sup [iff?]:
    "is_sup (dual x) (dual y) (dual inf) = is_inf x y inf"
  by (simp add: is_inf_def is_sup_def dual_all [symmetric] dual_leq)

theorem dual_Inf [iff?]:
    "is_Inf (dual ` A) (dual sup) = is_Sup A sup"
  by (simp add: is_Inf_def is_Sup_def dual_all [symmetric] dual_leq)

theorem dual_Sup [iff?]:
    "is_Sup (dual ` A) (dual inf) = is_Inf A inf"
  by (simp add: is_Inf_def is_Sup_def dual_all [symmetric] dual_leq)

subsection {* Uniqueness *}

text {*
  Infima and suprema on partial orders are unique; this is mainly due
  to anti-symmetry of the underlying relation.
*}

theorem is_inf_uniq: "is_inf x y inf \<Longrightarrow> is_inf x y inf' \<Longrightarrow> inf = inf'"
proof -
  assume inf: "is_inf x y inf"
  assume inf': "is_inf x y inf'"
  show ?thesis
  proof (rule leq_antisym)
    from inf' show "inf \<sqsubseteq> inf'"
    proof (rule is_inf_greatest)
      from inf show "inf \<sqsubseteq> x" ..
      from inf show "inf \<sqsubseteq> y" ..
    qed
    from inf show "inf' \<sqsubseteq> inf"
    proof (rule is_inf_greatest)
      from inf' show "inf' \<sqsubseteq> x" ..
      from inf' show "inf' \<sqsubseteq> y" ..
    qed
  qed
qed

theorem is_sup_uniq: "is_sup x y sup \<Longrightarrow> is_sup x y sup' \<Longrightarrow> sup = sup'"
proof -
  assume sup: "is_sup x y sup" and sup': "is_sup x y sup'"
  have "dual sup = dual sup'"
  proof (rule is_inf_uniq)
    from sup show "is_inf (dual x) (dual y) (dual sup)" ..
    from sup' show "is_inf (dual x) (dual y) (dual sup')" ..
  qed
  then show "sup = sup'" ..
qed

theorem is_Inf_uniq: "is_Inf A inf \<Longrightarrow> is_Inf A inf' \<Longrightarrow> inf = inf'"
proof -
  assume inf: "is_Inf A inf"
  assume inf': "is_Inf A inf'"
  show ?thesis
  proof (rule leq_antisym)
    from inf' show "inf \<sqsubseteq> inf'"
    proof (rule is_Inf_greatest)
      fix x assume "x \<in> A"
      with inf show "inf \<sqsubseteq> x" ..
    qed
    from inf show "inf' \<sqsubseteq> inf"
    proof (rule is_Inf_greatest)
      fix x assume "x \<in> A"
      with inf' show "inf' \<sqsubseteq> x" ..
    qed
  qed
qed

theorem is_Sup_uniq: "is_Sup A sup \<Longrightarrow> is_Sup A sup' \<Longrightarrow> sup = sup'"
proof -
  assume sup: "is_Sup A sup" and sup': "is_Sup A sup'"
  have "dual sup = dual sup'"
  proof (rule is_Inf_uniq)
    from sup show "is_Inf (dual ` A) (dual sup)" ..
    from sup' show "is_Inf (dual ` A) (dual sup')" ..
  qed
  then show "sup = sup'" ..
qed

subsection {* Related elements *}

text {*
  The binary bound of related elements is either one of the argument.
*}

theorem is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
  qed
qed

theorem is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> y" by fact
    show "y \<sqsubseteq> y" ..
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed
qed

subsection {* General versus binary bounds \label{sec:gen-bin-bounds} *}

text {*
  General bounds of two-element sets coincide with binary bounds.
*}

theorem is_Inf_binary: "is_Inf {x, y} inf = is_inf x y inf"
proof -
  let ?A = "{x, y}"
  show ?thesis
  proof
    assume is_Inf: "is_Inf ?A inf"
    show "is_inf x y inf"
    proof
      have "x \<in> ?A" by simp
      with is_Inf show "inf \<sqsubseteq> x" ..
      have "y \<in> ?A" by simp
      with is_Inf show "inf \<sqsubseteq> y" ..
      fix z assume zx: "z \<sqsubseteq> x" and zy: "z \<sqsubseteq> y"
      from is_Inf show "z \<sqsubseteq> inf"
      proof (rule is_Inf_greatest)
        fix a assume "a \<in> ?A"
        then have "a = x \<or> a = y" by blast
        then show "z \<sqsubseteq> a"
        proof
          assume "a = x"
          with zx show ?thesis by simp
        next
          assume "a = y"
          with zy show ?thesis by simp
        qed
      qed
    qed
  next
    assume is_inf: "is_inf x y inf"
    show "is_Inf {x, y} inf"
    proof
      fix a assume "a \<in> ?A"
      then have "a = x \<or> a = y" by blast
      then show "inf \<sqsubseteq> a"
      proof
        assume "a = x"
        also from is_inf have "inf \<sqsubseteq> x" ..
        finally show ?thesis .
      next
        assume "a = y"
        also from is_inf have "inf \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
    next
      fix z assume z: "\<forall>a \<in> ?A. z \<sqsubseteq> a"
      from is_inf show "z \<sqsubseteq> inf"
      proof (rule is_inf_greatest)
        from z show "z \<sqsubseteq> x" by blast
        from z show "z \<sqsubseteq> y" by blast
      qed
    qed
  qed
qed

theorem is_Sup_binary: "is_Sup {x, y} sup = is_sup x y sup"
proof -
  have "is_Sup {x, y} sup = is_Inf (dual ` {x, y}) (dual sup)"
    by (simp only: dual_Inf)
  also have "dual ` {x, y} = {dual x, dual y}"
    by simp
  also have "is_Inf \<dots> (dual sup) = is_inf (dual x) (dual y) (dual sup)"
    by (rule is_Inf_binary)
  also have "\<dots> = is_sup x y sup"
    by (simp only: dual_inf)
  finally show ?thesis .
qed

subsection {* Connecting general bounds \label{sec:connect-bounds} *}

text {*
  Either kind of general bounds is sufficient to express the other.
  The least upper bound (supremum) is the same as the the greatest
  lower bound of the set of all upper bounds; the dual statements
  holds as well; the dual statement holds as well.
*}

theorem Inf_Sup: "is_Inf {b. \<forall>a \<in> A. a \<sqsubseteq> b} sup \<Longrightarrow> is_Sup A sup"
proof -
  let ?B = "{b. \<forall>a \<in> A. a \<sqsubseteq> b}"
  assume is_Inf: "is_Inf ?B sup"
  show "is_Sup A sup"
  proof
    fix x assume x: "x \<in> A"
    from is_Inf show "x \<sqsubseteq> sup"
    proof (rule is_Inf_greatest)
      fix y assume "y \<in> ?B"
      then have "\<forall>a \<in> A. a \<sqsubseteq> y" ..
      from this x show "x \<sqsubseteq> y" ..
    qed
  next
    fix z assume "\<forall>x \<in> A. x \<sqsubseteq> z"
    then have "z \<in> ?B" ..
    with is_Inf show "sup \<sqsubseteq> z" ..
  qed
qed

theorem Sup_Inf: "is_Sup {b. \<forall>a \<in> A. b \<sqsubseteq> a} inf \<Longrightarrow> is_Inf A inf"
proof -
  assume "is_Sup {b. \<forall>a \<in> A. b \<sqsubseteq> a} inf"
  then have "is_Inf (dual ` {b. \<forall>a \<in> A. dual a \<sqsubseteq> dual b}) (dual inf)"
    by (simp only: dual_Inf dual_leq)
  also have "dual ` {b. \<forall>a \<in> A. dual a \<sqsubseteq> dual b} = {b'. \<forall>a' \<in> dual ` A. a' \<sqsubseteq> b'}"
    by (auto iff: dual_ball dual_Collect simp add: image_Collect)  (* FIXME !? *)
  finally have "is_Inf \<dots> (dual inf)" .
  then have "is_Sup (dual ` A) (dual inf)"
    by (rule Inf_Sup)
  then show ?thesis ..
qed

end


theory Multiplicity_Pair
  imports
    Main
    Ecore.Multiplicity
begin

section "Definition of a multiplicity pair"

type_synonym multiplicity_pair = "multiplicity \<times> multiplicity"

definition m_in :: "multiplicity_pair \<Rightarrow> multiplicity" where
  "m_in p = fst p"

declare m_in_def[simp add]

definition m_out :: "multiplicity_pair \<Rightarrow> multiplicity" where
  "m_out p = snd p"

declare m_out_def[simp add]

lemma multiplicity_pair_in_out: "\<And>mp. mp = (mp_in, mp_out) \<Longrightarrow> m_in mp = mp_in \<and> m_out mp = mp_out"
  by auto

locale multiplicity_pair = fixes mult_pair :: "multiplicity_pair"
  assumes in_mult_is_mult: "multiplicity (m_in mult_pair)"
  assumes out_mult_is_mult: "multiplicity (m_out mult_pair)"

context multiplicity_pair
begin

lemma in_mult_lower_bound_valid[simp]: "lower (m_in mult_pair) \<noteq> \<^emph>"
  using in_mult_is_mult multiplicity_def by simp

lemma in_mult_upper_bound_valid[simp]: "upper (m_in mult_pair) \<noteq> \<^bold>0"
  using in_mult_is_mult multiplicity_def by simp

lemma in_mult_properly_bounded[simp]: "lower (m_in mult_pair) \<le> upper (m_in mult_pair)"
  using in_mult_is_mult multiplicity_def by simp

lemma out_mult_lower_bound_valid[simp]: "lower (m_out mult_pair) \<noteq> \<^emph>"
  using out_mult_is_mult multiplicity_def by simp

lemma out_mult_upper_bound_valid[simp]: "upper (m_out mult_pair) \<noteq> \<^bold>0"
  using out_mult_is_mult multiplicity_def by simp

lemma out_mult_properly_bounded[simp]: "lower (m_out mult_pair) \<le> upper (m_out mult_pair)"
  using out_mult_is_mult multiplicity_def by simp

end

section "Definition of intersection of a multiplicity pair"

definition mult_pair_intersect :: "multiplicity_pair \<Rightarrow> multiplicity_pair \<Rightarrow> multiplicity_pair" where
  "mult_pair_intersect mp1 mp2 \<equiv> (m_in mp1 \<sqinter> m_in mp2, m_out mp1 \<sqinter> m_out mp2)"

lemma mult_pair_intersect_identity[simp]: "mult_pair_intersect mp (\<^bold>0..\<^emph>, \<^bold>0..\<^emph>) = mp"
  unfolding mult_pair_intersect_def
  by simp

lemma mult_pair_intersect_commute[simp]: "mult_pair_intersect mp1 mp2 = mult_pair_intersect mp2 mp1"
  unfolding mult_pair_intersect_def
  by simp

lemma mult_pair_intersect_assoc[simp]: "mult_pair_intersect (mult_pair_intersect mp1 mp2) mp3 = mult_pair_intersect mp1 (mult_pair_intersect mp2 mp3)"
  unfolding mult_pair_intersect_def
  using mult_intersect_assoc
  by simp

lemma mult_pair_intersect_idemp[simp]: "mult_pair_intersect mp mp = mp"
  unfolding mult_pair_intersect_def
  by simp

lemma mult_pair_intersect_correct[simp]: "\<And>mp1 mp2. multiplicity (m_in mp1 \<sqinter> m_in mp2) \<Longrightarrow> multiplicity (m_out mp1 \<sqinter> m_out mp2) \<Longrightarrow> multiplicity_pair (mult_pair_intersect mp1 mp2)"
  by (simp add: mult_pair_intersect_def multiplicity_pair_def)

lemma mult_pair_intersect_correct_alt: "\<And>mp1 mp2. multiplicity_pair mp1 \<Longrightarrow> multiplicity_pair mp2 \<Longrightarrow> max (lower (m_in mp1)) (lower (m_in mp2)) \<le> min (upper (m_in mp1)) (upper (m_in mp2)) \<Longrightarrow> max (lower (m_out mp1)) (lower (m_out mp2)) \<le> min (upper (m_out mp1)) (upper (m_out mp2)) \<Longrightarrow> multiplicity_pair (mult_pair_intersect mp1 mp2)"
  using mult_intersect_correct mult_pair_intersect_correct multiplicity_pair.in_mult_is_mult multiplicity_pair.out_mult_is_mult by auto

lemma mult_pair_intersect_eq[simp]: "\<And>mp. mp = mult_pair_intersect mp mp"
  using mult_pair_intersect_def by auto

lemma mult_pair_intersect_in_eq[simp]: "\<And>mp1 mp2. m_in mp1 = m_in mp2 \<Longrightarrow> m_in (mult_pair_intersect mp1 mp2) = m_in mp1"
  by (simp add: mult_intersect_def mult_pair_intersect_def)

lemma mult_pair_intersect_in_eq_alt[simp]: "\<And>mp1 mp2. m_in mp1 = m_in mp2 \<Longrightarrow> m_in (mult_pair_intersect mp1 mp2) = m_in mp2"
  by (simp add: mult_intersect_def mult_pair_intersect_def)

lemma mult_pair_intersect_out_eq[simp]: "\<And>mp1 mp2. m_out mp1 = m_out mp2 \<Longrightarrow> m_out (mult_pair_intersect mp1 mp2) = m_out mp1"
  by (simp add: mult_intersect_def mult_pair_intersect_def)

lemma mult_pair_intersect_out_eq_alt[simp]: "\<And>mp1 mp2. m_out mp1 = m_out mp2 \<Longrightarrow> m_out (mult_pair_intersect mp1 mp2) = m_out mp2"
  by (simp add: mult_intersect_def mult_pair_intersect_def)

end


(*  Title:      HOL/Library/Nat_Bijection.thy
    Author:     Brian Huffman
    Author:     Florian Haftmann
    Author:     Stefan Richter
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section \<open>Bijections between natural numbers and other types\<close>

theory Nat_Bijection
  imports Main
begin

subsection \<open>Type \<^typ>\<open>nat \<times> nat\<close>\<close>

text \<open>Triangle numbers: 0, 1, 3, 6, 10, 15, ...\<close>

definition triangle :: "nat \<Rightarrow> nat"
  where "triangle n = (n * Suc n) div 2"

lemma triangle_0 [simp]: "triangle 0 = 0"
  by (simp add: triangle_def)

lemma triangle_Suc [simp]: "triangle (Suc n) = triangle n + Suc n"
  by (simp add: triangle_def)

definition prod_encode :: "nat \<times> nat \<Rightarrow> nat"
  where "prod_encode = (\<lambda>(m, n). triangle (m + n) + m)"

text \<open>In this auxiliary function, \<^term>\<open>triangle k + m\<close> is an invariant.\<close>

fun prod_decode_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
  where "prod_decode_aux k m =
    (if m \<le> k then (m, k - m) else prod_decode_aux (Suc k) (m - Suc k))"

declare prod_decode_aux.simps [simp del]

definition prod_decode :: "nat \<Rightarrow> nat \<times> nat"
  where "prod_decode = prod_decode_aux 0"

lemma prod_encode_prod_decode_aux: "prod_encode (prod_decode_aux k m) = triangle k + m"
proof (induction k m rule: prod_decode_aux.induct)
  case (1 k m)
  then show ?case
    by (simp add: prod_encode_def prod_decode_aux.simps)
qed

lemma prod_decode_inverse [simp]: "prod_encode (prod_decode n) = n"
  by (simp add: prod_decode_def prod_encode_prod_decode_aux)

lemma prod_decode_triangle_add: "prod_decode (triangle k + m) = prod_decode_aux k m"
proof (induct k arbitrary: m)
  case 0
  then show ?case
    by (simp add: prod_decode_def)
next
  case (Suc k)
  then show ?case
    by (metis ab_semigroup_add_class.add_ac(1) add_diff_cancel_left' le_add1 not_less_eq_eq prod_decode_aux.simps triangle_Suc)
qed

lemma prod_encode_inverse [simp]: "prod_decode (prod_encode x) = x"
  unfolding prod_encode_def
proof (induct x)
  case (Pair a b)
  then show ?case
    by (simp add: prod_decode_triangle_add prod_decode_aux.simps)
qed

lemma inj_prod_encode: "inj_on prod_encode A"
  by (rule inj_on_inverseI) (rule prod_encode_inverse)

lemma inj_prod_decode: "inj_on prod_decode A"
  by (rule inj_on_inverseI) (rule prod_decode_inverse)

lemma surj_prod_encode: "surj prod_encode"
  by (rule surjI) (rule prod_decode_inverse)

lemma surj_prod_decode: "surj prod_decode"
  by (rule surjI) (rule prod_encode_inverse)

lemma bij_prod_encode: "bij prod_encode"
  by (rule bijI [OF inj_prod_encode surj_prod_encode])

lemma bij_prod_decode: "bij prod_decode"
  by (rule bijI [OF inj_prod_decode surj_prod_decode])

lemma prod_encode_eq [simp]: "prod_encode x = prod_encode y \<longleftrightarrow> x = y"
  by (rule inj_prod_encode [THEN inj_eq])

lemma prod_decode_eq [simp]: "prod_decode x = prod_decode y \<longleftrightarrow> x = y"
  by (rule inj_prod_decode [THEN inj_eq])

text \<open>Ordering properties\<close>

lemma le_prod_encode_1: "a \<le> prod_encode (a, b)"
  by (simp add: prod_encode_def)

lemma le_prod_encode_2: "b \<le> prod_encode (a, b)"
  by (induct b) (simp_all add: prod_encode_def)

subsection \<open>Type \<^typ>\<open>nat + nat\<close>\<close>

definition sum_encode :: "nat + nat \<Rightarrow> nat"
  where "sum_encode x = (case x of Inl a \<Rightarrow> 2 * a | Inr b \<Rightarrow> Suc (2 * b))"

definition sum_decode :: "nat \<Rightarrow> nat + nat"
  where "sum_decode n = (if even n then Inl (n div 2) else Inr (n div 2))"

lemma sum_encode_inverse [simp]: "sum_decode (sum_encode x) = x"
  by (induct x) (simp_all add: sum_decode_def sum_encode_def)

lemma sum_decode_inverse [simp]: "sum_encode (sum_decode n) = n"
  by (simp add: even_two_times_div_two sum_decode_def sum_encode_def)

lemma inj_sum_encode: "inj_on sum_encode A"
  by (rule inj_on_inverseI) (rule sum_encode_inverse)

lemma inj_sum_decode: "inj_on sum_decode A"
  by (rule inj_on_inverseI) (rule sum_decode_inverse)

lemma surj_sum_encode: "surj sum_encode"
  by (rule surjI) (rule sum_decode_inverse)

lemma surj_sum_decode: "surj sum_decode"
  by (rule surjI) (rule sum_encode_inverse)

lemma bij_sum_encode: "bij sum_encode"
  by (rule bijI [OF inj_sum_encode surj_sum_encode])

lemma bij_sum_decode: "bij sum_decode"
  by (rule bijI [OF inj_sum_decode surj_sum_decode])

lemma sum_encode_eq: "sum_encode x = sum_encode y \<longleftrightarrow> x = y"
  by (rule inj_sum_encode [THEN inj_eq])

lemma sum_decode_eq: "sum_decode x = sum_decode y \<longleftrightarrow> x = y"
  by (rule inj_sum_decode [THEN inj_eq])

subsection \<open>Type \<^typ>\<open>int\<close>\<close>

definition int_encode :: "int \<Rightarrow> nat"
  where "int_encode i = sum_encode (if 0 \<le> i then Inl (nat i) else Inr (nat (- i - 1)))"

definition int_decode :: "nat \<Rightarrow> int"
  where "int_decode n = (case sum_decode n of Inl a \<Rightarrow> int a | Inr b \<Rightarrow> - int b - 1)"

lemma int_encode_inverse [simp]: "int_decode (int_encode x) = x"
  by (simp add: int_decode_def int_encode_def)

lemma int_decode_inverse [simp]: "int_encode (int_decode n) = n"
  unfolding int_decode_def int_encode_def
  using sum_decode_inverse [of n] by (cases "sum_decode n") simp_all

lemma inj_int_encode: "inj_on int_encode A"
  by (rule inj_on_inverseI) (rule int_encode_inverse)

lemma inj_int_decode: "inj_on int_decode A"
  by (rule inj_on_inverseI) (rule int_decode_inverse)

lemma surj_int_encode: "surj int_encode"
  by (rule surjI) (rule int_decode_inverse)

lemma surj_int_decode: "surj int_decode"
  by (rule surjI) (rule int_encode_inverse)

lemma bij_int_encode: "bij int_encode"
  by (rule bijI [OF inj_int_encode surj_int_encode])

lemma bij_int_decode: "bij int_decode"
  by (rule bijI [OF inj_int_decode surj_int_decode])

lemma int_encode_eq: "int_encode x = int_encode y \<longleftrightarrow> x = y"
  by (rule inj_int_encode [THEN inj_eq])

lemma int_decode_eq: "int_decode x = int_decode y \<longleftrightarrow> x = y"
  by (rule inj_int_decode [THEN inj_eq])

subsection \<open>Type \<^typ>\<open>nat list\<close>\<close>

fun list_encode :: "nat list \<Rightarrow> nat"
  where
    "list_encode [] = 0"
  | "list_encode (x # xs) = Suc (prod_encode (x, list_encode xs))"

function list_decode :: "nat \<Rightarrow> nat list"
  where
    "list_decode 0 = []"
  | "list_decode (Suc n) = (case prod_decode n of (x, y) \<Rightarrow> x # list_decode y)"
  by pat_completeness auto

termination list_decode
proof -
  have "\<And>n x y. (x, y) = prod_decode n \<Longrightarrow> y < Suc n"
    by (metis le_imp_less_Suc le_prod_encode_2 prod_decode_inverse)
  then show ?thesis
    using "termination" by blast
qed

lemma list_encode_inverse [simp]: "list_decode (list_encode x) = x"
  by (induct x rule: list_encode.induct) simp_all

lemma list_decode_inverse [simp]: "list_encode (list_decode n) = n"
proof (induct n rule: list_decode.induct)
  case (2 n)
  then show ?case
    by (metis list_encode.simps(2) list_encode_inverse prod_decode_inverse surj_pair)
qed auto

lemma inj_list_encode: "inj_on list_encode A"
  by (rule inj_on_inverseI) (rule list_encode_inverse)

lemma inj_list_decode: "inj_on list_decode A"
  by (rule inj_on_inverseI) (rule list_decode_inverse)

lemma surj_list_encode: "surj list_encode"
  by (rule surjI) (rule list_decode_inverse)

lemma surj_list_decode: "surj list_decode"
  by (rule surjI) (rule list_encode_inverse)

lemma bij_list_encode: "bij list_encode"
  by (rule bijI [OF inj_list_encode surj_list_encode])

lemma bij_list_decode: "bij list_decode"
  by (rule bijI [OF inj_list_decode surj_list_decode])

lemma list_encode_eq: "list_encode x = list_encode y \<longleftrightarrow> x = y"
  by (rule inj_list_encode [THEN inj_eq])

lemma list_decode_eq: "list_decode x = list_decode y \<longleftrightarrow> x = y"
  by (rule inj_list_decode [THEN inj_eq])

subsection \<open>Finite sets of naturals\<close>

subsubsection \<open>Preliminaries\<close>

lemma finite_vimage_Suc_iff: "finite (Suc -` F) \<longleftrightarrow> finite F"
proof
  have "F \<subseteq> insert 0 (Suc ` Suc -` F)"
    using nat.nchotomy by force
  moreover
  assume "finite (Suc -` F)"
  then have "finite (insert 0 (Suc ` Suc -` F))"
    by blast
  ultimately show "finite F"
    using finite_subset by blast
qed (force intro: finite_vimageI inj_Suc)

lemma vimage_Suc_insert_0: "Suc -` insert 0 A = Suc -` A"
  by auto

lemma vimage_Suc_insert_Suc: "Suc -` insert (Suc n) A = insert n (Suc -` A)"
  by auto

lemma div2_even_ext_nat:
  fixes x y :: nat
  assumes "x div 2 = y div 2"
    and "even x \<longleftrightarrow> even y"
  shows "x = y"
proof -
  from \<open>even x \<longleftrightarrow> even y\<close> have "x mod 2 = y mod 2"
    by (simp only: even_iff_mod_2_eq_zero) auto
  with assms have "x div 2 * 2 + x mod 2 = y div 2 * 2 + y mod 2"
    by simp
  then show ?thesis
    by simp
qed

subsubsection \<open>From sets to naturals\<close>

definition set_encode :: "nat set \<Rightarrow> nat"
  where "set_encode = sum ((^) 2)"

lemma set_encode_empty [simp]: "set_encode {} = 0"
  by (simp add: set_encode_def)

lemma set_encode_inf: "\<not> finite A \<Longrightarrow> set_encode A = 0"
  by (simp add: set_encode_def)

lemma set_encode_insert [simp]: "finite A \<Longrightarrow> n \<notin> A \<Longrightarrow> set_encode (insert n A) = 2^n + set_encode A"
  by (simp add: set_encode_def)

lemma even_set_encode_iff: "finite A \<Longrightarrow> even (set_encode A) \<longleftrightarrow> 0 \<notin> A"
  by (induct set: finite) (auto simp: set_encode_def)

lemma set_encode_vimage_Suc: "set_encode (Suc -` A) = set_encode A div 2"
proof (induction A rule: infinite_finite_induct)
  case (infinite A)
  then show ?case
    by (simp add: finite_vimage_Suc_iff set_encode_inf)
next
  case (insert x A)
  show ?case
  proof (cases x)
    case 0
    with insert show ?thesis
      by (simp add: even_set_encode_iff vimage_Suc_insert_0)
  next
    case (Suc y)
    with insert show ?thesis
      by (simp add: finite_vimageI add.commute vimage_Suc_insert_Suc)
  qed
qed auto

lemmas set_encode_div_2 = set_encode_vimage_Suc [symmetric]

subsubsection \<open>From naturals to sets\<close>

definition set_decode :: "nat \<Rightarrow> nat set"
  where "set_decode x = {n. odd (x div 2 ^ n)}"

lemma set_decode_0 [simp]: "0 \<in> set_decode x \<longleftrightarrow> odd x"
  by (simp add: set_decode_def)

lemma set_decode_Suc [simp]: "Suc n \<in> set_decode x \<longleftrightarrow> n \<in> set_decode (x div 2)"
  by (simp add: set_decode_def div_mult2_eq)

lemma set_decode_zero [simp]: "set_decode 0 = {}"
  by (simp add: set_decode_def)

lemma set_decode_div_2: "set_decode (x div 2) = Suc -` set_decode x"
  by auto

lemma set_decode_plus_power_2:
  "n \<notin> set_decode z \<Longrightarrow> set_decode (2 ^ n + z) = insert n (set_decode z)"
proof (induct n arbitrary: z)
  case 0
  show ?case
  proof (rule set_eqI)
    show "q \<in> set_decode (2 ^ 0 + z) \<longleftrightarrow> q \<in> insert 0 (set_decode z)" for q
      by (induct q) (use 0 in simp_all)
  qed
next
  case (Suc n)
  show ?case
  proof (rule set_eqI)
    show "q \<in> set_decode (2 ^ Suc n + z) \<longleftrightarrow> q \<in> insert (Suc n) (set_decode z)" for q
      by (induct q) (use Suc in simp_all)
  qed
qed

lemma finite_set_decode [simp]: "finite (set_decode n)"
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof (cases "n = 0")
    case False
    then show ?thesis
      using less.IH [of "n div 2"] finite_vimage_Suc_iff set_decode_div_2 by auto
  qed auto
qed

subsubsection \<open>Proof of isomorphism\<close>

lemma set_decode_inverse [simp]: "set_encode (set_decode n) = n"
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof (cases "n = 0")
    case False
    then have "set_encode (set_decode (n div 2)) = n div 2"
      using less.IH by auto
    then show ?thesis
      by (metis div2_even_ext_nat even_set_encode_iff finite_set_decode set_decode_0 set_decode_div_2 set_encode_div_2)
  qed auto
qed

lemma set_encode_inverse [simp]: "finite A \<Longrightarrow> set_decode (set_encode A) = A"
proof (induction rule: finite_induct)
  case (insert x A)
  then show ?case
    by (simp add: set_decode_plus_power_2)
qed auto

lemma inj_on_set_encode: "inj_on set_encode (Collect finite)"
  by (rule inj_on_inverseI [where g = "set_decode"]) simp

lemma set_encode_eq: "finite A \<Longrightarrow> finite B \<Longrightarrow> set_encode A = set_encode B \<longleftrightarrow> A = B"
  by (rule iffI) (simp_all add: inj_onD [OF inj_on_set_encode])

lemma subset_decode_imp_le:
  assumes "set_decode m \<subseteq> set_decode n"
  shows "m \<le> n"
proof -
  have "n = m + set_encode (set_decode n - set_decode m)"
  proof -
    obtain A B where
      "m = set_encode A" "finite A"
      "n = set_encode B" "finite B"
      by (metis finite_set_decode set_decode_inverse)
  with assms show ?thesis
    by auto (simp add: set_encode_def add.commute sum.subset_diff)
  qed
  then show ?thesis
    by (metis le_add1)
qed

end