(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Finite Fields\<close>

text \<open>We provide four implementations for $GF(p)$ -- the field with $p$ elements for some
  prime $p$ -- one by int, one by integers, one by 32-bit numbers and one 64-bit implementation.
  Correctness of the implementations is proven by
  transfer rules to the type-based version of $GF(p)$.\<close>

theory Finite_Field_Record_Based
imports
  Finite_Field
  Arithmetic_Record_Based
  Native_Word.Uint32
  Native_Word.Uint64
  Native_Word.Code_Target_Bits_Int
  "HOL-Library.Code_Target_Numeral"
begin

(* mod on standard case which can immediately be mapped to
   target languages without considering special cases *)
definition mod_nonneg_pos :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "x \<ge> 0 \<Longrightarrow> y > 0 \<Longrightarrow> mod_nonneg_pos x y = (x mod y)"

code_printing \<comment> \<open>FIXME illusion of partiality\<close>
  constant mod_nonneg_pos \<rightharpoonup>
        (SML) "IntInf.mod/ ( _,/ _ )"
    and (Eval) "IntInf.mod/ ( _,/ _ )"
    and (OCaml) "Z.rem"
    and (Haskell) "Prelude.mod/ ( _ )/ ( _ )"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ (k '% l))"

definition mod_nonneg_pos_int :: "int \<Rightarrow> int \<Rightarrow> int" where
  "mod_nonneg_pos_int x y = int_of_integer (mod_nonneg_pos (integer_of_int x) (integer_of_int y))"

lemma mod_nonneg_pos_int[simp]: "x \<ge> 0 \<Longrightarrow> y > 0 \<Longrightarrow> mod_nonneg_pos_int x y = (x mod y)"
  unfolding mod_nonneg_pos_int_def using mod_nonneg_pos_def by simp

context
  fixes p :: int
begin
definition plus_p :: "int \<Rightarrow> int \<Rightarrow> int" where
  "plus_p x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

definition minus_p :: "int \<Rightarrow> int \<Rightarrow> int" where
  "minus_p x y \<equiv> if y \<le> x then x - y else x + p - y"

definition uminus_p :: "int \<Rightarrow> int" where
  "uminus_p x = (if x = 0 then 0 else p - x)"

definition mult_p :: "int \<Rightarrow> int \<Rightarrow> int" where
  "mult_p x y = (mod_nonneg_pos_int (x * y) p)"

fun power_p :: "int \<Rightarrow> nat \<Rightarrow> int" where
  "power_p x n = (if n = 0 then 1 else
    let (d,r) = Divides.divmod_nat n 2;
       rec = power_p (mult_p x x) d in
    if r = 0 then rec else mult_p rec x)"

text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.\<close>

definition inverse_p :: "int \<Rightarrow> int" where
  "inverse_p x = (if x = 0 then 0 else power_p x (nat (p - 2)))"

definition divide_p :: "int \<Rightarrow> int \<Rightarrow> int"  where
  "divide_p x y = mult_p x (inverse_p y)"

definition finite_field_ops_int :: "int arith_ops_record" where
  "finite_field_ops_int \<equiv> Arith_Ops_Record
      0
      1
      plus_p
      mult_p
      minus_p
      uminus_p
      divide_p
      inverse_p
      (\<lambda> x y . if y = 0 then x else 0)
      (\<lambda> x . if x = 0 then 0 else 1)
      (\<lambda> x . x)
      (\<lambda> x . x)
      (\<lambda> x . x)
      (\<lambda> x. 0 \<le> x \<and> x < p)"

end

context
  fixes p :: uint32
begin
definition plus_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
  "plus_p32 x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

definition minus_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
  "minus_p32 x y \<equiv> if y \<le> x then x - y else (x + p) - y"

definition uminus_p32 :: "uint32 \<Rightarrow> uint32" where
  "uminus_p32 x = (if x = 0 then 0 else p - x)"

definition mult_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
  "mult_p32 x y = (x * y mod p)"

lemma int_of_uint32_shift: "int_of_uint32 (shiftr n k) = (int_of_uint32 n) div (2 ^ k)"
  by (transfer, rule shiftr_div_2n)

lemma int_of_uint32_0_iff: "int_of_uint32 n = 0 \<longleftrightarrow> n = 0"
  by (transfer, rule uint_0_iff)

lemma int_of_uint32_0: "int_of_uint32 0 = 0" unfolding int_of_uint32_0_iff by simp

lemma int_of_uint32_ge_0: "int_of_uint32 n \<ge> 0"
  by (transfer, auto)

lemma two_32: "2 ^ LENGTH(32) = (4294967296 :: int)" by simp

lemma int_of_uint32_plus: "int_of_uint32 (x + y) = (int_of_uint32 x + int_of_uint32 y) mod 4294967296"
  by (transfer, unfold uint_word_ariths two_32, rule refl)

lemma int_of_uint32_mult: "int_of_uint32 (x * y) = (int_of_uint32 x * int_of_uint32 y) mod 4294967296"
  by (transfer, unfold uint_word_ariths two_32, rule refl)

lemma int_of_uint32_mod: "int_of_uint32 (x mod y) = (int_of_uint32 x mod int_of_uint32 y)"
  by (transfer, unfold uint_mod two_32, rule refl)

lemma int_of_uint32_inv: "0 \<le> x \<Longrightarrow> x < 4294967296 \<Longrightarrow> int_of_uint32 (uint32_of_int x) = x"
  by (transfer, simp add: int_word_uint)

function power_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
  "power_p32 x n = (if n = 0 then 1 else
    let rec = power_p32 (mult_p32 x x) (shiftr n 1) in
    if n AND 1 = 0 then rec else mult_p32 rec x)"
  by pat_completeness auto

termination
proof -
  {
    fix n :: uint32
    assume "n \<noteq> 0"
    with int_of_uint32_ge_0[of n] int_of_uint32_0_iff[of n] have "int_of_uint32 n > 0" by auto
    hence "0 < int_of_uint32 n" "int_of_uint32 n div 2 < int_of_uint32 n" by auto
  } note * = this
  show ?thesis
    by (relation "measure (\<lambda> (x,n). nat (int_of_uint32 n))", auto simp: int_of_uint32_shift *)
qed

text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.\<close>

definition inverse_p32 :: "uint32 \<Rightarrow> uint32" where
  "inverse_p32 x = (if x = 0 then 0 else power_p32 x (p - 2))"

definition divide_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"  where
  "divide_p32 x y = mult_p32 x (inverse_p32 y)"

definition finite_field_ops32 :: "uint32 arith_ops_record" where
  "finite_field_ops32 \<equiv> Arith_Ops_Record
      0
      1
      plus_p32
      mult_p32
      minus_p32
      uminus_p32
      divide_p32
      inverse_p32
      (\<lambda> x y . if y = 0 then x else 0)
      (\<lambda> x . if x = 0 then 0 else 1)
      (\<lambda> x . x)
      uint32_of_int
      int_of_uint32
      (\<lambda> x. 0 \<le> x \<and> x < p)"
end

lemma shiftr_uint32_code [code_unfold]: "shiftr x 1 = (uint32_shiftr x 1)"
  unfolding shiftr_uint32_code using integer_of_nat_1 by auto

(* ******************************************************************************** *)
subsubsection \<open>Transfer Relation\<close>
locale mod_ring_locale =
  fixes p :: int and ty :: "'a :: nontriv itself"
  assumes p: "p = int CARD('a)"
begin
lemma nat_p: "nat p = CARD('a)" unfolding p by simp
lemma p2: "p \<ge> 2" unfolding p using nontriv[where 'a = 'a] by auto
lemma p2_ident: "int (CARD('a) - 2) = p - 2" using p2 unfolding p by simp

definition mod_ring_rel :: "int \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
  "mod_ring_rel x x' = (x = to_int_mod_ring x')"

(* domain transfer rules *)
lemma Domainp_mod_ring_rel [transfer_domain_rule]:
  "Domainp (mod_ring_rel) = (\<lambda> v. v \<in> {0 ..< p})"
proof -
  {
    fix v :: int
    assume *: "0 \<le> v" "v < p"
    have "Domainp mod_ring_rel v"
    proof
      show "mod_ring_rel v (of_int_mod_ring v)" unfolding mod_ring_rel_def using * p by auto
    qed
  } note * = this
  show ?thesis
    by (intro ext iffI, insert range_to_int_mod_ring[where 'a = 'a] *, auto simp: mod_ring_rel_def p)
qed

(* left/right/bi-unique *)
lemma bi_unique_mod_ring_rel [transfer_rule]:
  "bi_unique mod_ring_rel" "left_unique mod_ring_rel" "right_unique mod_ring_rel"
  unfolding mod_ring_rel_def bi_unique_def left_unique_def right_unique_def
  by auto

(* left/right-total *)
lemma right_total_mod_ring_rel [transfer_rule]: "right_total mod_ring_rel"
  unfolding mod_ring_rel_def right_total_def by simp

(* ************************************************************************************ *)
subsubsection \<open>Transfer Rules\<close>

(* 0 / 1 *)
lemma mod_ring_0[transfer_rule]: "mod_ring_rel 0 0" unfolding mod_ring_rel_def by simp
lemma mod_ring_1[transfer_rule]: "mod_ring_rel 1 1" unfolding mod_ring_rel_def by simp

(* addition *)
lemma plus_p_mod_def: assumes x: "x \<in> {0 ..< p}" and y: "y \<in> {0 ..< p}"
  shows "plus_p p x y = ((x + y) mod p)"
proof (cases "p \<le> x + y")
  case False
  thus ?thesis using x y unfolding plus_p_def Let_def by auto
next
  case True
  from True x y have *: "p > 0" "0 \<le> x + y - p" "x + y - p < p" by auto
  from True have id: "plus_p p x y = x + y - p" unfolding plus_p_def by auto
  show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
qed

lemma mod_ring_plus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (plus_p p) (+)"
proof -
  {
    fix x y :: "'a mod_ring"
    have "plus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x + y)"
      by (transfer, subst plus_p_mod_def, auto, auto simp: p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* subtraction *)
lemma minus_p_mod_def: assumes x: "x \<in> {0 ..< p}" and y: "y \<in> {0 ..< p}"
  shows "minus_p p x y = ((x - y) mod p)"
proof (cases "x - y < 0")
  case False
  thus ?thesis using x y unfolding minus_p_def Let_def by auto
next
  case True
  from True x y have *: "p > 0" "0 \<le> x - y + p" "x - y + p < p" by auto
  from True have id: "minus_p p x y = x - y + p" unfolding minus_p_def by auto
  show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
qed

lemma mod_ring_minus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (minus_p p) (-)"
proof -
  {
    fix x y :: "'a mod_ring"
    have "minus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x - y)"
      by (transfer, subst minus_p_mod_def, auto simp: p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* unary minus *)
lemma mod_ring_uminus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (uminus_p p) uminus"
proof -
  {
    fix x :: "'a mod_ring"
    have "uminus_p p (to_int_mod_ring x) = to_int_mod_ring (uminus x)"
      by (transfer, auto simp: uminus_p_def p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* multiplication *)
lemma mod_ring_mult[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (mult_p p) ((*))"
proof -
  {
    fix x y :: "'a mod_ring"
    have "mult_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x * y)"
      by (transfer, auto simp: mult_p_def p)
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *)
qed

(* equality *)
lemma mod_ring_eq[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> (=)) (=) (=)"
  by (intro rel_funI, auto simp: mod_ring_rel_def)

(* power *)
lemma mod_ring_power[transfer_rule]: "(mod_ring_rel ===> (=) ===> mod_ring_rel) (power_p p) (^)"
proof (intro rel_funI, clarify, unfold binary_power[symmetric], goal_cases)
  fix x y n
  assume xy: "mod_ring_rel x y"
  from xy show "mod_ring_rel (power_p p x n) (binary_power y n)"
  proof (induct y n arbitrary: x rule: binary_power.induct)
    case (1 x n y)
    note 1(2)[transfer_rule]
    show ?case
    proof (cases "n = 0")
      case True
      thus ?thesis by (simp add: mod_ring_1)
    next
      case False
      obtain d r where id: "Divides.divmod_nat n 2 = (d,r)" by force
      let ?int = "power_p p (mult_p p y y) d"
      let ?gfp = "binary_power (x * x) d"
      from False have id': "?thesis = (mod_ring_rel
         (if r = 0 then ?int else mult_p p ?int y)
         (if r = 0 then ?gfp else ?gfp * x))"
        unfolding power_p.simps[of _ _ n] binary_power.simps[of _ n] Let_def id split by simp
      have [transfer_rule]: "mod_ring_rel ?int ?gfp"
        by (rule 1(1)[OF False refl id[symmetric]], transfer_prover)
      show ?thesis unfolding id' by transfer_prover
    qed
  qed
qed

declare power_p.simps[simp del]

lemma ring_finite_field_ops_int: "ring_ops (finite_field_ops_int p) mod_ring_rel"
  by (unfold_locales, auto simp:
  finite_field_ops_int_def
  bi_unique_mod_ring_rel
  right_total_mod_ring_rel
  mod_ring_plus
  mod_ring_minus
  mod_ring_uminus
  mod_ring_mult
  mod_ring_eq
  mod_ring_0
  mod_ring_1
  Domainp_mod_ring_rel)
end

locale prime_field = mod_ring_locale p ty for p and ty :: "'a :: prime_card itself"
begin

lemma prime: "prime p" unfolding p using prime_card[where 'a = 'a] by simp

(* mod *)
lemma mod_ring_mod[transfer_rule]:
 "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) ((\<lambda> x y. if y = 0 then x else 0)) (mod)"
proof -
  {
    fix x y :: "'a mod_ring"
    have "(if to_int_mod_ring y = 0 then to_int_mod_ring x else 0) = to_int_mod_ring (x mod y)"
      unfolding modulo_mod_ring_def by auto
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed

(* normalize *)
lemma mod_ring_normalize[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) ((\<lambda> x. if x = 0 then 0 else 1)) normalize"
proof -
  {
    fix x :: "'a mod_ring"
    have "(if to_int_mod_ring x = 0 then 0 else 1) = to_int_mod_ring (normalize x)"
      unfolding normalize_mod_ring_def by auto
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed

(* unit_factor *)
lemma mod_ring_unit_factor[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (\<lambda> x. x) unit_factor"
proof -
  {
    fix x :: "'a mod_ring"
    have "to_int_mod_ring x = to_int_mod_ring (unit_factor x)"
      unfolding unit_factor_mod_ring_def by auto
  } note * = this
  show ?thesis
    by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
qed

(* inverse *)
lemma mod_ring_inverse[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (inverse_p p) inverse"
proof (intro rel_funI)
  fix x y
  assume [transfer_rule]: "mod_ring_rel x y"
  show "mod_ring_rel (inverse_p p x) (inverse y)"
    unfolding inverse_p_def inverse_mod_ring_def
    apply (transfer_prover_start)
    apply (transfer_step)+
    apply (unfold p2_ident)
    apply (rule refl)
    done
qed

(* division *)
lemma mod_ring_divide[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel)
  (divide_p p) (/)"
  unfolding divide_p_def[abs_def] divide_mod_ring_def[abs_def] inverse_mod_ring_def[symmetric]
  by transfer_prover

lemma mod_ring_rel_unsafe: assumes "x < CARD('a)"
  shows "mod_ring_rel (int x) (of_nat x)" "0 < x \<Longrightarrow> of_nat x \<noteq> (0 :: 'a mod_ring)"
proof -
  have id: "of_nat x = (of_int (int x) :: 'a mod_ring)" by simp
  show "mod_ring_rel (int x) (of_nat x)" "0 < x \<Longrightarrow> of_nat x \<noteq> (0 :: 'a mod_ring)" unfolding id
  unfolding mod_ring_rel_def
  proof (auto simp add: assms of_int_of_int_mod_ring)
    assume "0 < x" with assms
    have "of_int_mod_ring (int x) \<noteq> (0 :: 'a mod_ring)"
      by (metis (no_types) less_imp_of_nat_less less_irrefl of_nat_0_le_iff of_nat_0_less_iff to_int_mod_ring_hom.hom_zero to_int_mod_ring_of_int_mod_ring)
    thus "of_int_mod_ring (int x) = (0 :: 'a mod_ring) \<Longrightarrow> False" by blast
  qed
qed

lemma finite_field_ops_int: "field_ops (finite_field_ops_int p) mod_ring_rel"
  by (unfold_locales, auto simp:
  finite_field_ops_int_def
  bi_unique_mod_ring_rel
  right_total_mod_ring_rel
  mod_ring_divide
  mod_ring_plus
  mod_ring_minus
  mod_ring_uminus
  mod_ring_inverse
  mod_ring_mod
  mod_ring_unit_factor
  mod_ring_normalize
  mod_ring_mult
  mod_ring_eq
  mod_ring_0
  mod_ring_1
  Domainp_mod_ring_rel)

end

text \<open>Once we have proven the soundness of the implementation, we do not care any longer
  that @{typ "'a mod_ring"} has been defined internally via lifting. Disabling the transfer-rules
  will hide the internal definition in further applications of transfer.\<close>
lifting_forget mod_ring.lifting

text \<open>For soundness of the 32-bit implementation, we mainly prove that this implementation
  implements the int-based implementation of the mod-ring.\<close>
context mod_ring_locale
begin

context fixes pp :: "uint32"
  assumes ppp: "p = int_of_uint32 pp"
  and small: "p \<le> 65535"
begin

lemmas uint32_simps =
  int_of_uint32_0
  int_of_uint32_plus
  int_of_uint32_minus
  int_of_uint32_mult

definition urel32 :: "uint32 \<Rightarrow> int \<Rightarrow> bool" where "urel32 x y = (y = int_of_uint32 x \<and> y < p)"

definition mod_ring_rel32 :: "uint32 \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
  "mod_ring_rel32 x y = (\<exists> z. urel32 x z \<and> mod_ring_rel z y)"

lemma urel32_0: "urel32 0 0" unfolding urel32_def using p2 by (simp, transfer, simp)

lemma urel32_1: "urel32 1 1" unfolding urel32_def using p2 by (simp, transfer, simp)

lemma le_int_of_uint32: "(x \<le> y) = (int_of_uint32 x \<le> int_of_uint32 y)"
  by (transfer, simp add: word_le_def)

lemma urel32_plus: assumes "urel32 x y" "urel32 x' y'"
  shows "urel32 (plus_p32 pp x x') (plus_p p y y')"
proof -
  let ?x = "int_of_uint32 x"
  let ?x' = "int_of_uint32 x'"
  let ?p = "int_of_uint32 pp"
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' \<le> p" unfolding urel32_def by auto
  have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_uint32
    using rel small by (auto simp: uint32_simps)
  show ?thesis
  proof (cases "?p \<le> ?x + ?x'")
    case True
    hence True: "(?p \<le> ?x + ?x') = True" by simp
    show ?thesis unfolding id
      using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def
      unfolding ppp le True if_True
      using True by (auto simp: uint32_simps)
  next
    case False
    hence False: "(?p \<le> ?x + ?x') = False" by simp
    show ?thesis unfolding id
      using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def
      unfolding ppp le False if_False
      using False by (auto simp: uint32_simps)
  qed
qed

lemma urel32_uminus: assumes "urel32 x y"
  shows "urel32 (uminus_p32 pp x) (uminus_p p y)"
proof -
  let ?x = "int_of_uint32 x"
  from assms int_of_uint32_ge_0 have id: "y = ?x"
    and rel: "0 \<le> ?x" "?x < p"
      unfolding urel32_def by auto
  have le: "(x = 0) = (?x = 0)" unfolding int_of_uint32_0_iff
    using rel small by (auto simp: uint32_simps)
  show ?thesis
  proof (cases "?x = 0")
    case True
    hence True: "(?x = 0) = True" by simp
    show ?thesis unfolding id
      using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def
      unfolding ppp le True if_True
      using True by (auto simp: uint32_simps)
  next
    case False
    hence False: "(?x = 0) = False" by simp
    show ?thesis unfolding id
      using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def
      unfolding ppp le False if_False
      using False by (auto simp: uint32_simps)
  qed
qed

lemma urel32_mult: assumes "urel32 x y" "urel32 x' y'"
  shows "urel32 (mult_p32 pp x x') (mult_p p y y')"
proof -
  let ?x = "int_of_uint32 x"
  let ?x' = "int_of_uint32 x'"
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' < p" unfolding urel32_def by auto
  from rel have "?x * ?x' < p * p" by (metis mult_strict_mono')
  also have "\<dots> \<le> 65536 * 65536"
    by (rule mult_mono, insert p2 small, auto)
  finally have le: "?x * ?x' < 4294967296" by simp
  show ?thesis unfolding id
      using small rel unfolding mult_p32_def mult_p_def Let_def urel32_def
      unfolding ppp
    by (auto simp: uint32_simps, unfold int_of_uint32_mod int_of_uint32_mult,
        subst mod_pos_pos_trivial[of _ 4294967296], insert le, auto)
qed

lemma urel32_eq: assumes "urel32 x y" "urel32 x' y'"
  shows "(x = x') = (y = y')"
proof -
  let ?x = "int_of_uint32 x"
  let ?x' = "int_of_uint32 x'"
  from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'"
    unfolding urel32_def by auto
  show ?thesis unfolding id by (transfer, auto)
qed

lemma urel32_normalize:
assumes x: "urel32 x y"
shows "urel32 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
 unfolding urel32_eq[OF x urel32_0] using urel32_0 urel32_1 by auto

lemma urel32_mod:
assumes x: "urel32 x x'" and y: "urel32 y y'"
shows "urel32 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
  unfolding urel32_eq[OF y urel32_0] using urel32_0 x by auto

lemma urel32_inverse: assumes x: "urel32 x x'"
  shows "urel32 (inverse_p32 pp x) (inverse_p p x')"
proof -
  have p: "urel32 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel32_def unfolding ppp
    by (transfer, auto simp: uint_word_ariths)
  show ?thesis
    unfolding inverse_p32_def inverse_p_def urel32_eq[OF x urel32_0] using urel32_0 urel32_power[OF x p]
    by auto
qed

lemma mod_ring_0_32: "mod_ring_rel32 0 0"
  using urel32_0 mod_ring_0 unfolding mod_ring_rel32_def by blast

lemma mod_ring_1_32: "mod_ring_rel32 1 1"
  using urel32_1 mod_ring_1 unfolding mod_ring_rel32_def by blast

lemma mod_ring_uminus32: "(mod_ring_rel32 ===> mod_ring_rel32) (uminus_p32 pp) uminus"
  using urel32_uminus mod_ring_uminus unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_plus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (plus_p32 pp) (+)"
  using urel32_plus mod_ring_plus unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_minus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (minus_p32 pp) (-)"
  using urel32_minus mod_ring_minus unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_mult32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (mult_p32 pp) ((*))"
  using urel32_mult mod_ring_mult unfolding mod_ring_rel32_def rel_fun_def by blast

lemma mod_ring_eq32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> (=)) (=) (=)"
  using urel32_eq mod_ring_eq unfolding mod_ring_rel32_def rel_fun_def by blast

lemma urel32_inj: "urel32 x y \<Longrightarrow> urel32 x z \<Longrightarrow> y = z"
  using urel32_eq[of x y x z] by auto

lemma urel32_inj': "urel32 x z \<Longrightarrow> urel32 y z \<Longrightarrow> x = y"
  using urel32_eq[of x z y z] by auto

lemma bi_unique_mod_ring_rel32:
  "bi_unique mod_ring_rel32" "left_unique mod_ring_rel32" "right_unique mod_ring_rel32"
  using bi_unique_mod_ring_rel urel32_inj'
  unfolding mod_ring_rel32_def bi_unique_def left_unique_def right_unique_def
  by (auto simp: urel32_def)

lemma right_total_mod_ring_rel32: "right_total mod_ring_rel32"
  unfolding mod_ring_rel32_def right_total_def
proof
  fix y :: "'a mod_ring"
  from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
  obtain z where zy: "mod_ring_rel z y" by auto
  hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
  hence "urel32 (uint32_of_int z) z" unfolding urel32_def using small unfolding ppp
    by (auto simp: int_of_uint32_inv)
  with zy show "\<exists> x z. urel32 x z \<and> mod_ring_rel z y" by blast
qed

lemma Domainp_mod_ring_rel32: "Domainp mod_ring_rel32 = (\<lambda>x. 0 \<le> x \<and> x < pp)"
proof
  fix x
  show "Domainp mod_ring_rel32 x = (0 \<le> x \<and> x < pp)"
    unfolding Domainp.simps
    unfolding mod_ring_rel32_def
  proof
    let ?i = "int_of_uint32"
    assume *: "0 \<le> x \<and> x < pp"
    hence "0 \<le> ?i x \<and> ?i x < p" using small unfolding ppp
      by (transfer, auto simp: word_less_def)
    hence "?i x \<in> {0 ..< p}" by auto
    with Domainp_mod_ring_rel
    have "Domainp mod_ring_rel (?i x)" by auto
    from this[unfolded Domainp.simps]
    obtain b where b: "mod_ring_rel (?i x) b" by auto
    show "\<exists>a b. x = a \<and> (\<exists>z. urel32 a z \<and> mod_ring_rel z b)"
    proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
      show "urel32 x (?i x)" unfolding urel32_def using small * unfolding ppp
        by (transfer, auto simp: word_less_def)
    qed
  next
    assume "\<exists>a b. x = a \<and> (\<exists>z. urel32 a z \<and> mod_ring_rel z b)"
    then obtain b z where xz: "urel32 x z" and zb: "mod_ring_rel z b" by auto
    hence "Domainp mod_ring_rel z"  by auto
    with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
    with xz show "0 \<le> x \<and> x < pp" unfolding urel32_def using small unfolding ppp
      by (transfer, auto simp: word_less_def)
  qed
qed

lemma ring_finite_field_ops32: "ring_ops (finite_field_ops32 pp) mod_ring_rel32"
  by (unfold_locales, auto simp:
  finite_field_ops32_def
  bi_unique_mod_ring_rel32
  right_total_mod_ring_rel32
  mod_ring_plus32
  mod_ring_minus32
  mod_ring_uminus32
  mod_ring_mult32
  mod_ring_eq32
  mod_ring_0_32
  mod_ring_1_32
  Domainp_mod_ring_rel32)
end
end

context prime_field
begin
context fixes pp :: "uint32"
  assumes *: "p = int_of_uint32 pp" "p \<le> 65535"
begin

lemma mod_ring_mod32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x y. if y = 0 then x else 0) (mod)"
  using urel32_mod[OF *] mod_ring_mod unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_unit_factor32: "(mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x. x) unit_factor"
  using mod_ring_unit_factor unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_inverse32: "(mod_ring_rel32 ===> mod_ring_rel32) (inverse_p32 pp) inverse"
  using urel32_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast

lemma mod_ring_divide32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (divide_p32 pp) (/)"
  using mod_ring_inverse32 mod_ring_mult32[OF *]
  unfolding divide_p32_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
    rel_fun_def by blast

lemma finite_field_ops32: "field_ops (finite_field_ops32 pp) mod_ring_rel32"
  by (unfold_locales, insert ring_finite_field_ops32[OF *], auto simp:
  ring_ops_def
  finite_field_ops32_def
  mod_ring_divide32
  mod_ring_inverse32
  mod_ring_mod32
  mod_ring_normalize32)

end
end

(* now there is 64-bit time *)
context
  fixes p :: uint64
begin
definition plus_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
  "plus_p64 x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

definition minus_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
  "minus_p64 x y \<equiv> if y \<le> x then x - y else (x + p) - y"

definition uminus_p64 :: "uint64 \<Rightarrow> uint64" where
  "uminus_p64 x = (if x = 0 then 0 else p - x)"

definition mult_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
  "mult_p64 x y = (x * y mod p)"

lemma int_of_uint64_shift: "int_of_uint64 (shiftr n k) = (int_of_uint64 n) div (2 ^ k)"
  by (transfer, rule shiftr_div_2n)

lemma int_of_uint64_0_iff: "int_of_uint64 n = 0 \<longleftrightarrow> n = 0"
  by (transfer, rule uint_0_iff)

lemma int_of_uint64_0: "int_of_uint64 0 = 0" unfolding int_of_uint64_0_iff by simp

lemma int_of_uint64_ge_0: "int_of_uint64 n \<ge> 0"
  by (transfer, auto)

lemma two_64: "2 ^ LENGTH(64) = (18446744073709551616 :: int)" by simp

lemma int_of_uint64_plus: "int_of_uint64 (x + y) = (int_of_uint64 x + int_of_uint64 y) mod 18446744073709551616"
  by (transfer, unfold uint_word_ariths two_64, rule refl)

lemma int_of_uint64_minus: "int_of_uint64 (x - y) = (int_of_uint64 x - int_of_uint64 y) mod 18446744073709551616"
  by (transfer, unfold uint_word_ariths two_64, rule refl)

lemma int_of_uint64_mult: "int_of_uint64 (x * y) = (int_of_uint64 x * int_of_uint64 y) mod 18446744073709551616"
  by (transfer, unfold uint_word_ariths two_64, rule refl)

lemma int_of_uint64_mod: "int_of_uint64 (x mod y) = (int_of_uint64 x mod int_of_uint64 y)"
  by (transfer, unfold uint_mod two_64, rule refl)

lemma int_of_uint64_inv: "0 \<le> x \<Longrightarrow> x < 18446744073709551616 \<Longrightarrow> int_of_uint64 (uint64_of_int x) = x"
  by (transfer, simp add: int_word_uint)

function power_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
  "power_p64 x n = (if n = 0 then 1 else
    let rec = power_p64 (mult_p64 x x) (shiftr n 1) in
    if n AND 1 = 0 then rec else mult_p64 rec x)"
  by pat_completeness auto

termination
proof -
  {
    fix n :: uint64
    assume "n \<noteq> 0"
    with int_of_uint64_ge_0[of n] int_of_uint64_0_iff[of n] have "int_of_uint64 n > 0" by auto
    hence "0 < int_of_uint64 n" "int_of_uint64 n div 2 < int_of_uint64 n" by auto
  } note * = this
  show ?thesis
    by (relation "measure (\<lambda> (x,n). nat (int_of_uint64 n))", auto simp: int_of_uint64_shift *)
qed

text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.\<close>

definition inverse_p64 :: "uint64 \<Rightarrow> uint64" where
  "inverse_p64 x = (if x = 0 then 0 else power_p64 x (p - 2))"

definition divide_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"  where
  "divide_p64 x y = mult_p64 x (inverse_p64 y)"

definition finite_field_ops64 :: "uint64 arith_ops_record" where
  "finite_field_ops64 \<equiv> Arith_Ops_Record
      0
      1
      plus_p64
      mult_p64
      minus_p64
      uminus_p64
      divide_p64
      inverse_p64
      (\<lambda> x y . if y = 0 then x else 0)
      (\<lambda> x . if x = 0 then 0 else 1)
      (\<lambda> x . x)
      uint64_of_int
      int_of_uint64
      (\<lambda> x. 0 \<le> x \<and> x < p)"
end

lemma shiftr_uint64_code [code_unfold]: "shiftr x 1 = (uint64_shiftr x 1)"
  unfolding shiftr_uint64_code using integer_of_nat_1 by auto

text \<open>For soundness of the 64-bit implementation, we mainly prove that this implementation
  implements the int-based implementation of GF(p).\<close>
context mod_ring_locale
begin

context fixes pp :: "uint64"
  assumes ppp: "p = int_of_uint64 pp"
  and small: "p \<le> 4294967295"
begin

lemmas uint64_simps =
  int_of_uint64_0
  int_of_uint64_plus
  int_of_uint64_minus
  int_of_uint64_mult

definition urel64 :: "uint64 \<Rightarrow> int \<Rightarrow> bool" where "urel64 x y = (y = int_of_uint64 x \<and> y < p)"

definition mod_ring_rel64 :: "uint64 \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
  "mod_ring_rel64 x y = (\<exists> z. urel64 x z \<and> mod_ring_rel z y)"

lemma urel64_0: "urel64 0 0" unfolding urel64_def using p2 by (simp, transfer, simp)

lemma urel64_1: "urel64 1 1" unfolding urel64_def using p2 by (simp, transfer, simp)

lemma le_int_of_uint64: "(x \<le> y) = (int_of_uint64 x \<le> int_of_uint64 y)"
  by (transfer, simp add: word_le_def)

lemma urel64_plus: assumes "urel64 x y" "urel64 x' y'"
  shows "urel64 (plus_p64 pp x x') (plus_p p y y')"
proof -
  let ?x = "int_of_uint64 x"
  let ?x' = "int_of_uint64 x'"
  let ?p = "int_of_uint64 pp"
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' \<le> p" unfolding urel64_def by auto
  have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_uint64
    using rel small by (auto simp: uint64_simps)
  show ?thesis
  proof (cases "?p \<le> ?x + ?x'")
    case True
    hence True: "(?p \<le> ?x + ?x') = True" by simp
    show ?thesis unfolding id
      using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def
      unfolding ppp le True if_True
      using True by (auto simp: uint64_simps)
  next
    case False
    hence False: "(?p \<le> ?x + ?x') = False" by simp
    show ?thesis unfolding id
      using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def
      unfolding ppp le False if_False
      using False by (auto simp: uint64_simps)
  qed
qed

lemma urel64_minus: assumes "urel64 x y" "urel64 x' y'"
  shows "urel64 (minus_p64 pp x x') (minus_p p y y')"
proof -
  let ?x = "int_of_uint64 x"
  let ?x' = "int_of_uint64 x'"
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' \<le> p" unfolding urel64_def by auto
  have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_uint64
    using rel small by (auto simp: uint64_simps)
  show ?thesis
  proof (cases "?x' \<le> ?x")
    case True
    hence True: "(?x' \<le> ?x) = True" by simp
    show ?thesis unfolding id
      using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def
      unfolding ppp le True if_True
      using True by (auto simp: uint64_simps)
  next
    case False
    hence False: "(?x' \<le> ?x) = False" by simp
    show ?thesis unfolding id
      using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def
      unfolding ppp le False if_False
      using False by (auto simp: uint64_simps)
  qed
qed

lemma urel64_uminus: assumes "urel64 x y"
  shows "urel64 (uminus_p64 pp x) (uminus_p p y)"
proof -
  let ?x = "int_of_uint64 x"
  from assms int_of_uint64_ge_0 have id: "y = ?x"
    and rel: "0 \<le> ?x" "?x < p"
      unfolding urel64_def by auto
  have le: "(x = 0) = (?x = 0)" unfolding int_of_uint64_0_iff
    using rel small by (auto simp: uint64_simps)
  show ?thesis
  proof (cases "?x = 0")
    case True
    hence True: "(?x = 0) = True" by simp
    show ?thesis unfolding id
      using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def
      unfolding ppp le True if_True
      using True by (auto simp: uint64_simps)
  next
    case False
    hence False: "(?x = 0) = False" by simp
    show ?thesis unfolding id
      using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def
      unfolding ppp le False if_False
      using False by (auto simp: uint64_simps)
  qed
qed

lemma urel64_mult: assumes "urel64 x y" "urel64 x' y'"
  shows "urel64 (mult_p64 pp x x') (mult_p p y y')"
proof -
  let ?x = "int_of_uint64 x"
  let ?x' = "int_of_uint64 x'"
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' < p" unfolding urel64_def by auto
  from rel have "?x * ?x' < p * p" by (metis mult_strict_mono')
  also have "\<dots> \<le> 4294967296 * 4294967296"
    by (rule mult_mono, insert p2 small, auto)
  finally have le: "?x * ?x' < 18446744073709551616" by simp
  show ?thesis unfolding id
      using small rel unfolding mult_p64_def mult_p_def Let_def urel64_def
      unfolding ppp
    by (auto simp: uint64_simps, unfold int_of_uint64_mod int_of_uint64_mult,
        subst mod_pos_pos_trivial[of _ 18446744073709551616], insert le, auto)
qed

lemma urel64_eq: assumes "urel64 x y" "urel64 x' y'"
  shows "(x = x') = (y = y')"
proof -
  let ?x = "int_of_uint64 x"
  let ?x' = "int_of_uint64 x'"
  from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'"
    unfolding urel64_def by auto
  show ?thesis unfolding id by (transfer, auto)
qed

lemma urel64_normalize:
assumes x: "urel64 x y"
shows "urel64 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
 unfolding urel64_eq[OF x urel64_0] using urel64_0 urel64_1 by auto

lemma urel64_mod:
assumes x: "urel64 x x'" and y: "urel64 y y'"
shows "urel64 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
  unfolding urel64_eq[OF y urel64_0] using urel64_0 x by auto

lemma urel64_power: "urel64 x x' \<Longrightarrow> urel64 y (int y') \<Longrightarrow> urel64 (power_p64 pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
  case (1 x' y' x y)
  note x = 1(2) note y = 1(3)
  show ?case
  proof (cases "y' = 0")
    case True
    hence y: "y = 0" using urel64_eq[OF y urel64_0] by auto
    show ?thesis unfolding y True by (simp add: power_p.simps urel64_1)
  next
    case False
    hence id: "(y = 0) = False" "(y' = 0) = False" using urel64_eq[OF y urel64_0] by auto
    obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
    from divmod_nat_def[of y' 2, unfolded dr']
    have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
    have aux: "\<And> y'. int (y' mod 2) = int y' mod 2" by presburger
    have "urel64 (y AND 1) r'" unfolding r' using y unfolding urel64_def using small
      unfolding ppp by (transfer, auto simp: uint_and int_and_1, auto simp: aux)
    from urel64_eq[OF this urel64_0]
    have rem: "(y AND 1 = 0) = (r' = 0)" by simp
    have div: "urel64 (shiftr y 1) (int d')" unfolding d' using y unfolding urel64_def using small
      unfolding ppp
      by (transfer, auto simp: shiftr_div_2n)
    note IH = 1(1)[OF False refl dr'[symmetric] urel64_mult[OF x x] div]
    show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p64.simps[of _ _ y] dr' id if_False rem
      using IH urel64_mult[OF IH x] by (auto simp: Let_def)
  qed
qed

lemma urel64_inverse: assumes x: "urel64 x x'"
  shows "urel64 (inverse_p64 pp x) (inverse_p p x')"
proof -
  have p: "urel64 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel64_def unfolding ppp
    by (transfer, auto simp: uint_word_ariths)
  show ?thesis
    unfolding inverse_p64_def inverse_p_def urel64_eq[OF x urel64_0] using urel64_0 urel64_power[OF x p]
    by auto
qed

lemma mod_ring_0_64: "mod_ring_rel64 0 0"
  using urel64_0 mod_ring_0 unfolding mod_ring_rel64_def by blast

lemma mod_ring_1_64: "mod_ring_rel64 1 1"
  using urel64_1 mod_ring_1 unfolding mod_ring_rel64_def by blast

lemma mod_ring_uminus64: "(mod_ring_rel64 ===> mod_ring_rel64) (uminus_p64 pp) uminus"
  using urel64_uminus mod_ring_uminus unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_plus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (plus_p64 pp) (+)"
  using urel64_plus mod_ring_plus unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_minus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (minus_p64 pp) (-)"
  using urel64_minus mod_ring_minus unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_mult64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (mult_p64 pp) ((*))"
  using urel64_mult mod_ring_mult unfolding mod_ring_rel64_def rel_fun_def by blast

lemma mod_ring_eq64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> (=)) (=) (=)"
  using urel64_eq mod_ring_eq unfolding mod_ring_rel64_def rel_fun_def by blast

lemma urel64_inj: "urel64 x y \<Longrightarrow> urel64 x z \<Longrightarrow> y = z"
  using urel64_eq[of x y x z] by auto

lemma urel64_inj': "urel64 x z \<Longrightarrow> urel64 y z \<Longrightarrow> x = y"
  using urel64_eq[of x z y z] by auto

lemma bi_unique_mod_ring_rel64:
  "bi_unique mod_ring_rel64" "left_unique mod_ring_rel64" "right_unique mod_ring_rel64"
  using bi_unique_mod_ring_rel urel64_inj'
  unfolding mod_ring_rel64_def bi_unique_def left_unique_def right_unique_def
  by (auto simp: urel64_def)

lemma right_total_mod_ring_rel64: "right_total mod_ring_rel64"
  unfolding mod_ring_rel64_def right_total_def
proof
  fix y :: "'a mod_ring"
  from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
  obtain z where zy: "mod_ring_rel z y" by auto
  hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
  hence "urel64 (uint64_of_int z) z" unfolding urel64_def using small unfolding ppp
    by (auto simp: int_of_uint64_inv)
  with zy show "\<exists> x z. urel64 x z \<and> mod_ring_rel z y" by blast
qed

lemma Domainp_mod_ring_rel64: "Domainp mod_ring_rel64 = (\<lambda>x. 0 \<le> x \<and> x < pp)"
proof
  fix x
  show "Domainp mod_ring_rel64 x = (0 \<le> x \<and> x < pp)"
    unfolding Domainp.simps
    unfolding mod_ring_rel64_def
  proof
    let ?i = "int_of_uint64"
    assume *: "0 \<le> x \<and> x < pp"
    hence "0 \<le> ?i x \<and> ?i x < p" using small unfolding ppp
      by (transfer, auto simp: word_less_def)
    hence "?i x \<in> {0 ..< p}" by auto
    with Domainp_mod_ring_rel
    have "Domainp mod_ring_rel (?i x)" by auto
    from this[unfolded Domainp.simps]
    obtain b where b: "mod_ring_rel (?i x) b" by auto
    show "\<exists>a b. x = a \<and> (\<exists>z. urel64 a z \<and> mod_ring_rel z b)"
    proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
      show "urel64 x (?i x)" unfolding urel64_def using small * unfolding ppp
        by (transfer, auto simp: word_less_def)
    qed
  next
    assume "\<exists>a b. x = a \<and> (\<exists>z. urel64 a z \<and> mod_ring_rel z b)"
    then obtain b z where xz: "urel64 x z" and zb: "mod_ring_rel z b" by auto
    hence "Domainp mod_ring_rel z"  by auto
    with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
    with xz show "0 \<le> x \<and> x < pp" unfolding urel64_def using small unfolding ppp
      by (transfer, auto simp: word_less_def)
  qed
qed

lemma ring_finite_field_ops64: "ring_ops (finite_field_ops64 pp) mod_ring_rel64"
  by (unfold_locales, auto simp:
  finite_field_ops64_def
  bi_unique_mod_ring_rel64
  right_total_mod_ring_rel64
  mod_ring_plus64
  mod_ring_minus64
  mod_ring_uminus64
  mod_ring_mult64
  mod_ring_eq64
  mod_ring_0_64
  mod_ring_1_64
  Domainp_mod_ring_rel64)
end
end

context prime_field
begin
context fixes pp :: "uint64"
  assumes *: "p = int_of_uint64 pp" "p \<le> 4294967295"
begin

lemma mod_ring_normalize64: "(mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x. if x = 0 then 0 else 1) normalize"
  using urel64_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_mod64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x y. if y = 0 then x else 0) (mod)"
  using urel64_mod[OF *] mod_ring_mod unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_unit_factor64: "(mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x. x) unit_factor"
  using mod_ring_unit_factor unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_inverse64: "(mod_ring_rel64 ===> mod_ring_rel64) (inverse_p64 pp) inverse"
  using urel64_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast

lemma mod_ring_divide64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (divide_p64 pp) (/)"
  using mod_ring_inverse64 mod_ring_mult64[OF *]
  unfolding divide_p64_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
    rel_fun_def by blast

lemma finite_field_ops64: "field_ops (finite_field_ops64 pp) mod_ring_rel64"
  by (unfold_locales, insert ring_finite_field_ops64[OF *], auto simp:
  ring_ops_def
  finite_field_ops64_def
  mod_ring_divide64
  mod_ring_inverse64
  mod_ring_mod64
  mod_ring_normalize64)
end
end

(* and a final implementation via integer *)
context
  fixes p :: integer
begin
definition plus_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "plus_p_integer x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"

definition minus_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "minus_p_integer x y \<equiv> if y \<le> x then x - y else (x + p) - y"

definition uminus_p_integer :: "integer \<Rightarrow> integer" where
  "uminus_p_integer x = (if x = 0 then 0 else p - x)"

definition mult_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "mult_p_integer x y = (x * y mod p)"

lemma int_of_integer_0_iff: "int_of_integer n = 0 \<longleftrightarrow> n = 0"
  using integer_eqI by auto

lemma int_of_integer_0: "int_of_integer 0 = 0" unfolding int_of_integer_0_iff by simp

lemma int_of_integer_plus: "int_of_integer (x + y) = (int_of_integer x + int_of_integer y)"
  by simp

lemma int_of_integer_minus: "int_of_integer (x - y) = (int_of_integer x - int_of_integer y)"
  by simp

lemma int_of_integer_mult: "int_of_integer (x * y) = (int_of_integer x * int_of_integer y)"
  by simp

lemma int_of_integer_mod: "int_of_integer (x mod y) = (int_of_integer x mod int_of_integer y)"
  by simp

lemma int_of_integer_inv: "int_of_integer (integer_of_int x) = x" by simp

lemma int_of_integer_shift: "int_of_integer (shiftr n k) = (int_of_integer n) div (2 ^ k)"
  by (simp add: shiftr_int_def shiftr_integer.rep_eq)

function power_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "power_p_integer x n = (if n \<le> 0 then 1 else
    let rec = power_p_integer (mult_p_integer x x) (shiftr n 1) in
    if n AND 1 = 0 then rec else mult_p_integer rec x)"
  by pat_completeness auto

termination
proof -
  {
    fix n :: integer
    assume "\<not> (n \<le> 0)"
    hence "n > 0" by auto
    hence "int_of_integer n > 0"
      by (simp add: less_integer.rep_eq)
    hence "0 < int_of_integer n" "int_of_integer n div 2 < int_of_integer n" by auto
  } note * = this
  show ?thesis
    by (relation "measure (\<lambda> (x,n). nat (int_of_integer n))", auto simp: * int_of_integer_shift)
qed

text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
  it turned out that taking the below implementation of inverse via exponentiation
  is faster than the one based on the extended Euclidean algorithm.\<close>

definition inverse_p_integer :: "integer \<Rightarrow> integer" where
  "inverse_p_integer x = (if x = 0 then 0 else power_p_integer x (p - 2))"

definition divide_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"  where
  "divide_p_integer x y = mult_p_integer x (inverse_p_integer y)"

definition finite_field_ops_integer :: "integer arith_ops_record" where
  "finite_field_ops_integer \<equiv> Arith_Ops_Record
      0
      1
      plus_p_integer
      mult_p_integer
      minus_p_integer
      uminus_p_integer
      divide_p_integer
      inverse_p_integer
      (\<lambda> x y . if y = 0 then x else 0)
      (\<lambda> x . if x = 0 then 0 else 1)
      (\<lambda> x . x)
      integer_of_int
      int_of_integer
      (\<lambda> x. 0 \<le> x \<and> x < p)"
end

lemma shiftr_integer_code [code_unfold]: "shiftr x 1 = (integer_shiftr x 1)"
  unfolding shiftr_integer_code using integer_of_nat_1 by auto

text \<open>For soundness of the integer implementation, we mainly prove that this implementation
  implements the int-based implementation of GF(p).\<close>
context mod_ring_locale
begin

context fixes pp :: "integer"
  assumes ppp: "p = int_of_integer pp"
begin

lemmas integer_simps =
  int_of_integer_0
  int_of_integer_plus
  int_of_integer_minus
  int_of_integer_mult

definition urel_integer :: "integer \<Rightarrow> int \<Rightarrow> bool" where "urel_integer x y = (y = int_of_integer x \<and> y \<ge> 0 \<and> y < p)"

definition mod_ring_rel_integer :: "integer \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
  "mod_ring_rel_integer x y = (\<exists> z. urel_integer x z \<and> mod_ring_rel z y)"

lemma urel_integer_0: "urel_integer 0 0" unfolding urel_integer_def using p2 by simp

lemma urel_integer_1: "urel_integer 1 1" unfolding urel_integer_def using p2 by simp

lemma le_int_of_integer: "(x \<le> y) = (int_of_integer x \<le> int_of_integer y)"
  by (rule less_eq_integer.rep_eq)

lemma urel_integer_plus: assumes "urel_integer x y" "urel_integer x' y'"
  shows "urel_integer (plus_p_integer pp x x') (plus_p p y y')"
proof -
  let ?x = "int_of_integer x"
  let ?x' = "int_of_integer x'"
  let ?p = "int_of_integer pp"
  from assms have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' \<le> p" unfolding urel_integer_def by auto
  have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_integer
    using rel by auto
  show ?thesis
  proof (cases "?p \<le> ?x + ?x'")
    case True
    hence True: "(?p \<le> ?x + ?x') = True" by simp
    show ?thesis unfolding id
      using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def
      unfolding ppp le True if_True
      using True by auto
  next
    case False
    hence False: "(?p \<le> ?x + ?x') = False" by simp
    show ?thesis unfolding id
      using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def
      unfolding ppp le False if_False
      using False by auto
  qed
qed

lemma urel_integer_minus: assumes "urel_integer x y" "urel_integer x' y'"
  shows "urel_integer (minus_p_integer pp x x') (minus_p p y y')"
proof -
  let ?x = "int_of_integer x"
  let ?x' = "int_of_integer x'"
  from assms have id: "y = ?x" "y' = ?x'"
    and rel: "0 \<le> ?x" "?x < p"
      "0 \<le> ?x'" "?x' \<le> p" unfolding urel_integer_def by auto
  have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_integer
    using rel by auto
  show ?thesis
  proof (cases "?x' \<le> ?x")
    case True
    hence True: "(?x' \<le> ?x) = True" by simp
    show ?thesis unfolding id
      using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def
      unfolding ppp le True if_True
      using True by auto
  next
    case False
    hence False: "(?x' \<le> ?x) = False" by simp
    show ?thesis unfolding id
      using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def
      unfolding ppp le False if_False
      using False by auto
  qed
qed

lemma urel_integer_uminus: assumes "urel_integer x y"
  shows "urel_integer (uminus_p_integer pp x) (uminus_p p y)"
proof -
  let ?x = "int_of_integer x"
  from assms have id: "y = ?x"
    and rel: "0 \<le> ?x" "?x < p"
      unfolding urel_integer_def by auto
  have le: "(x = 0) = (?x = 0)" unfolding int_of_integer_0_iff
    using rel by auto
  show ?thesis
  proof (cases "?x = 0")
    case True
    hence True: "(?x = 0) = True" by simp
    show ?thesis unfolding id
      using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def
      unfolding ppp le True if_True
      using True by auto
  next
    case False
    hence False: "(?x = 0) = False" by simp
    show ?thesis unfolding id
      using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def
      unfolding ppp le False if_False
      using False by auto
  qed
qed

lemma pp_pos: "int_of_integer pp > 0"
  using ppp nontriv[where 'a = 'a]  unfolding p
  by (simp add: less_integer.rep_eq)

lemma urel_integer_eq: assumes "urel_integer x y" "urel_integer x' y'"
  shows "(x = x') = (y = y')"
proof -
  let ?x = "int_of_integer x"
  let ?x' = "int_of_integer x'"
  from assms have id: "y = ?x" "y' = ?x'"
    unfolding urel_integer_def by auto
  show ?thesis unfolding id integer_eq_iff ..
qed

lemma urel_integer_normalize:
assumes x: "urel_integer x y"
shows "urel_integer (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
 unfolding urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_1 by auto

lemma urel_integer_mod:
assumes x: "urel_integer x x'" and y: "urel_integer y y'"
shows "urel_integer (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
  unfolding urel_integer_eq[OF y urel_integer_0] using urel_integer_0 x by auto

lemma urel_integer_power: "urel_integer x x' \<Longrightarrow> urel_integer y (int y') \<Longrightarrow> urel_integer (power_p_integer pp x y) (power_p p x' y')"
proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
  case (1 x' y' x y)
  note x = 1(2) note y = 1(3)
  show ?case
  proof (cases "y' \<le> 0")
    case True
    hence y: "y = 0" "y' = 0" using urel_integer_eq[OF y urel_integer_0] by auto
    show ?thesis unfolding y True by (simp add: power_p.simps urel_integer_1)
  next
    case False
    hence id: "(y \<le> 0) = False" "(y' = 0) = False" using False y unfolding urel_integer_def
      by ((metis eq_iff nat_int nat_of_integer.rep_eq nat_of_integer_code)+)
    obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
    from divmod_nat_def[of y' 2, unfolded dr']
    have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
    have aux: "\<And> y'. int (y' mod 2) = int y' mod 2" by presburger
    have "urel_integer (y AND 1) r'" unfolding r' using y unfolding urel_integer_def
      unfolding ppp
      by (smt aux bitAND_int_code int_and_1 mod2_gr_0 of_nat_0_le_iff of_nat_0_less_iff of_nat_1 one_integer.rep_eq p2 ppp)
    from urel_integer_eq[OF this urel_integer_0]
    have rem: "(y AND 1 = 0) = (r' = 0)" by simp
    have div: "urel_integer (shiftr y 1) (int d')" unfolding d' using y unfolding urel_integer_def
      unfolding ppp shiftr_integer_conv_div_pow2 by auto
    from id have "y' \<noteq> 0" by auto
    note IH = 1(1)[OF this refl dr'[symmetric] urel_integer_mult[OF x x] div]
    show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p_integer.simps[of _ _ y] dr' id if_False rem
      using IH urel_integer_mult[OF IH x] by (auto simp: Let_def)
  qed
qed

lemma urel_integer_inverse: assumes x: "urel_integer x x'"
  shows "urel_integer (inverse_p_integer pp x) (inverse_p p x')"
proof -
  have p: "urel_integer (pp - 2) (int (nat (p - 2)))" using p2 unfolding urel_integer_def unfolding ppp
    by auto
  show ?thesis
    unfolding inverse_p_integer_def inverse_p_def urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_power[OF x p]
    by auto
qed

lemma mod_ring_0__integer: "mod_ring_rel_integer 0 0"
  using urel_integer_0 mod_ring_0 unfolding mod_ring_rel_integer_def by blast

lemma mod_ring_1__integer: "mod_ring_rel_integer 1 1"
  using urel_integer_1 mod_ring_1 unfolding mod_ring_rel_integer_def by blast

lemma mod_ring_uminus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (uminus_p_integer pp) uminus"
  using urel_integer_uminus mod_ring_uminus unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_plus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (plus_p_integer pp) (+)"
  using urel_integer_plus mod_ring_plus unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_minus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (minus_p_integer pp) (-)"
  using urel_integer_minus mod_ring_minus unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_mult_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (mult_p_integer pp) ((*))"
  using urel_integer_mult mod_ring_mult unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma mod_ring_eq_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> (=)) (=) (=)"
  using urel_integer_eq mod_ring_eq unfolding mod_ring_rel_integer_def rel_fun_def by blast

lemma urel_integer_inj: "urel_integer x y \<Longrightarrow> urel_integer x z \<Longrightarrow> y = z"
  using urel_integer_eq[of x y x z] by auto

lemma urel_integer_inj': "urel_integer x z \<Longrightarrow> urel_integer y z \<Longrightarrow> x = y"
  using urel_integer_eq[of x z y z] by auto

lemma bi_unique_mod_ring_rel_integer:
  "bi_unique mod_ring_rel_integer" "left_unique mod_ring_rel_integer" "right_unique mod_ring_rel_integer"
  using bi_unique_mod_ring_rel urel_integer_inj'
  unfolding mod_ring_rel_integer_def bi_unique_def left_unique_def right_unique_def
  by (auto simp: urel_integer_def)

lemma right_total_mod_ring_rel_integer: "right_total mod_ring_rel_integer"
  unfolding mod_ring_rel_integer_def right_total_def
proof
  fix y :: "'a mod_ring"
  from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
  obtain z where zy: "mod_ring_rel z y" by auto
  hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
  hence "urel_integer (integer_of_int z) z" unfolding urel_integer_def unfolding ppp
    by auto
  with zy show "\<exists> x z. urel_integer x z \<and> mod_ring_rel z y" by blast
qed

lemma Domainp_mod_ring_rel_integer: "Domainp mod_ring_rel_integer = (\<lambda>x. 0 \<le> x \<and> x < pp)"
proof
  fix x
  show "Domainp mod_ring_rel_integer x = (0 \<le> x \<and> x < pp)"
    unfolding Domainp.simps
    unfolding mod_ring_rel_integer_def
  proof
    let ?i = "int_of_integer"
    assume *: "0 \<le> x \<and> x < pp"
    hence "0 \<le> ?i x \<and> ?i x < p" unfolding ppp
      by (simp add: le_int_of_integer less_integer.rep_eq)
    hence "?i x \<in> {0 ..< p}" by auto
    with Domainp_mod_ring_rel
    have "Domainp mod_ring_rel (?i x)" by auto
    from this[unfolded Domainp.simps]
    obtain b where b: "mod_ring_rel (?i x) b" by auto
    show "\<exists>a b. x = a \<and> (\<exists>z. urel_integer a z \<and> mod_ring_rel z b)"
    proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
      show "urel_integer x (?i x)" unfolding urel_integer_def using * unfolding ppp
        by (simp add: le_int_of_integer less_integer.rep_eq)
    qed
  next
    assume "\<exists>a b. x = a \<and> (\<exists>z. urel_integer a z \<and> mod_ring_rel z b)"
    then obtain b z where xz: "urel_integer x z" and zb: "mod_ring_rel z b" by auto
    hence "Domainp mod_ring_rel z"  by auto
    with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
    with xz show "0 \<le> x \<and> x < pp" unfolding urel_integer_def unfolding ppp
      by (simp add: le_int_of_integer less_integer.rep_eq)
  qed
qed

lemma ring_finite_field_ops_integer: "ring_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
  by (unfold_locales, auto simp:
  finite_field_ops_integer_def
  bi_unique_mod_ring_rel_integer
  right_total_mod_ring_rel_integer
  mod_ring_plus_integer
  mod_ring_minus_integer
  mod_ring_uminus_integer
  mod_ring_mult_integer
  mod_ring_eq_integer
  mod_ring_0__integer
  mod_ring_1__integer
  Domainp_mod_ring_rel_integer)
end
end

context prime_field
begin
context fixes pp :: "integer"
  assumes *: "p = int_of_integer pp"
begin

lemma mod_ring_normalize_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x. if x = 0 then 0 else 1) normalize"
  using urel_integer_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_mod_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x y. if y = 0 then x else 0) (mod)"
  using urel_integer_mod[OF *] mod_ring_mod unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_unit_factor_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x. x) unit_factor"
  using mod_ring_unit_factor unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_inverse_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (inverse_p_integer pp) inverse"
  using urel_integer_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast

lemma mod_ring_divide_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (divide_p_integer pp) (/)"
  using mod_ring_inverse_integer mod_ring_mult_integer[OF *]
  unfolding divide_p_integer_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
    rel_fun_def by blast

lemma finite_field_ops_integer: "field_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
  by (unfold_locales, insert ring_finite_field_ops_integer[OF *], auto simp:
  ring_ops_def
  finite_field_ops_integer_def
  mod_ring_divide_integer
  mod_ring_inverse_integer
  mod_ring_mod_integer
  mod_ring_normalize_integer)
end
end

context prime_field
begin
 (* four implementations of modular integer arithmetic for finite fields *)
thm
  finite_field_ops64
  finite_field_ops32
  finite_field_ops_integer
  finite_field_ops_int
end

context mod_ring_locale
begin
 (* four implementations of modular integer arithmetic for finite rings *)
thm
  ring_finite_field_ops64
  ring_finite_field_ops32
  ring_finite_field_ops_integer
  ring_finite_field_ops_int
end

no_notation shiftr (infixl ">>" 55) (* to avoid conflict with bind *)
end


(*
    Author:      René Thiemann
    License:     BSD
*)

section \<open>GCD of rational polynomials via GCD for integer polynomials\<close>

text \<open>This theory contains an algorithm to compute GCDs of rational polynomials via
  a conversion to integer polynomials and then invoking the integer polynomial GCD algorithm.\<close>

theory Gcd_Rat_Poly
imports
  Gauss_Lemma
  "HOL-Computational_Algebra.Field_as_Ring"
begin

definition gcd_rat_poly :: "rat poly \<Rightarrow> rat poly \<Rightarrow> rat poly" where
  "gcd_rat_poly f g = (let
     f' = snd (rat_to_int_poly f);
     g' = snd (rat_to_int_poly g);
     h = map_poly rat_of_int (gcd f' g')
   in smult (inverse (lead_coeff h)) h)"

lemma gcd_rat_poly_unfold[code_unfold]: "gcd = gcd_rat_poly" by simp
end


theory FP64
imports
  IEEE
  Word_Lib.Word_Lemmas_64
begin

section \<open>Concrete encodings\<close>

text \<open>Floating point operations defined as operations on words.
  Called ''fixed precision'' (fp) word in HOL4.\<close>

type_synonym float64 = "(11,52)float"
type_synonym fp64 = "64 word"

lift_definition fp64_of_float :: "float64 \<Rightarrow> fp64" is
  "\<lambda>(s::1 word, e::11 word, f::52 word). word_cat s (word_cat e f::63 word)" .

lift_definition float_of_fp64 :: "fp64 \<Rightarrow> float64" is
  "\<lambda>x. apsnd word_split (word_split x::1 word * 63 word)" .

definition "rel_fp64 \<equiv> (\<lambda>x (y::word64). x = float_of_fp64 y)"

definition eq_fp64::"float64 \<Rightarrow> float64 \<Rightarrow> bool" where [simp]: "eq_fp64 \<equiv> (=)"

lemma float_of_fp64_inverse[simp]: "fp64_of_float (float_of_fp64 a) = a"
  by (auto
      simp: fp64_of_float_def float_of_fp64_def Abs_float_inverse apsnd_def map_prod_def word_size
      dest!: word_cat_split_alt[rotated]
      split: prod.splits)

lemma float_of_fp64_inj_iff[simp]: "fp64_of_float r = fp64_of_float s \<longleftrightarrow> r = s"
  using Rep_float_inject
  by (force simp: fp64_of_float_def word_cat_inj word_size split: prod.splits)

lemma fp64_of_float_inverse[simp]: "float_of_fp64 (fp64_of_float a) = a"
  using float_of_fp64_inj_iff float_of_fp64_inverse by blast

lemma Quotientfp: "Quotient eq_fp64 fp64_of_float float_of_fp64 rel_fp64"
  \<comment>\<open>\<^term>\<open>eq_fp64\<close> is a workaround to prevent a (failing -- TODO: why?)
      code setup in \<open>setup_lifting\<close>.\<close>
  by (force intro!: QuotientI simp: rel_fp64_def)

setup_lifting Quotientfp

lift_definition fp64_lessThan::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "flt::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_lessEqual::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "fle::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_greaterThan::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "fgt::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_greaterEqual::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "fge::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_equal::"fp64 \<Rightarrow> fp64 \<Rightarrow> bool" is
  "feq::float64\<Rightarrow>float64\<Rightarrow>bool" by simp

lift_definition fp64_abs::"fp64 \<Rightarrow> fp64" is
  "abs::float64\<Rightarrow>float64" by simp

lift_definition fp64_negate::"fp64 \<Rightarrow> fp64" is
  "uminus::float64\<Rightarrow>float64" by simp

lift_definition fp64_sqrt::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fsqrt::roundmode\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_add::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fadd::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_sub::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fsub::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_mul::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fmul::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_div::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fdiv::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

lift_definition fp64_mul_add::"roundmode \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64 \<Rightarrow> fp64" is
  "fmul_add::roundmode\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64\<Rightarrow>float64" by simp

end


(*<*)
theory Regex
  imports
    "MFOTL_Monitor_Devel.Trace"
    "HOL-Library.Extended_Nat"
begin
(*>*)

unbundle lattice_syntax

section \<open>Regular expressions\<close>

context begin

qualified datatype (atms: 'a) regex = Skip nat | Test 'a
  | Plus "'a regex" "'a regex" | Times "'a regex" "'a regex"  | Star "'a regex"

lemma finite_atms[simp]: "finite (atms r)"
  by (induct r) auto

definition "Wild = Skip 1"

lemma size_regex_estimation[termination_simp]: "x \<in> atms r \<Longrightarrow> y < f x \<Longrightarrow> y < size_regex f r"
  by (induct r) auto

lemma size_regex_estimation'[termination_simp]: "x \<in> atms r \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_regex f r"
  by (induct r) auto

qualified definition "TimesL r S = Times r ` S"
qualified definition "TimesR R s = (\<lambda>r. Times r s) ` R"

qualified primrec fv_regex where
  "fv_regex fv (Skip n) = {}"
| "fv_regex fv (Test \<phi>) = fv \<phi>"
| "fv_regex fv (Plus r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Times r s) = fv_regex fv r \<union> fv_regex fv s"
| "fv_regex fv (Star r) = fv_regex fv r"

lemma fv_regex_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>z. z \<in> atms r \<Longrightarrow> fv z = fv' z) \<Longrightarrow> fv_regex fv r = fv_regex fv' r'"
  by (induct r arbitrary: r') auto

lemma finite_fv_regex[simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z)) \<Longrightarrow> finite (fv_regex fv r)"
  by (induct r) auto

lemma fv_regex_commute:
  "(\<And>z. z \<in> atms r \<Longrightarrow> x \<in> fv z \<longleftrightarrow> g x \<in> fv' z) \<Longrightarrow> x \<in> fv_regex fv r \<longleftrightarrow> g x \<in> fv_regex fv' r"
  by (induct r) auto

lemma fv_regex_alt: "fv_regex fv r = (\<Union>z \<in> atms r. fv z)"
  by (induct r) auto

qualified definition nfv_regex where
  "nfv_regex fv r = Max (insert 0 (Suc ` fv_regex fv r))"

lemma insert_Un: "insert x (A \<union> B) = insert x A \<union> insert x B"
  by auto

lemma nfv_regex_simps[simp]:
  assumes [simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z))" "(\<And>z. z \<in> atms s \<Longrightarrow> finite (fv z))"
  shows
  "nfv_regex fv (Skip n) = 0"
  "nfv_regex fv (Test \<phi>) = Max (insert 0 (Suc ` fv \<phi>))"
  "nfv_regex fv (Plus r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Times r s) = max (nfv_regex fv r) (nfv_regex fv s)"
  "nfv_regex fv (Star r) = nfv_regex fv r"
  unfolding nfv_regex_def
  by (auto simp add: image_Un Max_Un insert_Un simp del: Un_insert_right Un_insert_left)

abbreviation "min_regex_default f r j \<equiv> (if atms r = {} then j else Min ((\<lambda>z. f z j) ` atms r))"

qualified primrec match :: "(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a regex \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "match test (Skip n) = (\<lambda>i j. j = i + n)"
| "match test (Test \<phi>) = (\<lambda>i j. i = j \<and> test i \<phi>)"
| "match test (Plus r s) = match test r \<squnion> match test s"
| "match test (Times r s) = match test r OO match test s"
| "match test (Star r) = (match test r)\<^sup>*\<^sup>*"

lemma match_cong[fundef_cong]:
  "r = r' \<Longrightarrow> (\<And>i z. z \<in> atms r \<Longrightarrow> t i z = t' i z) \<Longrightarrow> match t r = match t' r'"
  by (induct r arbitrary: r') auto

qualified primrec eps where
  "eps test i (Skip n) = (n = 0)"
| "eps test i (Test \<phi>) = test i \<phi>"
| "eps test i (Plus r s) = (eps test i r \<or> eps test i s)"
| "eps test i (Times r s) = (eps test i r \<and> eps test i s)"
| "eps test i (Star r) = True"

qualified primrec lpd where
  "lpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "lpd test i (Test \<phi>) = {}"
| "lpd test i (Plus r s) = (lpd test i r \<union> lpd test i s)"
| "lpd test i (Times r s) = TimesR (lpd test i r) s \<union> (if eps test i r then lpd test i s else {})"
| "lpd test i (Star r) = TimesR (lpd test i r) (Star r)"

qualified primrec lpd\<kappa> where
  "lpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "lpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "lpd\<kappa> \<kappa> test i (Plus r s) = lpd\<kappa> \<kappa> test i r \<union> lpd\<kappa> \<kappa> test i s"
| "lpd\<kappa> \<kappa> test i (Times r s) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t s)) test i r \<union> (if eps test i r then lpd\<kappa> \<kappa> test i s else {})"
| "lpd\<kappa> \<kappa> test i (Star r) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t (Star r))) test i r"

qualified primrec rpd where
  "rpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
| "rpd test i (Test \<phi>) = {}"
| "rpd test i (Plus r s) = (rpd test i r \<union> rpd test i s)"
| "rpd test i (Times r s) = TimesL r (rpd test i s) \<union> (if eps test i s then rpd test i r else {})"
| "rpd test i (Star r) = TimesL (Star r) (rpd test i r)"

qualified primrec rpd\<kappa> where
  "rpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
| "rpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
| "rpd\<kappa> \<kappa> test i (Plus r s) = rpd\<kappa> \<kappa> test i r \<union> rpd\<kappa> \<kappa> test i s"
| "rpd\<kappa> \<kappa> test i (Times r s) = rpd\<kappa> (\<lambda>t. \<kappa> (Times r t)) test i s \<union> (if eps test i s then rpd\<kappa> \<kappa> test i r else {})"
| "rpd\<kappa> \<kappa> test i (Star r) = rpd\<kappa> (\<lambda>t. \<kappa> (Times (Star r) t)) test i r"

lemma lpd\<kappa>_lpd: "lpd\<kappa> \<kappa> test i r = \<kappa> ` lpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesR_def split: nat.splits)

lemma rpd\<kappa>_rpd: "rpd\<kappa> \<kappa> test i r = \<kappa> ` rpd test i r"
  by (induct r arbitrary: \<kappa>) (auto simp: TimesL_def split: nat.splits)

lemma match_le: "match test r i j \<Longrightarrow> i \<le> j"
proof (induction r arbitrary: i j)
  case (Times r s)
  then show ?case using order.trans by fastforce
next
  case (Star r)
  from Star.prems show ?case
    unfolding match.simps by (induct i j rule: rtranclp.induct) (force dest: Star.IH)+
qed auto

lemma match_rtranclp_le: "(match test r)\<^sup>*\<^sup>* i j \<Longrightarrow> i \<le> j"
  by (metis match.simps(5) match_le)

lemma eps_match: "eps test i r \<longleftrightarrow> match test r i i"
  by (induction r) (auto dest: antisym[OF match_le match_le])

lemma lpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> lpd test i r. match test s) (i + 1) j"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> match test s i j \<or>
    (\<exists>k>i. match test r i k \<and> match test s k j)"
    using match_le[of test r i] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k>i. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.IH(1) Times.IH(2)[OF Times.prems] by metis
  also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
    (\<exists>k. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` lpd test i (Times r s))) (i + 1) j"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>lpd test i r. (match test s OO (match test r)\<^sup>*\<^sup>*) (i + 1) j" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ "i + 1"]
  proof (induct rule: converse_rtranclp_induct)
    case (step i k)
    then show ?case
      by (cases "i < k") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case using match_le[of test _  "i + 1"]
    by (auto simp: TimesL_def TimesR_def Suc_le_eq Star.IH[of i]
      elim!: converse_rtranclp_into_rtranclp[rotated])
qed (auto split: nat.splits)

lemma rpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> rpd test j r. match test s) i (j - 1)"
proof (induction r arbitrary: i j)
  case (Times r s)
  have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
    by auto
  also have "\<dots> \<longleftrightarrow> match test r i j \<and> match test s j j \<or>
    (\<exists>k<j. match test r i k \<and> match test s k j)"
    using match_le[of test s _ j] nat_less_le by auto
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k<j. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.IH(1)[OF Times.prems] Times.IH(2) by metis
  also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
    (\<exists>k. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
    using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
  also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` rpd test j (Times r s))) i (j - 1)"
    by (force simp: TimesL_def TimesR_def eps_match)
  finally show ?case .
next
  case (Star r)
  have "\<exists>s\<in>rpd test j r. ((match test r)\<^sup>*\<^sup>* OO match test s) i (j - 1)" if "(match test r)\<^sup>*\<^sup>* i j"
    using that Star.prems match_le[of test _ _ "j - 1"]
  proof (induct rule: rtranclp_induct)
    case (step k j)
    then show ?case
      by (cases "k < j") (auto simp: not_less Star.IH dest: match_le)
  qed simp
  with Star.prems show ?case
    by (auto 0 3 simp: TimesL_def TimesR_def intro: Star.IH[of _ j, THEN iffD2]
      elim!: rtranclp.rtrancl_into_rtrancl dest: match_le[of test _ _ "j - 1", unfolded One_nat_def])
qed (auto split: nat.splits)

lemma lpd_fv_regex: "s \<in> lpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma rpd_fv_regex: "s \<in> rpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
  by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+

lemma match_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> match test r = match test' r"
  by (induct r) auto

lemma eps_fv_cong:
  "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> eps test i r = eps test' i r"
  by (induct r) auto

datatype modality = Past | Futu
datatype safety = Strict | Lax

context
  fixes fv :: "'a \<Rightarrow> 'b set"
  and safe :: "safety \<Rightarrow> 'a \<Rightarrow> bool"
begin

qualified fun safe_regex :: "modality \<Rightarrow> safety \<Rightarrow> 'a regex \<Rightarrow> bool" where
  "safe_regex m _ (Skip n) = True"
| "safe_regex m g (Test \<phi>) = safe g \<phi>"
| "safe_regex m g (Plus r s) = ((g = Lax \<or> fv_regex fv r = fv_regex fv s) \<and> safe_regex m g r \<and> safe_regex m g s)"
| "safe_regex Futu g (Times r s) =
    ((g = Lax \<or> fv_regex fv r \<subseteq> fv_regex fv s) \<and> safe_regex Futu g s \<and> safe_regex Futu Lax r)"
| "safe_regex Past g (Times r s) =
    ((g = Lax \<or> fv_regex fv s \<subseteq> fv_regex fv r) \<and> safe_regex Past g r \<and> safe_regex Past Lax s)"
| "safe_regex m g (Star r) = ((g = Lax \<or> fv_regex fv r = {}) \<and> safe_regex m g r)"

lemmas safe_regex_induct = safe_regex.induct[case_names Skip Test Plus TimesF TimesP Star]

lemma safe_cosafe:
  "(\<And>x. x \<in> atms r \<Longrightarrow> safe Strict x \<Longrightarrow> safe Lax x) \<Longrightarrow> safe_regex m Strict r \<Longrightarrow> safe_regex m Lax r"
  by (induct r; cases m) auto

lemma safe_lpd_fv_regex_le: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesR_def split: if_splits)

lemma safe_lpd_fv_regex: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff lpd_fv_regex safe_lpd_fv_regex_le)

lemma cosafe_lpd: "safe_regex Futu Lax r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesR_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesR_def split: nat.splits)

lemma safe_lpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesR_def ball_Un elim: Times(1,2) cosafe_lpd dest: lpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesR_def elim: Star(1) cosafe_lpd
      dest: safe_cosafe[rotated] lpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_rpd_fv_regex_le: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
  by (induct r) (auto simp: TimesL_def split: if_splits)

lemma safe_rpd_fv_regex: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
  by (simp add: eq_iff rpd_fv_regex safe_rpd_fv_regex_le)

lemma cosafe_rpd: "safe_regex Past Lax r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Lax s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4) show ?case
    by (auto elim: Plus(1,2))
next
  case (Times r1 r2)
  from Times(3,4) show ?case
    by (auto simp: TimesL_def elim: Times(1,2) split: if_splits)
qed (auto simp: TimesL_def split: nat.splits)

lemma safe_rpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
  safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Strict s"
proof (induct r arbitrary: s)
  case (Plus r1 r2)
  from Plus(3,4,5) show ?case
    by (auto elim: Plus(1,2) simp: ball_Un)
next
  case (Times r1 r2)
  from Times(3,4,5) show ?case
    by (force simp: TimesL_def ball_Un elim: Times(1,2) cosafe_rpd dest: rpd_fv_regex split: if_splits)
next
  case (Star r)
  from Star(2,3,4) show ?case
    by (force simp: TimesL_def elim: Star(1) cosafe_rpd
      dest: safe_cosafe[rotated] rpd_fv_regex[where fv=fv] split: if_splits)
qed (auto split: nat.splits)

lemma safe_regex_safe: "(\<And>g r. safe g r \<Longrightarrow> safe Lax r) \<Longrightarrow>
  safe_regex m g r \<Longrightarrow> x \<in> atms r \<Longrightarrow> safe Lax x"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_map_regex:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow>  safe g (f x)) \<Longrightarrow> (\<And>x. x \<in> atms r \<Longrightarrow> fv (f x) = fv x) \<Longrightarrow>
   safe_regex m g r \<Longrightarrow> safe_regex m g (map_regex f r)"
  by (induct m g r rule: safe_regex.induct) (auto simp: fv_regex_alt regex.set_map)

end

lemma safe_regex_cong[fundef_cong]:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x = safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r = Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma safe_regex_mono:
  "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow> safe' g x) \<Longrightarrow>
  Regex.safe_regex fv safe m g r \<Longrightarrow> Regex.safe_regex fv safe' m g r"
  by (induct m g r rule: safe_regex.induct) auto

lemma match_map_regex: "match t (map_regex f r) = match (\<lambda>k z. t k (f z)) r"
  by (induct r) auto

lemma match_cong_strong:
  "(\<And>k z. k \<in> {i ..< j + 1} \<Longrightarrow> z \<in> atms r \<Longrightarrow> t k z = t' k z) \<Longrightarrow> match t r i j = match t' r i j"
proof (induction r arbitrary: i j)
  case (Times r s)
  from Times.prems show ?case
    by (auto 0 4 simp: relcompp_apply intro: le_less_trans match_le less_Suc_eq_le
      dest: Times.IH[THEN iffD1, rotated -1] Times.IH[THEN iffD2, rotated -1] match_le)
next
  case (Star r)
  show ?case unfolding match.simps
  proof (rule iffI)
    assume *: "(match t r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t' r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD1, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  next
    assume *: "(match t' r)\<^sup>*\<^sup>* i j"
    then have "i \<le> j" unfolding match.simps(5)[symmetric]
      by (rule match_le)
    with * show "(match t r)\<^sup>*\<^sup>* i j" using Star.prems
    proof (induction i j rule: rtranclp.induct)
      case (rtrancl_into_rtrancl a b c)
      from rtrancl_into_rtrancl(1,2,4,5) show ?case
        by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
          (auto dest!: Star.IH[THEN iffD2, rotated -1]
            dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
    qed simp
  qed
qed auto

end

(*<*)
end
(*>*)


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Cardinality of Bijections\<close>

theory Card_Bijections
imports
  Twelvefold_Way_Entry2
  Twelvefold_Way_Entry3
  Twelvefold_Way_Entry5
  Twelvefold_Way_Entry6
  Twelvefold_Way_Entry8
  Twelvefold_Way_Entry9
  Twelvefold_Way_Entry11
  Twelvefold_Way_Entry12
begin

subsection \<open>Bijections from A to B\<close>

lemma bij_betw_set_is_empty:
  assumes "finite A" "finite B"
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = {}"
using assms bij_betw_same_card by blast

lemma card_bijections_eq_zero:
  assumes "finite A" "finite B"
  assumes "card A \<noteq> card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = 0"
using bij_betw_set_is_empty[OF assms] by (simp only: card.empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on A.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = fact (card B)"
proof -
  have "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = card {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A}"
    using \<open>finite B\<close> \<open>card A = card B\<close> by (metis bij_betw_implies_inj_on_and_card_eq)
  also have "\<dots> = fact (card B)"
    using \<open>finite A\<close> \<open>finite B\<close> \<open>card A = card B\<close> by (simp add: card_extensional_funcset_inj_on)
  finally show ?thesis .
qed

lemma card_bijections:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = fact (card B)"
proof -
  have "card {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = card {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B}"
    using \<open>finite A\<close> \<open>card A = card B\<close>
    by (metis bij_betw_implies_surj_on_and_card_eq)
  also have "\<dots> = fact (card B)"
    using \<open>finite A\<close> \<open>finite B\<close> \<open>card A = card B\<close>
    by (simp add: card_extensional_funcset_surj_on)
  finally show ?thesis .
qed

subsection \<open>Bijections from A to B up to a Permutation on A\<close>

lemma bij_betw_quotient_domain_permutation_eq_empty:
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B = {}"
using \<open>card A \<noteq> card B\<close> bij_betw_same_card by auto

lemma card_bijections_domain_permutation_eq_0:
  assumes "card A \<noteq> card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 0"
using bij_betw_quotient_domain_permutation_eq_empty[OF assms] by (simp only: card.empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on A.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B
    = {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_inj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_injective_functions_domain_permutation)
qed

lemma card_bijections_domain_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B
    = {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_surj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_surjective_functions_domain_permutation)
qed

lemma card_bijections_domain_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = iverson (card A = card B)"
using assms card_bijections_domain_permutation_eq_0 card_bijections_domain_permutation_eq_1
unfolding iverson_def by auto

subsection \<open>Bijections from A to B up to a Permutation on B\<close>

lemma bij_betw_quotient_range_permutation_eq_empty:
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B = {}"
using \<open>card A \<noteq> card B\<close> bij_betw_same_card by auto

lemma card_bijections_range_permutation_eq_0:
  assumes "card A \<noteq> card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 0"
using bij_betw_quotient_range_permutation_eq_empty[OF assms] by (simp only: card.empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on B.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_inj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: iverson_def card_injective_functions_range_permutation)
qed

lemma card_bijections_range_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_surj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_surjective_functions_range_permutation)
qed

lemma card_bijections_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = iverson (card A = card B)"
using assms card_bijections_range_permutation_eq_0 card_bijections_range_permutation_eq_1
unfolding iverson_def by auto

subsection \<open>Bijections from A to B up to a Permutation on A and B\<close>

lemma bij_betw_quotient_domain_and_range_permutation_eq_empty:
  assumes "card A \<noteq> card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B = {}"
using \<open>card A \<noteq> card B\<close> bij_betw_same_card by auto

lemma card_bijections_domain_and_range_permutation_eq_0:
  assumes "card A \<noteq> card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 0"
using bij_betw_quotient_domain_and_range_permutation_eq_empty[OF assms] by (simp only: card.empty)

text \<open>Two alternative proofs for the cardinality of bijections up to a permutation on A and B.\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. inj_on f A} // domain_and_range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_inj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: iverson_def card_injective_functions_domain_and_range_permutation)
qed

lemma card_bijections_domain_and_range_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 1"
proof -
  from assms have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B =
    {f \<in> A \<rightarrow>\<^sub>E B. f ` A = B} // domain_and_range_permutation A B"
    by (metis (no_types, lifting) PiE_cong bij_betw_implies_surj_on_and_card_eq)
  from this show ?thesis
    using assms by (simp add: card_surjective_functions_domain_and_range_permutation Partition_diag)
qed

lemma card_bijections_domain_and_range_permutation:
  assumes "finite A" "finite B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = iverson (card A = card B)"
using assms card_bijections_domain_and_range_permutation_eq_0 card_bijections_domain_and_range_permutation_eq_1
unfolding iverson_def by auto

end