I am trying to refine the proof on the complete path proving as shown below:
lemma completePathProp:
assumes a1:"p \<in> complete_Path a b"
shows "(b \<in> bundles) \<longrightarrow> unique_originate a n
\<longrightarrow> (\<forall> n'. ((n'\<in> nodes b) \<and> last p=n' \<longrightarrow>(n'=n | (n,n'):(edges b)^+)))"
(is "?cons1 p")
and "p \<noteq>[]" (is "?cons2 p")
and "\<forall>m. m\<in>(set p)\<and>node_sign m=+ \<and> a\<sqsubset> node_term m
\<longrightarrow>
(\<forall>m'.(m'\<Rightarrow>\<^sup>+ m)\<and> a\<sqsubset> node_term m'\<longrightarrow> m'\<in>(set p))"
(is "?cons3 p")
using a1
proof (induction)
fix m m2 p
let ?p="p # slice_arr_cons (strand m) (index m) (index m2 - index m)"
show "?cons1 p \<and> ?cons2 p \<and> ?cons3 p "
But I meet the problem that isabelle can not refine the proof automatically that:
goal (9 subgoals):
1. ⋀m2 m p.
non_originate a (strand m2) ⟹
node_sign m2 = + ⟹
a ⊏ node_term m2 ⟹
first_node_in_nonorigi_strand a m2 m ⟹
p ∈ complete_Path a b ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last p = n' ⟶ n' = n ∨ n ≺⇩b n') ⟹
p ≠ [] ⟹
∀m. m ∈ set p ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set p) ⟹
last p = m ⟹
b ∈ bundles ⟶
unique_originate a n ⟶
(∀n'. n' ∈ nodes b ∧ last (p # slice_arr_cons (strand m) (index m) (index m2 - index m)) = n' ⟶
n' = n ∨ n ≺⇩b n')
2. ⋀m2 m p.
non_originate a (strand m2) ⟹
node_sign m2 = + ⟹
a ⊏ node_term m2 ⟹
first_node_in_nonorigi_strand a m2 m ⟹
p ∈ complete_Path a b ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last p = n' ⟶ n' = n ∨ n ≺⇩b n') ⟹
p ≠ [] ⟹
∀m. m ∈ set p ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set p) ⟹
last p = m ⟹ p # slice_arr_cons (strand m) (index m) (index m2 - index m) ≠ []
3. ⋀m2 m p.
non_originate a (strand m2) ⟹
node_sign m2 = + ⟹
a ⊏ node_term m2 ⟹
first_node_in_nonorigi_strand a m2 m ⟹
p ∈ complete_Path a b ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last p = n' ⟶ n' = n ∨ n ≺⇩b n') ⟹
p ≠ [] ⟹
∀m. m ∈ set p ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set p) ⟹
last p = m ⟹
∀ma. ma ∈ set (p # slice_arr_cons (strand m) (index m) (index m2 - index m)) ∧
node_sign ma = + ∧ a ⊏ node_term ma ⟶
(∀m'. m' ⇒⇧+ ma ∧ a ⊏ node_term m' ⟶
m' ∈ set (p # slice_arr_cons (strand m) (index m) (index m2 - index m)))
4. ⋀m m2.
unique_originate a m ⟹
strand m2 = strand m ⟹
a ⊏ node_term m2 ⟹
node_sign m2 = + ⟹
b ∈ bundles ⟶
unique_originate a n ⟶
(∀n'. n' ∈ nodes b ∧ last (slice_arr_cons (strand m) (index m) (index m2 - index m)) = n' ⟶
n' = n ∨ n ≺⇩b n')
5. ⋀m m2.
unique_originate a m ⟹
strand m2 = strand m ⟹
a ⊏ node_term m2 ⟹ node_sign m2 = + ⟹ slice_arr_cons (strand m) (index m) (index m2 - index m) ≠ []
6. ⋀m m2.
unique_originate a m ⟹
strand m2 = strand m ⟹
a ⊏ node_term m2 ⟹
node_sign m2 = + ⟹
∀ma. ma ∈ set (slice_arr_cons (strand m) (index m) (index m2 - index m)) ∧
node_sign ma = + ∧ a ⊏ node_term ma ⟶
(∀m'. m' ⇒⇧+ ma ∧ a ⊏ node_term m' ⟶
m' ∈ set (slice_arr_cons (strand m) (index m) (index m2 - index m)))
7. ⋀m1 m2 p.
m1 → m2 ⟹
m1 ∈ nodes b ⟹
(m1, m2) ∈ edges b ⟹
p ∈ complete_Path a b ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last p = n' ⟶ n' = n ∨ n ≺⇩b n') ⟹
p ≠ [] ⟹
∀m. m ∈ set p ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set p) ⟹
a ⊏ node_term m2 ⟹
last p = m1 ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last (p # [m2]) = n' ⟶ n' = n ∨ n ≺⇩b n')
8. ⋀m1 m2 p.
m1 → m2 ⟹
m1 ∈ nodes b ⟹
(m1, m2) ∈ edges b ⟹
p ∈ complete_Path a b ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last p = n' ⟶ n' = n ∨ n ≺⇩b n') ⟹
p ≠ [] ⟹
∀m. m ∈ set p ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set p) ⟹
a ⊏ node_term m2 ⟹ last p = m1 ⟹ p # [m2] ≠ []
9. ⋀m1 m2 p.
m1 → m2 ⟹
m1 ∈ nodes b ⟹
(m1, m2) ∈ edges b ⟹
p ∈ complete_Path a b ⟹
b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last p = n' ⟶ n' = n ∨ n ≺⇩b n') ⟹
p ≠ [] ⟹
∀m. m ∈ set p ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set p) ⟹
a ⊏ node_term m2 ⟹
last p = m1 ⟹
∀m. m ∈ set (p # [m2]) ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set (p # [m2]))
Failed to refine any pending goal
Local statement fails to refine any pending goal
Failed attempt to solve goal by exported rule:
(b ∈ bundles ⟶ unique_originate a n ⟶ (∀n'. n' ∈ nodes b ∧ last ?pa2 = n' ⟶ n' = n ∨ n ≺⇩b n')) ∧
?pa2 ≠ [] ∧
(∀m. m ∈ set ?pa2 ∧ node_sign m = + ∧ a ⊏ node_term m ⟶
(∀m'. m' ⇒⇧+ m ∧ a ⊏ node_term m' ⟶ m' ∈ set ?pa2))
I found that there are total 9 subgoals on the lemma proving, and on the subgoal 5 and 6, parameter q is unused, is this cause the error, and how to fix it?
Related
I am looking for a method to do rewriting, but with implications instead of equalities.
For example I know that x = 3 ∧ y = 4 implies Q x y and now I want to replace a positive occurrence of Q x y in my current subgoal with x = 3 ∧ y = 4.
Is there an existing method in Isabelle to do this?
For example I would like to do somthing like this (where implication_subst is the name of the method I am looking for):
lemma
assumes a1: "⋀x y. x = 3 ∧ y = 4 ⟹ Q x y"
shows "(∃x y. A x ∧ Q x y ∧ B y)"
proof (implication_subst a1)
show "∃x y. A x ∧ (x = 3 ∧ y = 4) ∧ B y"
sorry
qed
Below is my (incomplete) attempt to implement such a method using Eisbach, maybe this gives a better idea of what I am looking for:
named_theorems pos_cong
lemma implication_subst_exists[pos_cong]:
assumes "⋀x. P x ⟹ Q x"
and "∃x. P x"
shows "∃x. Q x"
using assms by blast
lemma implication_subst_conjl[pos_cong]:
assumes "P ⟹ Q"
and "P ∧ A"
shows "Q ∧ A"
using assms by blast
lemma implication_subst_conjr[pos_cong]:
assumes "P ⟹ Q"
and "A ∧ P"
shows "A ∧ Q"
using assms by blast
lemma implication_subst_neg[pos_cong]:
assumes "P ⟹ Q"
and "P"
shows "¬¬Q"
using assms by auto
lemma implication_subst_impl[pos_cong]:
assumes "P ⟹ ¬Q"
and "¬P ⟶ A"
shows "Q ⟶ A"
using assms by auto
lemma implication_subst_impr[pos_cong]:
assumes "P ⟹ Q"
and "A ⟶ P"
shows "A ⟶ Q"
using assms by auto
lemma implication_subst_neg_disj_l[pos_cong]:
assumes "P ⟹ ¬Q"
and "¬(¬P ∨ A)"
shows "¬(Q ∨ A)"
using assms by auto
lemma implication_subst_neg_disj_r[pos_cong]:
assumes "P ⟹ ¬Q"
and "¬(A ∨ ¬P)"
shows "¬(A ∨ Q)"
using assms by auto
method implication_subst_h uses r declares pos_cong = (
rule r
| (rule pos_cong, implication_subst_h r: r, assumption))
method implication_subst uses r declares pos_cong =
(implication_subst_h r: r pos_cong: pos_cong, (unfold not_not)?)
lemma example1:
assumes a1: "⋀x y. x = 3 ∧ y = 4 ⟹ Q x y"
shows "∃x y. A x ∧ Q x y ∧ B y"
proof (implication_subst r: a1)
show "∃x y. A x ∧ (x = 3 ∧ y = 4) ∧ B y"
sorry
qed
lemma example2:
assumes a1: "⋀x y. x = 3 ∧ y = 4 ⟹ Q x y"
shows "(∃x y. ¬(¬A x ∨ ¬Q x y ∨ ¬B y))"
proof (implication_subst r: a1)
show "∃x y. ¬ (¬ A x ∨ ¬ (x = 3 ∧ y = 4) ∨ ¬ B y)"
sorry
qed
I'm formalizing this article in Isabelle. In section 4.1 it describes the following setting:
context
fixes c d :: real
assumes "c ≠ 0" "∃ b. c = b^2" "∃ b'. d = b'^2"
begin
definition t where "t = sqrt(d/c)"
definition e' where "e' x y = x^2 + y^2 - 1 - t^2 * x^2 * y^2"
definition ρ where "ρ x y = (-y,x)"
definition τ where "τ x y = (1/(t*x),1/(t*y))"
It then defines G to be the abelian group of order eight generated by ρ and τ.
Is there an easy way of:
Stating that ρ and τ generate a group.
Since ρ and τ have order 2 and commute I think that all the rest commute and maybe there is a built-in theorem saying that this has to correspond to an abelian group of order 8?
I did make an attempt to solve the problem and came up with a slightly forceful method for its solution:
context
fixes c d :: real
assumes "c ≠ 0" "∃b. c = b^2" "∃b'. d = b'^2"
begin
definition t where "t = sqrt(d/c)"
definition e' where "e' x y = x^2 + y^2 - 1 - t^2 * x^2 * y^2"
context
assumes nz_t: "t ≠ 0"
begin
definition ρ :: "real × real ⇒ real × real" where
"ρ z = (-snd z, fst z)"
definition τ :: "real × real ⇒ real × real" where
"τ z = (1/(t*fst z), 1/(t*snd z))"
definition S where
"S ≡
{
id,
(λz. (-snd z, fst z)),
(λz. (-fst z, -snd z)),
(λz. (snd z, -fst z)),
(λz. (1/(t*fst z), 1/(t*snd z))),
(λz. (-1/(t*snd z), 1/(t*fst z))),
(λz. (-1/(t*fst z), -1/(t*snd z))),
(λz. (1/(t*snd z), -1/(t*fst z)))
}"
definition ρS where
"ρS ≡
{id, (λz. (-snd z, fst z)), (λz. (-fst z, -snd z)), (λz. (snd z, -fst z))}"
definition τS where
"τS ≡ {id, (λz. (1/(t*fst z), 1/(t*snd z)))}"
definition BIJ where "BIJ = ⦇carrier = {f. bij f}, mult = comp, one = id⦈"
interpretation bij: group BIJ
unfolding BIJ_def
apply unfold_locales
subgoal by (simp add: bij_comp)
subgoal by (simp add: comp_assoc)
subgoal by simp
subgoal by simp
subgoal by simp
subgoal
unfolding Units_def
by clarsimp
(metis inj_iff bij_betw_def bij_betw_inv_into inv_o_cancel surj_iff)
done
(*the proof may take quite a few seconds*)
lemma comp_S: "x ∈ S ⟹ y ∈ S ⟹ x ∘ y ∈ S"
unfolding comp_apply S_def Set.insert_iff by (elim disjE) fastforce+
lemma comm_S: "x ∈ S ⟹ y ∈ S ⟹ x ∘ y = y ∘ x"
unfolding comp_apply S_def Set.insert_iff by (elim disjE) fastforce+
lemma bij_ρ: "bij ρ"
unfolding bij_def inj_def surj_def ρ_def
by clarsimp (metis add.inverse_inverse)
lemma bij_τ: "bij τ"
unfolding bij_def inj_def surj_def τ_def
proof(simp add: nz_t, intro allI, intro exI)
fix a show "a = 1 / (t * (1/(a*t)))" using nz_t by simp
qed
lemma generate_ρτ: "generate BIJ {ρ, τ} = S"
proof(standard; intro subsetI)
have inv_τ: "inv⇘BIJ⇙ τ = τ"
unfolding m_inv_def
proof(standard)
show "τ ∈ carrier BIJ ∧ τ ⊗⇘BIJ⇙ τ = 𝟭⇘BIJ⇙ ∧ τ ⊗⇘BIJ⇙ τ = 𝟭⇘BIJ⇙"
unfolding BIJ_def apply(intro conjI)
subgoal using bij_τ by simp
subgoal unfolding τ_def using nz_t by auto
subgoal unfolding τ_def using nz_t by auto
done
then show
"y ∈ carrier BIJ ∧ τ ⊗⇘BIJ⇙ y = 𝟭⇘BIJ⇙ ∧ y ⊗⇘BIJ⇙ τ = 𝟭⇘BIJ⇙ ⟹ y = τ"
for y
unfolding BIJ_def by (auto intro: left_right_inverse_eq)
qed
define ρ' :: "real × real ⇒ real × real" where "ρ' = (λz. (snd z, -fst z))"
have bij_ρ': "bij ρ'"
unfolding bij_def inj_def surj_def ρ'_def
by simp (metis add.inverse_inverse)
have inv_ρ: "inv⇘BIJ⇙ ρ = ρ'"
unfolding m_inv_def
proof(standard)
show "ρ' ∈ carrier BIJ ∧ ρ ⊗⇘BIJ⇙ ρ' = 𝟭⇘BIJ⇙ ∧ ρ' ⊗⇘BIJ⇙ ρ = 𝟭⇘BIJ⇙"
unfolding BIJ_def apply(intro conjI)
subgoal using bij_ρ' by auto
subgoal unfolding ρ_def ρ'_def by auto
subgoal unfolding ρ_def ρ'_def by auto
done
then show
"y ∈ carrier BIJ ∧ ρ ⊗⇘BIJ⇙ y = 𝟭⇘BIJ⇙ ∧ y ⊗⇘BIJ⇙ ρ = 𝟭⇘BIJ⇙ ⟹ y = ρ'"
for y
unfolding BIJ_def by (auto intro: left_right_inverse_eq)
qed
have ττ: "τ ⊗⇘BIJ⇙ τ = 𝟭⇘BIJ⇙"
unfolding BIJ_def τ_def comp_def by (auto simp: nz_t)
show "x ∈ generate BIJ {ρ, τ} ⟹ x ∈ S" for x
apply(induction rule: generate.induct)
subgoal unfolding BIJ_def S_def by auto
subgoal unfolding BIJ_def S_def ρ_def τ_def by auto
subgoal
unfolding Set.insert_iff apply(elim disjE)
subgoal using inv_ρ unfolding BIJ_def S_def ρ_def ρ'_def by simp
subgoal using inv_τ unfolding BIJ_def S_def τ_def by simp
subgoal by simp
done
subgoal unfolding BIJ_def by (metis monoid.select_convs(1) comp_S)
done
show "x ∈ S ⟹ x ∈ generate BIJ {ρ, τ}" for x
unfolding S_def Set.insert_iff
proof(elim disjE; clarsimp)
show "id ∈ generate BIJ {ρ, τ}"
unfolding BIJ_def using generate.simps by fastforce
show ρ_gen: "(λz. (- snd z, fst z)) ∈ generate BIJ {ρ, τ}"
by (fold ρ_def, rule generate.simps[THEN iffD2]) simp
show τ_gen: "(λz. (1 / (t * fst z), 1 / (t * snd z))) ∈ generate BIJ {ρ, τ}"
by (fold τ_def) (simp add: generate.incl)
from inv_ρ show inv_ρ_gen: "(λz. (snd z, - fst z)) ∈ generate BIJ {ρ, τ}"
by (fold ρ'_def) (auto simp: generate.inv insertI1)
show ρρ_gen: "(λz. (- fst z, - snd z)) ∈ generate BIJ {ρ, τ}"
proof-
have ρρ: "(λz. (- fst z, - snd z)) = ρ ⊗⇘BIJ⇙ ρ"
unfolding ρ_def BIJ_def by auto
show ?thesis
apply(rule generate.simps[THEN iffD2])
using ρρ ρ_gen[folded ρ_def] by auto
qed
show "(λz. (- (1 / (t * snd z)), 1 / (t * fst z))) ∈ generate BIJ {ρ, τ}"
proof-
have ρτ: "(λz. (- (1 / (t * snd z)), 1 / (t * fst z))) = ρ ⊗⇘BIJ⇙ τ"
unfolding ρ_def τ_def BIJ_def by auto
show ?thesis
apply(rule generate.simps[THEN iffD2])
using ρτ ρ_gen[folded ρ_def] τ_gen[folded τ_def] by auto
qed
show
"(λz. (- (1 / (t * fst z)), - (1 / (t * snd z)))) ∈ generate BIJ {ρ, τ}"
proof-
have ρρτ:
"(λz. (- (1 / (t * fst z)), - (1 / (t * snd z)))) =
(λz. (- fst z, - snd z)) ⊗⇘BIJ⇙ τ"
unfolding τ_def BIJ_def by auto
show ?thesis
apply(rule generate.simps[THEN iffD2])
using ρρτ ρρ_gen τ_gen[folded τ_def] by auto
qed
show "(λz. (1 / (t * snd z), - (1 / (t * fst z)))) ∈ generate BIJ {ρ, τ}"
proof-
have inv_ρ_τ:
"(λz. (1 / (t * snd z), - (1 / (t * fst z)))) =
(λz. (snd z, - fst z)) ⊗⇘BIJ⇙ τ"
unfolding τ_def BIJ_def by auto
show ?thesis
apply(rule generate.simps[THEN iffD2])
using inv_ρ_τ inv_ρ_gen τ_gen[folded τ_def] by auto
qed
qed
qed
lemma "comm_group (BIJ⦇carrier := (generate BIJ {ρ, τ})⦈)"
proof-
have ρτ_ss_BIJ: "{ρ, τ} ⊆ carrier BIJ"
using bij_ρ bij_τ unfolding BIJ_def by simp
interpret ρτ_sg: subgroup "(generate BIJ {ρ, τ})" BIJ
using ρτ_ss_BIJ by (rule bij.generate_is_subgroup)
interpret ρτ_g: group "BIJ⦇carrier := (generate BIJ {ρ, τ})⦈"
by (rule ρτ_sg.subgroup_is_group[OF bij.group_axioms])
have car_S: "carrier (BIJ⦇carrier := S⦈) = S" by simp
have BIJ_comp: "x ⊗⇘BIJ⦇carrier := S⦈⇙ y = x ∘ y" for x y
unfolding BIJ_def by auto
from ρτ_g.group_comm_groupI[
unfolded generate_ρτ car_S BIJ_comp, OF comm_S, simplified
]
show ?thesis unfolding generate_ρτ by assumption
qed
lemma id_pair_def: "(λx. x) = (λz. (fst z, snd z))" by simp
lemma distinct_single: "distinct [x] = True" by simp
lemma ne_ff'_gg'_imp_ne_fgf'g':
assumes "f ≠ f' ∨ g ≠ g'"
shows
"(λz. (f (fst z) (snd z), g (fst z) (snd z))) ≠
(λz. (f' (fst z) (snd z), g' (fst z) (snd z)))"
using assms
proof(rule disjE)
assume "f ≠ f'"
then obtain x y where "f x y ≠ f' x y" by blast
then show ?thesis by (metis (hide_lams) fst_eqD snd_eqD)
next
assume "g ≠ g'"
then obtain x y where "g x y ≠ g' x y" by blast
then show ?thesis by (metis (hide_lams) fst_eqD snd_eqD)
qed
lemma id_ne_hyp: "(λa. a) ≠ (λa. 1/(t*a))"
proof(rule ccontr, simp)
assume id_eq_hyp: "(λa. a) = (λa. 1/(t*a))"
{
fix a :: real assume "a > 0"
define b where "b = sqrt(a)"
from ‹a > 0› have "a = b*b" and "b > 0" unfolding b_def by auto
from id_eq_hyp have "b = 1/(t*b)" by metis
with ‹b > 0› have "b div b =(1/(t*b)) div b" by simp
with ‹b > 0› have "1 = (1/(t*a))" unfolding ‹a = b*b› by simp
with ‹a > 0› nz_t have "t*a = 1" by simp
}
note ta_eq_one = this
define t2 where "t2 = (if t > 0 then 2/t else -2/t)"
with nz_t have "t2 > 0" unfolding t2_def by auto
from nz_t have "t*t2 = 2 ∨ t*t2 = -2" unfolding t2_def by auto
from ta_eq_one ‹t2 > 0› this show False by auto
qed
lemma id_ne_mhyp: "(λa. a) ≠ (λa. -1/(t*a))"
proof(rule ccontr, simp)
assume id_eq_hyp: "(λa. a) = (λa. -(1/(t*a)))"
{
fix a :: real assume "a > 0"
define b where "b = sqrt(a)"
from ‹a > 0› have "a = b*b" and "b > 0" unfolding b_def by auto
from id_eq_hyp have "b = -(1/(t*b))" by metis
with ‹b > 0› have "b div b =-1/(t*b) div b" by simp
with ‹b > 0› have "1 = -1/(t*a)" unfolding ‹a = b*b› by simp
with ‹a > 0› nz_t have "t*a = -1" by (metis divide_eq_1_iff)
}
note ta_eq_one = this
define t2 where "t2 = (if t > 0 then 2/t else -2/t)"
with nz_t have "t2 > 0" unfolding t2_def by auto
from nz_t have "t*t2 = 2 ∨ t*t2 = -2" unfolding t2_def by auto
from ta_eq_one ‹t2 > 0› this show False by auto
qed
lemma mid_ne_hyp: "(λa. -a) ≠ (λa. 1 / (t*a))"
using id_ne_mhyp by (metis minus_divide_left minus_equation_iff)
lemma mid_ne_mhyp: "(λa. -a) ≠ (λa. -1 / (t*a))"
using id_ne_hyp by (metis divide_minus_left minus_equation_iff)
lemma hyp_neq_hyp_1: "(λa. - 1/(t*a)) ≠ (λa. 1/(t*a))"
using nz_t
by (metis divide_cancel_right id_ne_mhyp mult_cancel_right1 mult_left_cancel
one_neq_neg_one)
lemma distinct:
"distinct
[
id,
(λz. (-snd z, fst z)),
(λz. (-fst z, -snd z)),
(λz. (snd z, -fst z)),
(λz. (1/(t*fst z), 1/(t*snd z))),
(λz. (-1/(t*snd z), 1/(t*fst z))),
(λz. (-1/(t*fst z), -1/(t*snd z))),
(λz. (1/(t*snd z), -1/(t*fst z)))
]"
apply(unfold distinct_length_2_or_more)+
unfolding
distinct_length_2_or_more
distinct_single
id_def id_pair_def
HOL.simp_thms(21)
by
(intro conjI)
(
rule ne_ff'_gg'_imp_ne_fgf'g',
metis one_neq_neg_one id_ne_hyp id_ne_mhyp
mid_ne_hyp mid_ne_mhyp hyp_neq_hyp_1
)+
lemma "card S = 8"
using distinct unfolding S_def using card_empty card_insert_disjoint by auto
end
end
Remarks
I relied on sledgehammer for many parts of the proofs and there is some unnecessary code duplication. Therefore, just like most of my answers on SO, this answer is far from perfect from the perspective of the coding style.
I would be interested to know if there is a better overall approach for the solution. Somehow, I came to believe that most of the more thoughtful approaches (e.g. using theorems about cyclic groups to determine the order of ρ and τ and then using |HK|=|H||K|/|H∩K| to determine the order of G) would require proving quite a number of additional theorems for HOL-Algebra, but I did not check with the AFP before making this remark and I do not use HOL-Algebra on a regular basis. Therefore, I may have missed something.
I'm trying to prove that a transitive relation on elements of finite maps is equivalent to a transitive relation on finite maps itself.
Here is a helper lemma, which shows that relations on finite maps are transitive if relations on their elements are transitive:
lemma fmrel_trans:
"(⋀x y z. x ∈ fmran' xm ⟹ P x y ⟹ Q y z ⟹ R x z) ⟹
fmrel P xm ym ⟹ fmrel Q ym zm ⟹ fmrel R xm zm"
unfolding fmrel_iff
by (metis fmdomE fmdom_notD fmran'I option.rel_inject(2) option.rel_sel)
Here is a first lemma, which I successfully proved:
lemma trancl_to_fmrel:
"(fmrel f)⇧+⇧+ xm ym ⟹ fmrel f⇧+⇧+ xm ym"
apply (induct rule: tranclp_induct)
apply (simp add: fmap.rel_mono_strong)
apply (rule_tac ?P="f⇧+⇧+" and ?Q="f" and ?ym="y" in fmrel_trans; auto)
done
And here is a symmetric lemma, which I can't prove:
lemma fmrel_to_trancl:
"fmrel r⇧+⇧+ xm ym ⟹
(⋀x. r x x) ⟹
(fmrel r)⇧+⇧+ xm ym"
Equivalently this lemma can be stated as
lemma fmrel_tranclp_induct:
"fmrel r⇧+⇧+ a b ⟹
(⋀x. r x x) ⟹
(⋀y. fmrel r a y ⟹ P y) ⟹
(⋀y z. fmrel r⇧+⇧+ a y ⟹ fmrel r y z ⟹ P y ⟹ P z) ⟹ P b"
or
lemma fmrel_tranclp_trans_induct:
"fmrel r⇧+⇧+ a b ⟹
(⋀x. r x x) ⟹
(⋀x y. fmrel r x y ⟹ P x y) ⟹
(⋀x y z. fmrel r⇧+⇧+ x y ⟹ P x y ⟹ fmrel r⇧+⇧+ y z ⟹ P y z ⟹ P x z) ⟹ P a b"
Proving any of these 3 lemmas I can prove the rest.
The question is very similar to How to lift a transitive relation from elements to lists? But the proof in that question is based on the induction rule list_all2_induct. I can't find a similar rule for fmrel. I tried to prove something like this, but with no success:
lemma fmrel_induct
[consumes 1, case_names Nil Cons, induct set: fmrel]:
assumes P: "fmrel P xs ys"
assumes Nil: "R fmempty fmempty"
assumes Cons: "⋀k x xs y ys.
⟦P x y; fmrel P xs ys; fmlookup xs k = None; fmlookup ys k = None; R xs ys⟧ ⟹
R (fmupd k x xs) (fmupd k y ys)"
shows "R xs ys"
I also tried to replace fmrel by list_all2 in the lemmas, but with no success:
lemma fmrel_to_list_all2:
"fmrel f xm ym ⟹
xs = map snd (sorted_list_of_fmap xm) ⟹
ys = map snd (sorted_list_of_fmap ym) ⟹
list_all2 f xs ys"
The idea is that keys (domains) of xm and ym are equal. And fmrel is equivalent to list_all2 on sorted values (ranges) of the maps.
Could you help me to prove fmrel_to_trancl?
There exist several methodologies that can help you to achieve your goal:
Perform lifting gradually but in a semi-automated manner using the functionality of the transfer package of Isabelle.
Prove the theorems directly as they are stated for finite maps.
As noted by larsrh, the theorems that you are looking to prove hold for general BNFs, not only for lists/finite maps. Therefore, in general, it may be sensible to think about whether it would be worth to augment the BNF infrastructure with similar theorems.
Below I present a skeleton of a solution using the first methodology and a complete solution using the second methodology. However, it goes without saying that the code presented below is not 'production ready'.
The code listing below demonstrates the first methodology. The theorems of interest are first transferred from list to alist and only then from alist to fmap. I do not provide a complete solution, but it should be relatively easy to infer it using the code listing below as a skeleton of a solution (if necessary, I can provide the missing details upon request).
First, the relevant theorems are proven for alist:
subsection ‹Further results about lists›
abbreviation "dmf ≡ distinct ∘ map fst"
lemma double_length_induct:
"(⋀xs ys. ∀xs' ys'.
length xs' < length xs ⟶ length ys' < length ys ⟶ P xs' ys' ⟹
P xs ys) ⟹
P xs ys"
sorry
lemma list_all2_sym: "list_all2 P xs ys ⟷ list_all2 (λy x. P x y) ys xs"
sorry
subsection ‹Extension of the theory #{text Multiset}›
lemma list_all2_reorder_right_invariance:
assumes rel: "list_all2 R xs ys" and ms_y: "mset ys' = mset ys"
shows "∃xs'. list_all2 R xs' ys' ∧ mset xs' = mset xs"
sorry
subsection ‹Further results about permutations›
lemma perm_map_of:
assumes "dmf xs" and "dmf ys"
shows "xs <~~> ys ⟹ map_of xs k = map_of ys k"
sorry
lemma perm_map_of_none:
"xs <~~> ys ⟹ map_of xs k = None ⟷ map_of ys k = None"
sorry
lemma map_of_eq_mset:
assumes "dmf xs" and "dmf ys"
shows "map_of xs = map_of ys ⟷ mset xs = mset ys"
sorry
lemma map_of_eq_perm:
assumes "dmf xs" and "dmf ys"
shows "map_of xs = map_of ys ⟷ xs <~~> ys"
sorry
definition perm_list_all2 ::
"('a ⇒ 'b ⇒ bool) ⇒ 'a list ⇒ 'b list ⇒ bool" where
"perm_list_all2 P xs ys = (∃ys'. ys <~~> ys' ∧ list_all2 P xs ys')"
lemma perm_list_all2_def_alt:
"perm_list_all2 P xs ys = (∃xs'. xs <~~> xs' ∧ list_all2 P xs' ys)"
unfolding perm_list_all2_def
sorry
lemma perm_list_all2_sym:
"perm_list_all2 P xs ys = perm_list_all2 (λy x. P x y) ys xs"
sorry
lemma list_all2_to_perm_list_all2_2:
"list_all2 P xs ys ⟹
xs <~~> xs' ⟹
ys <~~> ys'⟹
perm_list_all2 P xs' ys'"
sorry
lemma perm_list_all2_to_perm_list_all2:
"perm_list_all2 P xs ys ⟹
xs <~~> xs' ⟹
ys <~~> ys'⟹
perm_list_all2 P xs' ys'"
sorry
lemma perm_list_all2_lengthD:
"perm_list_all2 P xs ys ⟹ length xs = length ys"
sorry
lemma perm_list_all2_Nil[iff, code]: "perm_list_all2 P [] ys = (ys = [])"
sorry
lemma perm_list_all2_Cons:
"P x y ⟹ perm_list_all2 P xs ys ⟹ perm_list_all2 P (x # xs) (y # ys) "
sorry
subsection ‹Permutation of AList›
lemma update_new_imp_append:
"map_of xs k = None ⟹ AList.update k v xs = xs # [(k, v)]"
sorry
lemma map_of_distinct_to_none:
"dmf xs ⟹ xs = ys # [(ky, vy)] # ys' ⟹ map_of ys ky = None"
sorry
abbreviation "pred_snd P ≡ (λx y. fst x = fst y ∧ P (snd x) (snd y))"
definition listvalrel ::
"('aval ⇒ 'bval ⇒ bool) ⇒
('key × 'aval) list ⇒
('key × 'bval) list ⇒
bool"
where
"listvalrel P xs ys = list_all2 (pred_snd P) xs ys"
lemma listvalrel_map_fst: "listvalrel P xs ys ⟹ map fst xs = map fst ys"
unfolding listvalrel_def
sorry
subsection ‹Permutation of AList›
lemma dmf_perm_imp_dmf: "dmf xs ⟹ xs <~~> xs' ⟹ dmf xs'"
sorry
lemma perm_update:
assumes "dmf xs" and "dmf ys"
shows "xs <~~> ys ⟹ AList.update k v xs <~~> AList.update k v ys"
sorry
definition perm_listvalrel ::
"('aval ⇒ 'bval ⇒ bool) ⇒
('key × 'aval) list ⇒
('key × 'bval) list ⇒
bool"
where
"perm_listvalrel P xs ys = perm_list_all2 (pred_snd P) xs ys"
lemma perm_listvalrel_def_alt:
"perm_listvalrel P xs ys = (∃ys'. ys <~~> ys' ∧ listvalrel P xs ys')"
unfolding perm_listvalrel_def listvalrel_def by (simp add: perm_list_all2_def)
lemma perm_listvalrel_to_perm_listvalrel:
"perm_listvalrel P xs ys ⟹
xs <~~> xs' ⟹
ys <~~> ys'⟹
perm_listvalrel P xs' ys'"
sorry
lemma perm_listvalrel_lengthD[intro?]:
"perm_listvalrel P xs ys ⟹ length xs = length ys"
sorry
lemma perm_listvalrel_Nil[iff, code]:
"perm_listvalrel P [] ys = (ys = [])"
sorry
lemma perm_listvalrel_Cons:
"pred_snd P x y ⟹
perm_listvalrel P xs ys ⟹
perm_listvalrel P (x # xs) (y # ys) "
sorry
lemma map_of_remove1:
"dmf xs ⟹ map_of xs k = Some v ⟹ map_of (remove1 (k, v) xs) k = None"
sorry
lemma map_of_Cons:
"k ≠ k' ⟹ map_of (xss # xse) k = map_of (xss # (k', v') # xse) k"
sorry
lemma ro_imp_ro_rm1:
assumes dmf_xs: "dmf (xss # (k', v') # xse)"
and dmf_ys: "dmf (yss # (k', w') # yse)"
and ro:
"⋀k. rel_option P
(map_of (xss # (k', v') # xse) k) (map_of (yss # (k', w') # yse) k)"
shows "⋀k. rel_option P (map_of (xss # xse) k) (map_of (yss # yse) k)"
proof -
fix k
show "rel_option P (map_of (xss # xse) k) (map_of (yss # yse) k)"
proof(cases "k ≠ k'")
case True show ?thesis sorry
next
case False show ?thesis
proof -
from dmf_xs dmf_ys have
"distinct (xss # (k', v') # xse)" and "distinct (yss # (k', w') # yse)"
by (metis comp_apply distinct_map)+
then have
xss_xse: "xss # xse = remove1 (k', v') (xss # (k', v') # xse)" and
yss_yse: "yss # yse = remove1 (k', w') (yss # (k', w') # yse)"
by (simp add: remove1_append)+
have
k'v'_in_set: "(k', v') ∈ List.set (xss # (k', v') # xse)" and
k'w'_in_set: "(k', w') ∈ List.set (yss # (k', w') # yse)"
by auto
have
mo_v': "map_of (xss # (k', v') # xse) k' = Some v'" and
mo_w': "map_of (yss # (k', w') # yse) k' = Some w'"
subgoal
apply(rule map_of_eq_Some_iff[THEN iffD2]) using dmf_xs by auto
apply(rule map_of_eq_Some_iff[THEN iffD2]) using dmf_ys by auto
have
xss_xse_rm: "map_of (remove1 (k', v') (xss # (k', v') # xse)) k' = None"
and
yss_yse_rm: "map_of (remove1 (k', w') (yss # (k', w') # yse)) k' = None"
subgoal
apply(rule map_of_remove1) using dmf_xs mo_v' by auto
apply(rule map_of_remove1) using dmf_ys mo_w' by auto
have "map_of (xss#xse) k = None" and "map_of (yss#yse) k = None"
subgoal
using False xss_xse_rm xss_xse by simp
using False yss_yse_rm yss_yse by simp
thus "rel_option P (map_of (xss#xse) k) (map_of (yss#yse) k)"
by (metis rel_option_None1)
qed
qed
qed
lemma perm_listvalrel_eq_rel_option:
assumes dmf_xs: "dmf xs" and dmf_ys: "dmf ys"
shows
"perm_listvalrel P xs ys ⟷ (∀k. rel_option P (map_of xs k) (map_of ys k))"
proof
assume "perm_listvalrel P xs ys"
then obtain ys' where
ys_ys': "ys <~~> ys'" and la2_psP: "list_all2 (pred_snd P) xs ys'"
unfolding perm_listvalrel_def_alt listvalrel_def by clarsimp
from dmf_ys ys_ys' have dys': "dmf ys'" by (rule dmf_perm_imp_dmf)
from dmf_ys dys' ys_ys' have "map_of ys k = map_of ys' k" for k
by (rule perm_map_of)
moreover have "rel_option P (map_of xs k) (map_of ys' k)" for k
proof(cases "map_of xs k = None")
case True show ?thesis sorry
next
case False show ?thesis
proof -
from False obtain v where v: "map_of xs k = Some v" by clarsimp
then obtain n where n: "n < length xs ∧ xs!n = (k, v)"
by (meson in_set_conv_nth map_of_SomeD)
with la2_psP have n_l_ys': "n < length ys'"
using list_all2_lengthD by force
with la2_psP have psP: "pred_snd P (xs!n) (ys'!n)"
by (simp add: list_all2_conv_all_nth)
with n have "fst (ys'!n) = k" by simp
with dys' ys_ys' n_l_ys' have "map_of ys' k = Some (snd (ys'!n))" by auto
moreover with psP n have "P v (snd (ys'!n))" by simp
ultimately show "rel_option P (map_of xs k) (map_of ys' k)"
using v by simp
qed
qed
ultimately show "∀k. rel_option P (map_of xs k) (map_of ys k)" by simp
next
assume "(∀k. rel_option P (map_of xs k) (map_of ys k))"
with dmf_xs dmf_ys show "perm_listvalrel P xs ys"
proof(induction xs ys rule: double_length_induct)
case (1 xs ys) show ?case
proof(cases "xs = []")
case True show ?thesis sorry
next
case False show ?thesis
proof -
from False obtain xse x where x_xse: "xs = x # xse"
by (meson remdups_adj.cases)
then obtain k v where k_v: "x = (k, v)" by fastforce
with x_xse have xs_split: "xs = [] # (k, v) # xse" by simp
from k_v dmf_xs x_xse have v: "map_of xs k = Some v" by simp
then have "map_of ys k ≠ None"
by (metis option.rel_distinct(2) "1.prems"(3))
then obtain w where w: "map_of ys k = Some w" by clarsimp
then have "(k, w) ∈ List.set ys" by (auto dest: map_of_SomeD)
then obtain yss yse where ys_split: "ys = yss # (k, w) # yse"
using split_list by fastforce
from xs_split ys_split "1.prems"(3) have ro_split:
"∀k'.
rel_option P
(map_of ([] # (k, v)#xse) k') (map_of (yss # (k, w) # yse) k')"
by simp
have
d_xs_split: "dmf ([] # (k, v) # xse)" and
d_ys_split: "dmf (yss # (k, w) # yse)"
subgoal
using xs_split "1.prems"(1) by (rule subst)
using ys_split "1.prems"(2) by (rule subst)
then have d_rm_xs: "dmf ([] # xse)" and d_rm_ys: "dmf (yss # yse)"
by simp+
from d_xs_split d_ys_split ro_split[rule_format] have ro_rm:
"rel_option P (map_of ([] # xse) k) (map_of (yss # yse) k)" for k
by (rule ro_imp_ro_rm1)
with x_xse have l_rm_xs: "length ([] # xse) < length xs" by simp
with ys_split have l_rm_ys: "length (yss # yse) < length ys" by simp
with ro_split v w have "pred_snd P (k, v) (k, w)"
by (metis "1.prems"(3) fst_conv option.rel_inject(2) snd_conv)
moreover from l_rm_xs l_rm_ys d_rm_xs d_rm_ys ro_rm have
"perm_listvalrel P ([] # xse) (yss # yse)"
by (rule "1.IH"[rule_format])
ultimately have
"perm_listvalrel P ((k, v) # [] # xse) ((k, w) # yss # yse)"
by (rule perm_listvalrel_Cons)
with k_v x_xse have "perm_listvalrel P xs ((k, w) # yss # yse)" by simp
moreover have "((k, w) # yss # yse) <~~> ys"
unfolding ys_split by (rule perm_append_Cons)
ultimately show "perm_listvalrel P xs ys"
using perm_listvalrel_to_perm_listvalrel by blast
qed
qed
qed
qed
subsection ‹Further results of DAList›
lift_definition alist_all2 ::
"(('akey × 'a) ⇒ ('bkey × 'b) ⇒ bool) ⇒
('akey, 'a) alist ⇒
('bkey, 'b) alist ⇒
bool"
is List.list_all2 .
abbreviation alength :: "('akey, 'aval) alist ⇒ nat" where
"alength ≡ size"
lemma alength_transfer[transfer_rule]:
includes lifting_syntax
shows "((pcr_alist (=) (=)) ===> (=)) List.length alength"
sorry
lemma neq_empty_conv:
"xs ≠ DAList.empty =
(∃ky vy ys.
xs = DAList.update ky vy ys ∧
alength ys < alength xs ∧
DAList.lookup ys ky = None)"
sorry
lemma alength_induct:
"(⋀xs::('key, 'val) alist.
∀ys::('key, 'val) alist. alength ys < alength xs ⟶ P ys ⟹ P xs) ⟹
P xs"
sorry
lemma aupdate_induct_3[case_names Nil update, induct type: alist]:
"P DAList.empty ⟹
(⋀kx vx xs.
P xs ⟹ DAList.lookup xs kx = None ⟹ P (DAList.update kx vx xs)
) ⟹
P xs"
sorry
lemma alist_all2_update[iff]:
assumes "DAList.lookup xs kx = None" and "DAList.lookup ys ky = None"
shows
"alist_all2 P (DAList.update kx vx xs) (DAList.update ky vy ys) =
(P (kx, vx) (ky, vy) ∧ alist_all2 P xs ys)"
sorry
lemma alist_all2_update1:
assumes "DAList.lookup xs kx = None"
shows
"alist_all2 P (DAList.update kx vx xs) ys =
(∃kz vz zs.
DAList.lookup zs kz = None ∧
ys = (DAList.update kz vz zs) ∧
P (kx, vx) (kz, vz) ∧
alist_all2 P xs zs)"
proof(insert assms, transfer)
fix xs :: "('b × 'a) list"
and ys :: "('c × 'd) list"
and kx P vx
assume mo_xs_none: "map_of xs kx = None" and dmf_ys: "dmf ys"
from mo_xs_none have xs_append: "AList.update kx vx xs = xs # [(kx, vx)]"
by (simp add: update_new_imp_append)
show
"list_all2 P (AList.update kx vx xs) ys =
(∃kz vz. ∃zs∈Collect dmf.
map_of zs kz = None ∧
ys = AList.update kz vz zs ∧
P (kx, vx) (kz, vz) ∧
list_all2 P xs zs)"
sorry
qed
subsection ‹Permutation of DAList›
lift_definition mset :: "('key, 'val) alist ⇒ ('key × 'val) multiset"
is Multiset.mset .
lift_definition aperm ::
"('key, 'val) alist ⇒ ('key, 'val) alist ⇒ bool" ("_ <~~>a _" [50, 50] 50)
is Permutation.perm .
lemma aperm_trans[intro]: "xs <~~>a ys ⟹ ys <~~>a zs ⟹ xs <~~>a zs"
by transfer auto
lemma aperm_refl[iff]: "l <~~>a l"
by transfer simp
lemma aperm_sym: "xs <~~>a ys ⟹ ys <~~>a xs"
by transfer (rule perm_sym)
lemma aperm_aperm_snd: "x <~~>a y ⟹ aperm x = aperm y"
sorry
lemma aperm_update[intro!]:
"xs <~~>a ys ⟹ DAList.update k v xs <~~>a DAList.update k v ys"
sorry
lemma aperm_imp_lookup_none:
"xs <~~>a ys ⟹ DAList.lookup xs k = None ⟷ DAList.lookup ys k = None"
sorry
lift_definition perm_alist_all2 ::
"(('akey × 'a) ⇒ ('bkey × 'b) ⇒ bool) ⇒
('akey, 'a) alist ⇒
('bkey, 'b) alist ⇒
bool"
is perm_list_all2 .
lemma perm_alist_all2_def_alt:
"perm_alist_all2 P xs ys = (∃ys'. ys <~~>a ys' ∧ alist_all2 P xs ys')"
sorry
lemma perm_alist_all2_sym:
"perm_alist_all2 P xs ys = perm_alist_all2 (λy x. P x y) ys xs"
sorry
lemma alist_all2_to_perm_perm_alist_all2:
"alist_all2 P xs ys ⟹
xs <~~>a xs' ⟹
ys <~~>a ys'⟹
perm_alist_all2 P xs' ys'"
sorry
lemma perm_alist_all2_Nil:
"perm_alist_all2 P DAList.empty ys = (ys = DAList.empty)"
sorry
lemma perm_alist_all2_update:
assumes "DAList.lookup xs kx = None" and "DAList.lookup ys ky = None"
shows
"P (kx, vx) (ky, vy) ⟹
perm_alist_all2 P xs ys ⟹
perm_alist_all2 P (DAList.update kx vx xs) (DAList.update ky vy ys)"
sorry
lemma perm_alist_all2_update1:
assumes "DAList.lookup xs kx = None"
shows
"perm_alist_all2 P (DAList.update kx vx xs) ys =
(∃kz vz zs.
DAList.lookup zs kz = None ∧
ys <~~>a (DAList.update kz vz zs) ∧
P (kx, vx) (kz, vz) ∧
perm_alist_all2 P xs zs)"
sorry
lemma perm_alist_all2_update2:
assumes "DAList.lookup ys ky = None"
shows
"perm_alist_all2 P xs (DAList.update ky vy ys) =
(∃kz vz zs.
DAList.lookup zs kz = None ∧
xs <~~>a (DAList.update kz vz zs) ∧
P (kz, vz) (ky, vy) ∧
perm_alist_all2 P zs ys)"
sorry
lemma perm_alist_all2_induct[consumes 1, case_names Nil update]:
assumes P: "perm_alist_all2 P xs ys"
and Nil: "R DAList.empty DAList.empty"
assumes update:
"⋀kx vx xs ky vy ys ys'.
⟦
DAList.lookup xs kx = None;
DAList.lookup ys ky = None;
P (kx, vx) (ky, vy);
perm_alist_all2 P xs ys;
R xs ys;
(DAList.update ky vy ys) <~~>a ys'
⟧ ⟹
R (DAList.update kx vx xs) ys'"
shows "R xs ys"
using P
sorry
lift_definition perm_alistvalrel ::
"('aval ⇒ 'bval ⇒ bool) ⇒
('key, 'aval) alist ⇒
('key, 'bval) alist ⇒
bool"
is perm_listvalrel .
lemma perm_alistvalrel_def_alt:
"perm_alistvalrel P xs ys = perm_alist_all2 (pred_snd P) xs ys"
sorry
lemma perm_alistvalrel_update:
assumes "DAList.lookup xs kx = None" and "DAList.lookup ys ky = None"
shows
"pred_snd P (kx, vx) (ky, vy) ⟹
perm_alistvalrel P xs ys ⟹
perm_alistvalrel P (DAList.update kx vx xs) (DAList.update ky vy ys)"
sorry
lemma perm_alistvalrel_update1:
assumes "DAList.lookup xs k = None"
shows
"perm_alistvalrel P (DAList.update k vx xs) ys =
(∃vz zs.
DAList.lookup zs k = None ∧
ys <~~>a (DAList.update k vz zs) ∧
P vx vz ∧
perm_alistvalrel P xs zs)"
sorry
lemma perm_alistvalrel_update2:
assumes "DAList.lookup ys k = None"
shows
"perm_alistvalrel P xs (DAList.update k vy ys) =
(∃vz zs.
DAList.lookup zs k = None ∧
xs <~~>a (DAList.update k vz zs) ∧
P vz vy ∧
perm_alistvalrel P zs ys)"
sorry
lemma perm_alistvalrel_induct[consumes 1, case_names Nil update]:
assumes P: "perm_alistvalrel P xs ys"
and Nil: "R DAList.empty DAList.empty"
assumes update:
"⋀k vx xs vy ys ys'.
⟦
P vx vy;
perm_alistvalrel P xs ys;
R xs ys;
(DAList.update k vy ys) <~~>a ys'
⟧ ⟹
R (DAList.update k vx xs) ys'"
shows "R xs ys"
using P
proof -
from update have update':
"⋀kx vx xs ky vy ys ys'.
⟦
DAList.lookup xs kx = None;
DAList.lookup ys ky = None;
pred_snd P (kx, vx) (ky, vy);
perm_alistvalrel P xs ys;
R xs ys;
(DAList.update ky vy ys) <~~>a ys'
⟧ ⟹
R (DAList.update kx vx xs) ys'"
by auto
then show "R xs ys"
apply(insert assms update')
unfolding perm_alistvalrel_def_alt by (rule perm_alist_all2_induct)
qed
Then the theorems can be transferred to fmap:
lemma perm_eq_fmap_of_list:
assumes "dmf xs" and "dmf ys"
shows "xs <~~> ys ⟷ fmap_of_list xs = fmap_of_list ys"
sorry
lemma exists_distinct_fst_fmap_of_list:
"∃xa. dmf xa ∧ fmap_of_list xa = m"
sorry
lift_definition fmap_of_alist_impl :: "('a, 'b) alist ⇒ ('a, 'b) fmap"
is fmap_of_list .
lemma perm_eq_fmap_of_alist:
"xs <~~>a ys ⟷ fmap_of_alist_impl xs = fmap_of_alist_impl ys"
sorry
lemma exists_distinct_fst_fmap_of_alist: "∃xs. fmap_of_alist_impl xs = m"
sorry
definition fmap_of_alists :: "('a, 'b) alist set ⇒ ('a, 'b) fmap" where
"fmap_of_alists X = fmap_of_alist_impl (SOME x. x ∈ X)"
definition alists_of_fmap :: "('a, 'b) fmap ⇒ ('a, 'b) alist set" where
"alists_of_fmap y = {x. fmap_of_alist_impl x = y}"
interpretation fmap : quot_type aperm fmap_of_alists alists_of_fmap
sorry
abbreviation "fmap_of_alist ≡ fmap.abs"
abbreviation "alist_of_fmap ≡ fmap.rep"
definition cr_fmaplist where "cr_fmaplist = (λx. (=) (fmap_of_alist x))"
lemma fmap_of_alist_def_impl: "fmap_of_alist y = fmap_of_alist_impl y"
sorry
lemma alist_of_fmap_def_alt: "alist_of_fmap y = (SOME x. fmap_of_alist x = y)"
sorry
lemma fmap_alist_rep_abs: "fmap_of_alist (alist_of_fmap a) = a"
sorry
lemma Quotient_fmaplist:
"Quotient aperm fmap_of_alist alist_of_fmap cr_fmaplist"
sorry
locale fmap_fmaplist
begin
lemma reflp_aperm: "reflp aperm" by (simp add: reflpI)
setup_lifting Quotient_fmaplist reflp_aperm
lemma fmap_of_alist_imp_eq_lookup:
"m = fmap_of_alist ml ⟹ fmlookup m k = DAList.lookup ml k"
sorry
lemma cr_fmaplist_imp_eq_lookup:
"cr_fmaplist ml m ⟹ fmlookup m k = DAList.lookup ml k"
sorry
lemma eq_lookup_imp_cr_fmaplist:
"∀k. fmlookup m k = DAList.lookup ml k ⟹ cr_fmaplist ml m"
sorry
context includes lifting_syntax
begin
lemma lookup_fmlookup_transfer[transfer_rule]:
"(cr_fmaplist ===> (=) ===> (=)) DAList.lookup fmlookup"
unfolding rel_fun_def cr_fmaplist_def fmap_of_alist_def_impl
by (transfer, simp add: fmlookup_of_list)
lemma fmempty_transfer[transfer_rule]: "cr_fmaplist DAList.empty fmempty"
unfolding rel_fun_def cr_fmaplist_def fmap_of_alist_def_impl
by (simp add: empty.rep_eq fmap_of_alist_impl.rep_eq)
lemma fmrel_transfer[transfer_rule]:
"((=) ===> cr_fmaplist ===> cr_fmaplist ===> (=)) perm_alistvalrel fmrel"
unfolding rel_fun_def cr_fmaplist_def fmap_of_alist_def_impl
by transfer
(auto simp: fmlookup_of_list fmrel_iff perm_listvalrel_eq_rel_option)+
lemma fmupd_transfer[transfer_rule]:
"((=) ===> (=) ===> cr_fmaplist ===> cr_fmaplist) DAList.update fmupd"
unfolding rel_fun_def
using cr_fmaplist_imp_eq_lookup
by (fastforce simp: eq_lookup_imp_cr_fmaplist)
end
lifting_update fmap.lifting
lifting_forget fmap.lifting
end
context
begin
interpretation fmap_fmaplist .
lemma fmrel_update1:
assumes "fmlookup xs k = None"
shows
"fmrel P (fmupd k vx xs) ys =
(∃vz zs.
fmlookup zs k = None ∧
ys = (fmupd k vz zs) ∧
P vx vz ∧
fmrel P xs zs)"
including fmap.lifting
by (insert assms, transfer) (simp add: perm_alistvalrel_update1)
lemma fmrel_update2:
assumes "fmlookup ys k = None"
shows
"fmrel P xs (fmupd k vy ys) =
(∃vz zs.
fmlookup zs k = None ∧
xs = (fmupd k vz zs) ∧
P vz vy ∧
fmrel P zs ys)"
including fmap.lifting
by (insert assms, transfer) (simp add: perm_alistvalrel_update2)
lemma fmrel_induct[consumes 1, case_names Nil update]:
assumes P: "fmrel P xs ys"
and Nil: "R fmempty fmempty"
and update:
"⋀k vx xs vy ys.
⟦P vx vy; fmrel P xs ys; R xs ys⟧ ⟹ R (fmupd k vx xs) (fmupd k vy ys)"
shows "R xs ys"
proof -
from update have update':
"⋀k vx xs vy ys ys'.
⟦P vx vy; fmrel P xs ys; R xs ys; (fmupd k vy ys) = ys'⟧ ⟹
R (fmupd k vx xs) ys'"
by auto
show "R xs ys" sorry
qed
end
lemma fmrel_to_rtrancl:
assumes as_r: "(⋀x. r x x)" and rel_rpp_xm_ym: "(fmrel r⇧*⇧*) xm ym"
shows "(fmrel r)⇧*⇧* xm ym"
sorry
The lemma
lemma fmrel_to_rtrancl:
assumes as_r: "(⋀x. r x x)" and rel_rpp_xm_ym: "(fmrel r⇧*⇧*) xm ym"
shows "(fmrel r)⇧*⇧* xm ym"
sorry
can be transferred following the same methodology.
The code listing below presents the answer using the second methodology.
theory so_htlartfm
imports
Complex_Main
"HOL-Library.Finite_Map"
begin
lemma fmap_eqdom_Cons1:
assumes as_1: "fmlookup xm i = None"
and as_2: "fmrel R (fmupd i x xm) ym"
shows
"(∃z zm.
fmlookup zm i = None ∧ ym = (fmupd i z zm) ∧ R x z ∧ fmrel R xm zm)"
proof -
from as_2 have eq_dom: "fmdom (fmupd i x xm) = fmdom ym"
using fmrel_fmdom_eq by blast
from as_1 eq_dom as_2 obtain y where y: "fmlookup ym i = Some y"
by force
obtain z zm where z_zm: "ym = (fmupd i z zm) ∧ fmlookup zm i = None"
using y by (smt fmap_ext fmlookup_drop fmupd_lookup)
{
assume "¬R x z"
with as_1 z_zm have "¬fmrel R (fmupd i x xm) ym"
by (metis fmrel_iff fmupd_lookup option.simps(11))
}
with as_2 have c3: "R x z" by auto
{
assume "¬fmrel R xm zm"
with as_1 have "¬fmrel R (fmupd i x xm) ym"
by (metis fmrel_iff fmupd_lookup option.rel_sel z_zm)
}
with as_2 have c4: "fmrel R xm zm" by auto
from z_zm c3 c4 show ?thesis by auto
qed
lemma fmap_eqdom_induct [consumes 1, case_names nil step]:
assumes R: "fmrel R xm ym"
and nil: "P fmempty fmempty"
and step:
"⋀x xm y ym i. ⟦R x y; fmrel R xm ym; P xm ym⟧ ⟹
P (fmupd i x xm) (fmupd i y ym)"
shows "P xm ym"
using R
proof(induct xm arbitrary: ym)
case fmempty
then show ?case
by (metis fempty_iff fmdom_empty fmfilter_alt_defs(5)
fmfilter_false fmrel_fmdom_eq fmrestrict_fset_dom nil)
next
case (fmupd i x xm) show ?case
proof -
from fmupd.prems(1) obtain y where y: "fmlookup ym i = Some y"
by (metis fmupd.prems(1) fmrel_cases fmupd_lookup option.discI)
from fmupd.hyps(2) fmupd.prems(1) fmupd.prems(1) obtain z zm where
zm_i_none: "fmlookup zm i = None" and
ym_eq_z_zm: "ym = (fmupd i z zm)" and
R_x_z: "R x z" and
R_xm_zm: "fmrel R xm zm"
using fmap_eqdom_Cons1 by metis
with R_xm_zm fmupd.hyps(1) have P_xm_zm: "P xm zm" by blast
from R_x_z R_xm_zm P_xm_zm have "P (fmupd i x xm) (fmupd i z zm)"
by (rule step)
then show ?thesis by (simp add: ym_eq_z_zm)
qed
qed
lemma fmrel_to_rtrancl:
assumes as_r: "(⋀x. r x x)"
and rel_rpp_xm_ym: "(fmrel r⇧*⇧*) xm ym"
shows "(fmrel r)⇧*⇧* xm ym"
proof-
from rel_rpp_xm_ym show "(fmrel r)⇧*⇧* xm ym"
proof(induct rule: fmap_eqdom_induct)
case nil then show ?case by auto
next
case (step x xm y ym i) show ?case
proof -
from as_r have lp_xs_xs: "fmrel r xm xm" by (simp add: fmap.rel_refl)
from step.hyps(1) have x_xs_y_zs:
"(fmrel r)⇧*⇧* (fmupd i x xm) (fmupd i y xm)"
proof(induction rule: rtranclp_induct)
case base then show ?case by simp
next
case (step y z) then show ?case
proof -
have rt_step_2: "(fmrel r)⇧*⇧* (fmupd i y xm) (fmupd i z xm)"
by (rule r_into_rtranclp, simp add: fmrel_upd lp_xs_xs step.hyps(2))
from step.IH rt_step_2 show ?thesis by (rule rtranclp_trans)
qed
qed
from step.hyps(3) have "(fmrel r)⇧*⇧* (fmupd i y xm) (fmupd i y ym)"
proof(induction rule: rtranclp_induct)
case base then show ?case by simp
next
case (step ya za) show ?case
proof -
have rt_step_2: "(fmrel r)⇧*⇧* (fmupd i y ya) (fmupd i y za)"
by (rule r_into_rtranclp, simp add: as_r fmrel_upd step.hyps(2))
from step.IH rt_step_2 show ?thesis by (rule rtranclp_trans)
qed
qed
with x_xs_y_zs show ?thesis by simp
qed
qed
qed
lemma fmrel_to_trancl:
assumes as_r: "(⋀x. r x x)"
and rel_rpp_xm_ym: "(fmrel r⇧+⇧+) xm ym"
shows "(fmrel r)⇧+⇧+ xm ym"
by (metis as_r fmrel_to_rtrancl fmap.rel_mono_strong fmap.rel_refl
r_into_rtranclp reflclp_tranclp rel_rpp_xm_ym rtranclpD rtranclp_idemp
rtranclp_reflclp tranclp.r_into_trancl)
end
I am struggling to convert this sentence to CNF:
(A ∨ B) ⇔ (C ∧ D).
I have already tried to use the Biconditional elimination logic rule to eliminate the ⇔.
(A ∨ B) → (C ∧ D) ∧ (C ∧ D) → (A ∨ B).
Then I eliminated the → with the Implication elimination logic rule. Now I have
¬(A ∨ B) ∨ (C ∧ D) ∧ ¬(C ∧ D) ∨ (A ∨ B).
I am pretty much stuck here. My professor says I should use Distributivity rule to reduce the sentence. I can't seem to find anything that matches the requirements of Distributivity rule. So, I can't seem to use Distributivity rule before doing some logical rule that I do not know of.
What am I missing here? Can Stack Overflow help me to resume the conversion to CNF?
You began with the expression:
(A ∨ B) ⇔ (C ∧ D).
You tried to perform the first few steps. Here I added brackets to be clear and correct:
[(A ∨ B) → (C ∧ D)] ∧ [(C ∧ D) → (A ∨ B)]. (by definition of ⇔)
[¬(A ∨ B) ∨ (C ∧ D)] ∧ [¬(C ∧ D) ∨ (A ∨ B)]. (by definition of →)
Apply the De Morgan negation law to ¬(A ∨ B) and ¬(C ∧ D):
[(¬A ∧ ¬B) ∨ (C ∧ D)] ∧ [(¬C ∨ ¬D) ∨ (A ∨ B)].
Simplify the right half:
[(¬A ∧ ¬B) ∨ (C ∧ D)] ∧ [¬C ∨ ¬D ∨ A ∨ B].
The distributive law for ∨ over ∧ states that: X ∨ (Y ∧ Z) ⇔ (X ∨ Y) ∧ (X ∨ Z).
We apply the law to the left half, with X = (¬A ∧ ¬B), Y = C, Z = D:
[((¬A ∧ ¬B) ∨ C) ∧ ((¬A ∧ ¬B) ∨ D)] ∧ [¬C ∨ ¬D ∨ A ∨ B].
Apply the distributive law to two subexpressions in the left half:
[[(¬A ∨ C) ∧ (¬B ∨ C)] ∧ [(¬A ∨ D) ∧ (¬B ∨ D)]] ∧ [¬C ∨ ¬D ∨ A ∨ B].
Remove the extra brackets because ∧ is associative and commutative:
(¬A ∨ C) ∧ (¬B ∨ C) ∧ (¬A ∨ D) ∧ (¬B ∨ D) ∧ [¬C ∨ ¬D ∨ A ∨ B].
Rearrange the variables, and we have our final formula in conjunctive normal form (CNF):
(¬A ∨ C) ∧ (¬A ∨ D) ∧ (¬B ∨ C) ∧ (¬B ∨ D) ∧ (A ∨ B ∨ ¬C ∨ ¬D).
I'm trying to prove the following simple theorem I've come up with, that:
A point is on the boundary iff any small enough ball around that point contains points both in S and out of S.
Below I've managed to do the forward direction but I'm stuck on the backwards direction.
Using the same approach fails on the last step, the goal is close but not quite there, and I'm not sure what to do here:
lemma frontier_ball: "x ∈ frontier S ⟷
(∃r>0. (∀δ>0. δ<r ⟶ ((ball x δ) ∩ S ≠ {} ∧ (ball x δ) ∩ -S ≠ {})))"
(is "?lhs = ?rhs")
proof
{
assume "?lhs"
hence "x ∉ interior S ∧ x ∉ interior (-S)" by (auto simp: frontier_def interior_complement)
hence "∀δ>0. ((ball x δ) ∩ S ≠ {} ∧ (ball x δ) ∩ -S ≠ {})" by (auto simp: mem_interior)
then have "?rhs" by (simp add: Orderings.no_top_class.gt_ex)
}
{
assume "¬?lhs"
hence "x ∈ interior S ∨ x ∈ interior (-S)" by (auto simp: frontier_def interior_complement)
hence "∃δ>0. ball x δ ∩ S = {} ∨ ball x δ ∩ -S = {}" by (auto simp: mem_interior)
then have "¬?rhs" by (simp add: subset_ball)
}
qed
I tried to tell isabelle how to obtain such a delta but it's stuck on the obtain step:
lemma frontier_ball: "x ∈ frontier S ⟷
(∃r>0. (∀δ>0. δ<r ⟶ ((ball x δ) ∩ S ≠ {} ∧ (ball x δ) ∩ -S ≠ {})))"
(is "?lhs = ?rhs")
proof
{
assume "?lhs"
hence "x ∉ interior S ∧ x ∉ interior (-S)" by (auto simp: frontier_def interior_complement)
hence "∀δ>0. ((ball x δ) ∩ S ≠ {} ∧ (ball x δ) ∩ -S ≠ {})" by (auto simp: mem_interior)
then have "?rhs" by (simp add: Orderings.no_top_class.gt_ex)
}
{
fix r::real
assume "¬?lhs ∧ r>0"
hence "x ∈ interior S ∨ x ∈ interior (-S)" by (auto simp: frontier_def interior_complement)
then obtain r2 where "r2>0" and "ball x r2 ∩ S = {} ∨ ball x r2 ∩ -S = {}" by (auto simp: mem_interior)
then obtain δ where "δ>0 ∧ δ<r ∧ δ<r2" by auto
}
qed
Any pointers would be great!
Well, you can just construct such a δ. If you have r > 0 and r2 > 0 you want some δ that fulfils 0 < δ ≤ r2 and 0 < δ < r, why not just use min r2 (r/2)? You can define δ to be that and then you can prove the properties you want:
def δ ≡ "min r2 (r/2)"
with r2 A have δ: "δ > 0" "δ < r" "δ ≤ r2" by auto
with r2 have δ': "ball x δ ∩ S = {} ∨ ball x r2 ∩ -S = {}" using subset_ball[OF δ(3)] by auto
Or, a bit more direct:
lemma frontier_ball: "(x :: 'a :: {metric_space}) ∈ frontier S ⟷
(∃r>0. (∀δ>0. δ<r ⟶ ((ball x δ) ∩ S ≠ {} ∧ (ball x δ) ∩ -S ≠ {})))"
(is "?lhs = ?rhs")
proof -
{
assume "?lhs"
hence "x ∉ interior S ∧ x ∉ interior (-S)" by (auto simp: frontier_def interior_complement)
hence "∀δ>0. ((ball x δ) ∩ S ≠ {} ∧ (ball x δ) ∩ -S ≠ {})" by (auto simp: mem_interior)
then have "?rhs" by (simp add: Orderings.no_top_class.gt_ex)
}
moreover
{
assume lhs: "¬?lhs"
{
fix r :: real assume r: "r > 0"
from lhs have "x ∈ interior S ∨ x ∈ interior (-S)"
by (auto simp: frontier_def interior_complement)
then obtain δ where "δ > 0" "ball x δ ∩ S = {} ∨ ball x δ ∩ -S = {}"
by (auto simp: mem_interior)
with r have "min δ (r/2) > 0" "min δ (r/2) < r"
"ball x (min δ (r/2)) ∩ S = {} ∨ ball x (min δ (r/2)) ∩ -S = {}" using subset_ball by auto
hence "∃δ>0. δ < r ∧ (ball x δ ∩ S = {} ∨ ball x δ ∩ -S = {})" by blast
}
hence "¬?rhs" by blast
}
ultimately show ?thesis by blast
qed
For the record, I would avoid doing things like assume "A ∧ B". Do assume "A" "B" instead. That gives you two facts that you can work with directly, instead of having them wrapped up with a HOL conjunction in one fact.