section \<open>Specification\<close>

theory Goodstein_Lambda
  imports Main "Eval_Base.Eval_Base"
begin

subsection \<open>Hereditary base representation\<close>

text \<open>We define a data type of trees and an evaluation function that sums siblings and
  exponentiates with respect to the given base on nesting.\<close>

datatype C = C (unC: "C list")

fun evalC where
  "evalC b (C []) = 0"
| "evalC b (C (x # xs)) = b^evalC b x + evalC b (C xs)"

value "evalC 2 (C [])" \<comment> \<open>$0$\<close>
value "evalC 2 (C [C []])" \<comment> \<open>$2^0 = 1$\<close>
value "evalC 2 (C [C [C []]])" \<comment> \<open>$2^1 = 2$\<close>
value "evalC 2 (C [C [], C []])" \<comment> \<open>$2^0 + 2^0 = 2^0 \cdot 2 = 2$; not in hereditary base $2$\<close>

text \<open>The hereditary base representation is characterized as trees (i.e., nested lists) whose
  lists have monotonically increasing evaluations, with fewer than @{term "b"} repetitions for
  each value. We will show later that this representation is unique.\<close>

inductive_set hbase for b where
  "C [] \<in> hbase b"
| "i \<noteq> 0 \<Longrightarrow> i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow>
   C ms \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
   C (replicate i n @ ms) \<in> hbase b"

text \<open>We can convert to and from natural numbers as follows.\<close>

definition H2N where
  "H2N b n = evalC b n"

text \<open>As we will show later, @{term "H2N b"} restricted to @{term "hbase n"} is bijective
  if @{prop "b \<ge> (2 :: nat)"}, so we can convert from natural numbers by taking the inverse.\<close>

definition N2H where
  "N2H b n = inv_into (hbase b) (H2N b) n"

subsection \<open>The Goodstein function\<close>

text \<open>We define a function that computes the length of the Goodstein sequence whose $c$-th element
  is $g_c = n$. Termination will be shown later, thereby establishing Goodstein's theorem.\<close>

function (sequential) goodstein :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "goodstein 0 n = 0"
  \<comment> \<open>we start counting at 1; also note that the initial base is @{term "c+1 :: nat"} and\<close>
  \<comment> \<open>hereditary base 1 makes no sense, so we have to avoid this case\<close>
| "goodstein c 0 = c"
| "goodstein c n = goodstein (c+1) (H2N (c+2) (N2H (c+1) n) - 1)"
  by pat_completeness auto

abbreviation \<G> where
  "\<G> n \<equiv> goodstein (Suc 0) n"

section \<open>Ordinals\<close>

text \<open>The following type contains countable ordinals, by the usual case distinction into 0,
  successor ordinal, or limit ordinal; limit ordinals are given by their fundamental sequence.
  Hereditary base @{term "b"} representations carry over to such ordinals by replacing each
  occurrence of the base by @{term "\<omega>"}.\<close>

datatype Ord = Z | S Ord | L "nat \<Rightarrow> Ord"

text \<open>Note that the following arithmetic operations are not correct for all ordinals. However, they
  will only be used in cases where they actually correspond to the ordinal arithmetic operations.\<close>

primrec addO where
  "addO n Z = n"
| "addO n (S m) = S (addO n m)"
| "addO n (L f) = L (\<lambda>i. addO n (f i))"

primrec mulO where
  "mulO n Z = Z"
| "mulO n (S m) = addO (mulO n m) n"
| "mulO n (L f) = L (\<lambda>i. mulO n (f i))"

definition \<omega> where
  "\<omega> = L (\<lambda>n. (S ^^ n) Z)"

primrec exp\<omega> where
  "exp\<omega> Z = S Z"
| "exp\<omega> (S n) = mulO (exp\<omega> n) \<omega>"
| "exp\<omega> (L f) = L (\<lambda>i. exp\<omega> (f i))"

subsection \<open>Evaluation\<close>

text \<open>Evaluating an ordinal number at base $b$ is accomplished by taking the $b$-th element of
  all fundamental sequences and interpreting zero and successor over the natural numbers.\<close>

primrec evalO where
  "evalO b Z = 0"
| "evalO b (S n) = Suc (evalO b n)"
| "evalO b (L f) = evalO b (f b)"

subsection \<open>Goodstein function and sequence\<close>

text \<open>We can define the Goodstein function very easily, but proving correctness will take a while.\<close>

primrec goodsteinO where
  "goodsteinO c Z = c"
| "goodsteinO c (S n) = goodsteinO (c+1) n"
| "goodsteinO c (L f) = goodsteinO c (f (c+2))"

primrec stepO where
  "stepO c Z = Z"
| "stepO c (S n) = n"
| "stepO c (L f) = stepO c (f (c+2))"

text \<open>We can compute a few values of the Goodstein sequence starting at $4$.\<close>

definition g4O where
  "g4O n = fold stepO [1..<Suc n] ((exp\<omega> ^^ 3) Z)"

value "map (\<lambda>n. evalO (n+2) (g4O n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties of evaluation\<close>

lemma evalO_addO [simp]:
  "evalO b (addO n m) = evalO b n + evalO b m"
  apply2 (induct m) by auto

lemma evalO_mulO [simp]:
  "evalO b (mulO n m) = evalO b n * evalO b m"
  apply2 (induct m) by auto

lemma evalO_n [simp]:
  "evalO b ((S ^^ n) Z) = n"
  apply2 (induct n) by auto

lemma evalO_\<omega> [simp]:
  "evalO b \<omega> = b"
  by (auto simp: \<omega>_def)

lemma evalO_exp\<omega> [simp]:
  "evalO b (exp\<omega> n) = b^(evalO b n)"
  apply2 (induct n) by auto

text \<open>Note that evaluation is useful for proving that @{type "Ord"} values are distinct:\<close>
notepad begin
  have "addO n (exp\<omega> m) \<noteq> n" for n m by (auto dest: arg_cong[of _ _ "evalO 1"])
end

subsection \<open>Arithmetic properties\<close>

lemma addO_Z [simp]:
  "addO Z n = n"
  apply2 (induct n) by auto

lemma addO_assoc [simp]:
  "addO n (addO m p) = addO (addO n m) p"
  apply2 (induct p) by auto

lemma mul0_distrib [simp]:
  "mulO n (addO p q) = addO (mulO n p) (mulO n q)"
  apply2 (induct q) by auto

lemma mulO_assoc [simp]:
  "mulO n (mulO m p) = mulO (mulO n m) p"
  apply2 (induct p) by auto

section \<open>Cantor normal form\<close>

text \<open>The previously introduced tree type @{type C} can be used to represent Cantor normal forms;
  they are trees (evaluated at base @{term \<omega>}) such that siblings are in non-decreasing order.
  One can think of this as hereditary base @{term \<omega>}. The plan is to mirror selected operations on
  ordinals in Cantor normal forms.\<close>

subsection \<open>Conversion to and from the ordinal type @{type Ord}\<close>

fun C2O where
  "C2O (C []) = Z"
| "C2O (C (n # ns)) = addO (C2O (C ns)) (exp\<omega> (C2O n))"

definition O2C where
  "O2C = inv C2O"

text \<open>We show that @{term C2O} is injective, meaning the inverse is unique.\<close>

lemma addO_exp\<omega>_inj:
  assumes "addO n (exp\<omega> m) = addO n' (exp\<omega> m')"
  shows "n = n'" and "m = m'"
proof -
  have "addO n (exp\<omega> m) = addO n' (exp\<omega> m') \<Longrightarrow> n = n'"
    apply2 (induct m arbitrary: m') by(case_tac m';
      force simp: \<omega>_def dest!: fun_cong[of _ _ 1])+
  moreover have "addO n (exp\<omega> m) = addO n (exp\<omega> m') \<Longrightarrow> m = m'"
    apply2 (induct m arbitrary: n m'; case_tac m')
    apply (auto 0 3 simp: \<omega>_def intro: rangeI
      dest: arg_cong[of _ _ "evalO 1"] fun_cong[of _ _ 0] fun_cong[of _ _ 1])[8] (* 1 left *)
    by simp (meson ext rangeI)
  ultimately show "n = n'" and "m = m'" using assms by simp_all
qed

lemma C2O_inj:
  "C2O n = C2O m \<Longrightarrow> n = m"
  apply2 (induct n arbitrary: m rule: C2O.induct; case_tac m rule: C2O.cases)
    by (auto dest: addO_exp\<omega>_inj arg_cong[of _ _ "evalO 1"])

lemma O2C_C2O [simp]:
  "O2C (C2O n) = n"
  by (auto intro!: inv_f_f simp: O2C_def inj_def C2O_inj)

lemma O2C_Z [simp]:
  "O2C Z = C []"
  using O2C_C2O[of "C []", unfolded C2O.simps] .

lemma C2O_replicate:
  "C2O (C (replicate i n)) = mulO (exp\<omega> (C2O n)) ((S ^^ i) Z)"
  apply2 (induct i) by auto

lemma C2O_app:
  "C2O (C (xs @ ys)) = addO (C2O (C ys)) (C2O (C xs))"
  apply2 (induct xs arbitrary: ys) by auto

subsection \<open>Evaluation\<close>

lemma evalC_def':
  "evalC b n = evalO b (C2O n)"
  apply2 (induct n rule: C2O.induct) by auto

lemma evalC_app [simp]:
  "evalC b (C (ns @ ms)) = evalC b (C ns) + evalC b (C ms)"
  apply2 (induct ns) by auto

lemma evalC_replicate [simp]:
  "evalC b (C (replicate c n)) = c * evalC b (C [n])"
  apply2 (induct c) by auto

subsection \<open>Transfer of the @{type Ord} induction principle to @{type C}\<close>

fun funC where \<comment> \<open>@{term funC} computes the fundamental sequence on @{type C}\<close>
  "funC (C []) = (\<lambda>i. [C []])"
| "funC (C (C [] # ns)) = (\<lambda>i. replicate i (C ns))"
| "funC (C (n # ns)) = (\<lambda>i. [C (funC n i @ ns)])"

lemma C2O_cons:
  "C2O (C (n # ns)) =
    (if n = C [] then S (C2O (C ns)) else L (\<lambda>i. C2O (C (funC n i @ ns))))"
  apply2 (induct n arbitrary: ns rule: funC.induct)
  by (simp_all add: \<omega>_def C2O_replicate C2O_app flip: exp\<omega>_addO)

lemma C_Ord_induct:
  assumes "P (C [])"
  and "\<And>ns. P (C ns) \<Longrightarrow> P (C (C [] # ns))"
  and "\<And>n ns ms. (\<And>i. P (C (funC (C (n # ns)) i @ ms))) \<Longrightarrow>
    P (C (C (n # ns) # ms))"
  shows "P n"
proof -
  have "\<forall>n. C2O n = m \<longrightarrow> P n" for m
    apply2 (induct m; intro allI; case_tac n rule: funC.cases)
  by (auto simp: C2O_cons simp del: C2O.simps(2) intro: assms)
  then show ?thesis by simp
qed

subsection \<open>Goodstein function and sequence on @{type C}\<close>

function (domintros) goodsteinC where
  "goodsteinC c (C []) = c"
| "goodsteinC c (C (C [] # ns)) = goodsteinC (c+1) (C ns)"
| "goodsteinC c (C (C (n # ns) # ms)) =
    goodsteinC c (C (funC (C (n # ns)) (c+2) @ ms))"
  by pat_completeness auto

termination
proof -
  have "goodsteinC_dom (c, n)" for c n
    apply2 (induct n arbitrary: c rule: C_Ord_induct) by(auto intro: goodsteinC.domintros)
  then show ?thesis by simp
qed

lemma goodsteinC_def':
  "goodsteinC c n = goodsteinO c (C2O n)"
  apply2 (induct c n rule: goodsteinC.induct) by(simp_all add: C2O_cons del: C2O.simps(2))

function (domintros) stepC where
  "stepC c (C []) = C []"
| "stepC c (C (C [] # ns)) = C ns"
| "stepC c (C (C (n # ns) # ms)) =
    stepC c (C (funC (C (n # ns)) (Suc (Suc c)) @ ms))"
  by pat_completeness auto

termination
proof -
  have "stepC_dom (c, n)" for c n
    apply2 (induct n arbitrary: c rule: C_Ord_induct) by(auto intro: stepC.domintros)
  then show ?thesis by simp
qed

definition g4C where
  "g4C n = fold stepC [1..<Suc n] (C [C [C [C []]]])"

value "map (\<lambda>n. evalC (n+2) (g4C n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties\<close>

lemma stepC_def':
  "stepC c n = O2C (stepO c (C2O n))"
  apply2 (induct c n rule: stepC.induct) by(simp_all add: C2O_cons del: C2O.simps(2))

lemma funC_ne [simp]:
  "funC m (Suc n) \<noteq> []"
  by (cases m rule: funC.cases) simp_all

lemma evalC_funC [simp]:
  "evalC b (C (funC n b)) = evalC b (C [n])"
  apply2 (induct n rule: funC.induct) by simp_all

lemma stepC_app [simp]:
  "n \<noteq> C [] \<Longrightarrow> stepC c (C (unC n @ ns)) = C (unC (stepC c n) @ ns)"
  apply2 (induct n arbitrary: ns rule: stepC.induct) by simp_all

lemma stepC_cons [simp]:
  "ns \<noteq> [] \<Longrightarrow> stepC c (C (n # ns)) = C (unC (stepC c (C [n])) @ ns)"
  using stepC_app[of "C[n]" c ns] by simp

lemma stepC_dec:
  "n \<noteq> C [] \<Longrightarrow> Suc (evalC (Suc (Suc c)) (stepC c n)) = evalC (Suc (Suc c)) n"
  apply2 (induct c n rule: stepC.induct) by simp_all

lemma stepC_dec':
  "n \<noteq> C [] \<Longrightarrow> evalC (c+3) (stepC c n) < evalC (c+3) n"
proof2 (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  have "evalC (c+3) (C (funC (C (n # ns)) (Suc (Suc c)))) \<le>
      (c+3) ^ ((c+3) ^ evalC (c+3) n + evalC (c+3) (C ns))"
    apply2 (induct n rule: funC.induct) by(simp_all add: distrib_right)
  then show ?case using 3 by simp
qed simp_all

section \<open>Hereditary base @{term b} representation\<close>

text \<open>We now turn to properties of the @{term "hbase b"} subset of trees.\<close>

subsection \<open>Uniqueness\<close>

text \<open>We show uniqueness of the hereditary base representation by showing that @{term "evalC b"}
  restricted to @{term "hbase b"} is injective.\<close>

lemma hbaseI2:
  "i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow> C m \<in> hbase b \<Longrightarrow>
    (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
    C (replicate i n @ m) \<in> hbase b"
  by (cases i) (auto intro: hbase.intros simp del: replicate.simps(2))

lemmas hbase_singletonI =
  hbase.intros(2)[of 1 "Suc (Suc b)" for b, OF _ _ _ hbase.intros(1), simplified]

lemma hbase_hd:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> hd ns \<in> hbase b"
  by (cases rule: hbase.cases) auto

lemmas hbase_hd' [dest] = hbase_hd[of "n # ns" for n ns, simplified]

lemma hbase_tl:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase.cases) (auto intro: hbaseI2)

lemmas hbase_tl' [dest] = hbase_tl[of "n # ns" for n ns, simplified]

lemma hbase_elt [dest]:
  "C ns \<in> hbase b \<Longrightarrow> n \<in> set ns \<Longrightarrow> n \<in> hbase b"
  apply2 (induct ns) by auto

lemma evalC_sum_list:
  "evalC b (C ns) = sum_list (map (\<lambda>n. b^evalC b n) ns)"
  apply2 (induct ns) by auto

lemma sum_list_replicate:
  "sum_list (replicate n x) = n * x"
  apply2 (induct n) by auto

lemma base_red:
  fixes b :: nat
  assumes n: "\<And>n'. n' \<in> set ns \<Longrightarrow> n < n'" "i < b" "i \<noteq> 0"
  and m: "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
  and s: "i * b^n + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
  shows "i = j \<and> n = m"
  using n(1) m(1) s
proof2 (induct n arbitrary: m ns ms)
  { fix ns ms :: "nat list" and i j m :: nat
    assume n': "\<And>n'. n' \<in> set ns \<Longrightarrow> 0 < n'" "i < b" "i \<noteq> 0"
    assume m': "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
    assume s': "i * b^0 + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
    obtain x where [simp]: "sum_list (map ((^) b) ns) = x*b"
      using n'(1)
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ns)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    obtain y where [simp]: "sum_list (map ((^) b) ms) = y*b"
      using order.strict_trans1[OF le0 m'(1)]
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ms)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    have [simp]: "m = 0"
      using s' n'(2,3)
      by (cases m, simp_all)
        (metis Groups.mult_ac(2) Groups.mult_ac(3) Suc_pred div_less mod_div_mult_eq
          mod_mult_self2 mod_mult_self2_is_0 mult_zero_right nat.simps(3))
    have "i = j \<and> 0 = m" using s' n'(2,3) m'(2,3)
      by simp (metis div_less mod_div_mult_eq mod_mult_self1)
  } note BASE = this
  {
    case 0 show ?case by (rule BASE; fact)
  next
    case (Suc n m')
    have "j = i \<and> 0 = Suc n" if "m' = 0" using Suc(2-4)
      by (intro BASE[of ms j ns "Suc n" i]) (simp_all add: ac_simps that n(2,3) m(2,3))
    then obtain m where m' [simp]: "m' = Suc m"
      by (cases m') auto
    obtain ns' where [simp]: "ns = map Suc ns'" "\<And>n'. n' \<in> set ns' \<Longrightarrow> n < n'"
      using Suc(2) less_trans[OF zero_less_Suc Suc(2)]
      by (intro that[of "map (\<lambda>n. n-1) ns"]; force cong: map_cong)
    obtain ms' where [simp]: "ms = map Suc ms'" "\<And>m'. m' \<in> set ms' \<Longrightarrow> m < m'"
      using Suc(3)[unfolded m'] less_trans[OF zero_less_Suc Suc(3)[unfolded m']]
      by (intro that[of "map (\<lambda>n. n-1) ms"]; force cong: map_cong)
    have *: "b * x = b * y \<Longrightarrow> x = y" for x y using n(2) by simp
    have "i = j \<and> n = m"
    proof (rule Suc(1)[of "map (\<lambda>n. n-1) ns" "map (\<lambda>n. n-1) ms" m, OF _ _ *], goal_cases)
      case 3 show ?case using Suc(4) unfolding add_mult_distrib2
        by (simp add: comp_def ac_simps flip: sum_list_const_mult)
    qed simp_all
    then show ?case by simp
  }
qed

lemma evalC_inj_on_hbase:
  "n \<in> hbase b \<Longrightarrow> m \<in> hbase b \<Longrightarrow> evalC b n = evalC b m \<Longrightarrow> n = m"
proof2 (induct n arbitrary: m rule: hbase.induct)
  case 1
  then show ?case by (cases m rule: hbase.cases) simp_all
next
  case (2 i n ns m')
  obtain j m ms where [simp]: "m' = C (replicate j m @ ms)" and
    m: "j \<noteq> 0" "j < b" "m \<in> hbase b" "C ms \<in> hbase b" "\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b m < evalC b m'"
    using 2(8,1,2,9) by (cases m' rule: hbase.cases) simp_all
  have "i = j \<and> evalC b n = evalC b m" using 2(1,2,7,9) m(1,2,5)
    by (intro base_red[of "map (evalC b) ns" _ _ b "map (evalC b) ms"])
      (auto simp: comp_def evalC_sum_list sum_list_replicate)
  then show ?case
    using 2(4)[OF m(3)] 2(6)[OF m(4)] 2(9) by simp
qed

subsection \<open>Correctness of @{const stepC}\<close>

text \<open>We show that @{term "stepC c"} preserves hereditary base @{term "c + 2 :: nat"}
  representations. In order to cover intermediate results produced by @{const stepC}, we extend
  the hereditary base representation to allow the least significant digit to be equal to @{term b},
  which essentially means that we may have an extra sibling in front on every level.\<close>

inductive_set hbase_ext for b where
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase_ext b"
| "n \<in> hbase_ext b \<Longrightarrow>
   C m \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n \<le> evalC b m') \<Longrightarrow>
   C (n # m) \<in> hbase_ext b"

lemma hbase_ext_hd' [dest]:
  "C (n # ns) \<in> hbase_ext b \<Longrightarrow> n \<in> hbase_ext b"
  by (cases rule: hbase_ext.cases) (auto intro: hbase_ext.intros(1))

lemma hbase_ext_tl:
  "C ns \<in> hbase_ext b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase_ext.cases; cases ns) (simp_all add: hbase_tl')

lemmas hbase_ext_tl' [dest] = hbase_ext_tl[of "n # ns" for n ns, simplified]

lemma hbase_funC:
  "c \<noteq> 0 \<Longrightarrow> C (n # ns) \<in> hbase_ext (Suc c) \<Longrightarrow>
    C (funC n (Suc c) @ ns) \<in> hbase_ext (Suc c)"
proof2 (induct n arbitrary: ns rule: funC.induct)
  case (2 ms)
  have [simp]: "evalC (Suc c) (C ms) < evalC (Suc c) m'" if "m' \<in> set ns" for m'
    using 2(2)
  proof (cases rule: hbase_ext.cases)
    case 1 then show ?thesis using that
      by (cases rule: hbase.cases, case_tac i) (auto intro: Suc_lessD)
  qed (auto simp: Suc_le_eq that)
  show ?case using 2
    by (auto 0 4 intro: hbase_ext.intros hbase.intros(2) order.strict_implies_order)
next
  case (3 m ms ms')
  show ?case
    unfolding funC.simps append_Cons append_Nil
  proof (rule hbase_ext.intros(2), goal_cases 31 32 33)
    case (33 m')
    show ?case using 3(3)
    proof (cases rule: hbase_ext.cases)
      case 1 show ?thesis using 1 3(1,2) 33
        by (cases rule: hbase.cases, case_tac i) (auto intro: less_or_eq_imp_le)
    qed (insert 33, simp)
  qed (insert 3, blast+)
qed auto

lemma stepC_sound:
  "n \<in> hbase_ext (Suc (Suc c)) \<Longrightarrow> stepC c n \<in> hbase (Suc (Suc c))"
proof2 (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  show ?case using 3(2,1)
    by (cases rule: hbase_ext.cases; unfold stepC.simps) (auto intro: hbase_funC)
qed (auto intro: hbase.intros)

subsection \<open>Surjectivity of @{const evalC}\<close>

text \<open>Note that the base must be at least @{term "2 :: nat"}.\<close>

lemma evalC_surjective:
  "\<exists>n' \<in> hbase (Suc (Suc b)). evalC (Suc (Suc b)) n' = n"
proof2 (induct n)
  case 0 then show ?case by (auto intro: bexI[of _ "C []"] hbase.intros)
next
  have [simp]: "Suc x \<le> Suc (Suc b)^x" for x apply2 (induct x) by auto
  case (Suc n)
  then guess n' by (rule bexE)
  then obtain n' j where n': "Suc n \<le> j" "j = evalC (Suc (Suc b)) n'" "n' \<in> hbase (Suc (Suc b))"
    by (intro that[of _ "C [n']"])
      (auto intro!: intro: hbase.intros(1) dest!: hbaseI2[of 1 "b+2" n' "[]", simplified])
  then show ?case
  proof2 (induct rule: inc_induct)
    case (step m)
    guess n' using step(3)[OF step(4,5)] by (rule bexE)
    then show ?case using stepC_dec[of n' "b"]
      by (cases n' rule: C2O.cases) (auto intro: stepC_sound hbase_ext.intros(1))
  qed blast
qed

subsection \<open>Monotonicity of @{const hbase}\<close>

text \<open>Here we show that every hereditary base @{term "b :: nat"} number is also a valid hereditary
  base @{term "b+1 :: nat"} number. This is not immediate because we have to show that monotonicity
  of siblings is preserved.\<close>

lemma hbase_evalC_mono:
  assumes "n \<in> hbase b" "m \<in> hbase b" "evalC b n < evalC b m"
  shows "evalC (Suc b) n < evalC (Suc b) m"
proof (cases "b < 2")
  case True show ?thesis using assms(2,3) True by (cases rule: hbase.cases) simp_all
next
  case False
  then obtain b' where [simp]: "b = Suc (Suc b')"
    by (auto simp: numeral_2_eq_2 not_less_eq dest: less_imp_Suc_add)
  show ?thesis using assms(3,1,2)
  proof2 (induct "evalC b n" "evalC b m" arbitrary: n m rule: less_Suc_induct)
    case 1 then show ?case using stepC_sound[of m b', OF hbase_ext.intros(1)]
      stepC_dec[of m b'] stepC_dec'[of m b'] evalC_inj_on_hbase
      by (cases m rule: C2O.cases) (fastforce simp: eval_nat_numeral)+
  next
    case (2 j) then show ?case
      using evalC_surjective[of b' j] less_trans by fastforce
  qed
qed

lemma hbase_mono:
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase (Suc b)"
  apply2 (induct n rule: hbase.induct) by(auto 0 3 intro: hbase.intros hbase_evalC_mono)

subsection \<open>Conversion to and from @{type nat}\<close>

text \<open>We have previously defined @{term "H2N b = evalC b"} and @{term "N2H b"} as its inverse.
  So we can use the injectivity and surjectivity of @{term "evalC b"} for simplification.\<close>

lemma N2H_inv:
  "n \<in> hbase b \<Longrightarrow> N2H b (H2N b n) = n"
  using evalC_inj_on_hbase
  by (auto simp: N2H_def H2N_def[abs_def] inj_on_def intro!: inv_into_f_f)

lemma N2H_eqI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n = m \<Longrightarrow> N2H (Suc (Suc b)) m = n"
  using N2H_inv by blast

lemma N2H_neI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n \<noteq> m \<Longrightarrow> N2H (Suc (Suc b)) m \<noteq> n"
  using H2N_inv by blast

lemma N2H_0 [simp]:
  "N2H (Suc (Suc c)) 0 = C []"
  using H2N_def N2H_inv hbase.intros(1) by fastforce

lemma N2H_nz [simp]:
  "0 < n \<Longrightarrow> N2H (Suc (Suc c)) n \<noteq> C []"
  by (metis N2H_0 H2N_inv neq0_conv)

section \<open>The Goodstein function revisited\<close>

text \<open>We are now ready to prove termination of the Goodstein function @{const goodstein} as well
  as its relation to @{const goodsteinC} and @{const goodsteinO}.\<close>

lemma goodstein_aux:
  "goodsteinC (Suc c) (N2H (Suc (Suc c)) (Suc n)) =
    goodsteinC (c+2) (N2H (c+3) (H2N (c+3) (N2H (c+2) (n+1)) - 1))"
proof -
  have [simp]: "n \<noteq> C [] \<Longrightarrow> goodsteinC c n = goodsteinC (c+1) (stepC c n)" for c n
    apply2 (induct c n rule: stepC.induct) by simp_all
  have [simp]: "stepC (Suc c) (N2H (Suc (Suc c)) (Suc n)) \<in> hbase (Suc (Suc (Suc c)))"
    by (metis H2N_def N2H_inv evalC_surjective hbase_ext.intros(1) hbase_mono stepC_sound)
  show ?thesis
    using arg_cong[OF stepC_dec[of "N2H (c+2) (n+1)" "c+1", folded H2N_def], of "\<lambda>n. N2H (c+3) (n-1)"]
    by (simp add: eval_nat_numeral N2H_inv)
qed

termination goodstein
proof (relation "measure (\<lambda>(c, n). goodsteinC c (N2H (c+1) n) - c)", goal_cases _ 1)
  case (1 c n)
  have *: "goodsteinC c n \<ge> c" for c n
    apply2 (induct c n rule: goodsteinC.induct) by simp_all
  show ?case by (simp add: goodstein_aux eval_nat_numeral) (meson Suc_le_eq diff_less_mono2 lessI *)
qed simp

lemma goodstein_def':
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinC c (N2H (c+1) n)"
  apply2 (induct c n rule: goodstein.induct) by(simp_all add: goodstein_aux eval_nat_numeral)

lemma goodstein_impl:
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinO c (C2O (N2H (c+1) n))"
  \<comment> \<open>but note that @{term N2H} is not executable as currently defined\<close>
  using goodstein_def'[unfolded goodsteinC_def'] .

lemma goodstein_16:
  "\<G> 16 = goodsteinO 1 (exp\<omega> (exp\<omega> (exp\<omega> (exp\<omega> Z))))"
proof -
  have "N2H (Suc (Suc 0)) 16 = C [C [C [C [C []]]]]"
    by (auto simp: H2N_def intro!: N2H_eqI hbase_singletonI hbase.intros(1))
  then show ?thesis by (simp add: goodstein_impl)
qed

section \<open>Translation to $\lambda$-calculus\<close>

text \<open>We define Church encodings for @{type nat} and @{type Ord}. Note that we are basically in a
  Hindley-Milner type system, so we cannot use a proper polymorphic type. We can still express
  Church encodings as folds over values of the original type.\<close>

abbreviation Z\<^sub>N where "Z\<^sub>N \<equiv> (\<lambda>s z. z)"
abbreviation S\<^sub>N where "S\<^sub>N \<equiv> (\<lambda>n s z. s (n s z))"

primrec fold_nat ("\<langle>_\<rangle>\<^sub>N") where
  "\<langle>0\<rangle>\<^sub>N = Z\<^sub>N"
| "\<langle>Suc n\<rangle>\<^sub>N = S\<^sub>N \<langle>n\<rangle>\<^sub>N"

lemma one\<^sub>N:
  "\<langle>1\<rangle>\<^sub>N = (\<lambda>x. x)"
  by simp

abbreviation Z\<^sub>O where "Z\<^sub>O \<equiv> (\<lambda>z s l. z)"
abbreviation S\<^sub>O where "S\<^sub>O \<equiv> (\<lambda>n z s l. s (n z s l))"
abbreviation L\<^sub>O where "L\<^sub>O \<equiv> (\<lambda>f z s l. l (\<lambda>i. f i z s l))"

primrec fold_Ord ("\<langle>_\<rangle>\<^sub>O") where
  "\<langle>Z\<rangle>\<^sub>O = Z\<^sub>O"
| "\<langle>S n\<rangle>\<^sub>O = S\<^sub>O \<langle>n\<rangle>\<^sub>O"
| "\<langle>L f\<rangle>\<^sub>O = L\<^sub>O (\<lambda>i. \<langle>f i\<rangle>\<^sub>O)"

text \<open>The following abbreviations and lemmas show how to implement the arithmetic functions and
  the Goodstein function on a Church-encoded @{type Ord} in lambda calculus.\<close>

abbreviation (input) add\<^sub>O where
  "add\<^sub>O n m \<equiv> (\<lambda>z s l. m (n z s l) s l)"

lemma add\<^sub>O:
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  apply2 (induct m) by simp_all

abbreviation (input) mul\<^sub>O where
  "mul\<^sub>O n m \<equiv> (\<lambda>z s l. m z (\<lambda>m. n m s l) l)"

lemma mul\<^sub>O:
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  apply2 (induct m) by(simp_all add: add\<^sub>O)

abbreviation (input) \<omega>\<^sub>O where
  "\<omega>\<^sub>O \<equiv> (\<lambda>z s l. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N s z))"

lemma \<omega>\<^sub>O:
  "\<langle>\<omega>\<rangle>\<^sub>O = \<omega>\<^sub>O"
proof -
  have [simp]: "\<langle>(S ^^ i) Z\<rangle>\<^sub>O z s l = \<langle>i\<rangle>\<^sub>N s z" for i z s l apply2 (induct i) by simp_all
  show ?thesis by (simp add: \<omega>_def)
qed

abbreviation (input) exp\<omega>\<^sub>O where
  "exp\<omega>\<^sub>O n \<equiv> (\<lambda>z s l. n s (\<lambda>x z. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N x z)) (\<lambda>f z. l (\<lambda>n. f n z)) z)"

lemma exp\<omega>\<^sub>O:
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
  apply2 (induct n) by (simp_all add: mul\<^sub>O \<omega>\<^sub>O)

abbreviation (input) goodstein\<^sub>O where
  "goodstein\<^sub>O \<equiv> (\<lambda>c n. n (\<lambda>x. x) (\<lambda>n m. n (m + 1)) (\<lambda>f m. f (m + 2) m) c)"

lemma goodstein\<^sub>O:
  "goodsteinO c n = goodstein\<^sub>O c \<langle>n\<rangle>\<^sub>O"
  apply2 (induct n arbitrary: c) by simp_all

text \<open>Note that modeling Church encodings with folds is still limited. For example, the meaningful
  expression @{text "\<langle>n\<rangle>\<^sub>N exp\<omega>\<^sub>O Z\<^sub>O"} cannot be typed in Isabelle/HOL, as that would require rank-2
  polymorphism.\<close>

subsection \<open>Alternative: free theorems\<close>

text \<open>The following is essentially the free theorem for Church-encoded @{type Ord} values.\<close>

lemma freeOrd:
  assumes "\<And>n. h (s n) = s' (h n)" and "\<And>f. h (l f) = l' (\<lambda>i. h (f i))"
  shows "h (\<langle>n\<rangle>\<^sub>O z s l) = \<langle>n\<rangle>\<^sub>O (h z) s' l'"
  apply2 (induct n) by(simp_all add: assms)

text \<open>Each of the following proofs first states a naive definition of the corresponding function
  (which is proved correct by induction), from which we then derive the optimized version using
  the free theorem, by (conditional) rewriting (without induction).\<close>

lemma add\<^sub>O':
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>addO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O \<langle>n\<rangle>\<^sub>O S\<^sub>O L\<^sub>O"
    apply2 (induct m) by simp_all
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma mul\<^sub>O':
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>mulO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O Z\<^sub>O (\<lambda>m. add\<^sub>O m \<langle>n\<rangle>\<^sub>O) L\<^sub>O"
    apply2 (induct m) by(simp_all add: add\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma exp\<omega>\<^sub>O':
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>exp\<omega> n\<rangle>\<^sub>O = \<langle>n\<rangle>\<^sub>O (S\<^sub>O Z\<^sub>O) (\<lambda>m. mul\<^sub>O m \<omega>\<^sub>O) L\<^sub>O"
    apply2 (induct n) by(simp_all add: mul\<^sub>O \<omega>\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: fun_cong[OF freeOrd[where h = "\<lambda>n z. n z _ _"]])
qed

end


(*  Gauss-Jordan elimination for matrices represented as functions
    Author: Tobias Nipkow
*)
section \<open>Gauss-Jordan elimination algorithm\<close>
theory Gauss_Jordan_Elim_Fun
imports Main
begin

text\<open>Matrices are functions:\<close>

type_synonym 'a matrix = "nat \<Rightarrow> nat \<Rightarrow> 'a"

text\<open>In order to restrict to finite matrices, a matrix is usually combined
with one or two natural numbers indicating the maximal row and column of the
matrix.

Gauss-Jordan elimination is parameterized with a natural number \<open>n\<close>. It indicates that the matrix \<open>A\<close> has \<open>n\<close> rows and columns.
In fact, \<open>A\<close> is the augmented matrix with \<open>n+1\<close> columns. Column
\<open>n\<close> is the ``right-hand side'', i.e.\ the constant vector \<open>b\<close>. The result is the unit matrix augmented with the solution in column
\<open>n\<close>; see the correctness theorem below.\<close>

fun gauss_jordan :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> ('a)matrix option" where
"gauss_jordan A 0 = Some(A)" |
"gauss_jordan A (Suc m) =
 (case dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] of
   [] \<Rightarrow> None |
   p # _ \<Rightarrow>
    (let Ap' = (\<lambda>j. A p j / A p m);
         A' = (\<lambda>i. if i=p then Ap' else (\<lambda>j. A i j - A i m * Ap' j))
     in gauss_jordan (Fun.swap p m A') m))"

text\<open>Some auxiliary functions:\<close>

definition solution :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
"solution A n x = (\<forall>i<n. (\<Sum> j=0..<n. A i j * x j) = A i n)"

definition unit :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"unit A m n =
 (\<forall>i j::nat. m\<le>j \<longrightarrow> j<n \<longrightarrow> A i j = (if i=j then 1 else 0))"

lemma solution_swap:
assumes "p1 < n" "p2 < n"
shows "solution (Fun.swap p1 p2 A) n x = solution A n x" (is "?L = ?R")
proof(cases "p1=p2")
  case True thus ?thesis by simp
next
  case False
  show ?thesis
  proof
    assume ?R thus ?L using assms False by(simp add: solution_def Fun.swap_def)
  next
   assume ?L
   show ?R
   proof(auto simp: solution_def)
     fix i assume "i<n"
     show "(\<Sum>j = 0..<n. A i j * x j) = A i n"
     proof cases
       assume "i=p1"
       with \<open>?L\<close> assms False show ?thesis
         by(fastforce simp add: solution_def Fun.swap_def)
     next
       assume "i\<noteq>p1"
       show ?thesis
       proof cases
         assume "i=p2"
         with \<open>?L\<close> assms False show ?thesis
           by(fastforce simp add: solution_def Fun.swap_def)
       next
         assume "i\<noteq>p2"
         with \<open>i\<noteq>p1\<close> \<open>?L\<close> \<open>i<n\<close> assms False show ?thesis
           by(fastforce simp add: solution_def Fun.swap_def)
       qed
     qed
   qed
 qed
qed

(* Converting these apply scripts makes them blow up - see above *)

lemma solution_upd1:
  "c \<noteq> 0 \<Longrightarrow> solution (A(p:=(\<lambda>j. A p j / c))) n x = solution A n x"
apply(cases "p<n")
 prefer 2
 apply(simp add: solution_def)
apply(clarsimp simp add: solution_def)
apply rule
 apply clarsimp
 apply(case_tac "i=p")
  apply (simp add: sum_divide_distrib[symmetric] eq_divide_eq field_simps)
 apply simp
apply (simp add: sum_divide_distrib[symmetric] eq_divide_eq field_simps)
done

lemma solution_upd_but1: "\<lbrakk> ap = A p; \<forall>i j. i\<noteq>p \<longrightarrow> a i j = A i j; p<n \<rbrakk> \<Longrightarrow>
 solution (\<lambda>i. if i=p then ap else (\<lambda>j. a i j - c i * ap j)) n x =
 solution A n x"
apply(clarsimp simp add: solution_def)
apply rule
 prefer 2
 apply (simp add: field_simps sum_subtractf sum_distrib_left[symmetric])
apply(clarsimp)
apply(case_tac "i=p")
 apply simp
apply (auto simp add: field_simps sum_subtractf sum_distrib_left[symmetric] all_conj_distrib)
done

subsection\<open>Correctness\<close>

text\<open>The correctness proof:\<close>

lemma gauss_jordan_lemma: "m\<le>n \<Longrightarrow> unit A m n \<Longrightarrow> gauss_jordan A m = Some B \<Longrightarrow>
  unit B 0 n \<and> solution A n (\<lambda>j. B j n)"
proof(induct m arbitrary: A B)
  case 0
  { fix a and b c d :: "'a"
    have "(if a then b else c) * d = (if a then b*d else c*d)" by simp
  } with 0 show ?case by(simp add: unit_def solution_def sum.If_cases)
next
  case (Suc m)
  let "?Ap' p" = "(\<lambda>j. A p j / A p m)"
  let "?A' p" = "(\<lambda>i. if i=p then ?Ap' p else (\<lambda>j. A i j - A i m * ?Ap' p j))"
  from \<open>gauss_jordan A (Suc m) = Some B\<close>
  obtain p ks where "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] = p#ks" and
    rec: "gauss_jordan (Fun.swap p m (?A' p)) m = Some B"
    by (auto split: list.splits)
  from this have p: "p\<le>m" "A p m \<noteq> 0"
    apply(simp_all add: dropWhile_eq_Cons_conv del:upt_Suc)
    by (metis set_upt atLeast0AtMost atLeastLessThanSuc_atLeastAtMost atMost_iff in_set_conv_decomp)
  have "m\<le>n" "m<n" using \<open>Suc m \<le> n\<close> by arith+
  have "unit (Fun.swap p m (?A' p)) m n" using Suc.prems(2) p
    unfolding unit_def Fun.swap_def Suc_le_eq by (auto simp: le_less)
  from Suc.hyps[OF \<open>m\<le>n\<close> this rec] \<open>m<n\<close> p
  show ?case
    by(simp add: solution_swap solution_upd1 solution_upd_but1[where A = "A(p := ?Ap' p)"])
qed

theorem gauss_jordan_correct:
  "gauss_jordan A n = Some B \<Longrightarrow> solution A n (\<lambda>j. B j n)"
by(simp add:gauss_jordan_lemma[of n n] unit_def  field_simps)

definition solution2 :: "('a::field)matrix \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where "solution2 A m n x = (\<forall>i<m. (\<Sum> j=0..<m. A i j * x j) = A i n)"

definition "usolution A m n x \<longleftrightarrow>
  solution2 A m n x \<and> (\<forall>y. solution2 A m n y \<longrightarrow> (\<forall>j<m. y j = x j))"

lemma non_null_if_pivot:
  assumes "usolution A m n x" and "q < m" shows "\<exists>p<m. A p q \<noteq> 0"
proof(rule ccontr)
  assume "\<not>(\<exists>p<m. A p q \<noteq> 0)"
  hence 1: "\<And>p. p<m \<Longrightarrow> A p q = 0" by simp
  { fix y assume 2: "\<forall>j. j\<noteq>q \<longrightarrow> y j = x j"
    { fix i assume "i<m"
      with assms(1) have "A i n = (\<Sum>j = 0..<m. A i j * x j)"
        by (auto simp: solution2_def usolution_def)
      with 1[OF \<open>i<m\<close>] 2
      have "(\<Sum>j = 0..<m. A i j * y j) = A i n"
        by (auto intro!: sum.cong)
    }
    hence "solution2 A m n y" by(simp add: solution2_def)
  }
  hence "solution2 A m n (x(q:=0))" and "solution2 A m n (x(q:=1))" by auto
  with assms(1) zero_neq_one \<open>q < m\<close>
  show False
    by (simp add: usolution_def)
       (metis fun_upd_same zero_neq_one)
qed

lemma lem1:
  fixes f :: "'a \<Rightarrow> 'b::field"
  shows "(\<Sum>x\<in>A. f x * (a * g x)) = a * (\<Sum>x\<in>A. f x * g x)"
  by (simp add: sum_distrib_left field_simps)

subsection\<open>Complete\<close>

lemma gauss_jordan_complete:
  "m \<le> n \<Longrightarrow> usolution A m n x \<Longrightarrow> \<exists>B. gauss_jordan A m = Some B"
proof(induction m arbitrary: A)
  case 0 show ?case by simp
next
  case (Suc m A)
  from \<open>Suc m \<le> n\<close> have "m\<le>n" and "m<Suc m" by arith+
  from non_null_if_pivot[OF Suc.prems(2) \<open>m<Suc m\<close>]
  obtain p' where "p'<Suc m" and "A p' m \<noteq> 0" by blast
  hence "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] \<noteq> []"
    by (simp add: atLeast0LessThan) (metis lessThan_iff linorder_neqE_nat not_less_eq)
  then obtain p xs where 1: "dropWhile (\<lambda>i. A i m = 0) [0..<Suc m] = p#xs"
    by (metis list.exhaust)
  from this have "p\<le>m" "A p m \<noteq> 0"
    by (simp_all add: dropWhile_eq_Cons_conv del: upt_Suc)
       (metis set_upt atLeast0AtMost atLeastLessThanSuc_atLeastAtMost atMost_iff in_set_conv_decomp)
  then have p: "p < Suc m" "A p m \<noteq> 0"
    by auto
  let ?Ap' = "(\<lambda>j. A p j / A p m)"
  let ?A' = "(\<lambda>i. if i=p then ?Ap' else (\<lambda>j. A i j - A i m * ?Ap' j))"
  let ?A = "Fun.swap p m ?A'"
  have A: "solution2 A (Suc m) n x" using Suc.prems(2) by(simp add: usolution_def)
  { fix i assume le_m: "p < Suc m" "i < Suc m" "A p m \<noteq> 0"
    have "(\<Sum>j = 0..<m. (A i j - A i m * A p j / A p m) * x j) =
      ((\<Sum>j = 0..<Suc m. A i j * x j) - A i m * x m) -
      ((\<Sum>j = 0..<Suc m. A p j * x j) - A p m * x m) * A i m / A p m"
      by (simp add: field_simps sum_subtractf sum_divide_distrib
                    sum_distrib_left)
    also have "\<dots> = A i n - A p n * A i m / A p m"
      using A le_m
      by (simp add: solution2_def field_simps del: sum.op_ivl_Suc)
    finally have "(\<Sum>j = 0..<m. (A i j - A i m * A p j / A p m) * x j) =
      A i n - A p n * A i m / A p m" . }
  then have "solution2 ?A m n x" using p
    by (auto simp add: solution2_def Fun.swap_def field_simps)
  moreover
  { fix y assume a: "solution2 ?A m n y"
    let ?y = "y(m := A p n / A p m - (\<Sum>j = 0..<m. A p j * y j) / A p m)"
    have "solution2 A (Suc m) n ?y" unfolding solution2_def
    proof safe
      fix i assume "i < Suc m"
      show "(\<Sum>j=0..<Suc m. A i j * ?y j) = A i n"
      proof (cases "i = p")
        assume "i = p" with p show ?thesis by (simp add: field_simps)
      next
        assume "i \<noteq> p"
        show ?thesis
        proof (cases "i = m")
          assume "i = m"
          with p \<open>i \<noteq> p\<close> have "p < m" by simp
          with a[unfolded solution2_def, THEN spec, of p] p(2)
          have "A p m * (A m m * A p n + A p m * (\<Sum>j = 0..<m. y j * A m j)) = A p m * (A m n * A p m + A m m * (\<Sum>j = 0..<m. y j * A p j))"
            by (simp add: Fun.swap_def field_simps sum_subtractf lem1 lem2 sum_divide_distrib[symmetric]
                     split: if_splits)
          with \<open>A p m \<noteq> 0\<close> show ?thesis unfolding \<open>i = m\<close>
            by simp (simp add: field_simps)
        next
          assume "i \<noteq> m"
          then have "i < m" using \<open>i < Suc m\<close> by simp
          with a[unfolded solution2_def, THEN spec, of i] p(2)
          have "A p m * (A i m * A p n + A p m * (\<Sum>j = 0..<m. y j * A i j)) = A p m * (A i n * A p m + A i m * (\<Sum>j = 0..<m. y j * A p j))"
            by (simp add: Fun.swap_def split: if_splits)
              (simp add: field_simps sum_subtractf lem1 lem2 sum_divide_distrib [symmetric])
          with \<open>A p m \<noteq> 0\<close> show ?thesis
            by simp (simp add: field_simps)
        qed
      qed
    qed
    with \<open>usolution A (Suc m) n x\<close>
    have "\<forall>j<Suc m. ?y j = x j" by (simp add: usolution_def)
    hence "\<forall>j<m. y j = x j"
      by simp (metis less_SucI nat_neq_iff)
  } ultimately have "usolution ?A m n x" by(simp add: usolution_def)
  from Suc.IH[OF \<open>m\<le>n\<close> this] 1 show ?case by(simp)
qed

text\<open>Future work: extend the proof to matrix inversion.\<close>

hide_const (open) unit

end


theory ConstOn
imports Main
begin

definition const_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool"
  where "const_on f S x = (\<forall> y \<in> S . f y = x)"

lemma const_onI[intro]: "(\<And>y. y \<in> S \<Longrightarrow> f y = x) \<Longrightarrow> const_on f S x"
  by (simp add: const_on_def)

(*
lemma const_onE[elim]: "const_on f S r ==> x : S ==> r = r' ==> f x = r'"
*)

lemma const_on_insert[simp]: "const_on f (insert x S) y \<longleftrightarrow> const_on f S y \<and> f x = y"
   by auto

lemma const_on_union[simp]: "const_on f (S \<union> S') y \<longleftrightarrow> const_on f S y \<and> const_on f S' y"
  by auto

lemma const_on_subset[elim]: "const_on f S y \<Longrightarrow> S' \<subseteq> S \<Longrightarrow> const_on f S' y"
  by auto

end


theory Exe2p6
  imports Main
begin

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

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l n r) = n # (contents l) @ (contents r)"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l n r) = n + sum_tree l + sum_tree r"

lemma sum_tree_lemma_1 : "sum_tree t = sum_list (contents t)"
  apply(induction t rule: sum_tree.induct)
   apply(auto)
  done

end


section \<open>Regular Expressions as Homogeneous Binary Relations\<close>

theory Relation_Interpretation
imports Regular_Exp
begin

primrec rel :: "('a \<Rightarrow> ('b * 'b) set) \<Rightarrow> 'a rexp \<Rightarrow> ('b * 'b) set"
where
  "rel v Zero = {}" |
  "rel v One = Id" |
  "rel v (Atom a) = v a" |
  "rel v (Plus r s) = rel v r \<union> rel v s" |
  "rel v (Times r s) = rel v r O rel v s" |
  "rel v (Star r) = (rel v r)^*"

primrec word_rel :: "('a \<Rightarrow> ('b * 'b) set) \<Rightarrow> 'a list \<Rightarrow> ('b * 'b) set"
where
  "word_rel v [] = Id"
| "word_rel v (a#as) = v a O word_rel v as"

lemma word_rel_append:
  "word_rel v w O word_rel v w' = word_rel v (w @ w')"
by (rule sym) (induct w, auto)

lemma rel_word_rel: "rel v r = (\<Union>w\<in>lang r. word_rel v w)"
proof (induct r)
  case Times thus ?case
    by (auto simp: rel_def word_rel_append conc_def relcomp_UNION_distrib relcomp_UNION_distrib2)
next
  case (Star r)
  { fix n
    have "(rel v r) ^^ n = (\<Union>w \<in> lang r ^^ n. word_rel v w)"
    proof (induct n)
      case 0 show ?case by simp
    next
      case (Suc n) thus ?case
        unfolding relpow.simps relpow_commute[symmetric]
        by (auto simp add: Star conc_def word_rel_append
          relcomp_UNION_distrib relcomp_UNION_distrib2)
    qed }

  thus ?case unfolding rel.simps
    by (force simp: rtrancl_power star_def)
qed auto

text \<open>Soundness:\<close>

end


theory IMPExpMult

imports Main

begin

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"

definition exp :: "aexp" where "exp = (Plus (N 5) (V ''x''))"

value "aval exp ((\<lambda> x. 0)(''x'' := 1))"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N(n1 + n2) |
    (b1, b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow>  aexp" where
"plus (N i1) (N i2) = N(i1 + i2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction rule: plus.induct)
    apply(auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
  apply(induction a)
    apply(auto simp add: aval_plus)
  done

fun optimal_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> bool" where
"optimal_plus (N _) (N _) = False" |
"optimal_plus a1 a2 = True"

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N _) = True" |
"optimal (V _) = True" |
"optimal (Plus a1 a2) = ((optimal a1) \<and> (optimal a2) \<and> (optimal_plus a1 a2))"

theorem "optimal(asimp_const a)"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun full_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"full_plus (N n1) (N n2) = N (n1 + n2)" |
"full_plus (N n1) (Plus a (N n2)) = (Plus a (N (n1 + n2)))" |
"full_plus (Plus a (N n1)) (N n2) = (Plus a (N (n1 + n2)))" |
"full_plus a1 a2 = (Plus a1 a2)"

lemma full_plus_aval: "aval (full_plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction rule: full_plus.induct)
    apply(auto)
  done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = N n" |
"full_asimp (V x) = V x" |
"full_asimp (Plus a1 a2) = full_plus (full_asimp a1) (full_asimp a2)"

value "full_asimp (Plus (N 1) (Plus (V ''x'') (N 2)))"

theorem "aval (full_asimp a) s = aval a s"
  apply(induction a arbitrary: s)
    apply(auto simp add: full_plus_aval)
  done

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst v e (V x) = (if v = x then e else (V x))" |
"subst v e (Plus a1 a2) = (Plus (subst v e a1) (subst v e a2))" |
"subst v e a = a"

value "subst ''x''  (N 2) (Plus (V ''x'') (N 1))"

lemma subst_preserves_semantics: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
    apply(auto)
  done

theorem "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(simp add: subst_preserves_semantics)
  done

end


theory GabrielaLimonta2
imports Main "Repeat_Big_Step" "~~/src/HOL/IMP/Star"
begin
subsection "List setup"

(** Score: 5/5
*)

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i+1+n else i+1,s,tl2 stk))"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the excution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

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

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = (if f then size cb2 else (size cb2::int)+n);
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])" |
(* begin mod *)
"ccomp (REPEAT c UNTIL b) =
  (let cc = ccomp c; cb = bcomp b True 1
    in cc @ cb @ [JMP (-(size cb + size cc + 1))])"
(* end mod *)

value "ccomp (REPEAT ''u'' ::= Plus (V ''u'') (N 1) UNTIL Less (N 0) (V ''u''))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
next
  case (RepeatTrue c s1 s2 b)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b True 1"
  let ?cr = "ccomp(REPEAT c UNTIL b)"
  have "?cr \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cc, s2, stk)"
    using RepeatTrue.IH and ccomp.simps(6) by fastforce
  moreover
  have "?cr \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cr, s2, stk)"
    using `bval b s2` by fastforce
  ultimately
  show ?case by(blast intro: star_trans)
next
  case (RepeatFalse c s1 s2 b s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b True 1"
  let ?cr = "ccomp(REPEAT c UNTIL b)"
  have "?cr \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cc, s2, stk)"
    using RepeatFalse.IH by fastforce
  moreover
  have "?cr \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cc + size ?cb, s2, stk)"
    using `\<not>bval b s2` by fastforce
  moreover
  have "?cr \<turnstile> (size ?cc + size ?cb, s2, stk) \<rightarrow>* (0, s2, stk)"
    using RepeatFalse.IH by fastforce
  moreover
  have "?cr \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cr, s3, stk)"
    using RepeatFalse.IH by fastforce
  ultimately
  show ?case by(blast intro: star_trans)
qed fastforce+

end


(*:maxLineLen=78:*)

section \<open>Example: First-Order Logic\<close>

theory %visible First_Order_Logic
imports Base  (* FIXME Pure!? *)
begin

text \<open>
  In order to commence a new object-logic within Isabelle/Pure we introduce
  abstract syntactic categories \<open>i\<close> for individuals and \<open>o\<close> for
  object-propositions. The latter is embedded into the language of Pure
  propositions by means of a separate judgment.
\<close>

typedecl i
typedecl o

judgment Trueprop :: "o \<Rightarrow> prop"    ("_" 5)

text \<open>
  Note that the object-logic judgment is implicit in the syntax: writing
  @{prop A} produces @{term "Trueprop A"} internally. From the Pure
  perspective this means ``@{prop A} is derivable in the object-logic''.
\<close>

subsection \<open>Equational reasoning \label{sec:framework-ex-equal}\<close>

text \<open>
  Equality is axiomatized as a binary predicate on individuals, with
  reflexivity as introduction, and substitution as elimination principle. Note
  that the latter is particularly convenient in a framework like Isabelle,
  because syntactic congruences are implicitly produced by unification of
  \<open>B x\<close> against expressions containing occurrences of \<open>x\<close>.
\<close>

axiomatization equal :: "i \<Rightarrow> i \<Rightarrow> o"  (infix "=" 50)
  where refl [intro]: "x = x"
    and subst [elim]: "x = y \<Longrightarrow> B x \<Longrightarrow> B y"

text \<open>
  Substitution is very powerful, but also hard to control in full generality.
  We derive some common symmetry~/ transitivity schemes of @{term equal} as
  particular consequences.
\<close>

theorem sym [sym]:
  assumes "x = y"
  shows "y = x"
proof -
  have "x = x" ..
  with \<open>x = y\<close> show "y = x" ..
qed

theorem forw_subst [trans]:
  assumes "y = x" and "B x"
  shows "B y"
proof -
  from \<open>y = x\<close> have "x = y" ..
  from this and \<open>B x\<close> show "B y" ..
qed

theorem back_subst [trans]:
  assumes "B x" and "x = y"
  shows "B y"
proof -
  from \<open>x = y\<close> and \<open>B x\<close>
  show "B y" ..
qed

theorem trans [trans]:
  assumes "x = y" and "y = z"
  shows "x = z"
proof -
  from \<open>y = z\<close> and \<open>x = y\<close>
  show "x = z" ..
qed

subsection \<open>Basic group theory\<close>

text \<open>
  As an example for equational reasoning we consider some bits of group
  theory. The subsequent locale definition postulates group operations and
  axioms; we also derive some consequences of this specification.
\<close>

locale group =
  fixes prod :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<circ>" 70)
    and inv :: "i \<Rightarrow> i"  ("(_\<inverse>)" [1000] 999)
    and unit :: i  ("1")
  assumes assoc: "(x \<circ> y) \<circ> z = x \<circ> (y \<circ> z)"
    and left_unit:  "1 \<circ> x = x"
    and left_inv: "x\<inverse> \<circ> x = 1"
begin

theorem right_inv: "x \<circ> x\<inverse> = 1"
proof -
  have "x \<circ> x\<inverse> = 1 \<circ> (x \<circ> x\<inverse>)" by (rule left_unit [symmetric])
  also have "\<dots> = (1 \<circ> x) \<circ> x\<inverse>" by (rule assoc [symmetric])
  also have "1 = (x\<inverse>)\<inverse> \<circ> x\<inverse>" by (rule left_inv [symmetric])
  also have "\<dots> \<circ> x = (x\<inverse>)\<inverse> \<circ> (x\<inverse> \<circ> x)" by (rule assoc)
  also have "x\<inverse> \<circ> x = 1" by (rule left_inv)
  also have "((x\<inverse>)\<inverse> \<circ> \<dots>) \<circ> x\<inverse> = (x\<inverse>)\<inverse> \<circ> (1 \<circ> x\<inverse>)" by (rule assoc)
  also have "1 \<circ> x\<inverse> = x\<inverse>" by (rule left_unit)
  also have "(x\<inverse>)\<inverse> \<circ> \<dots> = 1" by (rule left_inv)
  finally show "x \<circ> x\<inverse> = 1" .
qed

theorem right_unit: "x \<circ> 1 = x"
proof -
  have "1 = x\<inverse> \<circ> x" by (rule left_inv [symmetric])
  also have "x \<circ> \<dots> = (x \<circ> x\<inverse>) \<circ> x" by (rule assoc [symmetric])
  also have "x \<circ> x\<inverse> = 1" by (rule right_inv)
  also have "\<dots> \<circ> x = x" by (rule left_unit)
  finally show "x \<circ> 1 = x" .
qed

text \<open>
  Reasoning from basic axioms is often tedious. Our proofs work by producing
  various instances of the given rules (potentially the symmetric form) using
  the pattern ``\<^theory_text>\<open>have eq by (rule r)\<close>'' and composing the chain of results
  via \<^theory_text>\<open>also\<close>/\<^theory_text>\<open>finally\<close>. These steps may involve any of the transitivity
  rules declared in \secref{sec:framework-ex-equal}, namely @{thm trans} in
  combining the first two results in @{thm right_inv} and in the final steps
  of both proofs, @{thm forw_subst} in the first combination of @{thm
  right_unit}, and @{thm back_subst} in all other calculational steps.

  Occasional substitutions in calculations are adequate, but should not be
  over-emphasized. The other extreme is to compose a chain by plain
  transitivity only, with replacements occurring always in topmost position.
  For example:
\<close>

(*<*)
theorem "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
  assume [symmetric, defn]: "\<And>x y. (x \<equiv> y) \<equiv> Trueprop (x = y)"
  fix x
(*>*)
  have "x \<circ> 1 = x \<circ> (x\<inverse> \<circ> x)" unfolding left_inv ..
  also have "\<dots> = (x \<circ> x\<inverse>) \<circ> x" unfolding assoc ..
  also have "\<dots> = 1 \<circ> x" unfolding right_inv ..
  also have "\<dots> = x" unfolding left_unit ..
  finally have "x \<circ> 1 = x" .
(*<*)
qed
(*>*)

text \<open>
  Here we have re-used the built-in mechanism for unfolding definitions in
  order to normalize each equational problem. A more realistic object-logic
  would include proper setup for the Simplifier (\secref{sec:simplifier}), the
  main automated tool for equational reasoning in Isabelle. Then ``\<^theory_text>\<open>unfolding
  left_inv ..\<close>'' would become ``\<^theory_text>\<open>by (simp only: left_inv)\<close>'' etc.
\<close>

end

subsection \<open>Propositional logic \label{sec:framework-ex-prop}\<close>

text \<open>
  We axiomatize basic connectives of propositional logic: implication,
  disjunction, and conjunction. The associated rules are modeled after
  Gentzen's system of Natural Deduction @{cite "Gentzen:1935"}.
\<close>

axiomatization imp :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<longrightarrow>" 25)
  where impI [intro]: "(A \<Longrightarrow> B) \<Longrightarrow> A \<longrightarrow> B"
    and impD [dest]: "(A \<longrightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"

axiomatization disj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<or>" 30)
  where disjI\<^sub>1 [intro]: "A \<Longrightarrow> A \<or> B"
    and disjI\<^sub>2 [intro]: "B \<Longrightarrow> A \<or> B"
    and disjE [elim]: "A \<or> B \<Longrightarrow> (A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C"

axiomatization conj :: "o \<Rightarrow> o \<Rightarrow> o"  (infixr "\<and>" 35)
  where conjI [intro]: "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
    and conjD\<^sub>1: "A \<and> B \<Longrightarrow> A"
    and conjD\<^sub>2: "A \<and> B \<Longrightarrow> B"

text \<open>
  The conjunctive destructions have the disadvantage that decomposing @{prop
  "A \<and> B"} involves an immediate decision which component should be projected.
  The more convenient simultaneous elimination @{prop "A \<and> B \<Longrightarrow> (A \<Longrightarrow> B \<Longrightarrow> C) \<Longrightarrow>
  C"} can be derived as follows:
\<close>

theorem conjE [elim]:
  assumes "A \<and> B"
  obtains A and B
proof
  from \<open>A \<and> B\<close> show A by (rule conjD\<^sub>1)
  from \<open>A \<and> B\<close> show B by (rule conjD\<^sub>2)
qed

text \<open>
  Here is an example of swapping conjuncts with a single intermediate
  elimination step:
\<close>

(*<*)
lemma "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
  fix A B
(*>*)
  assume "A \<and> B"
  then obtain B and A ..
  then have "B \<and> A" ..
(*<*)
qed
(*>*)

text \<open>
  Note that the analogous elimination rule for disjunction ``\<^theory_text>\<open>assumes "A \<or> B"
  obtains A \<BBAR> B\<close>'' coincides with the original axiomatization of @{thm
  disjE}.

  \<^medskip>
  We continue propositional logic by introducing absurdity with its
  characteristic elimination. Plain truth may then be defined as a proposition
  that is trivially true.
\<close>

axiomatization false :: o  ("\<bottom>")
  where falseE [elim]: "\<bottom> \<Longrightarrow> A"

definition true :: o  ("\<top>")
  where "\<top> \<equiv> \<bottom> \<longrightarrow> \<bottom>"

theorem trueI [intro]: \<top>
  unfolding true_def ..

text \<open>
  \<^medskip>
  Now negation represents an implication towards absurdity:
\<close>

definition not :: "o \<Rightarrow> o"  ("\<not> _" [40] 40)
  where "\<not> A \<equiv> A \<longrightarrow> \<bottom>"

theorem notI [intro]:
  assumes "A \<Longrightarrow> \<bottom>"
  shows "\<not> A"
unfolding not_def
proof
  assume A
  then show \<bottom> by (rule \<open>A \<Longrightarrow> \<bottom>\<close>)
qed

theorem notE [elim]:
  assumes "\<not> A" and A
  shows B
proof -
  from \<open>\<not> A\<close> have "A \<longrightarrow> \<bottom>" unfolding not_def .
  from \<open>A \<longrightarrow> \<bottom>\<close> and \<open>A\<close> have \<bottom> ..
  then show B ..
qed

subsection \<open>Classical logic\<close>

text \<open>
  Subsequently we state the principle of classical contradiction as a local
  assumption. Thus we refrain from forcing the object-logic into the classical
  perspective. Within that context, we may derive well-known consequences of
  the classical principle.
\<close>

locale classical =
  assumes classical: "(\<not> C \<Longrightarrow> C) \<Longrightarrow> C"
begin

theorem double_negation:
  assumes "\<not> \<not> C"
  shows C
proof (rule classical)
  assume "\<not> C"
  with \<open>\<not> \<not> C\<close> show C ..
qed

theorem tertium_non_datur: "C \<or> \<not> C"
proof (rule double_negation)
  show "\<not> \<not> (C \<or> \<not> C)"
  proof
    assume "\<not> (C \<or> \<not> C)"
    have "\<not> C"
    proof
      assume C then have "C \<or> \<not> C" ..
      with \<open>\<not> (C \<or> \<not> C)\<close> show \<bottom> ..
    qed
    then have "C \<or> \<not> C" ..
    with \<open>\<not> (C \<or> \<not> C)\<close> show \<bottom> ..
  qed
qed

text \<open>
  These examples illustrate both classical reasoning and non-trivial
  propositional proofs in general. All three rules characterize classical
  logic independently, but the original rule is already the most convenient to
  use, because it leaves the conclusion unchanged. Note that @{prop "(\<not> C \<Longrightarrow> C)
  \<Longrightarrow> C"} fits again into our format for eliminations, despite the additional
  twist that the context refers to the main conclusion. So we may write @{thm
  classical} as the Isar statement ``\<^theory_text>\<open>obtains \<not> thesis\<close>''. This also explains
  nicely how classical reasoning really works: whatever the main \<open>thesis\<close>
  might be, we may always assume its negation!
\<close>

end

subsection \<open>Quantifiers \label{sec:framework-ex-quant}\<close>

text \<open>
  Representing quantifiers is easy, thanks to the higher-order nature of the
  underlying framework. According to the well-known technique introduced by
  Church @{cite "church40"}, quantifiers are operators on predicates, which
  are syntactically represented as \<open>\<lambda>\<close>-terms of type @{typ "i \<Rightarrow> o"}. Binder
  notation turns \<open>All (\<lambda>x. B x)\<close> into \<open>\<forall>x. B x\<close> etc.
\<close>

axiomatization All :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<forall>" 10)
  where allI [intro]: "(\<And>x. B x) \<Longrightarrow> \<forall>x. B x"
    and allD [dest]: "(\<forall>x. B x) \<Longrightarrow> B a"

axiomatization Ex :: "(i \<Rightarrow> o) \<Rightarrow> o"  (binder "\<exists>" 10)
  where exI [intro]: "B a \<Longrightarrow> (\<exists>x. B x)"
    and exE [elim]: "(\<exists>x. B x) \<Longrightarrow> (\<And>x. B x \<Longrightarrow> C) \<Longrightarrow> C"

text \<open>
  The statement of @{thm exE} corresponds to ``\<^theory_text>\<open>assumes "\<exists>x. B x" obtains x
  where "B x"\<close>'' in Isar. In the subsequent example we illustrate quantifier
  reasoning involving all four rules:
\<close>

theorem
  assumes "\<exists>x. \<forall>y. R x y"
  shows "\<forall>y. \<exists>x. R x y"
proof    \<comment> \<open>\<open>\<forall>\<close> introduction\<close>
  obtain x where "\<forall>y. R x y" using \<open>\<exists>x. \<forall>y. R x y\<close> ..    \<comment> \<open>\<open>\<exists>\<close> elimination\<close>
  fix y have "R x y" using \<open>\<forall>y. R x y\<close> ..    \<comment> \<open>\<open>\<forall>\<close> destruction\<close>
  then show "\<exists>x. R x y" ..    \<comment> \<open>\<open>\<exists>\<close> introduction\<close>
qed

subsection \<open>Canonical reasoning patterns\<close>

text \<open>
  The main rules of first-order predicate logic from
  \secref{sec:framework-ex-prop} and \secref{sec:framework-ex-quant} can now
  be summarized as follows, using the native Isar statement format of
  \secref{sec:framework-stmt}.

  \<^medskip>
  \begin{tabular}{l}
  \<^theory_text>\<open>impI: assumes "A \<Longrightarrow> B" shows "A \<longrightarrow> B"\<close> \\
  \<^theory_text>\<open>impD: assumes "A \<longrightarrow> B" and A shows B\<close> \\[1ex]

  \<^theory_text>\<open>disjI\<^sub>1: assumes A shows "A \<or> B"\<close> \\
  \<^theory_text>\<open>disjI\<^sub>2: assumes B shows "A \<or> B"\<close> \\
  \<^theory_text>\<open>disjE: assumes "A \<or> B" obtains A \<BBAR> B\<close> \\[1ex]

  \<^theory_text>\<open>conjI: assumes A and B shows A \<and> B\<close> \\
  \<^theory_text>\<open>conjE: assumes "A \<and> B" obtains A and B\<close> \\[1ex]

  \<^theory_text>\<open>falseE: assumes \<bottom> shows A\<close> \\
  \<^theory_text>\<open>trueI: shows \<top>\<close> \\[1ex]

  \<^theory_text>\<open>notI: assumes "A \<Longrightarrow> \<bottom>" shows "\<not> A"\<close> \\
  \<^theory_text>\<open>notE: assumes "\<not> A" and A shows B\<close> \\[1ex]

  \<^theory_text>\<open>allI: assumes "\<And>x. B x" shows "\<forall>x. B x"\<close> \\
  \<^theory_text>\<open>allE: assumes "\<forall>x. B x" shows "B a"\<close> \\[1ex]

  \<^theory_text>\<open>exI: assumes "B a" shows "\<exists>x. B x"\<close> \\
  \<^theory_text>\<open>exE: assumes "\<exists>x. B x" obtains a where "B a"\<close>
  \end{tabular}
  \<^medskip>

  This essentially provides a declarative reading of Pure rules as Isar
  reasoning patterns: the rule statements tells how a canonical proof outline
  shall look like. Since the above rules have already been declared as
  @{attribute (Pure) intro}, @{attribute (Pure) elim}, @{attribute (Pure)
  dest} --- each according to its particular shape --- we can immediately
  write Isar proof texts as follows:
\<close>

(*<*)
theorem "\<And>A. PROP A \<Longrightarrow> PROP A"
proof -
(*>*)

  text_raw \<open>\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<longrightarrow> B"
  proof
    assume A
    show B \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<longrightarrow> B" and A \<proof>
  then have B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have A \<proof>
  then have "A \<or> B" ..

  have B \<proof>
  then have "A \<or> B" ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<or> B" \<proof>
  then have C
  proof
    assume A
    then show C \<proof>
  next
    assume B
    then show C \<proof>
  qed

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have A and B \<proof>
  then have "A \<and> B" ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "A \<and> B" \<proof>
  then obtain A and B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<bottom>" \<proof>
  then have A ..

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<top>" ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<not> A"
  proof
    assume A
    then show "\<bottom>" \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<not> A" and A \<proof>
  then have B ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<forall>x. B x"
  proof
    fix x
    show "B x" \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<forall>x. B x" \<proof>
  then have "B a" ..

  text_raw \<open>\end{minipage}\\[3ex]\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<exists>x. B x"
  proof
    show "B a" \<proof>
  qed

  text_raw \<open>\end{minipage}\qquad\begin{minipage}[t]{0.4\textwidth}\<close>(*<*)next(*>*)

  have "\<exists>x. B x" \<proof>
  then obtain a where "B a" ..

  text_raw \<open>\end{minipage}\<close>

(*<*)
qed
(*>*)

text \<open>
  \<^bigskip>
  Of course, these proofs are merely examples. As sketched in
  \secref{sec:framework-subproof}, there is a fair amount of flexibility in
  expressing Pure deductions in Isar. Here the user is asked to express
  himself adequately, aiming at proof texts of literary quality.
\<close>

end %visible


(*  Title:      HOL/Isar_Examples/Mutilated_Checkerboard.thy
    Author:     Markus Wenzel, TU Muenchen (Isar document)
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory (original scripts)
*)

section \<open>The Mutilated Checker Board Problem\<close>

theory Mutilated_Checkerboard
  imports Main
begin

text \<open>
  The Mutilated Checker Board Problem, formalized inductively. See @{cite
  "paulson-mutilated-board"} for the original tactic script version.
\<close>

subsection \<open>Tilings\<close>

inductive_set tiling :: "'a set set \<Rightarrow> 'a set set" for A :: "'a set set"
  where
    empty: "{} \<in> tiling A"
  | Un: "a \<union> t \<in> tiling A" if "a \<in> A" and "t \<in> tiling A" and "a \<subseteq> - t"

text \<open>The union of two disjoint tilings is a tiling.\<close>

lemma tiling_Un:
  assumes "t \<in> tiling A"
    and "u \<in> tiling A"
    and "t \<inter> u = {}"
  shows "t \<union> u \<in> tiling A"
proof -
  let ?T = "tiling A"
  from \<open>t \<in> ?T\<close> and \<open>t \<inter> u = {}\<close>
  show "t \<union> u \<in> ?T"
  proof (induct t)
    case empty
    with \<open>u \<in> ?T\<close> show "{} \<union> u \<in> ?T" by simp
  next
    case (Un a t)
    show "(a \<union> t) \<union> u \<in> ?T"
    proof -
      have "a \<union> (t \<union> u) \<in> ?T"
        using \<open>a \<in> A\<close>
      proof (rule tiling.Un)
        from \<open>(a \<union> t) \<inter> u = {}\<close> have "t \<inter> u = {}" by blast
        then show "t \<union> u \<in> ?T" by (rule Un)
        from \<open>a \<subseteq> - t\<close> and \<open>(a \<union> t) \<inter> u = {}\<close>
        show "a \<subseteq> - (t \<union> u)" by blast
      qed
      also have "a \<union> (t \<union> u) = (a \<union> t) \<union> u"
        by (simp only: Un_assoc)
      finally show ?thesis .
    qed
  qed
qed

subsection \<open>Basic properties of ``below''\<close>

definition below :: "nat \<Rightarrow> nat set"
  where "below n = {i. i < n}"

lemma below_less_iff [iff]: "i \<in> below k \<longleftrightarrow> i < k"
  by (simp add: below_def)

lemma below_0: "below 0 = {}"
  by (simp add: below_def)

lemma Sigma_Suc1: "m = n + 1 \<Longrightarrow> below m \<times> B = ({n} \<times> B) \<union> (below n \<times> B)"
  by (simp add: below_def less_Suc_eq) blast

lemma Sigma_Suc2:
  "m = n + 2 \<Longrightarrow>
    A \<times> below m = (A \<times> {n}) \<union> (A \<times> {n + 1}) \<union> (A \<times> below n)"
  by (auto simp add: below_def)

lemmas Sigma_Suc = Sigma_Suc1 Sigma_Suc2

subsection \<open>Basic properties of ``evnodd''\<close>

definition evnodd :: "(nat \<times> nat) set \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set"
  where "evnodd A b = A \<inter> {(i, j). (i + j) mod 2 = b}"

lemma evnodd_iff: "(i, j) \<in> evnodd A b \<longleftrightarrow> (i, j) \<in> A  \<and> (i + j) mod 2 = b"
  by (simp add: evnodd_def)

lemma evnodd_subset: "evnodd A b \<subseteq> A"
  unfolding evnodd_def by (rule Int_lower1)

lemma evnoddD: "x \<in> evnodd A b \<Longrightarrow> x \<in> A"
  by (rule subsetD) (rule evnodd_subset)

lemma evnodd_finite: "finite A \<Longrightarrow> finite (evnodd A b)"
  by (rule finite_subset) (rule evnodd_subset)

lemma evnodd_Un: "evnodd (A \<union> B) b = evnodd A b \<union> evnodd B b"
  unfolding evnodd_def by blast

lemma evnodd_Diff: "evnodd (A - B) b = evnodd A b - evnodd B b"
  unfolding evnodd_def by blast

lemma evnodd_empty: "evnodd {} b = {}"
  by (simp add: evnodd_def)

lemma evnodd_insert: "evnodd (insert (i, j) C) b =
    (if (i + j) mod 2 = b
      then insert (i, j) (evnodd C b) else evnodd C b)"
  by (simp add: evnodd_def)

subsection \<open>Dominoes\<close>

inductive_set domino :: "(nat \<times> nat) set set"
  where
    horiz: "{(i, j), (i, j + 1)} \<in> domino"
  | vertl: "{(i, j), (i + 1, j)} \<in> domino"

lemma dominoes_tile_row:
  "{i} \<times> below (2 * n) \<in> tiling domino"
  (is "?B n \<in> ?T")
proof (induct n)
  case 0
  show ?case by (simp add: below_0 tiling.empty)
next
  case (Suc n)
  let ?a = "{i} \<times> {2 * n + 1} \<union> {i} \<times> {2 * n}"
  have "?B (Suc n) = ?a \<union> ?B n"
    by (auto simp add: Sigma_Suc Un_assoc)
  also have "\<dots> \<in> ?T"
  proof (rule tiling.Un)
    have "{(i, 2 * n), (i, 2 * n + 1)} \<in> domino"
      by (rule domino.horiz)
    also have "{(i, 2 * n), (i, 2 * n + 1)} = ?a" by blast
    finally show "\<dots> \<in> domino" .
    show "?B n \<in> ?T" by (rule Suc)
    show "?a \<subseteq> - ?B n" by blast
  qed
  finally show ?case .
qed

lemma dominoes_tile_matrix:
  "below m \<times> below (2 * n) \<in> tiling domino"
  (is "?B m \<in> ?T")
proof (induct m)
  case 0
  show ?case by (simp add: below_0 tiling.empty)
next
  case (Suc m)
  let ?t = "{m} \<times> below (2 * n)"
  have "?B (Suc m) = ?t \<union> ?B m" by (simp add: Sigma_Suc)
  also have "\<dots> \<in> ?T"
  proof (rule tiling_Un)
    show "?t \<in> ?T" by (rule dominoes_tile_row)
    show "?B m \<in> ?T" by (rule Suc)
    show "?t \<inter> ?B m = {}" by blast
  qed
  finally show ?case .
qed

lemma domino_singleton:
  assumes "d \<in> domino"
    and "b < 2"
  shows "\<exists>i j. evnodd d b = {(i, j)}"  (is "?P d")
  using assms
proof induct
  from \<open>b < 2\<close> have b_cases: "b = 0 \<or> b = 1" by arith
  fix i j
  note [simp] = evnodd_empty evnodd_insert mod_Suc
  from b_cases show "?P {(i, j), (i, j + 1)}" by rule auto
  from b_cases show "?P {(i, j), (i + 1, j)}" by rule auto
qed

lemma domino_finite:
  assumes "d \<in> domino"
  shows "finite d"
  using assms
proof induct
  fix i j :: nat
  show "finite {(i, j), (i, j + 1)}" by (intro finite.intros)
  show "finite {(i, j), (i + 1, j)}" by (intro finite.intros)
qed

subsection \<open>Tilings of dominoes\<close>

lemma tiling_domino_finite:
  assumes t: "t \<in> tiling domino"  (is "t \<in> ?T")
  shows "finite t"  (is "?F t")
  using t
proof induct
  show "?F {}" by (rule finite.emptyI)
  fix a t assume "?F t"
  assume "a \<in> domino"
  then have "?F a" by (rule domino_finite)
  from this and \<open>?F t\<close> show "?F (a \<union> t)" by (rule finite_UnI)
qed

lemma tiling_domino_01:
  assumes t: "t \<in> tiling domino"  (is "t \<in> ?T")
  shows "card (evnodd t 0) = card (evnodd t 1)"
  using t
proof induct
  case empty
  show ?case by (simp add: evnodd_def)
next
  case (Un a t)
  let ?e = evnodd
  note hyp = \<open>card (?e t 0) = card (?e t 1)\<close>
    and at = \<open>a \<subseteq> - t\<close>
  have card_suc: "card (?e (a \<union> t) b) = Suc (card (?e t b))" if "b < 2" for b :: nat
  proof -
    have "?e (a \<union> t) b = ?e a b \<union> ?e t b" by (rule evnodd_Un)
    also obtain i j where e: "?e a b = {(i, j)}"
    proof -
      from \<open>a \<in> domino\<close> and \<open>b < 2\<close>
      have "\<exists>i j. ?e a b = {(i, j)}" by (rule domino_singleton)
      then show ?thesis by (blast intro: that)
    qed
    also have "\<dots> \<union> ?e t b = insert (i, j) (?e t b)" by simp
    also have "card \<dots> = Suc (card (?e t b))"
    proof (rule card_insert_disjoint)
      from \<open>t \<in> tiling domino\<close> have "finite t"
        by (rule tiling_domino_finite)
      then show "finite (?e t b)"
        by (rule evnodd_finite)
      from e have "(i, j) \<in> ?e a b" by simp
      with at show "(i, j) \<notin> ?e t b" by (blast dest: evnoddD)
    qed
    finally show ?thesis .
  qed
  then have "card (?e (a \<union> t) 0) = Suc (card (?e t 0))" by simp
  also from hyp have "card (?e t 0) = card (?e t 1)" .
  also from card_suc have "Suc \<dots> = card (?e (a \<union> t) 1)"
    by simp
  finally show ?case .
qed

subsection \<open>Main theorem\<close>

definition mutilated_board :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set"
  where "mutilated_board m n =
    below (2 * (m + 1)) \<times> below (2 * (n + 1)) - {(0, 0)} - {(2 * m + 1, 2 * n + 1)}"

theorem mutil_not_tiling: "mutilated_board m n \<notin> tiling domino"
proof (unfold mutilated_board_def)
  let ?T = "tiling domino"
  let ?t = "below (2 * (m + 1)) \<times> below (2 * (n + 1))"
  let ?t' = "?t - {(0, 0)}"
  let ?t'' = "?t' - {(2 * m + 1, 2 * n + 1)}"

  show "?t'' \<notin> ?T"
  proof
    have t: "?t \<in> ?T" by (rule dominoes_tile_matrix)
    assume t'': "?t'' \<in> ?T"

    let ?e = evnodd
    have fin: "finite (?e ?t 0)"
      by (rule evnodd_finite, rule tiling_domino_finite, rule t)

    note [simp] = evnodd_iff evnodd_empty evnodd_insert evnodd_Diff
    have "card (?e ?t'' 0) < card (?e ?t' 0)"
    proof -
      have "card (?e ?t' 0 - {(2 * m + 1, 2 * n + 1)})
        < card (?e ?t' 0)"
      proof (rule card_Diff1_less)
        from _ fin show "finite (?e ?t' 0)"
          by (rule finite_subset) auto
        show "(2 * m + 1, 2 * n + 1) \<in> ?e ?t' 0" by simp
      qed
      then show ?thesis by simp
    qed
    also have "\<dots> < card (?e ?t 0)"
    proof -
      have "(0, 0) \<in> ?e ?t 0" by simp
      with fin have "card (?e ?t 0 - {(0, 0)}) < card (?e ?t 0)"
        by (rule card_Diff1_less)
      then show ?thesis by simp
    qed
    also from t have "\<dots> = card (?e ?t 1)"
      by (rule tiling_domino_01)
    also have "?e ?t 1 = ?e ?t'' 1" by simp
    also from t'' have "card \<dots> = card (?e ?t'' 0)"
      by (rule tiling_domino_01 [symmetric])
    finally have "\<dots> < \<dots>" . then show False ..
  qed
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Lagrange Interpolation\<close>

text \<open>We formalized the Lagrange interpolation, i.e., a method to interpolate a polynomial $p$
  from a list of points $(x_1,p(x_1)), (x_2, p(x_2)), \ldots$. The interpolation algorithm is proven
  to be sound and complete.\<close>

theory Lagrange_Interpolation
imports
  Missing_Polynomial
begin

definition lagrange_basis_poly :: "'a :: field list \<Rightarrow> 'a \<Rightarrow> 'a poly" where
  "lagrange_basis_poly xs xj \<equiv> let ys = filter (\<lambda> x. x \<noteq> xj) xs
    in prod_list (map (\<lambda> xi. smult (inverse (xj - xi)) [: - xi, 1 :]) ys)"

definition lagrange_interpolation_poly :: "('a :: field \<times> 'a)list \<Rightarrow> 'a poly" where
  "lagrange_interpolation_poly xs_ys \<equiv> let
    xs = map fst xs_ys
    in sum_list (map (\<lambda> (xj,yj). smult yj (lagrange_basis_poly xs xj)) xs_ys)"

lemma degree_lagrange_basis_poly: "degree (lagrange_basis_poly xs xj) \<le> length (filter (\<lambda> x. x \<noteq> xj) xs)"
  unfolding lagrange_basis_poly_def Let_def
  by (rule order.trans[OF degree_prod_list_le], rule order_trans[OF sum_list_mono[of _ _ "\<lambda> _. 1"]],
  auto simp: o_def, induct xs, auto)

lemma degree_lagrange_interpolation_poly:
  shows "degree (lagrange_interpolation_poly xs_ys) \<le> length xs_ys - 1"
proof -
  {
    fix a b
    assume ab: "(a,b) \<in> set xs_ys"
    let ?xs = "filter (\<lambda>x. x\<noteq>a) (map fst xs_ys)"
    from ab have "a \<in> set (map fst xs_ys)" by force
    hence "Suc (length ?xs) \<le> length xs_ys"
      by (induct xs_ys, auto)
    hence "length ?xs \<le> length xs_ys - 1" by auto
  } note main = this
  show ?thesis
    unfolding lagrange_interpolation_poly_def Let_def
    by (rule degree_sum_list_le, auto, rule order_trans[OF degree_lagrange_basis_poly], insert main, auto)
qed

lemma lagrange_basis_poly_1:
  "poly (lagrange_basis_poly (map fst xs_ys) x) x = 1"
  unfolding lagrange_basis_poly_def Let_def poly_prod_list
  by (rule prod_list_neutral, auto)
  (metis field_class.field_inverse mult.commute right_diff_distrib right_minus_eq)

lemma lagrange_basis_poly_0: assumes "x' \<in> set (map fst xs_ys)" and "x' \<noteq> x"
  shows "poly (lagrange_basis_poly (map fst xs_ys) x) x' = 0"
proof -
  let ?f = "\<lambda>xi. smult (inverse (x - xi)) [:- xi, 1:]"
  let ?xs = "filter (\<lambda>c. c\<noteq>x) (map fst xs_ys)"
  have mem: "?f x' \<in> set (map ?f ?xs)" using assms by auto
  show ?thesis
    unfolding lagrange_basis_poly_def Let_def poly_prod_list prod_list_map_remove1[OF mem]
    by simp
qed

lemma lagrange_interpolation_poly: assumes dist: "distinct (map fst xs_ys)"
  and p: "p = lagrange_interpolation_poly xs_ys"
  shows "\<And> x y. (x,y) \<in> set xs_ys \<Longrightarrow> poly p x = y"
proof -
  let ?xs = "map fst xs_ys"
  {
    fix x y
    assume xy: "(x,y) \<in> set xs_ys"
    show "poly p x = y" unfolding p lagrange_interpolation_poly_def Let_def poly_sum_list map_map o_def
    proof (subst sum_list_map_remove1[OF xy], unfold split poly_smult lagrange_basis_poly_1,
      subst sum_list_neutral)
      fix v
      assume "v \<in> set (map (\<lambda>xa. poly (case xa of (xj, yj) \<Rightarrow> smult yj (lagrange_basis_poly ?xs xj))
                               x)
                 (remove1 (x, y) xs_ys))" (is "_ \<in> set (map ?f ?xy)")
      then obtain xy' where mem: "xy' \<in> set ?xy" and v: "v = ?f xy'" by auto
      obtain x' y' where xy': "xy' = (x',y')" by force
      from v[unfolded this split] have v: "v = poly (smult y' (lagrange_basis_poly ?xs x')) x" .
      have neq: "x' \<noteq> x"
      proof
        assume "x' = x"
        with mem[unfolded xy'] have mem: "(x,y') \<in> set (remove1 (x,y) xs_ys)" by auto
        hence mem': "(x,y') \<in> set xs_ys" by (meson notin_set_remove1)
        from dist[unfolded distinct_map] have inj: "inj_on fst (set xs_ys)" by auto
        with mem' xy have y': "y' = y" unfolding inj_on_def by force
        from dist have "distinct xs_ys" using distinct_map by blast
        hence "(x,y) \<notin> set (remove1 (x,y) xs_ys)" by simp
        with mem[unfolded y']
        show False by auto
      qed
      have "poly (lagrange_basis_poly ?xs x') x = 0"
        by (rule lagrange_basis_poly_0, insert xy mem[unfolded xy'] dist neq, force+)
      thus "v = 0" unfolding v by simp
    qed simp
  } note sound = this
qed

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_BubSortSorts
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun ordered :: "int list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun bubble :: "int list => (bool, (int list)) pair" where
"bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "int list => int list" where
"bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "ordered (bubsort xs)"
  oops

end


theory Majorities
imports Main
begin

section {* Utility Lemmas About Majorities *}

text {*
  Consensus algorithms usually ensure that a majority of processes
  proposes the same value before taking a decision,
  and we provide a few utility lemmas for reasoning about majorities.
*}

text {*
  Any two subsets @{text S} and @{text T} of a finite  set @{text E} such that
  the sum of their cardinalities is larger than the size of @{text E} have a
  non-empty intersection.
*}
lemma abs_majorities_intersect:
    assumes crd: "card E < card S + card T"
        and s: "S \<subseteq> E" and t: "T \<subseteq> E" and e: "finite E"
    shows "S \<inter> T \<noteq> {}"
proof (clarify)
  assume contra: "S \<inter> T = {}"
  from s t e have "finite S" and "finite T" by (auto simp: finite_subset)
  with crd contra have "card E < card (S \<union> T)" by (auto simp add: card_Un_Int)
  moreover
  from s t e have "card (S \<union> T) \<le> card E" by (simp add: card_mono)
  ultimately
  show "False" by simp
qed

lemma abs_majoritiesE:
  assumes crd: "card E < card S + card T"
      and s: "S \<subseteq> E" and t: "T \<subseteq> E" and e: "finite E"
  obtains p where "p \<in> S" and "p \<in> T"
proof -
  from assms have "S \<inter> T \<noteq> {}" by (rule abs_majorities_intersect)
  then obtain p where "p \<in> S \<inter> T" by blast
  with that show ?thesis by auto
qed

text {* Special case: both sets @{text S} and @{text T} are majorities. *}

lemma abs_majoritiesE':
  assumes Smaj: "card S > (card E) div 2" and Tmaj: "card T > (card E) div 2"
      and s: "S \<subseteq> E" and t: "T \<subseteq> E" and e: "finite E"
  obtains p where "p \<in> S" and "p \<in> T"
proof (rule abs_majoritiesE[OF _ s t e])
  from Smaj Tmaj show "card E < card S + card T" by auto
qed

text {*
  We restate the above theorems for the case where the base type
  is finite (taking @{text E} as the universal set).
*}

lemma majorities_intersect:
  assumes crd: "card (UNIV::('a::finite) set) < card (S::'a set) + card T"
  shows "S \<inter> T \<noteq> {}"
  by (rule abs_majorities_intersect[OF crd]) auto

lemma majoritiesE:
  assumes crd: "card (UNIV::('a::finite) set) < card (S::'a set) + card (T::'a set)"
  obtains p where "p \<in> S" and "p \<in> T"
using crd majorities_intersect by blast

lemma majoritiesE':
  assumes S: "card (S::('a::finite) set) > (card (UNIV::'a set)) div 2"
  and T: "card (T::'a set) > (card (UNIV::'a set)) div 2"
  obtains p where "p \<in> S" and "p \<in> T"
by (rule abs_majoritiesE'[OF S T]) auto

end (* theory Majorities *)