(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>A new bridge to convert theorems from JNF to HOL Analysis and vice-versa,
based on the @{text "mod_type"} class\<close>

theory Mod_Type_Connect
  imports
          Perron_Frobenius.HMA_Connect
          Rank_Nullity_Theorem.Mod_Type
          Gauss_Jordan.Elementary_Operations
begin

text \<open>Some lemmas on @{text "Mod_Type.to_nat"} and @{text "Mod_Type.from_nat"} are added to have
them with the same names as the analogous ones for @{text "Bij_Nat.to_nat"}
and @{text "Bij_Nat.to_nat"}.\<close>

lemma inj_to_nat: "inj to_nat" by (simp add: inj_on_def)
lemmas from_nat_inj = from_nat_eq_imp_eq
lemma range_to_nat: "range (to_nat :: 'a :: mod_type \<Rightarrow> nat) = {0 ..< CARD('a)}"
  by (simp add: bij_betw_imp_surj_on mod_type_class.bij_to_nat)

text \<open>This theory is an adaptation of the one presented in @{text "Perron_Frobenius.HMA_Connect"},
  but for matrices and vectors where indexes have the @{text "mod_type"} class restriction.

  It is worth noting that some definitions still use the old abbreviation for HOL Analysis
  (HMA, from HOL Multivariate Analysis) instead of HA. This is done to be consistent with
  the existing names in the Perron-Frobenius development\<close>

context includes vec.lifting
begin
end

definition from_hma\<^sub>v :: "'a ^ 'n :: mod_type \<Rightarrow> 'a Matrix.vec" where
  "from_hma\<^sub>v v = Matrix.vec CARD('n) (\<lambda> i. v $h from_nat i)"

definition from_hma\<^sub>m :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> 'a Matrix.mat" where
  "from_hma\<^sub>m a = Matrix.mat CARD('nr) CARD('nc) (\<lambda> (i,j). a $h from_nat i $h from_nat j)"

definition to_hma\<^sub>v :: "'a Matrix.vec \<Rightarrow> 'a ^ 'n :: mod_type" where
  "to_hma\<^sub>v v = (\<chi> i. v $v to_nat i)"

definition to_hma\<^sub>m :: "'a Matrix.mat \<Rightarrow> 'a ^ 'nc :: mod_type ^ 'nr :: mod_type " where
  "to_hma\<^sub>m a = (\<chi> i j. a $$ (to_nat i, to_nat j))"

lemma to_hma_from_hma\<^sub>v[simp]: "to_hma\<^sub>v (from_hma\<^sub>v v) = v"
  by (auto simp: to_hma\<^sub>v_def from_hma\<^sub>v_def to_nat_less_card)

lemma from_hma_to_hma\<^sub>v[simp]:
  "v \<in> carrier_vec (CARD('n)) \<Longrightarrow> from_hma\<^sub>v (to_hma\<^sub>v v :: 'a ^ 'n :: mod_type) = v"
  by (auto simp: to_hma\<^sub>v_def from_hma\<^sub>v_def to_nat_from_nat_id)

lemma from_hma_to_hma\<^sub>m[simp]:
  "A \<in> carrier_mat (CARD('nr)) (CARD('nc)) \<Longrightarrow> from_hma\<^sub>m (to_hma\<^sub>m A :: 'a ^ 'nc :: mod_type  ^ 'nr :: mod_type) = A"
  by (auto simp: to_hma\<^sub>m_def from_hma\<^sub>m_def to_nat_from_nat_id)

lemma from_hma\<^sub>v_inj[simp]: "from_hma\<^sub>v x = from_hma\<^sub>v y \<longleftrightarrow> x = y"
  by (intro iffI, insert to_hma_from_hma\<^sub>v[of x], auto)

lemma from_hma\<^sub>m_inj[simp]: "from_hma\<^sub>m x = from_hma\<^sub>m y \<longleftrightarrow> x = y"
  by(intro iffI, insert to_hma_from_hma\<^sub>m[of x], auto)

definition HMA_V :: "'a Matrix.vec \<Rightarrow> 'a ^ 'n :: mod_type \<Rightarrow> bool" where
  "HMA_V = (\<lambda> v w. v = from_hma\<^sub>v w)"

definition HMA_M :: "'a Matrix.mat \<Rightarrow> 'a ^ 'nc :: mod_type ^ 'nr :: mod_type  \<Rightarrow> bool" where
  "HMA_M = (\<lambda> a b. a = from_hma\<^sub>m b)"

definition HMA_I :: "nat \<Rightarrow> 'n :: mod_type \<Rightarrow> bool" where
  "HMA_I = (\<lambda> i a. i = to_nat a)"

context includes lifting_syntax
begin

lemma Domainp_HMA_V [transfer_domain_rule]:
  "Domainp (HMA_V :: 'a Matrix.vec \<Rightarrow> 'a ^ 'n :: mod_type \<Rightarrow> bool) = (\<lambda> v. v \<in> carrier_vec (CARD('n )))"
  by(intro ext iffI, insert from_hma_to_hma\<^sub>v[symmetric], auto simp: from_hma\<^sub>v_def HMA_V_def)

lemma Domainp_HMA_M [transfer_domain_rule]:
  "Domainp (HMA_M :: 'a Matrix.mat \<Rightarrow> 'a ^ 'nc :: mod_type  ^ 'nr :: mod_type \<Rightarrow> bool)
  = (\<lambda> A. A \<in> carrier_mat CARD('nr) CARD('nc))"
  by (intro ext iffI, insert from_hma_to_hma\<^sub>m[symmetric], auto simp: from_hma\<^sub>m_def HMA_M_def)

lemma Domainp_HMA_I [transfer_domain_rule]:
  "Domainp (HMA_I :: nat \<Rightarrow> 'n :: mod_type \<Rightarrow> bool) = (\<lambda> i. i < CARD('n))" (is "?l = ?r")
proof (intro ext)
  fix i :: nat
  show "?l i = ?r i"
    unfolding HMA_I_def Domainp_iff
    by (auto intro: exI[of _ "from_nat i"] simp: to_nat_from_nat_id to_nat_less_card)
qed

lemma bi_unique_HMA_V [transfer_rule]: "bi_unique HMA_V" "left_unique HMA_V" "right_unique HMA_V"
  unfolding HMA_V_def bi_unique_def left_unique_def right_unique_def by auto

lemma bi_unique_HMA_M [transfer_rule]: "bi_unique HMA_M" "left_unique HMA_M" "right_unique HMA_M"
  unfolding HMA_M_def bi_unique_def left_unique_def right_unique_def by auto

lemma bi_unique_HMA_I [transfer_rule]: "bi_unique HMA_I" "left_unique HMA_I" "right_unique HMA_I"
  unfolding HMA_I_def bi_unique_def left_unique_def right_unique_def by auto

lemma right_total_HMA_V [transfer_rule]: "right_total HMA_V"
  unfolding HMA_V_def right_total_def by simp

lemma right_total_HMA_M [transfer_rule]: "right_total HMA_M"
  unfolding HMA_M_def right_total_def by simp

lemma right_total_HMA_I [transfer_rule]: "right_total HMA_I"
  unfolding HMA_I_def right_total_def by simp

lemma HMA_V_index [transfer_rule]: "(HMA_V ===> HMA_I ===> (=)) ($v) ($h)"
  unfolding rel_fun_def HMA_V_def HMA_I_def from_hma\<^sub>v_def
  by (auto simp: to_nat_less_card)

lemma HMA_M_index [transfer_rule]:
  "(HMA_M ===> HMA_I ===> HMA_I ===> (=)) (\<lambda> A i j. A $$ (i,j)) index_hma"
  by (intro rel_funI, simp add: index_hma_def to_nat_less_card HMA_M_def HMA_I_def from_hma\<^sub>m_def)

lemma HMA_V_0 [transfer_rule]: "HMA_V (0\<^sub>v CARD('n)) (0 :: 'a :: zero ^ 'n:: mod_type)"
  unfolding HMA_V_def from_hma\<^sub>v_def by auto

lemma HMA_M_0 [transfer_rule]:
  "HMA_M (0\<^sub>m CARD('nr) CARD('nc)) (0 :: 'a :: zero ^ 'nc:: mod_type  ^ 'nr :: mod_type)"
  unfolding HMA_M_def from_hma\<^sub>m_def by auto

lemma HMA_M_1[transfer_rule]:
  "HMA_M (1\<^sub>m (CARD('n))) (mat 1 :: 'a::{zero,one}^'n:: mod_type^'n:: mod_type)"
  unfolding HMA_M_def
  by (auto simp add: mat_def from_hma\<^sub>m_def from_nat_inj)

lemma from_hma\<^sub>v_add: "from_hma\<^sub>v v + from_hma\<^sub>v w = from_hma\<^sub>v (v + w)"
  unfolding from_hma\<^sub>v_def by auto

lemma HMA_V_add [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (+) (+) "
  unfolding rel_fun_def HMA_V_def
  by (auto simp: from_hma\<^sub>v_add)

lemma from_hma\<^sub>v_diff: "from_hma\<^sub>v v - from_hma\<^sub>v w = from_hma\<^sub>v (v - w)"
  unfolding from_hma\<^sub>v_def by auto

lemma HMA_V_diff [transfer_rule]: "(HMA_V ===> HMA_V ===> HMA_V) (-) (-)"
  unfolding rel_fun_def HMA_V_def
  by (auto simp: from_hma\<^sub>v_diff)

lemma from_hma\<^sub>m_add: "from_hma\<^sub>m a + from_hma\<^sub>m b = from_hma\<^sub>m (a + b)"
  unfolding from_hma\<^sub>m_def by auto

lemma HMA_M_add [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (+) (+) "
  unfolding rel_fun_def HMA_M_def
  by (auto simp: from_hma\<^sub>m_add)

lemma from_hma\<^sub>m_diff: "from_hma\<^sub>m a - from_hma\<^sub>m b = from_hma\<^sub>m (a - b)"
  unfolding from_hma\<^sub>m_def by auto

lemma HMA_M_diff [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (-) (-) "
  unfolding rel_fun_def HMA_M_def
  by (auto simp: from_hma\<^sub>m_diff)

lemma scalar_product: fixes v :: "'a :: semiring_1 ^ 'n :: mod_type"
  shows "scalar_prod (from_hma\<^sub>v v) (from_hma\<^sub>v w) = scalar_product v w"
  unfolding scalar_product_def scalar_prod_def from_hma\<^sub>v_def dim_vec
  by (simp add: sum.reindex[OF inj_to_nat, unfolded range_to_nat])

lemma [simp]:
  "from_hma\<^sub>v (y :: 'a ^ 'n:: mod_type) \<in> carrier_vec (CARD('n))"
  "dim_vec (from_hma\<^sub>v (y :: 'a ^ 'n:: mod_type)) = CARD('n)"
  unfolding from_hma\<^sub>v_def by simp_all

lemma HMA_scalar_prod [transfer_rule]:
  "(HMA_V ===> HMA_V ===> (=)) scalar_prod scalar_product"
  by (auto simp: HMA_V_def scalar_product)

lemma HMA_row [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (\<lambda> i a. Matrix.row a i) row"
  unfolding HMA_M_def HMA_I_def HMA_V_def
  by (auto simp: from_hma\<^sub>m_def from_hma\<^sub>v_def to_nat_less_card row_def)

lemma HMA_col [transfer_rule]: "(HMA_I ===> HMA_M ===> HMA_V) (\<lambda> i a. col a i) column"
  unfolding HMA_M_def HMA_I_def HMA_V_def
  by (auto simp: from_hma\<^sub>m_def from_hma\<^sub>v_def to_nat_less_card column_def)

lemma HMA_M_mk_mat[transfer_rule]: "((HMA_I ===> HMA_I ===> (=)) ===> HMA_M)
  (\<lambda> f. Matrix.mat (CARD('nr)) (CARD('nc)) (\<lambda> (i,j). f i j))
  (mk_mat :: (('nr \<Rightarrow> 'nc \<Rightarrow> 'a) \<Rightarrow> 'a^'nc:: mod_type^'nr:: mod_type))"
proof-
  {
    fix x y i j
    assume id: "\<forall> (ya :: 'nr) (yb :: 'nc). (x (to_nat ya) (to_nat yb) :: 'a) = y ya yb"
       and i: "i < CARD('nr)" and j: "j < CARD('nc)"
    from to_nat_from_nat_id[OF i] to_nat_from_nat_id[OF j] id[rule_format, of "from_nat i" "from_nat j"]
    have "x i j = y (from_nat i) (from_nat j)" by auto
  }
  thus ?thesis
    unfolding rel_fun_def mk_mat_def HMA_M_def HMA_I_def from_hma\<^sub>m_def by auto
qed

lemma HMA_M_mk_vec[transfer_rule]: "((HMA_I ===> (=)) ===> HMA_V)
  (\<lambda> f. Matrix.vec (CARD('n)) (\<lambda> i. f i))
  (mk_vec :: (('n \<Rightarrow> 'a) \<Rightarrow> 'a^'n:: mod_type))"
proof-
  {
    fix x y i
    assume id: "\<forall> (ya :: 'n). (x (to_nat ya) :: 'a) = y ya"
       and i: "i < CARD('n)"
    from to_nat_from_nat_id[OF i] id[rule_format, of "from_nat i"]
    have "x i = y (from_nat i)" by auto
  }
  thus ?thesis
    unfolding rel_fun_def mk_vec_def HMA_V_def HMA_I_def from_hma\<^sub>v_def by auto
qed

lemma mat_mult_scalar: "A ** B = mk_mat (\<lambda> i j. scalar_product (row i A) (column j B))"
  unfolding vec_eq_iff matrix_matrix_mult_def scalar_product_def mk_mat_def
  by (auto simp: row_def column_def)

lemma mult_mat_vec_scalar: "A *v v = mk_vec (\<lambda> i. scalar_product (row i A) v)"
  unfolding vec_eq_iff matrix_vector_mult_def scalar_product_def mk_mat_def mk_vec_def
  by (auto simp: row_def column_def)

lemma dim_row_transfer_rule:
  "HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type) \<Longrightarrow> (=) (dim_row A) (CARD('nr))"
  unfolding HMA_M_def by auto

lemma dim_col_transfer_rule:
  "HMA_M A (A' :: 'a ^ 'nc:: mod_type ^ 'nr:: mod_type) \<Longrightarrow> (=) (dim_col A) (CARD('nc))"
  unfolding HMA_M_def by auto

lemma HMA_M_mult [transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M) (*) (**)"
proof -
  {
    fix A B :: "'a :: semiring_1 mat" and A' :: "'a ^ 'n :: mod_type ^ 'nr:: mod_type"
      and B' :: "'a ^ 'nc :: mod_type ^ 'n:: mod_type"
    assume 1[transfer_rule]: "HMA_M A A'" "HMA_M B B'"
    note [transfer_rule] = dim_row_transfer_rule[OF 1(1)] dim_col_transfer_rule[OF 1(2)]
    have "HMA_M (A * B) (A' ** B')"
      unfolding times_mat_def mat_mult_scalar
      by (transfer_prover_start, transfer_step+, transfer, auto)
  }
  thus ?thesis by blast
qed

lemma HMA_M_mult_vec [transfer_rule]: "(HMA_M ===> HMA_V ===> HMA_V) (*\<^sub>v) (*v)"
proof -
  {
    fix A :: "'a :: semiring_1 mat" and v :: "'a Matrix.vec"
      and A' :: "'a ^ 'nc :: mod_type ^ 'nr :: mod_type" and v' :: "'a ^ 'nc :: mod_type"
    assume 1[transfer_rule]: "HMA_M A A'" "HMA_V v v'"
    note [transfer_rule] = dim_row_transfer_rule
    have "HMA_V (A *\<^sub>v v) (A' *v v')"
      unfolding mult_mat_vec_def mult_mat_vec_scalar
      by (transfer_prover_start, transfer_step+, transfer, auto)
  }
  thus ?thesis by blast
qed

lemma HMA_det [transfer_rule]: "(HMA_M ===> (=)) Determinant.det
  (det :: 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type \<Rightarrow> 'a)"
proof -
  {
    fix a :: "'a ^ 'n :: mod_type^ 'n:: mod_type"
    let ?tn = "to_nat :: 'n :: mod_type \<Rightarrow> nat"
    let ?fn = "from_nat :: nat \<Rightarrow> 'n"
    let ?zn = "{0..< CARD('n)}"
    let ?U = "UNIV :: 'n set"
    let ?p1 = "{p. p permutes ?zn}"
    let ?p2 = "{p. p permutes ?U}"
    let ?f= "\<lambda> p i. if i \<in> ?U then ?fn (p (?tn i)) else i"
    let ?g = "\<lambda> p i. ?fn (p (?tn i))"
    have fg: "\<And> a b c. (if a \<in> ?U then b else c) = b" by auto
    have "?p2 = ?f ` ?p1"
      by (rule permutes_bij', auto simp: to_nat_less_card to_nat_from_nat_id)
    hence id: "?p2 = ?g ` ?p1" by simp
    have inj_g: "inj_on ?g ?p1"
      unfolding inj_on_def
    proof (intro ballI impI ext, auto)
      fix p q i
      assume p: "p permutes ?zn" and q: "q permutes ?zn"
        and id: "(\<lambda> i. ?fn (p (?tn i))) = (\<lambda> i. ?fn (q (?tn i)))"
      {
        fix i
        from permutes_in_image[OF p] have pi: "p (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
        from permutes_in_image[OF q] have qi: "q (?tn i) < CARD('n)" by (simp add: to_nat_less_card)
        from fun_cong[OF id] have "?fn (p (?tn i))  = from_nat (q (?tn i))" .
        from arg_cong[OF this, of ?tn] have "p (?tn i) = q (?tn i)"
          by (simp add: to_nat_from_nat_id pi qi)
      } note id = this
      show "p i = q i"
      proof (cases "i < CARD('n)")
        case True
        hence "?tn (?fn i) = i" by (simp add: to_nat_from_nat_id)
        from id[of "?fn i", unfolded this] show ?thesis .
      next
        case False
        thus ?thesis using p q unfolding permutes_def by simp
      qed
    qed
    have mult_cong: "\<And> a b c d. a = b \<Longrightarrow> c = d \<Longrightarrow> a * c = b * d" by simp
    have "sum (\<lambda> p.
      signof p * (\<Prod>i\<in>?zn. a $h ?fn i $h ?fn (p i))) ?p1
      = sum (\<lambda> p. of_int (sign p) * (\<Prod>i\<in>UNIV. a $h i $h p i)) ?p2"
      unfolding id sum.reindex[OF inj_g]
    proof (rule sum.cong[OF refl], unfold mem_Collect_eq o_def, rule mult_cong)
      fix p
      assume p: "p permutes ?zn"
      let ?q = "\<lambda> i. ?fn (p (?tn i))"
      from id p have q: "?q permutes ?U" by auto
      from p have pp: "permutation p" unfolding permutation_permutes by auto
      let ?ft = "\<lambda> p i. ?fn (p (?tn i))"
      have fin: "finite ?zn" by simp
      have "sign p = sign ?q \<and> p permutes ?zn"
      using p fin proof (induction rule: permutes_induct)
        case id
        show ?case by (auto simp: sign_id[unfolded id_def] permutes_id[unfolded id_def])
      next
        case (swap a b p)
        then have \<open>permutation p\<close>
          using permutes_imp_permutation by blast
        let ?sab = "Transposition.transpose a b"
        let ?sfab = "Transposition.transpose (?fn a) (?fn b)"
        have p_sab: "permutation ?sab" by (rule permutation_swap_id)
        have p_sfab: "permutation ?sfab" by (rule permutation_swap_id)
        from swap(4) have IH1: "p permutes ?zn" and IH2: "sign p = sign (?ft p)" by auto
        have sab_perm: "?sab permutes ?zn" using swap(1-2) by (rule permutes_swap_id)
        from permutes_compose[OF IH1 this] have perm1: "?sab o p permutes ?zn" .
        from IH1 have p_p1: "p \<in> ?p1" by simp
        hence "?ft p \<in> ?ft ` ?p1" by (rule imageI)
        from this[folded id] have "?ft p permutes ?U" by simp
        hence p_ftp: "permutation (?ft p)" unfolding permutation_permutes by auto
        {
          fix a b
          assume a: "a \<in> ?zn" and b: "b \<in> ?zn"
          hence "(?fn a = ?fn b) = (a = b)" using swap(1-2)
            by (auto simp add: from_nat_eq_imp_eq)
        } note inj = this
        from inj[OF swap(1-2)] have id2: "sign ?sfab = sign ?sab" unfolding sign_swap_id by simp
        have id: "?ft (Transposition.transpose a b \<circ> p) = Transposition.transpose (?fn a) (?fn b) \<circ> ?ft p"
        proof
          fix c
          show "?ft (Transposition.transpose a b \<circ> p) c = (Transposition.transpose (?fn a) (?fn b) \<circ> ?ft p) c"
          proof (cases "p (?tn c) = a \<or> p (?tn c) = b")
            case True
            thus ?thesis by (cases, auto simp add: o_def swap_id_eq)
          next
            case False
            hence neq: "p (?tn c) \<noteq> a" "p (?tn c) \<noteq> b" by auto
            have pc: "p (?tn c) \<in> ?zn" unfolding permutes_in_image[OF IH1]
              by (simp add: to_nat_less_card)
            from neq[folded inj[OF pc swap(1)] inj[OF pc swap(2)]]
            have "?fn (p (?tn c)) \<noteq> ?fn a" "?fn (p (?tn c)) \<noteq> ?fn b" .
            with neq show ?thesis by (auto simp: o_def swap_id_eq)
          qed
        qed
        show ?case unfolding IH2 id sign_compose[OF p_sab \<open>permutation p\<close>] sign_compose[OF p_sfab p_ftp] id2
          by (rule conjI[OF refl perm1])
      qed
      thus "signof p = of_int (sign ?q)" by simp
      show "(\<Prod>i = 0..<CARD('n). a $h ?fn i $h ?fn (p i)) =
           (\<Prod>i\<in>UNIV. a $h i $h ?q i)" unfolding
           range_to_nat[symmetric] prod.reindex[OF inj_to_nat]
            by (rule prod.cong[OF refl], unfold o_def, simp)
    qed
  }
  thus ?thesis unfolding HMA_M_def
    by (auto simp: from_hma\<^sub>m_def Determinant.det_def det_def)
qed

lemma HMA_mat[transfer_rule]: "((=) ===> HMA_M) (\<lambda> k. k \<cdot>\<^sub>m 1\<^sub>m CARD('n))
  (Finite_Cartesian_Product.mat :: 'a::semiring_1 \<Rightarrow> 'a^'n :: mod_type^'n :: mod_type)"
  unfolding Finite_Cartesian_Product.mat_def[abs_def] rel_fun_def HMA_M_def
  by (auto simp: from_hma\<^sub>m_def from_nat_inj)

lemma HMA_mat_minus[transfer_rule]: "(HMA_M ===> HMA_M ===> HMA_M)
  (\<lambda> A B. A + map_mat uminus B) ((-) :: 'a :: group_add ^'nc:: mod_type^'nr:: mod_type
  \<Rightarrow> 'a^'nc:: mod_type^'nr:: mod_type \<Rightarrow> 'a^'nc:: mod_type^'nr:: mod_type)"
  unfolding rel_fun_def HMA_M_def from_hma\<^sub>m_def by auto

lemma HMA_transpose_matrix [transfer_rule]:
  "(HMA_M ===> HMA_M) transpose_mat transpose"
  unfolding transpose_mat_def transpose_def HMA_M_def from_hma\<^sub>m_def by auto

lemma HMA_invertible_matrix_mod_type[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n :: mod_type ^ 'n :: mod_type
      \<Rightarrow> _) ===> (=)) invertible_mat invertible"
proof (intro rel_funI, goal_cases)
  case (1 x y)
  note rel_xy[transfer_rule] = "1"
  have eq_dim: "dim_col x = dim_row x"
    using Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule rel_xy
    by fastforce
  moreover have "\<exists>A'. y ** A' = mat 1 \<and> A' ** y = mat 1"
    if xB: "x * B = 1\<^sub>m (dim_row x)" and Bx: "B * x = 1\<^sub>m (dim_row B)" for B
  proof -
    let ?A' = "Mod_Type_Connect.to_hma\<^sub>m B:: 'a :: comm_ring_1 ^ 'n :: mod_type^ 'n :: mod_type"
    have rel_BA[transfer_rule]: "Mod_Type_Connect.HMA_M B ?A'"
      by (metis (no_types, lifting) Bx Mod_Type_Connect.HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
          Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.from_hma_to_hma\<^sub>m index_mult_mat(3)
          index_one_mat(3) rel_xy xB)
    have [simp]: "dim_row B = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_BA by blast
    have [simp]: "dim_row x = CARD('n)" using Mod_Type_Connect.dim_row_transfer_rule rel_xy by blast
    have "y ** ?A' = mat 1" using xB by (transfer, simp)
    moreover have "?A' ** y  = mat 1" using Bx by (transfer, simp)
    ultimately show ?thesis by blast
  qed
  moreover have "\<exists>B. x * B = 1\<^sub>m (dim_row x) \<and> B * x = 1\<^sub>m (dim_row B)"
    if yA: "y ** A' = mat 1" and Ay: "A' ** y = mat 1" for A'
  proof -
    let ?B = "(Mod_Type_Connect.from_hma\<^sub>m A')"
    have [simp]: "dim_row x = CARD('n)" using rel_xy Mod_Type_Connect.dim_row_transfer_rule by blast
    have [transfer_rule]: "Mod_Type_Connect.HMA_M ?B A'" by (simp add: Mod_Type_Connect.HMA_M_def)
    hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
    have "x * ?B = 1\<^sub>m (dim_row x)" using yA by (transfer', auto)
    moreover have "?B * x = 1\<^sub>m (dim_row ?B)" using Ay by (transfer', auto)
    ultimately show ?thesis by auto
  qed
  ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
qed

end

text \<open>Some transfer rules for relating the elementary operations are also proved.\<close>

context
  includes lifting_syntax
begin

lemma HMA_swaprows[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nr :: mod_type \<Rightarrow> _ )
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nr :: mod_type \<Rightarrow> _ )
    ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A a b. swaprows a b A) interchange_rows"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_rows_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_swapcols[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nc :: mod_type \<Rightarrow> _ )
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nc :: mod_type \<Rightarrow> _ )
    ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A a b. swapcols a b A) interchange_columns"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def interchange_columns_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_addrow[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nr :: mod_type \<Rightarrow> _ )
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nr :: mod_type \<Rightarrow> _ )
    ===> (=)
    ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A a b q. addrow q a b A) row_add"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def row_add_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_addcol[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nc :: mod_type \<Rightarrow> _ )
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nc :: mod_type \<Rightarrow> _ )
    ===> (=)
    ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A a b q. addcol q a b A) column_add"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def column_add_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_multrow[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nr :: mod_type \<Rightarrow> _ )
    ===> (=)
    ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A i q. multrow i q A) mult_row"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_row_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def
      to_nat_less_card to_nat_from_nat_id)

lemma HMA_multcol[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (Mod_Type_Connect.HMA_I :: _ \<Rightarrow>'nc :: mod_type \<Rightarrow> _ )
    ===> (=)
    ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A i q. multcol i q A) mult_column"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def mult_column_def)
     (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def Mod_Type_Connect.HMA_I_def
      to_nat_less_card to_nat_from_nat_id)

end

fun HMA_M3 where
  "HMA_M3 (P,A,Q)
  (P' :: 'a :: comm_ring_1 ^ 'nr :: mod_type ^ 'nr :: mod_type,
   A' :: 'a ^ 'nc :: mod_type ^ 'nr :: mod_type,
   Q' :: 'a ^ 'nc :: mod_type ^ 'nc :: mod_type) =
  (Mod_Type_Connect.HMA_M P P' \<and> Mod_Type_Connect.HMA_M A A' \<and> Mod_Type_Connect.HMA_M Q Q')"

lemma HMA_M3_def:
  "HMA_M3 A B = (Mod_Type_Connect.HMA_M (fst A) (fst B)
  \<and> Mod_Type_Connect.HMA_M (fst (snd A)) (fst (snd B))
  \<and> Mod_Type_Connect.HMA_M (snd (snd A)) (snd (snd B)))"
  by (smt HMA_M3.simps prod.collapse)

context
  includes lifting_syntax
begin

lemma Domainp_HMA_M3 [transfer_domain_rule]:
 "Domainp (HMA_M3 :: _\<Rightarrow>(_\<times>('a::comm_ring_1^'nc::mod_type^'nr::mod_type)\<times>_)\<Rightarrow>_)
 = (\<lambda>(P,A,Q). P \<in> carrier_mat CARD('nr) CARD('nr) \<and> A \<in> carrier_mat CARD('nr) CARD('nc)
  \<and> Q \<in> carrier_mat CARD('nc) CARD('nc))"
proof -
  let ?HMA_M3 = "HMA_M3::_\<Rightarrow>(_\<times>('a::comm_ring_1^'nc::mod_type^'nr::mod_type)\<times>_)\<Rightarrow>_"
  have 1: "P \<in> carrier_mat CARD('nr) CARD('nr) \<and>
         A \<in> carrier_mat CARD('nr) CARD('nc) \<and> Q \<in> carrier_mat CARD('nc) CARD('nc)"
    if "Domainp ?HMA_M3 (P,A,Q)" for P A Q
      using that unfolding Domainp_iff by (auto simp add: Mod_Type_Connect.HMA_M_def)
  have 2: "Domainp ?HMA_M3 (P,A,Q)" if PAQ: "P \<in> carrier_mat CARD('nr) CARD('nr)
   \<and> A \<in> carrier_mat CARD('nr) CARD('nc) \<and>Q \<in> carrier_mat CARD('nc) CARD('nc)" for P A Q
  proof -
     let ?P = "Mod_Type_Connect.to_hma\<^sub>m P::'a^'nr::mod_type^'nr::mod_type"
     let ?A = "Mod_Type_Connect.to_hma\<^sub>m A::'a^'nc::mod_type^'nr::mod_type"
     let ?Q = "Mod_Type_Connect.to_hma\<^sub>m Q::'a^'nc::mod_type^'nc::mod_type"
     have "HMA_M3 (P,A,Q) (?P,?A,?Q)"
       by (auto simp add: Mod_Type_Connect.HMA_M_def PAQ)
     thus ?thesis unfolding Domainp_iff by auto
   qed
   have "fst x \<in> carrier_mat CARD('nr) CARD('nr) \<and> fst (snd x) \<in> carrier_mat CARD('nr) CARD('nc)
      \<and> (snd (snd x)) \<in> carrier_mat CARD('nc) CARD('nc)"
    if "Domainp ?HMA_M3 x" for x using 1
    by (metis (full_types) surjective_pairing that)
  moreover have "Domainp ?HMA_M3 x"
    if "fst x \<in> carrier_mat CARD('nr) CARD('nr) \<and> fst (snd x) \<in> carrier_mat CARD('nr) CARD('nc)
      \<and> (snd (snd x)) \<in> carrier_mat CARD('nc) CARD('nc)" for x
    using 2
    by (metis (full_types) surjective_pairing that)
  ultimately show ?thesis by (intro ext iffI, unfold split_beta, metis+)
qed

lemma bi_unique_HMA_M3 [transfer_rule]: "bi_unique HMA_M3" "left_unique HMA_M3" "right_unique HMA_M3"
  unfolding HMA_M3_def bi_unique_def left_unique_def right_unique_def
  by (auto simp add: Mod_Type_Connect.HMA_M_def)

lemma right_total_HMA_M3 [transfer_rule]: "right_total HMA_M3"
  unfolding HMA_M_def right_total_def
  by (simp add: Mod_Type_Connect.HMA_M_def)

end

(*
  TODO: add more theorems to connect everything from HA to JNF in this setting.
*)
end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>First-price auction: adapted from VCG auction\<close>

theory FirstPrice

imports
CombinatorialAuction

begin

(* In a first price auction we use the same allocation algorithm as in a VCG auction.
   The price a winning bidder has to pay is given by evaluating b with respect to the bidder
   and the set he/she gets. *)
abbreviation "firstPriceP N \<Omega> b r n ==
  b (n, winningAllocationAlg N \<Omega> r b,, n)"

(* The non-negativity of prices follows immediately from the assumptions that all bids are
   non-negative. *)
theorem NonnegFirstPrices:
   assumes "\<forall> X. b (n, X) \<ge> 0"
   shows "firstPriceP N \<Omega> b r n \<ge> 0"
   using assms by blast
end


(*  Title       : NSPrimes.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2002 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section{*The Nonstandard Primes as an Extension of the Prime Numbers*}

theory NSPrimes
imports "~~/src/HOL/Number_Theory/UniqueFactorization" "../Hyperreal"
begin

text{*These can be used to derive an alternative proof of the infinitude of
primes by considering a property of nonstandard sets.*}

declare dvd_def [transfer_refold]

definition
  starprime :: "hypnat set" where
  [transfer_unfold]: "starprime = ( *s* {p. prime p})"

definition
  choicefun :: "'a set => 'a" where
  "choicefun E = (@x. \<exists>X \<in> Pow(E) -{{}}. x : X)"

primrec injf_max :: "nat => ('a::{order} set) => 'a"
where
  injf_max_zero: "injf_max 0 E = choicefun E"
| injf_max_Suc:  "injf_max (Suc n) E = choicefun({e. e:E & injf_max n E < e})"

lemma dvd_by_all: "\<forall>M. \<exists>N. 0 < N & (\<forall>m. 0 < m & (m::nat) <= M --> m dvd N)"
apply (rule allI)
apply (induct_tac "M", auto)
apply (rule_tac x = "N * (Suc n) " in exI)
by (metis dvd.order_refl dvd_mult dvd_mult2 le_Suc_eq nat_0_less_mult_iff zero_less_Suc)

lemmas dvd_by_all2 = dvd_by_all [THEN spec]

lemma hypnat_of_nat_le_zero_iff [simp]: "(hypnat_of_nat n <= 0) = (n = 0)"
by (transfer, simp)

(* Goldblatt: Exercise 5.11(2) - p. 57 *)
lemma hdvd_by_all: "\<forall>M. \<exists>N. 0 < N & (\<forall>m. 0 < m & (m::hypnat) <= M --> m dvd N)"
by (transfer, rule dvd_by_all)

lemmas hdvd_by_all2 = hdvd_by_all [THEN spec]

(* Goldblatt: Exercise 5.11(2) - p. 57 *)
lemma hypnat_dvd_all_hypnat_of_nat:
     "\<exists>(N::hypnat). 0 < N & (\<forall>n \<in> -{0::nat}. hypnat_of_nat(n) dvd N)"
apply (cut_tac hdvd_by_all)
apply (drule_tac x = whn in spec, auto)
apply (rule exI, auto)
apply (drule_tac x = "hypnat_of_nat n" in spec)
apply (auto simp add: linorder_not_less)
done

text{*The nonstandard extension of the set prime numbers consists of precisely
those hypernaturals exceeding 1 that have no nontrivial factors*}

(* Goldblatt: Exercise 5.11(3a) - p 57  *)
lemma starprime:
  "starprime = {p. 1 < p & (\<forall>m. m dvd p --> m = 1 | m = p)}"
by (transfer, auto simp add: prime_nat_def)

(* Goldblatt Exercise 5.11(3b) - p 57  *)
lemma hyperprime_factor_exists [rule_format]:
  "!!n. 1 < n ==> (\<exists>k \<in> starprime. k dvd n)"
by (transfer, simp add: prime_factor_nat)

(* Goldblatt Exercise 3.10(1) - p. 29 *)
lemma NatStar_hypnat_of_nat: "finite A ==> *s* A = hypnat_of_nat ` A"
by (rule starset_finite)

subsection{*Another characterization of infinite set of natural numbers*}

lemma finite_nat_set_bounded: "finite N ==> \<exists>n. (\<forall>i \<in> N. i<(n::nat))"
apply (erule_tac F = N in finite_induct, auto)
apply (rule_tac x = "Suc n + x" in exI, auto)
done

lemma finite_nat_set_bounded_iff: "finite N = (\<exists>n. (\<forall>i \<in> N. i<(n::nat)))"
by (blast intro: finite_nat_set_bounded bounded_nat_set_is_finite)

lemma not_finite_nat_set_iff: "(~ finite N) = (\<forall>n. \<exists>i \<in> N. n <= (i::nat))"
by (auto simp add: finite_nat_set_bounded_iff not_less)

lemma bounded_nat_set_is_finite2: "(\<forall>i \<in> N. i<=(n::nat)) ==> finite N"
apply (rule finite_subset)
 apply (rule_tac [2] finite_atMost, auto)
done

lemma finite_nat_set_bounded2: "finite N ==> \<exists>n. (\<forall>i \<in> N. i<=(n::nat))"
apply (erule_tac F = N in finite_induct, auto)
apply (rule_tac x = "n + x" in exI, auto)
done

lemma finite_nat_set_bounded_iff2: "finite N = (\<exists>n. (\<forall>i \<in> N. i<=(n::nat)))"
by (blast intro: finite_nat_set_bounded2 bounded_nat_set_is_finite2)

lemma not_finite_nat_set_iff2: "(~ finite N) = (\<forall>n. \<exists>i \<in> N. n < (i::nat))"
by (auto simp add: finite_nat_set_bounded_iff2 not_le)

subsection{*An injective function cannot define an embedded natural number*}

lemma lemma_infinite_set_singleton: "\<forall>m n. m \<noteq> n --> f n \<noteq> f m
      ==>  {n. f n = N} = {} |  (\<exists>m. {n. f n = N} = {m})"
apply auto
apply (drule_tac x = x in spec, auto)
apply (subgoal_tac "\<forall>n. (f n = f x) = (x = n) ")
apply auto
done

lemma inj_fun_not_hypnat_in_SHNat:
  assumes inj_f: "inj (f::nat=>nat)"
  shows "starfun f whn \<notin> Nats"
proof
  from inj_f have inj_f': "inj (starfun f)"
    by (transfer inj_on_def Ball_def UNIV_def)
  assume "starfun f whn \<in> Nats"
  then obtain N where N: "starfun f whn = hypnat_of_nat N"
    by (auto simp add: Nats_def)
  hence "\<exists>n. starfun f n = hypnat_of_nat N" ..
  hence "\<exists>n. f n = N" by transfer
  then obtain n where n: "f n = N" ..
  hence "starfun f (hypnat_of_nat n) = hypnat_of_nat N"
    by transfer
  with N have "starfun f whn = starfun f (hypnat_of_nat n)"
    by simp
  with inj_f' have "whn = hypnat_of_nat n"
    by (rule injD)
  thus "False"
    by (simp add: whn_neq_hypnat_of_nat)
qed

lemma range_subset_mem_starsetNat:
   "range f <= A ==> starfun f whn \<in> *s* A"
apply (rule_tac x="whn" in spec)
apply (transfer, auto)
done

(*--------------------------------------------------------------------------------*)
(* Gleason Proposition 11-5.5. pg 149, pg 155 (ex. 3) and pg. 360                 *)
(* Let E be a nonvoid ordered set with no maximal elements (note: effectively an  *)
(* infinite set if we take E = N (Nats)). Then there exists an order-preserving   *)
(* injection from N to E. Of course, (as some doofus will undoubtedly point out!  *)
(* :-)) can use notion of least element in proof (i.e. no need for choice) if     *)
(* dealing with nats as we have well-ordering property                            *)
(*--------------------------------------------------------------------------------*)

lemma lemmaPow3: "E \<noteq> {} ==> \<exists>x. \<exists>X \<in> (Pow E - {{}}). x: X"
by auto

lemma choicefun_mem_set [simp]: "E \<noteq> {} ==> choicefun E \<in> E"
apply (unfold choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex], auto)
done

lemma injf_max_mem_set: "[| E \<noteq>{}; \<forall>x. \<exists>y \<in> E. x < y |] ==> injf_max n E \<in> E"
apply (induct_tac "n", force)
apply (simp (no_asm) add: choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex], auto)
done

lemma injf_max_order_preserving: "\<forall>x. \<exists>y \<in> E. x < y ==> injf_max n E < injf_max (Suc n) E"
apply (simp (no_asm) add: choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex], auto)
done

lemma injf_max_order_preserving2: "\<forall>x. \<exists>y \<in> E. x < y
      ==> \<forall>n m. m < n --> injf_max m E < injf_max n E"
apply (rule allI)
apply (induct_tac "n", auto)
apply (simp (no_asm) add: choicefun_def)
apply (rule lemmaPow3 [THEN someI2_ex])
apply (auto simp add: less_Suc_eq)
apply (drule_tac x = m in spec)
apply (drule subsetD, auto)
apply (drule_tac x = "injf_max m E" in order_less_trans, auto)
done

lemma inj_injf_max: "\<forall>x. \<exists>y \<in> E. x < y ==> inj (%n. injf_max n E)"
apply (rule inj_onI)
apply (rule ccontr, auto)
apply (drule injf_max_order_preserving2)
apply (metis linorder_antisym_conv3 order_less_le)
done

lemma infinite_set_has_order_preserving_inj:
     "[| (E::('a::{order} set)) \<noteq> {}; \<forall>x. \<exists>y \<in> E. x < y |]
      ==> \<exists>f. range f <= E & inj (f::nat => 'a) & (\<forall>m. f m < f(Suc m))"
apply (rule_tac x = "%n. injf_max n E" in exI, safe)
apply (rule injf_max_mem_set)
apply (rule_tac [3] inj_injf_max)
apply (rule_tac [4] injf_max_order_preserving, auto)
done

text{*Only need the existence of an injective function from N to A for proof*}

lemma hypnat_infinite_has_nonstandard:
     "~ finite A ==> hypnat_of_nat ` A < ( *s* A)"
apply auto
apply (subgoal_tac "A \<noteq> {}")
prefer 2 apply force
apply (drule infinite_set_has_order_preserving_inj)
apply (erule not_finite_nat_set_iff2 [THEN iffD1], auto)
apply (drule inj_fun_not_hypnat_in_SHNat)
apply (drule range_subset_mem_starsetNat)
apply (auto simp add: SHNat_eq)
done

lemma starsetNat_eq_hypnat_of_nat_image_finite: "*s* A =  hypnat_of_nat ` A ==> finite A"
by (metis hypnat_infinite_has_nonstandard less_irrefl)

lemma finite_starsetNat_iff: "( *s* A = hypnat_of_nat ` A) = (finite A)"
by (blast intro!: starsetNat_eq_hypnat_of_nat_image_finite NatStar_hypnat_of_nat)

lemma hypnat_infinite_has_nonstandard_iff: "(~ finite A) = (hypnat_of_nat ` A < *s* A)"
apply (rule iffI)
apply (blast intro!: hypnat_infinite_has_nonstandard)
apply (auto simp add: finite_starsetNat_iff [symmetric])
done

subsection{*Existence of Infinitely Many Primes: a Nonstandard Proof*}

lemma lemma_not_dvd_hypnat_one [simp]: "~ (\<forall>n \<in> - {0}. hypnat_of_nat n dvd 1)"
apply auto
apply (rule_tac x = 2 in bexI)
apply (transfer, auto)
done

lemma lemma_not_dvd_hypnat_one2 [simp]: "\<exists>n \<in> - {0}. ~ hypnat_of_nat n dvd 1"
apply (cut_tac lemma_not_dvd_hypnat_one)
apply (auto simp del: lemma_not_dvd_hypnat_one)
done

lemma hypnat_add_one_gt_one:
    "!!N. 0 < N ==> 1 < (N::hypnat) + 1"
by (transfer, simp)

lemma hypnat_of_nat_zero_not_prime [simp]: "hypnat_of_nat 0 \<notin> starprime"
by (transfer, simp)

lemma hypnat_zero_not_prime [simp]:
   "0 \<notin> starprime"
by (cut_tac hypnat_of_nat_zero_not_prime, simp)

lemma hypnat_of_nat_one_not_prime [simp]: "hypnat_of_nat 1 \<notin> starprime"
by (transfer, simp)

lemma hypnat_one_not_prime [simp]: "1 \<notin> starprime"
by (cut_tac hypnat_of_nat_one_not_prime, simp)

lemma hdvd_diff: "!!k m n :: hypnat. [| k dvd m; k dvd n |] ==> k dvd (m - n)"
by (transfer, rule dvd_diff_nat)

lemma hdvd_one_eq_one: "!!x. x dvd (1::hypnat) ==> x = 1"
by (transfer, rule gcd_lcm_complete_lattice_nat.le_bot)

text{*Already proved as @{text primes_infinite}, but now using non-standard naturals.*}
theorem not_finite_prime: "~ finite {p::nat. prime p}"
apply (rule hypnat_infinite_has_nonstandard_iff [THEN iffD2])
apply (cut_tac hypnat_dvd_all_hypnat_of_nat)
apply (erule exE)
apply (erule conjE)
apply (subgoal_tac "1 < N + 1")
prefer 2 apply (blast intro: hypnat_add_one_gt_one)
apply (drule hyperprime_factor_exists)
apply auto
apply (subgoal_tac "k \<notin> hypnat_of_nat ` {p. prime p}")
apply (force simp add: starprime_def, safe)
apply (drule_tac x = x in bspec, auto)
apply (metis add.commute hdvd_diff hdvd_one_eq_one hypnat_diff_add_inverse2 hypnat_one_not_prime)
done

end