Theory Transfer_Int_Nat

theory Transfer_Int_Nat
imports GCD
(*  Title:      HOL/ex/Transfer_Int_Nat.thy
    Author:     Brian Huffman, TU Muenchen
*)

header {* Using the transfer method between nat and int *}

theory Transfer_Int_Nat
imports GCD
begin

subsection {* Correspondence relation *}

definition ZN :: "int => nat => bool"
  where "ZN = (λz n. z = of_nat n)"

subsection {* Transfer domain rules *}

lemma Domainp_ZN [transfer_domain_rule]: "Domainp ZN = (λx. x ≥ 0)" 
  unfolding ZN_def Domainp_iff[abs_def] by (auto intro: zero_le_imp_eq_int)

subsection {* Transfer rules *}

context
begin
interpretation lifting_syntax .

lemma bi_unique_ZN [transfer_rule]: "bi_unique ZN"
  unfolding ZN_def bi_unique_def by simp

lemma right_total_ZN [transfer_rule]: "right_total ZN"
  unfolding ZN_def right_total_def by simp

lemma ZN_0 [transfer_rule]: "ZN 0 0"
  unfolding ZN_def by simp

lemma ZN_1 [transfer_rule]: "ZN 1 1"
  unfolding ZN_def by simp

lemma ZN_add [transfer_rule]: "(ZN ===> ZN ===> ZN) (op +) (op +)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_mult [transfer_rule]: "(ZN ===> ZN ===> ZN) (op *) (op *)"
  unfolding rel_fun_def ZN_def by (simp add: int_mult)

lemma ZN_diff [transfer_rule]: "(ZN ===> ZN ===> ZN) tsub (op -)"
  unfolding rel_fun_def ZN_def tsub_def by (simp add: zdiff_int)

lemma ZN_power [transfer_rule]: "(ZN ===> op = ===> ZN) (op ^) (op ^)"
  unfolding rel_fun_def ZN_def by (simp add: int_power)

lemma ZN_nat_id [transfer_rule]: "(ZN ===> op =) nat id"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_id_int [transfer_rule]: "(ZN ===> op =) id int"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_All [transfer_rule]:
  "((ZN ===> op =) ===> op =) (Ball {0..}) All"
  unfolding rel_fun_def ZN_def by (auto dest: zero_le_imp_eq_int)

lemma ZN_transfer_forall [transfer_rule]:
  "((ZN ===> op =) ===> op =) (transfer_bforall (λx. 0 ≤ x)) transfer_forall"
  unfolding transfer_forall_def transfer_bforall_def
  unfolding rel_fun_def ZN_def by (auto dest: zero_le_imp_eq_int)

lemma ZN_Ex [transfer_rule]: "((ZN ===> op =) ===> op =) (Bex {0..}) Ex"
  unfolding rel_fun_def ZN_def Bex_def atLeast_iff
  by (metis zero_le_imp_eq_int zero_zle_int)

lemma ZN_le [transfer_rule]: "(ZN ===> ZN ===> op =) (op ≤) (op ≤)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_less [transfer_rule]: "(ZN ===> ZN ===> op =) (op <) (op <)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_eq [transfer_rule]: "(ZN ===> ZN ===> op =) (op =) (op =)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_Suc [transfer_rule]: "(ZN ===> ZN) (λx. x + 1) Suc"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_numeral [transfer_rule]:
  "(op = ===> ZN) numeral numeral"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_dvd [transfer_rule]: "(ZN ===> ZN ===> op =) (op dvd) (op dvd)"
  unfolding rel_fun_def ZN_def by (simp add: zdvd_int)

lemma ZN_div [transfer_rule]: "(ZN ===> ZN ===> ZN) (op div) (op div)"
  unfolding rel_fun_def ZN_def by (simp add: zdiv_int)

lemma ZN_mod [transfer_rule]: "(ZN ===> ZN ===> ZN) (op mod) (op mod)"
  unfolding rel_fun_def ZN_def by (simp add: zmod_int)

lemma ZN_gcd [transfer_rule]: "(ZN ===> ZN ===> ZN) gcd gcd"
  unfolding rel_fun_def ZN_def by (simp add: transfer_int_nat_gcd)

lemma ZN_atMost [transfer_rule]:
  "(ZN ===> rel_set ZN) (atLeastAtMost 0) atMost"
  unfolding rel_fun_def ZN_def rel_set_def
  by (clarsimp simp add: Bex_def, arith)

lemma ZN_atLeastAtMost [transfer_rule]:
  "(ZN ===> ZN ===> rel_set ZN) atLeastAtMost atLeastAtMost"
  unfolding rel_fun_def ZN_def rel_set_def
  by (clarsimp simp add: Bex_def, arith)

lemma ZN_setsum [transfer_rule]:
  "bi_unique A ==> ((A ===> ZN) ===> rel_set A ===> ZN) setsum setsum"
  apply (intro rel_funI)
  apply (erule (1) bi_unique_rel_set_lemma)
  apply (simp add: setsum.reindex int_setsum ZN_def rel_fun_def)
  apply (rule setsum.cong)
  apply simp_all
  done

text {* For derived operations, we can use the @{text "transfer_prover"}
  method to help generate transfer rules. *}

lemma ZN_listsum [transfer_rule]: "(list_all2 ZN ===> ZN) listsum listsum"
  unfolding listsum_def [abs_def] by transfer_prover

end

subsection {* Transfer examples *}

lemma
  assumes "!!i::int. 0 ≤ i ==> i + 0 = i"
  shows "!!i::nat. i + 0 = i"
apply transfer
apply fact
done

lemma
  assumes "!!i k::int. [|0 ≤ i; 0 ≤ k; i < k|] ==> ∃j∈{0..}. i + j = k"
  shows "!!i k::nat. i < k ==> ∃j. i + j = k"
apply transfer
apply fact
done

lemma
  assumes "∀x∈{0::int..}. ∀y∈{0..}. x * y div y = x"
  shows "∀x y :: nat. x * y div y = x"
apply transfer
apply fact
done

lemma
  assumes "!!m n::int. [|0 ≤ m; 0 ≤ n; m * n = 0|] ==> m = 0 ∨ n = 0"
  shows "m * n = (0::nat) ==> m = 0 ∨ n = 0"
apply transfer
apply fact
done

lemma
  assumes "∀x∈{0::int..}. ∃y∈{0..}. ∃z∈{0..}. x + 3 * y = 5 * z"
  shows "∀x::nat. ∃y z. x + 3 * y = 5 * z"
apply transfer
apply fact
done

text {* The @{text "fixing"} option prevents generalization over the free
  variable @{text "n"}, allowing the local transfer rule to be used. *}

lemma
  assumes [transfer_rule]: "ZN x n"
  assumes "∀i∈{0..}. i < x --> 2 * i < 3 * x"
  shows "∀i. i < n --> 2 * i < 3 * n"
apply (transfer fixing: n)
apply fact
done

lemma
  assumes "gcd (2^i) (3^j) = (1::int)"
  shows "gcd (2^i) (3^j) = (1::nat)"
apply (transfer fixing: i j)
apply fact
done

lemma
  assumes "!!x y z::int. [|0 ≤ x; 0 ≤ y; 0 ≤ z|] ==> 
    listsum [x, y, z] = 0 <-> list_all (λx. x = 0) [x, y, z]"
  shows "listsum [x, y, z] = (0::nat) <-> list_all (λx. x = 0) [x, y, z]"
apply transfer
apply fact
done

text {* Quantifiers over higher types (e.g. @{text "nat list"}) are
  transferred to a readable formula thanks to the transfer domain rule @{thm Domainp_ZN} *}

lemma
  assumes "!!xs::int list. list_all (λx. x ≥ 0) xs ==>
    (listsum xs = 0) = list_all (λx. x = 0) xs"
  shows "listsum xs = (0::nat) <-> list_all (λx. x = 0) xs"
apply transfer
apply fact
done

text {* Equality on a higher type can be transferred if the relations
  involved are bi-unique. *}

lemma
  assumes "!!xs::int list. [|list_all (λx. x ≥ 0) xs; xs ≠ []|] ==>
    listsum xs < listsum (map (λx. x + 1) xs)"
  shows "xs ≠ [] ==> listsum xs < listsum (map Suc xs)"
apply transfer
apply fact
done

end