(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Code Generation for Basic Matrix Operations\<close>

text \<open>In this theory we implement matrices as arrays of arrays.
  Due to the target language serialization, access to matrix
  entries should be constant time. Hence operations like
  matrix addition, multiplication, etc.~should all have their
  standard complexity.

  There might be room for optimizations.

  To implement the infinite carrier set, we use A.\ Lochbihler's container framework
  \<^cite>\<open>"Containers-AFP"\<close>.\<close>

theory Matrix_IArray_Impl
imports
  Matrix
  "HOL-Library.IArray"
  Containers.Set_Impl
begin

typedef 'a vec_impl = "{(n,v :: 'a iarray). IArray.length v = n}" by auto
typedef 'a mat_impl = "{(nr,nc,m :: 'a iarray iarray).
  IArray.length m = nr \<and> IArray.all (\<lambda> r. IArray.length r = nc) m}"
  by (rule exI[of _ "(0,0,IArray [])"], auto)

setup_lifting type_definition_vec_impl
setup_lifting type_definition_mat_impl

lift_definition vec_impl :: "'a vec_impl \<Rightarrow> 'a vec" is
  "\<lambda> (n,v). (n,mk_vec n (IArray.sub v))" by auto

lift_definition vec_add_impl :: "'a::plus vec_impl \<Rightarrow> 'a vec_impl \<Rightarrow> 'a vec_impl" is
  "\<lambda> (n,v) (m,w).
  (n, IArray.of_fun (\<lambda>i. IArray.sub v i + IArray.sub w i) n)"
by auto

lift_definition mat_impl :: "'a mat_impl \<Rightarrow> 'a mat" is
  "\<lambda> (nr,nc,m). (nr,nc,mk_mat nr nc (\<lambda> (i,j). IArray.sub (IArray.sub m i) j))" by auto

lift_definition vec_of_list_impl :: "'a list \<Rightarrow> 'a vec_impl" is
  "\<lambda> v. (length v, IArray v)" by auto

lift_definition list_of_vec_impl :: "'a vec_impl \<Rightarrow> 'a list" is
  "\<lambda> (n,v). IArray.list_of v" .

lift_definition vec_of_fun :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a vec_impl" is
  "\<lambda> n f. (n, IArray.of_fun f n)" by auto

lift_definition mat_of_fun :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> 'a mat_impl" is
  "\<lambda> nr nc f. (nr, nc, IArray.of_fun (\<lambda> i. IArray.of_fun (\<lambda> j. f (i,j)) nc) nr)" by auto

lift_definition vec_index_impl :: "'a vec_impl \<Rightarrow> nat \<Rightarrow> 'a"
  is "\<lambda> (n,v). IArray.sub v" .

lift_definition index_mat_impl :: "'a mat_impl \<Rightarrow> nat \<times> nat \<Rightarrow> 'a"
  is "\<lambda> (nr,nc,m) (i,j). if i < nr then IArray.sub (IArray.sub m i) j
    else IArray.sub (IArray ([] ! (i - nr))) j" .

lift_definition vec_equal_impl :: "'a vec_impl \<Rightarrow> 'a vec_impl \<Rightarrow> bool"
  is "\<lambda> (n1,v1) (n2,v2). n1 = n2 \<and> v1 = v2" .

lift_definition mat_equal_impl :: "'a mat_impl \<Rightarrow> 'a mat_impl \<Rightarrow> bool"
  is "\<lambda> (nr1,nc1,m1) (nr2,nc2,m2). nr1 = nr2 \<and> nc1 = nc2 \<and> m1 = m2" .

lift_definition dim_vec_impl :: "'a vec_impl \<Rightarrow> nat" is fst .

lift_definition dim_row_impl :: "'a mat_impl \<Rightarrow> nat" is fst .
lift_definition dim_col_impl :: "'a mat_impl \<Rightarrow> nat" is "fst o snd" .

code_datatype vec_impl
code_datatype mat_impl

lemma vec_code[code]: "vec n f = vec_impl (vec_of_fun n f)"
  by (transfer, auto simp: mk_vec_def)

lemma mat_code[code]: "mat nr nc f = mat_impl (mat_of_fun nr nc f)"
  by (transfer, auto simp: mk_mat_def, intro ext, clarsimp,
  auto intro: undef_cong_mat)

lemma vec_of_list[code]: "vec_of_list v = vec_impl (vec_of_list_impl v)"
  by (transfer, auto simp: mk_vec_def)

lemma list_of_vec_code[code]: "list_of_vec (vec_impl v) = list_of_vec_impl v"
  by (transfer, auto simp: mk_vec_def, case_tac b, auto intro: nth_equalityI)

lemma empty_nth: "\<not> i < length x \<Longrightarrow> x ! i = [] ! (i - length x)"
  by (metis append_Nil2 nth_append)

lemma undef_vec: "\<not> i < length x \<Longrightarrow> undef_vec (i - length x) = x ! i"
  unfolding undef_vec_def by (rule empty_nth[symmetric])

lemma vec_index_code[code]: "(vec_impl v) $ i = vec_index_impl v i"
  by (transfer, auto simp: mk_vec_def, case_tac b, auto simp: undef_vec)

lemma index_mat_code[code]: "(mat_impl m) $$ ij = (index_mat_impl m ij :: 'a)"
proof (transfer, unfold o_def, clarify)
  fix m :: "'a iarray iarray" and i j nc
  assume all: "IArray.all (\<lambda>r. IArray.length r = nc) m"
  obtain mm where m: "m = IArray mm" by (cases m)
  with all have all: "\<And> v. v \<in> set mm \<Longrightarrow> IArray.length v = nc" by auto
  show "snd (snd (IArray.length m, nc, mk_mat (IArray.length m) nc (\<lambda>(i, y). m !! i !! y))) (i, j) =
     (if i < IArray.length m then m !! i !! j
        else IArray ([] ! (i - IArray.length m)) !! j)" (is "?l = ?r")
  proof (cases "i < length mm")
    case False
    hence "\<And> f. \<not> i < length (map f [0..<length mm])" by simp
    note [simp] = empty_nth[OF this]
    have "?l = [] ! (i - length mm) ! j" using False unfolding m mk_mat_def undef_mat_def by simp
    also have "\<dots> = ?r" unfolding m by (simp add: False empty_nth[OF False])
    finally show ?thesis .
  next
    case True
    obtain v where mm: "mm ! i = IArray v" by (cases "mm ! i")
    with True all[of "mm ! i"] have len: "length v = nc" unfolding set_conv_nth by force
    from mm True have "?l = map ((!) v) [0..<nc] ! j" (is "_ = ?m") unfolding m mk_mat_def undef_mat_def by simp
    also have "?m = m !! i !! j"
    proof (cases "j < length v")
      case True
      thus ?thesis unfolding m using mm len by auto
    next
      case False
      hence j: "\<not> j < length (map ((!) v) [0..<length v])" by simp
      show ?thesis unfolding m using mm len by (auto simp: empty_nth[OF j] empty_nth[OF False])
    qed
    also have "\<dots> = ?r" using True m by simp
    finally show ?thesis .
  qed
qed

lift_definition (code_dt) mat_of_rows_list_impl :: "nat \<Rightarrow> 'a list list \<Rightarrow> 'a mat_impl option" is
  "\<lambda> n rows. if list_all (\<lambda> r. length r = n) rows then Some (length rows, n, IArray (map IArray rows))
  else None"
  by (auto split: if_splits simp: list_all_iff)

lemma mat_of_rows_list_impl: "mat_of_rows_list_impl n rs = Some A \<Longrightarrow> mat_impl A = mat_of_rows_list n rs"
  unfolding mat_of_rows_list_def
  by (transfer, auto split: if_splits simp: list_all_iff intro!: cong_mk_mat)

lemma mat_of_rows_list_code[code]: "mat_of_rows_list nc vs =
  (case mat_of_rows_list_impl nc vs of Some A \<Rightarrow> mat_impl A
  | None \<Rightarrow> mat_of_rows nc (map (\<lambda> v. vec nc (nth v)) vs))"
proof (cases "mat_of_rows_list_impl nc vs")
  case (Some A)
  from mat_of_rows_list_impl[OF this] show ?thesis unfolding Some by simp
next
  case None
  show ?thesis unfolding None unfolding mat_of_rows_list_def mat_of_rows_def
    by (intro eq_matI, auto)
qed

lemma dim_vec_code[code]: "dim_vec (vec_impl v) = dim_vec_impl v"
  by (transfer, auto)

lemma dim_row_code[code]: "dim_row (mat_impl m) = dim_row_impl m"
  by (transfer, auto)

lemma dim_col_code[code]: "dim_col (mat_impl m) = dim_col_impl m"
  by (transfer, auto)

instantiation vec :: (type)equal
begin
  definition "(equal_vec :: ('a vec \<Rightarrow> 'a vec \<Rightarrow> bool)) = (=)"
instance
  by (intro_classes, auto simp: equal_vec_def)
end

instantiation mat :: (type)equal
begin
  definition "(equal_mat :: ('a mat \<Rightarrow> 'a mat \<Rightarrow> bool)) = (=)"
instance
  by (intro_classes, auto simp: equal_mat_def)
end

lemma veq_equal_code[code]: "HOL.equal (vec_impl (v1 :: 'a vec_impl)) (vec_impl v2) = vec_equal_impl v1 v2"
proof -
  {
    fix x1 x2 :: "'a list"
    assume len: "length x1 = length x2"
       and index: "(\<lambda>i. if i < length x2 then IArray x1 !! i else undef_vec (i - length (IArray.list_of (IArray x1)))) =
            (\<lambda>i. if i < length x2 then IArray x2 !! i else undef_vec (i - length (IArray.list_of (IArray x2))))"
    have "x1 = x2"
    proof (intro nth_equalityI[OF len])
      fix i
      assume "i < length x1"
      with fun_cong[OF index, of i] len show "x1 ! i = x2 ! i" by simp
    qed
  } note * = this
  show ?thesis unfolding equal_vec_def
    by (transfer, insert *, auto simp: mk_vec_def, case_tac b, case_tac ba, auto)
qed

lemma mat_equal_code[code]: "HOL.equal (mat_impl (m1 :: 'a mat_impl)) (mat_impl m2) = mat_equal_impl m1 m2"
proof -
  show ?thesis unfolding equal_mat_def
  proof (transfer, auto, case_tac b, case_tac ba, auto)
    fix x1 x2 :: "'a iarray list" and nc
    assume len: "\<forall>r\<in>set x1. length (IArray.list_of r) = nc"
      "\<forall>r\<in>set x2. length (IArray.list_of r) = nc"
      "length x1 = length x2"
    and index: "mk_mat (length x2) nc (\<lambda>(i, j). x1 ! i !! j) = mk_mat (length x2) nc (\<lambda>(i, j). x2 ! i !! j)"
    show "x1 = x2"
    proof (rule nth_equalityI[OF len(3)])
      fix i
      assume i: "i < length x1"
      obtain ia1 where 1: "x1 ! i = IArray ia1" by (cases "x1 ! i")
      obtain ia2 where 2: "x2 ! i = IArray ia2" by (cases "x2 ! i")
      from i 1 len(1) have l1: "length ia1 = nc" using nth_mem by fastforce
      from i 2 len(2-3) have l2: "length ia2 = nc" using nth_mem by fastforce
      from l1 l2 have l: "length ia1 = length ia2" by simp
      show "x1 ! i = x2 ! i" unfolding 1 2
      proof (simp, rule nth_equalityI[OF l])
        fix j
        assume j: "j < length ia1"
        with fun_cong[OF index, of "(i,j)"] i len(3)
        have "x1 ! i !! j = x2 ! i !! j"
          by (simp add: mk_mat_def l1)
        thus "ia1 ! j = ia2 ! j" unfolding 1 2 by simp
      qed
    qed
  qed
qed

declare prod.set_conv_list[code del, code_unfold]

derive (eq) ceq mat vec
derive (no) ccompare mat vec
derive (dlist) set_impl mat vec
derive (no) cenum mat vec

lemma carrier_mat_code[code]: "carrier_mat nr nc = Collect_set (\<lambda> A. dim_row A = nr \<and> dim_col A = nc)" by auto
lemma carrier_vec_code[code]: "carrier_vec n = Collect_set (\<lambda> v. dim_vec v = n)"
  unfolding carrier_vec_def by auto

end


theory Pappus_Property
  imports Main Projective_Plane_Axioms
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We give two formulations of Pappus's property for a configuration of nine points
 @{term is_pappus1} @{term is_pappus2}.
\<^item> We prove the equivalence of these two formulations @{term pappus_equiv}.
\<^item> We state Pappus property for a plane @{term is_pappus}.
\<close>

section \<open>Pappus's Property\<close>

context projective_plane
begin

definition col :: "['point, 'point, 'point] \<Rightarrow> bool" where
"col A B C \<equiv> \<exists>l. incid A l \<and> incid B l \<and> incid C l"

lemma distinct6_def:
"distinct [A,B,C,D,E,F] \<equiv> (A \<noteq> B) \<and> (A \<noteq> C) \<and> (A \<noteq> D) \<and> (A \<noteq> E) \<and> (A \<noteq> F) \<and>
(B \<noteq> C) \<and> (B \<noteq> D) \<and> (B \<noteq> E) \<and> (B \<noteq> F) \<and>
(C \<noteq> D) \<and> (C \<noteq> E) \<and> (C \<noteq> F) \<and>
(D \<noteq> E) \<and> (D \<noteq> F) \<and>
(E \<noteq> F)"
  by auto

definition lines :: "'point \<Rightarrow> 'point \<Rightarrow> 'line set" where
"lines P Q \<equiv> {l. incid P l \<and> incid Q l}"

lemma uniq_line:
  assumes "P \<noteq> Q" and "l \<in> lines P Q" and "m \<in> lines P Q"
  shows "l = m"
  using assms lines_def ax_uniqueness
  by blast

definition line :: "'point \<Rightarrow> 'point \<Rightarrow> 'line" where
"line P Q \<equiv> @l. incid P l \<and> incid Q l"

(* The point P is the intersection of the lines AB and CD. For P to be well-defined,
A and B should be distinct, C and D should be distinct, and the lines AB and CD should
be distinct *)
definition is_a_proper_intersec :: "['point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"is_a_proper_intersec P A B C D \<equiv> (A \<noteq> B) \<and> (C \<noteq> D) \<and> (line A B \<noteq> line C D)
\<and> col P A B \<and> col P C D"

(* We state a first form of Pappus's property *)
definition is_pappus1 ::
"['point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point] => bool " where
"is_pappus1 A B C A' B' C' P Q R \<equiv>
  distinct[A,B,C,A',B',C'] \<longrightarrow> col A B C \<longrightarrow> col A' B' C'
  \<longrightarrow> is_a_proper_intersec P A B' A' B \<longrightarrow> is_a_proper_intersec Q B C' B' C
  \<longrightarrow> is_a_proper_intersec R A C' A' C
  \<longrightarrow> col P Q R"

definition is_a_intersec :: "['point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"is_a_intersec P A B C D \<equiv> col P A B \<and> col P C D"

(* We state a second form of Pappus's property *)
definition is_pappus2 ::
"['point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"is_pappus2 A B C A' B' C' P Q R \<equiv>
  (distinct [A,B,C,A',B',C'] \<or> (A \<noteq> B' \<and> A'\<noteq> B \<and> line A B' \<noteq> line A' B \<and>
  B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
  A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C))
  \<longrightarrow> col A B C \<longrightarrow> col A' B' C' \<longrightarrow> is_a_intersec P A B' A' B
  \<longrightarrow> is_a_intersec Q B C' B' C \<longrightarrow> is_a_intersec R A C' A' C
  \<longrightarrow> col P Q R"

lemma is_a_proper_intersec_is_a_intersec:
  assumes "is_a_proper_intersec P A B C D"
  shows "is_a_intersec P A B C D"
  using assms is_a_intersec_def is_a_proper_intersec_def
  by auto

(* The first and the second forms of Pappus's property are equivalent *)
lemma pappus21:
  assumes "is_pappus2 A B C A' B' C' P Q R"
  shows "is_pappus1 A B C A' B' C' P Q R"
  using assms is_pappus2_def is_pappus1_def is_a_proper_intersec_is_a_intersec
  by auto

lemma col_AAB: "col A A B"
  by (simp add: ax1 col_def)

lemma col_ABA: "col A B A"
  using ax1 col_def
  by blast

lemma col_ABB: "col A B B"
  by (simp add: ax1 col_def)

lemma incidA_lAB: "incid A (line A B)"
  by (metis (no_types, lifting) ax1 line_def someI_ex)

lemma incidB_lAB: "incid B (line A B)"
  by (metis (no_types, lifting) ax1 line_def someI_ex)

lemma degenerate_hexagon_is_pappus:
  assumes "distinct [A,B,C,A',B',C']" and "col A B C" and "col A' B' C'" and
"is_a_intersec P A B' A' B" and "is_a_intersec Q B C' B' C" and "is_a_intersec R A C' A' C"
and "line A B' = line A' B \<or> line B C' = line B' C \<or> line A C' = line A' C"
  shows "col P Q R"
proof -
  have "col P Q R" if "line A B' = line A' B"
    by (smt assms(1) assms(3) assms(4) assms(5) assms(6) ax_uniqueness col_def distinct6_def
        incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "line B C' = line B' C"
    by (smt \<open>line A B' = line A' B \<Longrightarrow> col P Q R\<close> assms(1) assms(2) assms(3) ax_uniqueness col_def
        distinct6_def incidA_lAB incidB_lAB that)
  have "col P Q R" if "line A C' = line A' C"
    by (smt \<open>line B C' = line B' C \<Longrightarrow> col P Q R\<close> assms(1) assms(2) assms(3) assms(7) ax_uniqueness
        col_def distinct6_def incidA_lAB incidB_lAB)
  show "col P Q R"
    using \<open>line A B' = line A' B \<Longrightarrow> col P Q R\<close> \<open>line A C' = line A' C \<Longrightarrow> col P Q R\<close>
      \<open>line B C' = line B' C \<Longrightarrow> col P Q R\<close> assms(7)
    by blast
qed

lemma pappus12:
  assumes "is_pappus1 A B C A' B' C' P Q R"
  shows "is_pappus2 A B C A' B' C' P Q R"
proof -
  have "col P Q R" if "(A \<noteq> B' \<and> A'\<noteq> B \<and> line A B' \<noteq> line A' B \<and>
  B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
  A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C)" and h1:"col A B C" and h2:"col A' B' C'"
  and "is_a_intersec P A B' A' B" and "is_a_intersec Q B C' B' C"
  and "is_a_intersec R A C' A' C"
  proof -
    have "col P Q R" if "A = B" (* in this case P = A = B and P, Q, R lie on AC' *)
    proof -
      have "P = A"
        by (metis \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
  \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> ax_uniqueness col_def
            incidA_lAB incidB_lAB is_a_intersec_def that)
      have "col P A C' \<and> col Q A C' \<and> col R A C'"
        using \<open>P = A\<close> \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> col_AAB
          is_a_intersec_def that
        by auto
      then show "col P Q R"
        by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
          \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> ax_uniqueness col_def)
  qed
  have "col P Q R" if "A = C" (* case where P = A = C = Q and P,Q,R belong to AB' *)
  proof -
    have "R = A"
      by (metis \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
        \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
    have "col P A B' \<and> col Q A B' \<and> col R A B'"
      using \<open>R = A\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close> col_def
        is_a_intersec_def that
      by auto
    then show "col P Q R"
      by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
        \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> ax_uniqueness col_def)
  qed
  have "col P Q R" if "A = A'" (* very degenerate case, all the 9 points are collinear*)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec R A C' A' C\<close>
        ax_uniqueness col_ABA col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "B = C" (* case where B = C = Q and P,Q,R belong to A'B *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "B = B'" (* very degenerate case, the 9 points are collinear *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        ax_uniqueness col_AAB col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "C = C'" (* again, very degenerate case, the 9 points are collinear *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close>
        ax_uniqueness col_ABB col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "A' = B'" (* case where P = A' = B', and P,Q,R belong to A'C *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "A' = C'" (* case where R = A' = B', the points P,Q,R belong to A'B *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "B' = C'" (* case where Q = B' = C', the points P,Q,R belong to AB' *)
    by (smt \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
      A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> \<open>is_a_intersec Q B C' B' C\<close>
        \<open>is_a_intersec R A C' A' C\<close> ax_uniqueness col_def incidA_lAB incidB_lAB is_a_intersec_def that)
  have "col P Q R" if "A \<noteq> B \<and> A \<noteq> C \<and> A \<noteq> A' \<and> B \<noteq> C \<and> B \<noteq> B' \<and> C \<noteq> C' \<and> A'\<noteq> B'
    \<and> A' \<noteq> C' \<and> B' \<noteq> C'"
  proof -
    have a1:"distinct [A,B,C,A',B',C']"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> distinct6_def that
      by auto
    have "is_a_proper_intersec P A B' A' B"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec P A B' A' B\<close> is_a_intersec_def
        is_a_proper_intersec_def
      by auto
    have "is_a_proper_intersec Q B C' B' C"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec Q B C' B' C\<close> is_a_intersec_def
        is_a_proper_intersec_def
      by auto
    have "is_a_proper_intersec R A C' A' C"
      using \<open>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C \<and>
        A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C\<close> \<open>is_a_intersec R A C' A' C\<close> is_a_intersec_def
        is_a_proper_intersec_def
      by auto
    show "col P Q R"
      using \<open>is_a_proper_intersec P A B' A' B\<close> \<open>is_a_proper_intersec Q B C' B' C\<close>
        \<open>is_a_proper_intersec R A C' A' C\<close> a1 assms h1 h2 is_pappus1_def
      by blast
  qed
    show "col P Q R"
      using \<open>A = A' \<Longrightarrow> col P Q R\<close> \<open>A = B \<Longrightarrow> col P Q R\<close> \<open>A = C \<Longrightarrow> col P Q R\<close>
        \<open>A \<noteq> B \<and> A \<noteq> C \<and> A \<noteq> A' \<and> B \<noteq> C \<and> B \<noteq> B' \<and> C \<noteq> C' \<and> A' \<noteq> B' \<and> A' \<noteq> C' \<and> B' \<noteq> C' \<Longrightarrow> col P Q R\<close>
        \<open>A' = B' \<Longrightarrow> col P Q R\<close> \<open>A' = C' \<Longrightarrow> col P Q R\<close> \<open>B = B' \<Longrightarrow> col P Q R\<close> \<open>B = C \<Longrightarrow> col P Q R\<close>
        \<open>B' = C' \<Longrightarrow> col P Q R\<close> \<open>C = C' \<Longrightarrow> col P Q R\<close>
      by blast
  qed
  have "col P Q R" if "distinct [A,B,C,A',B',C']" and "col A B C" and "col A' B' C'"
    and "is_a_intersec P A B' A' B" and "is_a_intersec Q B C' B' C" and "is_a_intersec R A C' A' C"
  proof -
    have "col P Q R" if "line A B' = line A' B"
      using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_intersec P A B' A' B\<close>
        \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> degenerate_hexagon_is_pappus that
      by blast
    have "col P Q R" if "line B C' = line B' C"
      using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_intersec P A B' A' B\<close>
        \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> degenerate_hexagon_is_pappus that
      by blast
    have "col P Q R" if "line A' C = line A C'"
      using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_intersec P A B' A' B\<close>
        \<open>is_a_intersec Q B C' B' C\<close> \<open>is_a_intersec R A C' A' C\<close> degenerate_hexagon_is_pappus that
      by auto
    have "col P Q R" if "line A B' \<noteq> line A' B" and "line B C' \<noteq> line B' C" and
      "line A C' \<noteq> line A' C"
    proof -
      have "is_a_proper_intersec P A B' A' B"
        using \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_intersec P A B' A' B\<close> distinct6_def is_a_intersec_def
          is_a_proper_intersec_def that(1)
        by auto
      have "is_a_proper_intersec Q B C' B' C"
        using \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_intersec Q B C' B' C\<close> distinct6_def is_a_intersec_def
          is_a_proper_intersec_def that(2)
        by auto
      have "is_a_proper_intersec R A C' A' C"
        using \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_intersec R A C' A' C\<close> distinct6_def is_a_intersec_def
          is_a_proper_intersec_def that(3)
        by auto
      show "col P Q R"
        using \<open>col A B C\<close> \<open>col A' B' C'\<close> \<open>distinct [A,B,C,A',B',C']\<close> \<open>is_a_proper_intersec P A B' A' B\<close>
          \<open>is_a_proper_intersec Q B C' B' C\<close> \<open>is_a_proper_intersec R A C' A' C\<close> assms is_pappus1_def
        by blast
    qed
    show "col P Q R"
      using \<open>\<lbrakk>line A B' \<noteq> line A' B; line B C' \<noteq> line B' C; line A C' \<noteq> line A' C\<rbrakk> \<Longrightarrow> col P Q R\<close>
        \<open>line A B' = line A' B \<Longrightarrow> col P Q R\<close> \<open>line A' C = line A C' \<Longrightarrow> col P Q R\<close>
        \<open>line B C' = line B' C \<Longrightarrow> col P Q R\<close>
      by fastforce
  qed
  show "is_pappus2 A B C A' B' C' P Q R"
    by (simp add: \<open>\<lbrakk>A \<noteq> B' \<and> A' \<noteq> B \<and> line A B' \<noteq> line A' B \<and> B \<noteq> C' \<and> B' \<noteq> C \<and> line B C' \<noteq> line B' C
      \<and> A \<noteq> C' \<and> A' \<noteq> C \<and> line A C' \<noteq> line A' C; col A B C; col A' B' C'; is_a_intersec P A B' A' B; is_a_intersec Q B C' B' C; is_a_intersec R A C' A' C\<rbrakk> \<Longrightarrow> col P Q R\<close>
        \<open>\<lbrakk>distinct [A,B,C,A',B',C']; col A B C; col A' B' C'; is_a_intersec P A B' A' B; is_a_intersec Q B C' B' C; is_a_intersec R A C' A' C\<rbrakk> \<Longrightarrow> col P Q R\<close>
        is_pappus2_def)
qed

lemma pappus_equiv: "is_pappus1 A B C A' B' C' P Q R = is_pappus2 A B C A' B' C' P Q R"
  using pappus12 pappus21
  by blast

(* Finally, we give Pappus's property for a plane stating that the diagonal points
of any hexagon of that plane, whose vertices lie alternately on two lines, are collinear *)

definition is_pappus :: "bool" where
"is_pappus \<equiv> \<forall>A B C D E F P Q R. is_pappus2 A B C D E F P Q R"

end

end


section\<open>Examples of Reasoning in ZF Set Theory\<close>

theory ZF_examples imports ZFC begin

subsection \<open>Binary Trees\<close>

consts
  bt :: "i => i"

datatype "bt(A)" =
  Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")

declare bt.intros [simp]

text\<open>Induction via tactic emulation\<close>
lemma Br_neq_left [rule_format]: "l \<in> bt(A) ==> \<forall>x r. Br(x, l, r) \<noteq> l"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
  apply (induct_tac l)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
  apply auto
  done

(*
  apply (Inductive.case_tac l)
  apply (tactic {*exhaust_tac "l" 1*})
*)

text\<open>The new induction method, which I don't understand\<close>
lemma Br_neq_left': "l \<in> bt(A) ==> (!!x r. Br(x, l, r) \<noteq> l)"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
  apply (induct set: bt)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
  apply auto
  done

lemma Br_iff: "Br(a,l,r) = Br(a',l',r') <-> a=a' & l=l' & r=r'"
  \<comment> \<open>Proving a freeness theorem.\<close>
  by (blast elim!: bt.free_elims)

inductive_cases Br_in_bt: "Br(a,l,r) \<in> bt(A)"
  \<comment> \<open>An elimination rule, for type-checking.\<close>

text \<open>
@{thm[display] Br_in_bt[no_vars]}
\<close>

subsection\<open>Primitive recursion\<close>

consts  n_nodes :: "i => i"
primrec
  "n_nodes(Lf) = 0"
  "n_nodes(Br(a,l,r)) = succ(n_nodes(l) #+ n_nodes(r))"

lemma n_nodes_type [simp]: "t \<in> bt(A) ==> n_nodes(t) \<in> nat"
  by (induct_tac t, auto)

consts  n_nodes_aux :: "i => i"
primrec
  "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
  "n_nodes_aux(Br(a,l,r)) =
      (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"

lemma n_nodes_aux_eq [rule_format]:
     "t \<in> bt(A) ==> \<forall>k \<in> nat. n_nodes_aux(t)`k = n_nodes(t) #+ k"
  by (induct_tac t, simp_all)

definition n_nodes_tail :: "i => i" where
   "n_nodes_tail(t) == n_nodes_aux(t) ` 0"

lemma "t \<in> bt(A) ==> n_nodes_tail(t) = n_nodes(t)"
 by (simp add: n_nodes_tail_def n_nodes_aux_eq)

subsection \<open>Inductive definitions\<close>

consts  Fin       :: "i=>i"
inductive
  domains   "Fin(A)" \<subseteq> "Pow(A)"
  intros
    emptyI:  "0 \<in> Fin(A)"
    consI:   "[| a \<in> A;  b \<in> Fin(A) |] ==> cons(a,b) \<in> Fin(A)"
  type_intros  empty_subsetI cons_subsetI PowI
  type_elims   PowD [elim_format]

consts  acc :: "i => i"
inductive
  domains "acc(r)" \<subseteq> "field(r)"
  intros
    vimage:  "[| r-``{a}: Pow(acc(r)); a \<in> field(r) |] ==> a \<in> acc(r)"
  monos      Pow_mono

consts
  llist  :: "i=>i"

codatatype
  "llist(A)" = LNil | LCons ("a \<in> A", "l \<in> llist(A)")

(*Coinductive definition of equality*)
consts
  lleq :: "i=>i"

(*Previously used <*> in the domain and variant pairs as elements.  But
  standard pairs work just as well.  To use variant pairs, must change prefix
  a q/Q to the Sigma, Pair and converse rules.*)
coinductive
  domains "lleq(A)" \<subseteq> "llist(A) * llist(A)"
  intros
    LNil:  "<LNil, LNil> \<in> lleq(A)"
    LCons: "[| a \<in> A; <l,l'> \<in> lleq(A) |]
            ==> <LCons(a,l), LCons(a,l')> \<in> lleq(A)"
  type_intros  llist.intros

subsection\<open>Powerset example\<close>

lemma Pow_mono: "A\<subseteq>B  ==>  Pow(A) \<subseteq> Pow(B)"
apply (rule subsetI)
apply (rule PowI)
apply (drule PowD)
apply (erule subset_trans, assumption)
done

lemma "Pow(A Int B) = Pow(A) Int Pow(B)"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule equalityI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule Int_greatest)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule Int_lower1 [THEN Pow_mono])
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule Int_lower2 [THEN Pow_mono])
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule subsetI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule IntE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule PowI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (drule PowD)+
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule Int_greatest)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (assumption+)
done

text\<open>Trying again from the beginning in order to use \<open>blast\<close>\<close>
lemma "Pow(A Int B) = Pow(A) Int Pow(B)"
by blast

lemma "C\<subseteq>D ==> Union(C) \<subseteq> Union(D)"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule subsetI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule UnionE)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule UnionI)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule subsetD)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
done

text\<open>A more abstract version of the same proof\<close>

lemma "C\<subseteq>D ==> Union(C) \<subseteq> Union(D)"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule Union_least)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule Union_upper)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (erule subsetD, assumption)
done

lemma "[| a \<in> A;  f \<in> A->B;  g \<in> C->D;  A \<inter> C = 0 |] ==> (f \<union> g)`a = f`a"
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule apply_equality)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule UnI1)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule apply_Pair)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply (rule fun_disjoint_Un)
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
  \<comment> \<open>@{subgoals[display,indent=0,margin=65]}\<close>
apply assumption
done

end


(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Omega Algebras *}

theory Omega_Algebra
imports "$AFP/Kleene_Algebra/Kleene_Algebra"
begin

text {*
\emph{Omega algebras}~\cite{cohen00omega} extend Kleene algebras by an
$\omega$-operation that axiomatizes infinite iteration (just like the
Kleene star axiomatizes finite iteration).
*}

subsection {* Left Omega Algebras *}

text {*
In this section we consider \emph{left omega algebras}, i.e., omega
algebras based on left Kleene algebras. Surprisingly, we are still
looking for statements mentioning~$\omega$ that are true in omega
algebras, but do not already hold in left omega algebras.
*}

class left_omega_algebra_zerol = left_kleene_algebra_zerol + omega_op +
  assumes omega_unfold_eq [simp]: "x \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
  and omega_coinduct: "y \<le> z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
begin

lemma omega_unfold: "x\<cdot>x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_unfold_eq order_refl)

lemma omega_zeror: "x\<^sup>\<star>\<cdot>0 \<le> x\<^sup>\<omega>"
  apply (rule star_inductl[rule_format])
  by (simp add: omega_unfold)

text {* First we prove some variants of the coinduction axiom. *}

lemma omega_coinduct_var2: "y \<le> x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (auto intro: omega_coinduct[where z = 0, simplified, rule_format])

lemma omega_coinduct_var1: "y \<le> 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (metis mult_oner omega_coinduct)

lemma omega_coinduct_eq: "y = z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (metis eq_refl omega_coinduct)

lemma omega_coinduct_eq_var1: "y = 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (metis eq_refl omega_coinduct_var1)

lemma  omega_coinduct_eq_var2: "y = x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (metis eq_refl omega_coinduct_var2)

text {* Next we strengthen the unfold law to an equation. *}

lemma omega_unfold_var: "z + x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (simp add: local.omega_coinduct)

text {* We now prove subdistributivity and isotonicity of omega. *}

lemma omega_subdist: "x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<le> (x + y) \<cdot> x\<^sup>\<omega>"
    by auto
  thus ?thesis
    by (metis omega_coinduct_var2)
qed

lemma omega_iso: "x \<le> y \<longrightarrow> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  by (metis less_eq_def omega_subdist)

lemma omega_subdist_var: "x\<^sup>\<omega> + y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (simp add: omega_iso)

lemma zero_omega [simp]: "0\<^sup>\<omega> = 0"
  by (metis annil omega_unfold_eq)

text {* The next lemma is another variant of omega unfold *}

lemma star_omega_1 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis eq_refl omega_unfold_eq)
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis star_inductl_var)
  show "x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    by (metis star_ref mult_isor mult_onel)
qed

text {* The next lemma says that~@{term "1\<^sup>\<omega>"} is the maximal element
of omega algebra. We therefore baptise it~$\top$. *}

lemma max_element: "x \<le> 1\<^sup>\<omega>"
  by (metis eq_refl mult_onel omega_coinduct_var2)

definition omega_top ("\<top>")
  where "\<top> = 1\<^sup>\<omega>"

lemma star_omega_3 [simp]: "(x\<^sup>\<star>)\<^sup>\<omega> = \<top>"
proof -
  have "1 \<le> x\<^sup>\<star>"
    by (fact star_ref)
  hence "\<top> \<le> (x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis omega_iso omega_top_def)
  thus ?thesis
    by (metis eq_iff max_element omega_top_def)
qed

text {* The following lemma is strange since it is counterintuitive
that one should be able to append something after an infinite
iteration. *}

lemma omega_1: "x\<^sup>\<omega> \<cdot> y \<le> x\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<cdot> y \<le> x \<cdot> x\<^sup>\<omega> \<cdot> y"
    by (metis eq_refl omega_unfold_eq)
  thus ?thesis
    by (metis mult.assoc omega_coinduct_var2)
qed

lemma omega_sup_id: "1 \<le> y \<longrightarrow> x\<^sup>\<omega> \<cdot> y = x\<^sup>\<omega>"
  by (metis eq_iff mult_isol mult_oner omega_1)

lemma omega_top [simp]: "x\<^sup>\<omega> \<cdot> \<top> = x\<^sup>\<omega>"
  by (metis max_element omega_sup_id omega_top_def)

lemma supid_omega: "1 \<le> x \<longrightarrow> x\<^sup>\<omega> = \<top>"
  by (metis eq_iff max_element omega_iso omega_top_def)

text {* Next we prove a simulation law for the omega operation *}

lemma omega_simulation: "z \<cdot> x \<le> y \<cdot> z \<longrightarrow> z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
proof
  assume "z \<cdot> x \<le> y \<cdot> z"
  also have "z \<cdot> x\<^sup>\<omega> = z \<cdot> x \<cdot> x\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  moreover have "... \<le> y \<cdot> z \<cdot> x\<^sup>\<omega>"
    by (metis mult_isor calculation)
  thus "z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
    by (metis calculation(2) mult_assoc omega_coinduct_var2)
qed

text {* Next we prove transitivity of omega elements. *}

lemma omega_trans: "x\<^sup>\<omega> \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (fact omega_1)

lemma omega_omega: "(x\<^sup>\<omega>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_1 omega_unfold_eq)

text {* The next lemmas are axioms of Wagner's complete axiomatisation
for omega-regular languages~\cite{Wagner77omega}, but in a slightly
different setting.  *}

lemma wagner_1 [simp]: "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x \<cdot> x\<^sup>\<star> \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc star_slide_var)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc star_trans_eq)
  also have "... = x \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  thus "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis calculation eq_refl omega_coinduct_var2)
   show "x\<^sup>\<omega> \<le> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult_isol mult_oner omega_iso star_ref)
qed

lemma wagner_2_var: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
proof -
  have "x \<cdot> y \<cdot> x \<le> x \<cdot> y \<cdot> x"
    by auto
  thus "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (metis mult.assoc omega_simulation)
qed

lemma wagner_2 [simp]: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> = (x \<cdot> y)\<^sup>\<omega>"
proof (rule antisym)
  show "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (rule wagner_2_var)
  have "(x \<cdot> y)\<^sup>\<omega> = x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<omega>"
    by (metis omega_unfold_eq)
  thus "(x \<cdot> y)\<^sup>\<omega> \<le> x \<cdot> (y \<cdot> x)\<^sup>\<omega>"
    by (metis mult.assoc mult_isol wagner_2_var)
qed

text {*
This identity is called~(A8) in Wagner's paper.
*}

lemma wagner_3:
assumes "x \<cdot> (x + y)\<^sup>\<omega> + z = (x + y)\<^sup>\<omega>"
shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
proof (rule antisym)
  show  "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    by (metis add.commute assms omega_coinduct_eq)
  have "x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    by (metis add.commute assms star_inductl_eq)
  thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    by (simp add: omega_subdist)
qed

text {*
This identity is called~(R4) in Wagner's paper.
*}

lemma wagner_1_var [simp]: "(x\<^sup>\<star> \<cdot> x)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis star_slide_var wagner_1)

lemma star_omega_4 [simp]: "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega>"
proof (rule antisym)
  have "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by simp
  also have "... \<le> 1 + x\<^sup>\<omega> \<cdot> \<top>"
    using calculation local.boffa_var omega_trans by auto
  thus "(x\<^sup>\<omega>)\<^sup>\<star> \<le> 1 + x\<^sup>\<omega>"
    by (metis calculation omega_top)
  show "1 + x\<^sup>\<omega> \<le> (x\<^sup>\<omega>)\<^sup>\<star>"
    by (metis star2 star_ext)
qed

lemma star_omega_5 [simp]: "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> = x\<^sup>\<omega>"
proof (rule antisym)
  show "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> \<le> x\<^sup>\<omega>"
    by (rule omega_1)
  show "x\<^sup>\<omega> \<le> x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by (metis mult_oner star_ref mult_isol)
qed

text {* The next law shows how omegas below a sum can be unfolded. *}

lemma omega_sum_unfold: "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<omega> = (x + y)\<^sup>\<omega>"
proof -
  have "(x + y)\<^sup>\<omega> = x \<cdot> (x + y)\<^sup>\<omega> + y \<cdot> (x+y)\<^sup>\<omega>"
    by (metis distrib_right omega_unfold_eq)
  thus ?thesis
    by (metis mult.assoc wagner_3)
qed

text {*
The next two lemmas apply induction and coinduction to this law.
*}

lemma omega_sum_unfold_coind: "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
  by (metis omega_coinduct_eq omega_sum_unfold)

lemma omega_sum_unfold_ind: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (metis omega_sum_unfold star_inductl_eq)

lemma wagner_1_gen: "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> ((x + y) \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<omega>"
    using local.join.sup.bounded_iff local.join.sup_ge1 local.mult_isol_var local.star_subdist_var omega_iso by presburger
  thus ?thesis
    by (metis wagner_1)
qed

lemma wagner_1_var_gen: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis wagner_2)
  also have "... \<le> x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute mult_isol wagner_1_gen)
  also have "... \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using local.mult_isor local.star_subdist by auto
  thus ?thesis
    by (metis calculation order_trans star_omega_1)
qed

text {* The next lemma is a variant of the denest law for the star at
the level of omega. *}

lemma omega_denest [simp]: "(x + y)\<^sup>\<omega> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
proof (rule antisym)
  show "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    by (rule omega_sum_unfold_coind)
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le>  (x + y)\<^sup>\<omega>"
    by (rule wagner_1_var_gen)
  hence "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (metis omega_sum_unfold_ind)
  thus "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (simp add: wagner_1_var_gen)
qed

text {* The next lemma yields a separation theorem for infinite
iteration in the presence of a quasicommutation property. A
nondeterministic loop over~@{term x} and~@{term y} can be refined into
separate infinite loops over~@{term x} and~@{term y}.  *}

lemma omega_sum_refine:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
proof (rule antisym)
  have "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    by (metis assms quasicomm_var)
  also have "(x + y)\<^sup>\<omega> = y\<^sup>\<omega> + y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute omega_sum_unfold)
  moreover have "... \<le> x \<cdot> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega> + y\<^sup>\<omega>"
    by (smt abel_semigroup.commute calculation(1) local.add.abel_semigroup_axioms local.combine_common_factor local.join.sup.orderE local.join.sup_ge2)
  moreover have "... \<le> x \<cdot> (x + y)\<^sup>\<omega> + y\<^sup>\<omega>"
    by (metis mult.assoc order_refl star_omega_1)
  thus "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
    by (metis add.commute calculation mult.assoc omega_coinduct star_omega_1)
  have "x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (rule omega_subdist)
  moreover have "x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis calculation(2) local.subdistl)
  moreover have"... \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
     using local.mult_isor local.star_subdist by blast
  moreover have "... = (x + y)\<^sup>\<omega>"
     by (rule star_omega_1)
   thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
     by (metis calculation(4) calculation(5) calculation(6) local.join.sup.boundedI local.order_trans)
qed

text {* The following theorem by Bachmair and
Dershowitz~\cite{bachmair86commutation} is a corollary. *}

lemma bachmair_dershowitz:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = 0 \<longleftrightarrow> x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
proof
  assume "(x + y)\<^sup>\<omega> = 0"
  show "x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
    using \<open>(x + y)\<^sup>\<omega> = 0\<close> local.join.bot_unique omega_subdist_var by blast
next
  assume "x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
  show "(x + y)\<^sup>\<omega> = 0"
    by (metis \<open>x\<^sup>\<omega> + y\<^sup>\<omega> = 0\<close> assms local.add.monoid_axioms local.no_trivial_inverse monoid.left_neutral omega_sum_refine star_omega_1)
qed

text {*
The next lemmas consider an abstract variant of the empty word
property from language theory and match it with the absence of
infinite iteration~\cite{struth12regeq}.
*}

definition (in dioid_one_zerol) ewp
where "ewp x \<equiv> \<not>(\<forall>y. y \<le> x \<cdot> y \<longrightarrow> y = 0)"

lemma ewp_super_id1: "0 \<noteq> 1 \<longrightarrow> 1 \<le> x \<longrightarrow> ewp x"
  by (metis ewp_def mult_1_right)

text {* The next facts relate the absence of the empty word property
with the absence of infinite iteration. *}

lemma ewp_neg_and_omega: "\<not> ewp x \<longleftrightarrow> x\<^sup>\<omega> = 0"
proof
  assume "\<not> ewp x"
  hence a: "\<forall>y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    by (metis ewp_def)
  thus "x\<^sup>\<omega> = 0"
    by (metis eq_refl omega_unfold_eq)
next
  assume "x\<^sup>\<omega> = 0"
  hence "\<forall> y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    using local.join.le_bot local.omega_coinduct_var2 by blast
  thus "\<not> ewp x"
    by (metis ewp_def)
qed

lemma ewp_alt1: "(\<forall>z. x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> z) \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  by (metis add_comm less_eq_def omega_coinduct omega_unfold_eq order_prop)

(*
lemma ewp_alt: "x\<^sup>\<omega> = 0 \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  nitpick [expect = genuine]
oops
*)

text {* So we have obtained a condition for Arden's lemma in omega
algebra.  *}

lemma omega_super_id1: "0 \<noteq> 1 \<longrightarrow> 1 \<le> x \<longrightarrow> x\<^sup>\<omega> \<noteq> 0"
  using ewp_neg_and_omega ewp_super_id1 by blast

lemma omega_super_id2: "0 \<noteq> 1 \<longrightarrow> x\<^sup>\<omega> = 0 \<longrightarrow> \<not>(1 \<le> x)"
  by (metis omega_super_id1)

text {* The next lemmas are abstract versions of Arden's lemma from
language theory.  *}

lemma ardens_lemma_var:
  assumes "x\<^sup>\<omega> = 0" and  "z + x \<cdot> y = y"
  shows "x\<^sup>\<star> \<cdot> z = y"
proof -
  have "y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    by (metis assms omega_coinduct order_refl)
  hence "y \<le> x\<^sup>\<star> \<cdot> z"
    by (metis add_zero_l assms)
  thus "x\<^sup>\<star> \<cdot> z = y"
    by (metis assms eq_iff star_inductl_eq)
qed

lemma ardens_lemma: "\<not> ewp x \<longrightarrow> z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y"
  by (metis ardens_lemma_var ewp_neg_and_omega)

lemma ardens_lemma_equiv:
  assumes "\<not> ewp x"
  shows "z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y"
proof
  assume "z + x \<cdot> y = y"
  thus "x\<^sup>\<star> \<cdot> z = y"
    by (metis ardens_lemma assms)
next
  assume "x\<^sup>\<star> \<cdot> z = y"
  also have "z + x \<cdot> y = z + x \<cdot> x\<^sup>\<star> \<cdot> z"
    by (metis calculation mult.assoc)
  moreover have "... = (1 + x \<cdot> x\<^sup>\<star>) \<cdot> z"
    by (metis distrib_right mult_onel)
  moreover have "... = x\<^sup>\<star> \<cdot> z"
    by (metis star_unfoldl_eq)
  thus "z + x \<cdot> y = y"
    by (metis calculation)
qed

lemma ardens_lemma_var_equiv: "x\<^sup>\<omega> = 0 \<longrightarrow> (z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y)"
  by (metis ardens_lemma_equiv ewp_neg_and_omega)

lemma inf_star [simp]: "(x\<cdot>0)\<^sup>\<star> = 1 + x\<cdot>0"
  apply (rule antisym)
  apply (rule star_inductl_one[rule_format])
  apply (metis annil mult_assoc order_refl)
  by simp

lemma [simp]: "x \<cdot> 0 \<cdot> y = x \<cdot> 0"
  by (metis annil mult_assoc)

lemma inf_part_star1: "(y + x\<cdot>0)\<^sup>\<star> \<le> y\<^sup>\<star>\<cdot>x\<cdot>0 + y\<^sup>\<star>"
  apply (rule star_inductl_one[rule_format])
  apply (subst star_unfoldl_eq[symmetric]) back back
  apply (subst star_unfoldl_eq[symmetric]) back back back
  apply (simp only: distrib_right distrib_left mult_assoc[symmetric])
  apply (simp add: distrib_left)
  using local.dual_order.trans local.join.sup.cobounded1 local.join.sup_ge2 local.star_1l local.star_ref by blast

lemma inf_part_star [simp]: "(y + x\<cdot>0)\<^sup>\<star> = y\<^sup>\<star>\<cdot>x\<cdot>0 + y\<^sup>\<star>"
  apply (rule antisym)
  apply (metis inf_part_star1)
  by (metis local.boffa local.conway.dagger_denest local.mult.semigroup_axioms local.star_denest local.star_ext local.star_plus_one local.star_trans_eq semigroup.assoc)

(*
lemma arden_conv1: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longrightarrow> \<not> ewp x"
  nitpick [expect = genuine]
oops

lemma arden_conv2: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longrightarrow> x\<^sup>\<omega> = 0"
  nitpick [expect = genuine]
oops

lemma arden_var3: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longleftrightarrow> x\<^sup>\<omega> = 0"
  nitpick [expect = genuine]
oops
*)

end

end


theory Ex03_
imports Main "~~/src/HOL/IMP/AExp"
begin

inductive is_aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
  N: "is_aval (N n) s n"
| V: "is_aval (V x) s (s x)"
| P: "\<lbrakk> is_aval a1 s v1; is_aval a2 s v2 \<rbrakk> \<Longrightarrow> is_aval (Plus a1 a2) s (v1 + v2)"

lemma "is_aval (Plus (N 2) (Plus (V x) (N 3))) s (2 + (s x + 3))"
  apply(rule is_aval.intros)+
  done

lemma aval1: "is_aval a s v \<Longrightarrow> aval a s = v"
  apply(induction a)
  apply()

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Algebraic Number Tests\<close>

text \<open>We provide a sequence of examples which demonstrate what can be done with
  the implementation of algebraic numbers.\<close>

theory Algebraic_Number_Tests
imports
  Jordan_Normal_Form.Char_Poly
  Jordan_Normal_Form.Determinant_Impl
  Show.Show_Complex
  "HOL-Library.Code_Target_Nat"
  "HOL-Library.Code_Target_Int"
  Berlekamp_Zassenhaus.Factorize_Rat_Poly
  Real_Factorization
  Show_Real_Precise
begin

subsection \<open>Stand-Alone Examples\<close>

abbreviation (input) "show_lines x \<equiv> shows_lines x Nil"

fun show_factorization :: "'a :: {semiring_1,show} \<times> (('a poly \<times> nat)list) \<Rightarrow> string" where
  "show_factorization (c,[]) = show c"
| "show_factorization (c,((p,i) # ps)) = show_factorization (c,ps) @ '' * ('' @ show p @ '')'' @
  (if i = 1 then [] else ''^'' @ show i)"

definition show_sf_factorization :: "'a :: {semiring_1,show} \<times> (('a poly \<times> nat)list) \<Rightarrow> string" where
  "show_sf_factorization x = show_factorization (map_prod id (map (map_prod id Suc)) x)
     "

text \<open>Determine the roots over the rational, real, and complex numbers.\<close>

definition "testpoly = [:5/2, -7/2, 1/2, -5, 7, -1, 5/2, -7/2, 1/2:]"
definition "test = show_lines (   real_roots_of_rat_poly testpoly)"

value [code] "show_lines (        roots_of_rat_poly testpoly)"
value [code] "show_lines (   real_roots_of_rat_poly testpoly)"
value [code] "show_lines (complex_roots_of_rat_poly testpoly)"

text \<open>Factorize polynomials over the rational, real, and complex numbers.\<close>

value [code] "show_sf_factorization (factorize_rat_poly testpoly)"
value [code] "show_factorization (the (factorize_real_poly testpoly))"
value [code] "show_factorization (the (factorize_complex_poly testpoly))"

text \<open>If the input is not a rational polynomial, factorization can fail.\<close>

value [code] "factorize_real_poly [:sqrt 2,1,3,1:]" text \<open>fails\\\<close>
value [code] "factorize_real_poly [:sqrt 2,1,3:]" text \<open>does not fail, reveals internal representation\\\<close>
value [code] "show (factorize_real_poly [:sqrt 2,1,3:])" text \<open>does not fail, pretty printed\<close>

text \<open>A sequence of calculations.\<close>

value [code] "show (- sqrt 2 - sqrt 3)"
lemma "root 3 4 > sqrt (root 4 3) + \<lfloor>1/10 * root 3 7\<rfloor>" by eval
lemma "csqrt (4 + 3 * \<i>) \<notin> \<real>" by eval
value [code] "show (csqrt (4 + 3 * \<i>))"
value [code] "show (csqrt (1 + \<i>))"

subsection \<open>Example Application: Compute Norms of Eigenvalues\<close>

text \<open>For complexity analysis of some matrix $A$ it is important to compute the spectral
  radius of a matrix, i.e., the maximal norm of all complex eigenvalues,
  since the spectral radius determines
  the growth rates of matrix-powers $A^n$, cf.~\cite{JNF-AFP} for a formalized statement
  of this fact.\<close>

definition eigenvalues :: "rat mat \<Rightarrow> complex list" where
  "eigenvalues A = complex_roots_of_rat_poly (char_poly A)"

definition "testmat = mat_of_rows_list 3 [
  [1,-4,2],
  [1/5,7,9],
  [7,1,5 :: rat]
  ]"

definition "spectral_radius_test = show (Max (set [ norm ev. ev \<leftarrow> eigenvalues testmat]))"
value [code] "char_poly testmat"
value [code] spectral_radius_test

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_nat_BubSortCount
  imports "../../Test_Base"
begin

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

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

datatype Nat = Z | S "Nat"

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

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

fun bubble :: "Nat list => (bool, (Nat list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if le 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 :: "Nat list => Nat list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "((count x (bubsort xs)) = (count x xs))"
  oops

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

section "Regular Expressions Equivalence Framework"

(*<*)
theory Automaton
imports "Regular-Sets.Regular_Exp" "HOL-Library.While_Combinator"
begin
(*>*)

primrec add_atoms :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "add_atoms Zero = id"
| "add_atoms One = id"
| "add_atoms (Atom a) = List.insert a"
| "add_atoms (Plus r s) = add_atoms s o add_atoms r"
| "add_atoms (Times r s) = add_atoms s o add_atoms r"
| "add_atoms (Star r) = add_atoms r"

lemma set_add_atoms: "set (add_atoms r as) = atoms r \<union> set as"
by (induction r arbitrary: as) auto

lemma rtrancl_fold_product:
shows "{((r,s),(f a r,f a s))| r s a. a : A}^* =
       {((r,s),(fold f w r,fold f w s))| r s w. w : lists A}" (is "?L = ?R")
proof-
  { fix r s r' s'
    have "((r,s),(r',s')) : ?L \<Longrightarrow> ((r,s),(r',s')) : ?R"
    proof(induction rule: converse_rtrancl_induct2)
      case refl show ?case by(force intro!: fold_simps(1)[symmetric])
    next
      case step thus ?case by(force intro!: fold_simps(2)[symmetric])
    qed
  } moreover
  { fix r s r' s'
    { fix w have "\<forall>x\<in>set w. x \<in> A \<Longrightarrow> ((r, s), fold f w r, fold f w s) :?L"
      proof(induction w rule: rev_induct)
        case Nil show ?case by simp
      next
        case snoc thus ?case by (auto elim!: rtrancl_into_rtrancl)
      qed
    }
    hence "((r,s),(r',s')) : ?R \<Longrightarrow> ((r,s),(r',s')) : ?L" by auto
  } ultimately show ?thesis by (auto simp: in_lists_conv_set) blast
qed

lemma rtrancl_fold_product1:
shows "{(r,s). \<exists>a \<in> A. s = f a r}^* =
       {(r,fold f w r) | r w. w : lists A}" (is "?L = ?R")
proof-
  { fix r s
    have "(r,s) : ?L \<Longrightarrow> (r,s) : ?R"
    proof(induction rule: converse_rtrancl_induct)
      case base show ?case by(force intro!: fold_simps(1)[symmetric])
    next
      case step thus ?case by(force intro!: fold_simps(2)[symmetric])
    qed
  } moreover
  { fix r s
    { fix w have "\<forall>x\<in>set w. x \<in> A \<Longrightarrow> (r, fold f w r) :?L"
      proof(induction w rule: rev_induct)
        case Nil show ?case by simp
      next
        case snoc thus ?case by (auto elim!: rtrancl_into_rtrancl)
      qed
    }
    hence "(r,s) : ?R \<Longrightarrow> (r,s) : ?L" by auto
  } ultimately show ?thesis by (auto simp: in_lists_conv_set) blast
qed

locale rexp_DA =
fixes init :: "'a rexp \<Rightarrow> 's"
fixes delta :: "'a \<Rightarrow> 's \<Rightarrow> 's"
fixes final :: "'s \<Rightarrow> bool"
fixes L :: "'s \<Rightarrow> 'a lang"
assumes L_init: "L (init r) = lang r"
assumes L_delta: "L(delta a s) = Deriv a (L s)"
assumes final_iff_Nil: "final s \<longleftrightarrow> [] \<in> L s"
begin

lemma L_deltas: "L (fold delta w s) = fold Deriv w (L s)"
  by (induction w arbitrary: s) (auto simp add: L_delta)

definition closure :: "'a list \<Rightarrow> 's * 's \<Rightarrow> (('s * 's) list * ('s * 's) set) option"
where
"closure as = rtrancl_while (\<lambda>(p,q). final p = final q)
          (\<lambda>(p,q). map (\<lambda>a. (delta a p, delta a q)) as)"
(* stop when same opti? *)

theorem closure_sound_complete:
assumes result: "closure as (init r,init s) = Some(ws,R)"
and atoms: "set as = atoms r \<union> atoms s"
shows "ws = [] \<longleftrightarrow> lang r = lang s"
proof -
  have leq: "(lang r = lang s) =
  (\<forall>(r',s') \<in> {((r0,s0),(delta a r0,delta a s0))| r0 s0 a. a : set as}^* `` {(init r,init s)}.
    final r' = final s')"
    by (simp add: atoms rtrancl_fold_product Ball_def lang_eq_ext_Nil_fold_Deriv imp_ex
      L_deltas L_init final_iff_Nil del: Un_iff)
  have "{(x,y). y \<in> set ((\<lambda>(p,q). map (\<lambda>a. (delta a p, delta a q)) as) x)} =
    {((r,s), delta a r, delta a s) |r s a. a \<in> set as}"
    by auto
  with atoms rtrancl_while_Some[OF result[unfolded closure_def]]
  show ?thesis by (auto simp add: leq Ball_def split: if_splits)
qed

subsection \<open>The overall procedure\<close>

definition check_eqv :: "'a rexp \<Rightarrow> 'a rexp \<Rightarrow> bool" where
"check_eqv r s =
  (let as = add_atoms r (add_atoms s [])
   in case closure as (init r, init s) of
     Some([],_) \<Rightarrow> True | _ \<Rightarrow> False)"

(* completeness needs termination of closure, otherwise result could be None *)

text\<open>Auxiliary functions:\<close>
definition reachable :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 's set" where
"reachable as s =
  snd(the(rtrancl_while (\<lambda>_. True) (\<lambda>s. map (\<lambda>a. delta a s) as) (init s)))"

definition automaton :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> (('s * 'a) * 's) set" where
"automaton as s =
  snd (the
  (let i = init s;
       start = (([i], {i}), {});
       test = \<lambda>((ws, Z), A). ws \<noteq> [];
       step = \<lambda>((ws, Z), A).
         (let s = hd ws;
              new_edges = map (\<lambda>a. ((s, a), delta a s)) as;
              new = remdups (filter (\<lambda>ss. ss \<notin> Z) (map snd new_edges))
         in ((new @ tl ws, set new \<union> Z), set new_edges \<union> A))
  in while_option test step start))"

definition match :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> bool" where
"match s w = final (fold delta w (init s))"

lemma match_correct: "match s w \<longleftrightarrow> w \<in> lang s"
  unfolding match_def
  by (induct w arbitrary: s)
    (auto simp: L_init L_delta in_fold_Deriv final_iff_Nil L_deltas Deriv_def)

end

locale rexp_DFA = rexp_DA +
assumes fin: "finite {fold delta w (init s) | w. True}"
begin

lemma finite_rtrancl_delta_Image:
  "finite ({((r,s),(delta a r,delta a s))| r s a. a : A}^* `` {(init r, init s)})"
  unfolding rtrancl_fold_product Image_singleton
  by (auto intro: finite_subset[OF _ finite_cartesian_product[OF fin fin]])

lemma "termination": "\<exists>st. closure as (init r,init s) = Some st" (is "\<exists>_. closure as ?i = _")
unfolding closure_def proof (rule rtrancl_while_finite_Some)
  show "finite ({(x, st). st \<in> set ((\<lambda>(p,q). map (\<lambda>a. (delta a p, delta a q)) as) x)}\<^sup>* `` {?i})"
    by (rule finite_subset[OF Image_mono[OF rtrancl_mono] finite_rtrancl_delta_Image]) auto
qed

lemma completeness:
assumes "lang r = lang s" shows "check_eqv r s"
proof -
  let ?as = "add_atoms r (add_atoms s [])"
  obtain ws R where 1: "closure ?as (init r, init s) = Some(ws,R)"
    using "termination" by fastforce
  with closure_sound_complete[OF this] assms
  show "check_eqv r s" by (simp add: check_eqv_def set_add_atoms)
qed

lemma finite_rtrancl_delta_Image1:
  "finite ({(r,s). \<exists>a \<in> A. s = delta a r}^* `` {init r})"
  unfolding rtrancl_fold_product1 by (auto intro: finite_subset[OF _ fin])

lemma reachable: "reachable as r = {fold delta w (init r) | w. w \<in> lists (set as)}"
  and finite_reachable: "finite (reachable as r)"
proof -
  obtain wsZ where *: "rtrancl_while (\<lambda>_. True) (\<lambda>s. map (\<lambda>a. delta a s) as) (init r) = Some wsZ"
    by (atomize_elim,intro rtrancl_while_finite_Some Image_mono rtrancl_mono
      finite_subset[OF _ finite_rtrancl_delta_Image1[of "set as" r]]) auto
  then show "reachable as r = {fold delta w (init r) | w. w \<in> lists (set as)}"
    unfolding reachable_def by (cases wsZ)
      (auto dest!: rtrancl_while_Some split: if_splits simp: rtrancl_fold_product1 image_iff)
  then show "finite (reachable as r)" by (auto intro: finite_subset[OF _ fin])
qed

end

(*<*)
end
(*>*)


(*  Title:      ZF/Constructible/Wellorderings.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {*Relativized Wellorderings*}

theory Wellorderings imports Relative begin

text{*We define functions analogous to @{term ordermap} @{term ordertype}
      but without using recursion.  Instead, there is a direct appeal
      to Replacement.  This will be the basis for a version relativized
      to some class @{text M}.  The main result is Theorem I 7.6 in Kunen,
      page 17.*}

subsection{*Wellorderings*}

definition
  irreflexive :: "[i=>o,i,i]=>o" where
    "irreflexive(M,A,r) == \<forall>x[M]. x\<in>A \<longrightarrow> <x,x> \<notin> r"

definition
  transitive_rel :: "[i=>o,i,i]=>o" where
    "transitive_rel(M,A,r) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> (\<forall>z[M]. z\<in>A \<longrightarrow>
                          <x,y>\<in>r \<longrightarrow> <y,z>\<in>r \<longrightarrow> <x,z>\<in>r))"

definition
  linear_rel :: "[i=>o,i,i]=>o" where
    "linear_rel(M,A,r) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> <x,y>\<in>r | x=y | <y,x>\<in>r)"

definition
  wellfounded :: "[i=>o,i]=>o" where
    --{*EVERY non-empty set has an @{text r}-minimal element*}
    "wellfounded(M,r) ==
        \<forall>x[M]. x\<noteq>0 \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & <z,y> \<in> r))"
definition
  wellfounded_on :: "[i=>o,i,i]=>o" where
    --{*every non-empty SUBSET OF @{text A} has an @{text r}-minimal element*}
    "wellfounded_on(M,A,r) ==
        \<forall>x[M]. x\<noteq>0 \<longrightarrow> x\<subseteq>A \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & <z,y> \<in> r))"

definition
  wellordered :: "[i=>o,i,i]=>o" where
    --{*linear and wellfounded on @{text A}*}
    "wellordered(M,A,r) ==
        transitive_rel(M,A,r) & linear_rel(M,A,r) & wellfounded_on(M,A,r)"

subsubsection {*Trivial absoluteness proofs*}

lemma (in M_basic) irreflexive_abs [simp]:
     "M(A) ==> irreflexive(M,A,r) \<longleftrightarrow> irrefl(A,r)"
by (simp add: irreflexive_def irrefl_def)

lemma (in M_basic) transitive_rel_abs [simp]:
     "M(A) ==> transitive_rel(M,A,r) \<longleftrightarrow> trans[A](r)"
by (simp add: transitive_rel_def trans_on_def)

lemma (in M_basic) linear_rel_abs [simp]:
     "M(A) ==> linear_rel(M,A,r) \<longleftrightarrow> linear(A,r)"
by (simp add: linear_rel_def linear_def)

lemma (in M_basic) wellordered_is_trans_on:
    "[| wellordered(M,A,r); M(A) |] ==> trans[A](r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellordered_is_linear:
    "[| wellordered(M,A,r); M(A) |] ==> linear(A,r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellordered_is_wellfounded_on:
    "[| wellordered(M,A,r); M(A) |] ==> wellfounded_on(M,A,r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellfounded_imp_wellfounded_on:
    "[| wellfounded(M,r); M(A) |] ==> wellfounded_on(M,A,r)"
by (auto simp add: wellfounded_def wellfounded_on_def)

lemma (in M_basic) wellfounded_on_subset_A:
     "[| wellfounded_on(M,A,r);  B<=A |] ==> wellfounded_on(M,B,r)"
by (simp add: wellfounded_on_def, blast)

subsubsection {*Well-founded relations*}

lemma  (in M_basic) wellfounded_on_iff_wellfounded:
     "wellfounded_on(M,A,r) \<longleftrightarrow> wellfounded(M, r \<inter> A*A)"
apply (simp add: wellfounded_on_def wellfounded_def, safe)
 apply force
apply (drule_tac x=x in rspec, assumption, blast)
done

lemma (in M_basic) wellfounded_on_imp_wellfounded:
     "[|wellfounded_on(M,A,r); r \<subseteq> A*A|] ==> wellfounded(M,r)"
by (simp add: wellfounded_on_iff_wellfounded subset_Int_iff)

lemma (in M_basic) wellfounded_on_field_imp_wellfounded:
     "wellfounded_on(M, field(r), r) ==> wellfounded(M,r)"
by (simp add: wellfounded_def wellfounded_on_iff_wellfounded, fast)

lemma (in M_basic) wellfounded_iff_wellfounded_on_field:
     "M(r) ==> wellfounded(M,r) \<longleftrightarrow> wellfounded_on(M, field(r), r)"
by (blast intro: wellfounded_imp_wellfounded_on
                 wellfounded_on_field_imp_wellfounded)

(*Consider the least z in domain(r) such that P(z) does not hold...*)
lemma (in M_basic) wellfounded_induct:
     "[| wellfounded(M,r); M(a); M(r); separation(M, \<lambda>x. ~P(x));
         \<forall>x. M(x) & (\<forall>y. <y,x> \<in> r \<longrightarrow> P(y)) \<longrightarrow> P(x) |]
      ==> P(a)"
apply (simp (no_asm_use) add: wellfounded_def)
apply (drule_tac x="{z \<in> domain(r). ~P(z)}" in rspec)
apply (blast dest: transM)+
done

lemma (in M_basic) wellfounded_on_induct:
     "[| a\<in>A;  wellfounded_on(M,A,r);  M(A);
       separation(M, \<lambda>x. x\<in>A \<longrightarrow> ~P(x));
       \<forall>x\<in>A. M(x) & (\<forall>y\<in>A. <y,x> \<in> r \<longrightarrow> P(y)) \<longrightarrow> P(x) |]
      ==> P(a)"
apply (simp (no_asm_use) add: wellfounded_on_def)
apply (drule_tac x="{z\<in>A. z\<in>A \<longrightarrow> ~P(z)}" in rspec)
apply (blast intro: transM)+
done

subsubsection {*Kunen's lemma IV 3.14, page 123*}

lemma (in M_basic) linear_imp_relativized:
     "linear(A,r) ==> linear_rel(M,A,r)"
by (simp add: linear_def linear_rel_def)

lemma (in M_basic) trans_on_imp_relativized:
     "trans[A](r) ==> transitive_rel(M,A,r)"
by (unfold transitive_rel_def trans_on_def, blast)

lemma (in M_basic) wf_on_imp_relativized:
     "wf[A](r) ==> wellfounded_on(M,A,r)"
apply (simp add: wellfounded_on_def wf_def wf_on_def, clarify)
apply (drule_tac x=x in spec, blast)
done

lemma (in M_basic) wf_imp_relativized:
     "wf(r) ==> wellfounded(M,r)"
apply (simp add: wellfounded_def wf_def, clarify)
apply (drule_tac x=x in spec, blast)
done

lemma (in M_basic) well_ord_imp_relativized:
     "well_ord(A,r) ==> wellordered(M,A,r)"
by (simp add: wellordered_def well_ord_def tot_ord_def part_ord_def
       linear_imp_relativized trans_on_imp_relativized wf_on_imp_relativized)

text{*The property being well founded (and hence of being well ordered) is not absolute:
the set that doesn't contain a minimal element may not exist in the class M.
However, every set that is well founded in a transitive model M is well founded (page 124).*}

subsection{* Relativized versions of order-isomorphisms and order types *}

lemma (in M_basic) order_isomorphism_abs [simp]:
     "[| M(A); M(B); M(f) |]
      ==> order_isomorphism(M,A,r,B,s,f) \<longleftrightarrow> f \<in> ord_iso(A,r,B,s)"
by (simp add: apply_closed order_isomorphism_def ord_iso_def)

lemma (in M_basic) pred_set_abs [simp]:
     "[| M(r); M(B) |] ==> pred_set(M,A,x,r,B) \<longleftrightarrow> B = Order.pred(A,x,r)"
apply (simp add: pred_set_def Order.pred_def)
apply (blast dest: transM)
done

lemma (in M_basic) pred_closed [intro,simp]:
     "[| M(A); M(r); M(x) |] ==> M(Order.pred(A,x,r))"
apply (simp add: Order.pred_def)
apply (insert pred_separation [of r x], simp)
done

lemma (in M_basic) membership_abs [simp]:
     "[| M(r); M(A) |] ==> membership(M,A,r) \<longleftrightarrow> r = Memrel(A)"
apply (simp add: membership_def Memrel_def, safe)
  apply (rule equalityI)
   apply clarify
   apply (frule transM, assumption)
   apply blast
  apply clarify
  apply (subgoal_tac "M(<xb,ya>)", blast)
  apply (blast dest: transM)
 apply auto
done

lemma (in M_basic) M_Memrel_iff:
     "M(A) ==>
      Memrel(A) = {z \<in> A*A. \<exists>x[M]. \<exists>y[M]. z = \<langle>x,y\<rangle> & x \<in> y}"
apply (simp add: Memrel_def)
apply (blast dest: transM)
done

lemma (in M_basic) Memrel_closed [intro,simp]:
     "M(A) ==> M(Memrel(A))"
apply (simp add: M_Memrel_iff)
apply (insert Memrel_separation, simp)
done

subsection {* Main results of Kunen, Chapter 1 section 6 *}

text{*Subset properties-- proved outside the locale*}

lemma linear_rel_subset:
    "[| linear_rel(M,A,r);  B<=A |] ==> linear_rel(M,B,r)"
by (unfold linear_rel_def, blast)

lemma transitive_rel_subset:
    "[| transitive_rel(M,A,r);  B<=A |] ==> transitive_rel(M,B,r)"
by (unfold transitive_rel_def, blast)

lemma wellfounded_on_subset:
    "[| wellfounded_on(M,A,r);  B<=A |] ==> wellfounded_on(M,B,r)"
by (unfold wellfounded_on_def subset_def, blast)

lemma wellordered_subset:
    "[| wellordered(M,A,r);  B<=A |] ==> wellordered(M,B,r)"
apply (unfold wellordered_def)
apply (blast intro: linear_rel_subset transitive_rel_subset
                    wellfounded_on_subset)
done

lemma (in M_basic) wellfounded_on_asym:
     "[| wellfounded_on(M,A,r);  <a,x>\<in>r;  a\<in>A; x\<in>A;  M(A) |] ==> <x,a>\<notin>r"
apply (simp add: wellfounded_on_def)
apply (drule_tac x="{x,a}" in rspec)
apply (blast dest: transM)+
done

lemma (in M_basic) wellordered_asym:
     "[| wellordered(M,A,r);  <a,x>\<in>r;  a\<in>A; x\<in>A;  M(A) |] ==> <x,a>\<notin>r"
by (simp add: wellordered_def, blast dest: wellfounded_on_asym)

end


(* Author: Tobias Nipkow, Florian Haftmann, TU Muenchen *)

section \<open>Character and string types\<close>

theory String
imports Enum
begin

subsection \<open>Characters and strings\<close>

subsubsection \<open>Characters as finite algebraic type\<close>

typedef char = "{n::nat. n < 256}"
  morphisms nat_of_char Abs_char
proof
  show "Suc 0 \<in> {n. n < 256}" by simp
qed

definition char_of_nat :: "nat \<Rightarrow> char"
where
  "char_of_nat n = Abs_char (n mod 256)"

lemma char_cases [case_names char_of_nat, cases type: char]:
  "(\<And>n. c = char_of_nat n \<Longrightarrow> n < 256 \<Longrightarrow> P) \<Longrightarrow> P"
  by (cases c) (simp add: char_of_nat_def)

lemma char_of_nat_of_char [simp]:
  "char_of_nat (nat_of_char c) = c"
  by (cases c) (simp add: char_of_nat_def Abs_char_inject Abs_char_inverse)

lemma inj_nat_of_char:
  "inj nat_of_char"
proof (rule injI)
  fix c d
  assume "nat_of_char c = nat_of_char d"
  then have "char_of_nat (nat_of_char c) = char_of_nat (nat_of_char d)"
    by simp
  then show "c = d"
    by simp
qed

lemma nat_of_char_eq_iff [simp]:
  "nat_of_char c = nat_of_char d \<longleftrightarrow> c = d"
  by (fact nat_of_char_inject)

lemma nat_of_char_of_nat [simp]:
  "nat_of_char (char_of_nat n) = n mod 256"
  by (cases "char_of_nat n") (simp add: char_of_nat_def Abs_char_inject Abs_char_inverse)

lemma char_of_nat_mod_256 [simp]:
  "char_of_nat (n mod 256) = char_of_nat n"
  by (cases "char_of_nat (n mod 256)") (simp add: char_of_nat_def)

lemma char_of_nat_quasi_inj [simp]:
  "char_of_nat m = char_of_nat n \<longleftrightarrow> m mod 256 = n mod 256"
  by (simp add: char_of_nat_def Abs_char_inject)

lemma inj_on_char_of_nat [simp]:
  "inj_on char_of_nat {..<256}"
  by (rule inj_onI) simp

lemma nat_of_char_mod_256 [simp]:
  "nat_of_char c mod 256 = nat_of_char c"
  by (cases c) simp

lemma nat_of_char_less_256 [simp]:
  "nat_of_char c < 256"
proof -
  have "nat_of_char c mod 256 < 256"
    by arith
  then show ?thesis by simp
qed

lemma UNIV_char_of_nat:
  "UNIV = char_of_nat ` {..<256}"
proof -
  { fix c
    have "c \<in> char_of_nat ` {..<256}"
      by (cases c) auto
  } then show ?thesis by auto
qed

lemma card_UNIV_char:
  "card (UNIV :: char set) = 256"
  by (auto simp add: UNIV_char_of_nat card_image)

lemma range_nat_of_char:
  "range nat_of_char = {..<256}"
  by (auto simp add: UNIV_char_of_nat image_image image_def)

subsubsection \<open>Character literals as variant of numerals\<close>

instantiation char :: zero
begin

definition zero_char :: char
  where "0 = char_of_nat 0"

instance ..

end

definition Char :: "num \<Rightarrow> char"
  where "Char k = char_of_nat (numeral k)"

code_datatype "0 :: char" Char

lemma nat_of_char_zero [simp]:
  "nat_of_char 0 = 0"
  by (simp add: zero_char_def)

lemma nat_of_char_Char [simp]:
  "nat_of_char (Char k) = numeral k mod 256"
  by (simp add: Char_def)

lemma Char_eq_Char_iff [simp]:
  "Char k = Char l \<longleftrightarrow> numeral k mod (256 :: nat) = numeral l mod 256" (is "?P \<longleftrightarrow> ?Q")
proof -
  have "?P \<longleftrightarrow> nat_of_char (Char k) = nat_of_char (Char l)"
    by (rule sym, rule inj_eq) (fact inj_nat_of_char)
  also have "nat_of_char (Char k) = nat_of_char (Char l) \<longleftrightarrow> ?Q"
    by (simp only: Char_def nat_of_char_of_nat)
  finally show ?thesis .
qed

lemma zero_eq_Char_iff [simp]:
  "0 = Char k \<longleftrightarrow> numeral k mod (256 :: nat) = 0"
  by (auto simp add: zero_char_def Char_def)

lemma Char_eq_zero_iff [simp]:
  "Char k = 0 \<longleftrightarrow> numeral k mod (256 :: nat) = 0"
  by (auto simp add: zero_char_def Char_def)

definition integer_of_char :: "char \<Rightarrow> integer"
where
  "integer_of_char = integer_of_nat \<circ> nat_of_char"

definition char_of_integer :: "integer \<Rightarrow> char"
where
  "char_of_integer = char_of_nat \<circ> nat_of_integer"

lemma integer_of_char_zero [simp, code]:
  "integer_of_char 0 = 0"
  by (simp add: integer_of_char_def integer_of_nat_def)

lemma integer_of_char_Char [simp]:
  "integer_of_char (Char k) = numeral k mod 256"
  by (simp only: integer_of_char_def integer_of_nat_def comp_apply nat_of_char_Char map_fun_def
    id_apply zmod_int modulo_integer.abs_eq [symmetric]) simp

lemma less_256_integer_of_char_Char:
  assumes "numeral k < (256 :: integer)"
  shows "integer_of_char (Char k) = numeral k"
proof -
  have "numeral k mod 256 = (numeral k :: integer)"
    by (rule semiring_numeral_div_class.mod_less) (insert assms, simp_all)
  then show ?thesis using integer_of_char_Char [of k]
    by (simp only:)
qed

setup \<open>
let
  val chars = map_range (Thm.cterm_of @{context} o HOLogic.mk_numeral o curry (op +) 1) 255;
  val simpset =
    put_simpset HOL_ss @{context}
      addsimps @{thms numeral_less_iff less_num_simps};
  fun mk_code_eqn ct =
    Thm.instantiate' [] [SOME ct] @{thm less_256_integer_of_char_Char}
    |> full_simplify simpset;
  val code_eqns = map mk_code_eqn chars;
in
  Global_Theory.note_thmss ""
    [((@{binding integer_of_char_simps}, []), [(code_eqns, [])])]
  #> snd
end
\<close>

declare integer_of_char_simps [code]

lemma nat_of_char_code [code]:
  "nat_of_char = nat_of_integer \<circ> integer_of_char"
  by (simp add: integer_of_char_def fun_eq_iff)

lemma char_of_nat_code [code]:
  "char_of_nat = char_of_integer \<circ> integer_of_nat"
  by (simp add: char_of_integer_def fun_eq_iff)

instantiation char :: equal
begin

definition equal_char
  where "equal_char (c :: char) d \<longleftrightarrow> c = d"

instance
  by standard (simp add: equal_char_def)

end

lemma equal_char_simps [code]:
  "HOL.equal (0::char) 0 \<longleftrightarrow> True"
  "HOL.equal (Char k) (Char l) \<longleftrightarrow> HOL.equal (numeral k mod 256 :: nat) (numeral l mod 256)"
  "HOL.equal 0 (Char k) \<longleftrightarrow> HOL.equal (numeral k mod 256 :: nat) 0"
  "HOL.equal (Char k) 0 \<longleftrightarrow> HOL.equal (numeral k mod 256 :: nat) 0"
  by (simp_all only: equal refl Char_eq_Char_iff zero_eq_Char_iff Char_eq_zero_iff)

syntax
  "_Char" :: "str_position \<Rightarrow> char"    ("CHR _")
  "_Char_ord" :: "num_const \<Rightarrow> char"   ("CHR _")

type_synonym string = "char list"

syntax
  "_String" :: "str_position => string"    ("_")

ML_file "Tools/string_syntax.ML"

instantiation char :: enum
begin

definition
  "Enum.enum = [0, CHR 0x01, CHR 0x02, CHR 0x03,
    CHR 0x04, CHR 0x05, CHR 0x06, CHR 0x07,
    CHR 0x08, CHR 0x09, CHR ''\<newline>'', CHR 0x0B,
    CHR 0x0C, CHR 0x0D, CHR 0x0E, CHR 0x0F,
    CHR 0x10, CHR 0x11, CHR 0x12, CHR 0x13,
    CHR 0x14, CHR 0x15, CHR 0x16, CHR 0x17,
    CHR 0x18, CHR 0x19, CHR 0x1A, CHR 0x1B,
    CHR 0x1C, CHR 0x1D, CHR 0x1E, CHR 0x1F,
    CHR '' '', CHR ''!'', CHR 0x22, CHR ''#'',
    CHR ''$'', CHR ''%'', CHR ''&'', CHR 0x27,
    CHR ''('', CHR '')'', CHR ''*'', CHR ''+'',
    CHR '','', CHR ''-'', CHR ''.'', CHR ''/'',
    CHR ''0'', CHR ''1'', CHR ''2'', CHR ''3'',
    CHR ''4'', CHR ''5'', CHR ''6'', CHR ''7'',
    CHR ''8'', CHR ''9'', CHR '':'', CHR '';'',
    CHR ''<'', CHR ''='', CHR ''>'', CHR ''?'',
    CHR ''@'', CHR ''A'', CHR ''B'', CHR ''C'',
    CHR ''D'', CHR ''E'', CHR ''F'', CHR ''G'',
    CHR ''H'', CHR ''I'', CHR ''J'', CHR ''K'',
    CHR ''L'', CHR ''M'', CHR ''N'', CHR ''O'',
    CHR ''P'', CHR ''Q'', CHR ''R'', CHR ''S'',
    CHR ''T'', CHR ''U'', CHR ''V'', CHR ''W'',
    CHR ''X'', CHR ''Y'', CHR ''Z'', CHR ''['',
    CHR 0x5C, CHR '']'', CHR ''^'', CHR ''_'',
    CHR 0x60, CHR ''a'', CHR ''b'', CHR ''c'',
    CHR ''d'', CHR ''e'', CHR ''f'', CHR ''g'',
    CHR ''h'', CHR ''i'', CHR ''j'', CHR ''k'',
    CHR ''l'', CHR ''m'', CHR ''n'', CHR ''o'',
    CHR ''p'', CHR ''q'', CHR ''r'', CHR ''s'',
    CHR ''t'', CHR ''u'', CHR ''v'', CHR ''w'',
    CHR ''x'', CHR ''y'', CHR ''z'', CHR ''{'',
    CHR ''|'', CHR ''}'', CHR ''~'', CHR 0x7F,
    CHR 0x80, CHR 0x81, CHR 0x82, CHR 0x83,
    CHR 0x84, CHR 0x85, CHR 0x86, CHR 0x87,
    CHR 0x88, CHR 0x89, CHR 0x8A, CHR 0x8B,
    CHR 0x8C, CHR 0x8D, CHR 0x8E, CHR 0x8F,
    CHR 0x90, CHR 0x91, CHR 0x92, CHR 0x93,
    CHR 0x94, CHR 0x95, CHR 0x96, CHR 0x97,
    CHR 0x98, CHR 0x99, CHR 0x9A, CHR 0x9B,
    CHR 0x9C, CHR 0x9D, CHR 0x9E, CHR 0x9F,
    CHR 0xA0, CHR 0xA1, CHR 0xA2, CHR 0xA3,
    CHR 0xA4, CHR 0xA5, CHR 0xA6, CHR 0xA7,
    CHR 0xA8, CHR 0xA9, CHR 0xAA, CHR 0xAB,
    CHR 0xAC, CHR 0xAD, CHR 0xAE, CHR 0xAF,
    CHR 0xB0, CHR 0xB1, CHR 0xB2, CHR 0xB3,
    CHR 0xB4, CHR 0xB5, CHR 0xB6, CHR 0xB7,
    CHR 0xB8, CHR 0xB9, CHR 0xBA, CHR 0xBB,
    CHR 0xBC, CHR 0xBD, CHR 0xBE, CHR 0xBF,
    CHR 0xC0, CHR 0xC1, CHR 0xC2, CHR 0xC3,
    CHR 0xC4, CHR 0xC5, CHR 0xC6, CHR 0xC7,
    CHR 0xC8, CHR 0xC9, CHR 0xCA, CHR 0xCB,
    CHR 0xCC, CHR 0xCD, CHR 0xCE, CHR 0xCF,
    CHR 0xD0, CHR 0xD1, CHR 0xD2, CHR 0xD3,
    CHR 0xD4, CHR 0xD5, CHR 0xD6, CHR 0xD7,
    CHR 0xD8, CHR 0xD9, CHR 0xDA, CHR 0xDB,
    CHR 0xDC, CHR 0xDD, CHR 0xDE, CHR 0xDF,
    CHR 0xE0, CHR 0xE1, CHR 0xE2, CHR 0xE3,
    CHR 0xE4, CHR 0xE5, CHR 0xE6, CHR 0xE7,
    CHR 0xE8, CHR 0xE9, CHR 0xEA, CHR 0xEB,
    CHR 0xEC, CHR 0xED, CHR 0xEE, CHR 0xEF,
    CHR 0xF0, CHR 0xF1, CHR 0xF2, CHR 0xF3,
    CHR 0xF4, CHR 0xF5, CHR 0xF6, CHR 0xF7,
    CHR 0xF8, CHR 0xF9, CHR 0xFA, CHR 0xFB,
    CHR 0xFC, CHR 0xFD, CHR 0xFE, CHR 0xFF]"

definition
  "Enum.enum_all P \<longleftrightarrow> list_all P (Enum.enum :: char list)"

definition
  "Enum.enum_ex P \<longleftrightarrow> list_ex P (Enum.enum :: char list)"

lemma enum_char_unfold:
  "Enum.enum = map char_of_nat [0..<256]"
proof -
  have *: "Suc (Suc 0) = 2" by simp
  have "map nat_of_char Enum.enum = [0..<256]"
    by (simp add: enum_char_def upt_conv_Cons_Cons *)
  then have "map char_of_nat (map nat_of_char Enum.enum) =
    map char_of_nat [0..<256]" by simp
  then show ?thesis by (simp add: comp_def)
qed

instance proof
  show UNIV: "UNIV = set (Enum.enum :: char list)"
    by (simp add: enum_char_unfold UNIV_char_of_nat atLeast0LessThan)
  show "distinct (Enum.enum :: char list)"
    by (auto simp add: enum_char_unfold distinct_map intro: inj_onI)
  show "\<And>P. Enum.enum_all P \<longleftrightarrow> Ball (UNIV :: char set) P"
    by (simp add: UNIV enum_all_char_def list_all_iff)
  show "\<And>P. Enum.enum_ex P \<longleftrightarrow> Bex (UNIV :: char set) P"
    by (simp add: UNIV enum_ex_char_def list_ex_iff)
qed

end

lemma char_of_integer_code [code]:
  "char_of_integer n = Enum.enum ! (nat_of_integer n mod 256)"
  by (simp add: char_of_integer_def enum_char_unfold)

subsection \<open>Strings as dedicated type\<close>

typedef literal = "UNIV :: string set"
  morphisms explode STR ..

setup_lifting type_definition_literal

lemma STR_inject' [simp]:
  "STR s = STR t \<longleftrightarrow> s = t"
  by transfer rule

definition implode :: "string \<Rightarrow> String.literal"
where
  [code del]: "implode = STR"

instantiation literal :: size
begin

definition size_literal :: "literal \<Rightarrow> nat"
where
  [code]: "size_literal (s::literal) = 0"

instance ..

end

instantiation literal :: equal
begin

lift_definition equal_literal :: "literal \<Rightarrow> literal \<Rightarrow> bool" is "op =" .

instance by intro_classes (transfer, simp)

end

declare equal_literal.rep_eq[code]

lemma [code nbe]:
  fixes s :: "String.literal"
  shows "HOL.equal s s \<longleftrightarrow> True"
  by (simp add: equal)

lifting_update literal.lifting
lifting_forget literal.lifting

subsection \<open>Code generator\<close>

ML_file "Tools/string_code.ML"

code_reserved SML string
code_reserved OCaml string
code_reserved Scala string

code_printing
  type_constructor literal \<rightharpoonup>
    (SML) "string"
    and (OCaml) "string"
    and (Haskell) "String"
    and (Scala) "String"

setup \<open>
  fold String_Code.add_literal_string ["SML", "OCaml", "Haskell", "Scala"]
\<close>

code_printing
  class_instance literal :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: literal \<Rightarrow> literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) = _)"
    and (OCaml) "!((_ : string) = _)"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="

setup \<open>Sign.map_naming (Name_Space.mandatory_path "Code")\<close>

definition abort :: "literal \<Rightarrow> (unit \<Rightarrow> 'a) \<Rightarrow> 'a"
where [simp, code del]: "abort _ f = f ()"

lemma abort_cong: "msg = msg' ==> Code.abort msg f = Code.abort msg' f"
by simp

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm Code.abort_cong})\<close>

code_printing constant Code.abort \<rightharpoonup>
    (SML) "!(raise/ Fail/ _)"
    and (OCaml) "failwith"
    and (Haskell) "!(error/ ::/ forall a./ String -> (() -> a) -> a)"
    and (Scala) "!{/ sys.error((_));/  ((_)).apply(())/ }"

hide_type (open) literal

hide_const (open) implode explode

end