How to lift a transitive relation to finite maps? - isabelle

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

Related

Proving the correctness of an algorithm to partition lists in Isabelle

I trying to prove correct an algorithm to split a list of integers into sublists of equal sum in linear time. Here you can see the algorithm I have chosen to do so.
I would like to get some feedback regarding:
The convenience of my definition for the splitting function.
The "induction" hypothesis to use in my situation.
Please, bear in mind that up to now I have only worked with apply-scripts and not with Isar proofs.
Here is a preliminary implementation of the algorithm and the correctness definition:
definition
"ex_balanced_sum xs = (∃ ys zs. sum_list ys = sum_list zs ∧
xs = ys # zs ∧ ys ≠ [] ∧ zs ≠ [])"
fun check_list :: "int list ⇒ int ⇒ int ⇒ bool" where
"check_list [] n acc = False" |
"check_list (x#xs) n acc = (if n = acc then True else (check_list xs (n-x) (acc+x)))"
fun linear_split :: "int list ⇒ bool" where
"linear_split [] = False" |
"linear_split [x] = False" |
"linear_split (x # xs) = check_list xs (sum_list xs) x"
The theorem to prove is as follows:
lemma linear_correct: "linear_split xs ⟷ ex_balanced_sum xs"
If I reason for instance for the first implication as:
lemma linear_correct_1: "linear_split xs ⟹ ex_balanced_sum xs"
apply(induction xs rule: linear_split.induct)
Then I get a list of subgoals that I think are not appropriate:
linear_split [] ⟹ ex_balanced_sum []
⋀x. linear_split [x] ⟹ ex_balanced_sum [x]
⋀x v va. linear_split (x # v # va) ⟹ ex_balanced_sum (x # v # va)
In particular, these subgoals don't have an induction hypothesis! (am I right?). I tried to perform a different induction by just writing apply(induction xs) but then the goals look as:
linear_split [] ⟹ ex_balanced_sum []
⋀a xs. (linear_split xs ⟹ ex_balanced_sum xs) ⟹ linear_split (a # xs) ⟹ ex_balanced_sum (a # xs)
Here the hypothesis is also not an induction hypothesis since it is assuming an implication.
So, what is the best way to define this function to get a nice induction hypothesis?
Edit (a one-function version)
fun check :: "int list ⇒ int ⇒ int ⇒ bool" where
"check [] n acc = False" |
"check [x] n acc = False" |
"check (x # y # xs) n acc = (if n-x = acc+x then True else check (y # xs) (n-x) (acc+x))"
definition "linear_split xs = check xs (sum_list xs) 0"
Background
I was able to prove the theorem linear_correct for a function (splitl) that is very similar to the function check in the statement of the question. Unfortunately, I would prefer not to make any attempts to convert the proof into an apply script.
The proof below is the first proof that came to my mind after I started investigating the question. Thus, there may exist better proofs.
Proof Outline
The proof is based on the induction based on the length of the list. In particular, assume
splitl xs (sum_list xs) 0 ⟹ ex_balanced_sum xs
holds for all lists with the length less than l. If l = 1, then the result is easy to show. Assume, that l>=2. Then the list can be expressed in the form x#v#xs. In this case if it is possible to split the list using splitl, then it can be shown (splitl_reduce) that either
"splitl ((x + v)#xs) (sum_list ((x + v)#xs)) 0" (1)
or
"x = sum_list (v#xs)" (2).
Thus, the proof proceeds by cases for (1) and (2). For (1), the length of the list is (x + v)#xs) is l-1. Hence, by the induction hypothesis ex_balanced_sum (x + v)#xs). Therefore, by the definition of ex_balanced_sum, also ex_balanced_sum x#v#xs. For (2), it can be easily seen that the list can be expressed as [x]#(v#xs) and, in this case, given (2), it satisfies the conditions of ex_balanced_sum by definition.
The proof for the other direction is similar and based on the converse of the lemma associated with (1) and (2) above: if "splitl ((x + v)#xs) (sum_list ((x + v)#xs)) 0" or "x = sum_list (v#xs)", then "splitl (x#v#xs) (sum_list (x#v#xs)) 0".
theory so_ptcoaatplii
imports Complex_Main
begin
definition
"ex_balanced_sum xs =
(∃ ys zs. sum_list ys = sum_list zs ∧ xs = ys # zs ∧ ys ≠ [] ∧ zs ≠ [])"
fun splitl :: "int list ⇒ int ⇒ int ⇒ bool" where
"splitl [] s1 s2 = False" |
"splitl [x] s1 s2 = False" |
"splitl (x # xs) s1 s2 = ((s1 - x = s2 + x) ∨ splitl xs (s1 - x) (s2 + x))"
lemma splitl_reduce:
assumes "splitl (x#v#xs) (sum_list (x#v#xs)) 0"
shows "splitl ((x + v)#xs) (sum_list ((x + v)#xs)) 0 ∨ x = sum_list (v#xs)"
proof -
from assms have prem_cases:
"((x = sum_list (v#xs)) ∨ splitl (v#xs) (sum_list (v#xs)) x)" by auto
{
assume "splitl (v#xs) (sum_list (v#xs)) x"
then have "splitl ((x + v)#xs) (sum_list ((x + v)#xs)) 0"
proof(induction xs arbitrary: x v)
case Nil then show ?case by simp
next
case (Cons a xs) then show ?case by simp
qed
}
with prem_cases show ?thesis by auto
qed
(*Sledgehammered*)
lemma splitl_expand:
assumes "splitl ((x + v)#xs) (sum_list ((x + v)#xs)) 0 ∨ x = sum_list (v#xs)"
shows "splitl (x#v#xs) (sum_list (x#v#xs)) 0"
by (smt assms list.inject splitl.elims(2) splitl.simps(3) sum_list.Cons)
lemma splitl_to_sum: "splitl xs (sum_list xs) 0 ⟹ ex_balanced_sum xs"
proof(induction xs rule: length_induct)
case (1 xs) show ?case
proof-
obtain x v xst where x_xst: "xs = x#v#xst"
by (meson "1.prems" splitl.elims(2))
have main_cases:
"splitl ((x + v)#xst) (sum_list ((x + v)#xst)) 0 ∨ x = sum_list (v#xst)"
by (rule splitl_reduce, insert x_xst "1.prems", rule subst)
{
assume "splitl ((x + v)#xst) (sum_list ((x + v)#xst)) 0"
with "1.IH" x_xst have "ex_balanced_sum ((x + v)#xst)" by simp
then obtain yst zst where
yst_zst: "(x + v)#xst = yst#zst"
and sum_yst_eq_sum_zst: "sum_list yst = sum_list zst"
and yst_ne: "yst ≠ []"
and zst_ne: "zst ≠ []"
unfolding ex_balanced_sum_def by auto
then obtain ystt where ystt: "yst = (x + v)#ystt"
by (metis append_eq_Cons_conv)
with sum_yst_eq_sum_zst have "sum_list (x#v#ystt) = sum_list zst" by simp
moreover have "xs = (x#v#ystt)#zst" using x_xst yst_zst ystt by auto
moreover have "(x#v#ystt) ≠ []" by simp
moreover with zst_ne have "zst ≠ []" by simp
ultimately have "ex_balanced_sum xs" unfolding ex_balanced_sum_def by blast
}
note prem = this
{
assume "x = sum_list (v#xst)"
then have "sum_list [x] = sum_list (v#xst)" by auto
moreover with x_xst have "xs = [x] # (v#xst)" by auto
ultimately have "ex_balanced_sum xs" using ex_balanced_sum_def by blast
}
with prem main_cases show ?thesis by blast
qed
qed
lemma sum_to_splitl: "ex_balanced_sum xs ⟹ splitl xs (sum_list xs) 0"
proof(induction xs rule: length_induct)
case (1 xs) show ?case
proof -
from "1.prems" ex_balanced_sum_def obtain ys zs where
ys_zs: "xs = ys#zs"
and sum_ys_eq_sum_zs: "sum_list ys = sum_list zs"
and ys_ne: "ys ≠ []"
and zs_ne: "zs ≠ []"
by blast
have prem_cases: "∃y v yst. ys = (y#v#yst) ∨ (∃y. ys = [y])"
by (metis remdups_adj.cases ys_ne)
{
assume "∃y. ys = [y]"
then have "splitl xs (sum_list xs) 0"
using splitl.elims(3) sum_ys_eq_sum_zs ys_zs zs_ne by fastforce
}
note prem = this
{
assume "∃y v yst. ys = (y#v#yst)"
then obtain y v yst where y_v_yst: "ys = (y#v#yst)" by auto
then have
"sum_list ((y + v)#yst) = sum_list zs ∧ ((y + v)#yst) ≠ [] ∧ zs ≠ []"
using sum_ys_eq_sum_zs zs_ne by auto
then have ebs_ypv: "ex_balanced_sum (((y + v)#yst)#zs)"
using ex_balanced_sum_def by blast
have l_ypv: "length (((y + v)#yst)#zs) < length xs"
by (simp add: y_v_yst ys_zs)
from l_ypv ebs_ypv have
"splitl (((y + v)#yst)#zs) (sum_list (((y + v)#yst)#zs)) 0"
by (rule "1.IH"[THEN spec, rule_format])
with splitl_expand have splitl_ys_exp:
"splitl ((y#v#yst)#zs) (sum_list ((y#v#yst)#zs)) 0"
by (metis Cons_eq_appendI)
from ys_zs have "splitl xs (sum_list xs) 0"
by (rule ssubst, insert y_v_yst splitl_ys_exp, simp)
}
with prem prem_cases show ?thesis by auto
qed
qed
lemma linear_correct: "ex_balanced_sum xs ⟷ splitl xs (sum_list xs) 0"
using splitl_to_sum sum_to_splitl by auto
end

What kind of functions preserve properties of closure?

I'm trying to prove the following lemmas:
lemma tranclp_fun_preserve:
"(⋀x y. x ≠ y ⟹ f x ≠ f y) ⟹
(⋀x y. f x ≠ f y ⟹ x ≠ y) ⟹
(⋀x y. f x = f y ⟹ x = y) ⟹
(λ x y. P x y)⇧+⇧+ (f x) (f y) ⟹ (λ x y. P (f x) (f y))⇧+⇧+ x y"
apply (erule tranclp.cases)
apply blast
lemma tranclp_fun_preserve2:
"(⋀x y. x ≠ y ⟹ f x ≠ f y) ⟹
(⋀x y. f x ≠ f y ⟹ x ≠ y) ⟹
(⋀x y. f x = f y ⟹ x = y) ⟹
(λ x y. P (f x) (f y))⇧+⇧+ x y ⟹ (λ x y. P x y)⇧+⇧+ (f x) (f y)"
apply (erule tranclp.cases)
apply blast
However, I'm stuck. Should I choose another set of assumptions for the function f? Could you suggest how to prove the lemmas tranclp_fun_preserve and tranclp_fun_preserve2?
UPDATE
My function is injective with a special property described at the end. I'm afraid that the following example is too long. However, I want to make it a little bit more realistic. Here are two auxiliary types errorable and nullable:
(*** errorable ***)
notation
bot ("⊥")
typedef 'a errorable ("_⇩⊥" [21] 21) = "UNIV :: 'a option set" ..
definition errorable :: "'a ⇒ 'a errorable" ("_⇩⊥" [1000] 1000) where
"errorable x = Abs_errorable (Some x)"
instantiation errorable :: (type) bot
begin
definition "⊥ ≡ Abs_errorable None"
instance ..
end
free_constructors case_errorable for
errorable
| "⊥ :: 'a errorable"
apply (metis Rep_errorable_inverse bot_errorable_def errorable_def not_Some_eq)
apply (metis Abs_errorable_inverse UNIV_I errorable_def option.inject)
by (simp add: Abs_errorable_inject bot_errorable_def errorable_def)
(*** nullable ***)
class opt =
fixes null :: "'a" ("ε")
typedef 'a nullable ("_⇩□" [21] 21) = "UNIV :: 'a option set" ..
definition nullable :: "'a ⇒ 'a nullable" ("_⇩□" [1000] 1000) where
"nullable x = Abs_nullable (Some x)"
instantiation nullable :: (type) opt
begin
definition "ε ≡ Abs_nullable None"
instance ..
end
free_constructors case_nullable for
nullable
| "ε :: 'a nullable"
apply (metis Rep_nullable_inverse null_nullable_def nullable_def option.collapse)
apply (simp add: Abs_nullable_inject nullable_def)
by (metis Abs_nullable_inverse UNIV_I null_nullable_def nullable_def option.distinct(1))
Two kinds of values:
datatype any = BoolVal "bool⇩⊥" | NatVal "nat⇩⊥" | RealVal "real⇩⊥" | InvalidAny unit
datatype oany = OBoolVal "bool⇩⊥⇩□" | ONatVal "nat⇩⊥⇩□" | ORealVal "real⇩⊥⇩□" | OInvalidAny "unit⇩□"
Here is a concrete example of the function f (any_to_oany), it's injective:
inductive any_oany :: "any ⇒ oany ⇒ bool" where
"any_oany (BoolVal x) (OBoolVal x⇩□)"
| "any_oany (NatVal x) (ONatVal x⇩□)"
| "any_oany (RealVal x) (ORealVal x⇩□)"
| "any_oany (InvalidAny x) (OInvalidAny x⇩□)"
fun any_to_oany :: "any ⇒ oany" where
"any_to_oany (BoolVal x) = (OBoolVal x⇩□)"
| "any_to_oany (NatVal x) = (ONatVal x⇩□)"
| "any_to_oany (RealVal x) = (ORealVal x⇩□)"
| "any_to_oany (InvalidAny x) = (OInvalidAny x⇩□)"
lemma any_oany_eq_fun:
"any_oany x y ⟷ any_to_oany x = y"
by (cases x; cases y; auto simp: any_oany.simps)
Here is a concrete example of the relation P (cast_oany):
inductive cast_any :: "any ⇒ any ⇒ bool" where
"cast_any (BoolVal ⊥) (InvalidAny ())"
| "cast_any (NatVal ⊥) (RealVal ⊥)"
| "cast_any (NatVal x⇩⊥) (RealVal (real x)⇩⊥)"
| "cast_any (RealVal ⊥) (InvalidAny ())"
inductive cast_oany :: "oany ⇒ oany ⇒ bool" where
"cast_any x y ⟹ any_oany x ox ⟹ any_oany y oy ⟹
cast_oany ox oy"
| "cast_oany (OBoolVal ε) (OInvalidAny ε)"
| "cast_oany (ONatVal ε) (ORealVal ε)"
| "cast_oany (ORealVal ε) (OInvalidAny ε)"
I proved equivalence of cast_any and cast_oany on any:
lemma cast_any_implies_cast_oany:
"cast_any x y ⟹ cast_oany (any_to_oany x) (any_to_oany y)"
by (simp add: any_oany_eq_fun cast_oany.intros(1))
lemma cast_oany_implies_cast_any:
"cast_oany (any_to_oany x) (any_to_oany y) ⟹ cast_any x y"
by (cases x; cases y; simp add: any_oany.simps cast_oany.simps)
And my final goal is to prove similar lemmas for the transitive closures of these relations:
lemma trancl_cast_oany_implies_cast_any:
"cast_oany⇧+⇧+ (any_to_oany x) (any_to_oany y) ⟹ cast_any⇧+⇧+ x y"
lemma trancl_cast_any_implies_cast_oany:
"cast_any⇧+⇧+ x y ⟹ cast_oany⇧+⇧+ (any_to_oany x) (any_to_oany y)"
I proved the following intermediate lemmas:
lemma trancl_cast_oany_implies_cast_any':
"(λx y. cast_oany (any_to_oany x) (any_to_oany y))⇧+⇧+ x y ⟹
cast_any⇧+⇧+ x y"
apply (erule tranclp_trans_induct)
apply (simp add: cast_oany_implies_cast_any tranclp.r_into_trancl)
by auto
lemma trancl_cast_any_implies_cast_oany':
"cast_any⇧+⇧+ x y ⟹
(λx y. cast_oany (any_to_oany x) (any_to_oany y))⇧+⇧+ x y"
apply (erule tranclp_trans_induct)
apply (simp add: cast_any_implies_cast_oany tranclp.r_into_trancl)
by auto
At last, if I could prove the following lemmas from the original question, then I will able to prove my goal lemmas.
lemma tranclp_fun_preserve:
"cast_oany⇧+⇧+ (any_to_oany x) (any_to_oany y) ⟹
(λx y. cast_oany (any_to_oany x) (any_to_oany y))⇧+⇧+ x y"
lemma tranclp_fun_preserve2:
"(λx y. cast_oany (any_to_oany x) (any_to_oany y))⇧+⇧+ x y ⟹
cast_oany⇧+⇧+ (any_to_oany x) (any_to_oany y)"
In this paragraph I provide an important property of the function any_to_oany. The set of oany values consists of two parts:
nulls (OBoolVal ε, ONatVal ε, ORealVal ε, OInvalidAny ε)
all other values.
The relation cast_oany relates the values inside the first part and inside the second part separately. There is no relation between the values from different parts. The function any_to_oany maps values only to the second part. I don't know what is the right name of this property: subsets 1 and 2 are "closed" with respect to the relation cast_oany. And the function any_to_oany maps values only to one subset, and it's bijective on this subset.
The answer presented below is a substantial revision of the original answer. The original answer is available through the revision history.
Effectively, in the course of the initial revisions it was established that the question comes down to merely proving that bijective functions between two sets preserve the properties of closure. The solution below presents the relevant proofs without the application-specific context (the answer also combines some of the amendments to the original answer that were made by the author of the thread):
section ‹Extension of the theory #{text Transitive_Closure}›
theory Transitive_Closure_Ext
imports
Complex_Main
"HOL-Library.FuncSet"
begin
lemma trancl_subset_trancl: "r ⊆ s⇧+ ⟹ r⇧+ ⊆ s⇧+"
by (metis subsetI trancl_id trancl_mono trans_trancl)
lemma mono_tranclp[mono]: "(⋀a b. R a b ⟶ S a b) ⟹ R⇧+⇧+ a b ⟶ S⇧+⇧+ a b"
apply(rule) using trancl_mono[to_pred] by blast
lemma tranclp_mono: "R ≤ S ⟹ R⇧+⇧+ ≤ S⇧+⇧+"
by (metis (full_types) mono_tranclp predicate2D predicate2I)
lemma preserve_tranclp:
assumes "⋀x y. R x y ⟹ S (f x) (f y)"
shows "R⇧+⇧+ x y ⟹ S⇧+⇧+ (f x) (f y)"
proof -
assume Rpp: "R⇧+⇧+ x y"
define P where P: "P = (λx y. S⇧+⇧+ (f x) (f y))"
define r where r: "r = (λx y. S (f x) (f y))"
have major: "r⇧+⇧+ x y"
by (insert assms Rpp r; erule tranclp_trans_induct; auto)
have cases_1: "r x y ⟹ P x y" for x y unfolding r P by simp
have cases_2: "r⇧+⇧+ x y ⟹ P x y ⟹ r⇧+⇧+ y z ⟹ P y z ⟹ P x z" for x y z
unfolding P by simp
from major cases_1 cases_2 have "P x y" by (rule tranclp_trans_induct)
thus "S⇧+⇧+ (f x) (f y)" unfolding P .
qed
lemma preserve_trancl:
assumes "map_prod f f ` r ⊆ s"
shows "map_prod f f ` r⇧+ ⊆ s⇧+"
proof -
from assms have "(x, y) ∈ r ⟶ (f x, f y) ∈ s" for x y by auto
then have "(x, y) ∈ r⇧+ ⟶ (f x, f y) ∈ s⇧+" for x y
by (metis preserve_tranclp[to_set])
thus "map_prod f f ` r⇧+ ⊆ s⇧+" by clarsimp
qed
lemma preserve_tranclp_inv:
assumes bij_f: "bij_betw f a b"
and R: "⋀x y. R x y ⟹ (x, y) ∈ a × a"
and S: "⋀x y. S x y ⟹ (x, y) ∈ b × b"
and S_R: "⋀x y. (x, y) ∈ a × a ⟹ S (f x) (f y) ⟹ R x y"
shows "(x, y) ∈ a × a ⟹ S⇧+⇧+ (f x) (f y) ⟹ R⇧+⇧+ x y"
proof -
assume x_y_in_aa: "(x, y) ∈ a × a"
assume Spp: "S⇧+⇧+ (f x) (f y)"
define g where g: "g = the_inv_into a f"
define gr where gr: "gr = restrict g b"
define P where P: "P = (λx y. (x, y) ∈ b × b ⟶ R⇧+⇧+ (gr x) (gr y))"
from Spp have fx_fy_in_bb: "(f x, f y) ∈ b × b"
using S by (metis converse_tranclpE mem_Sigma_iff tranclp.cases)
have cases_1: "S x y ⟹ P x y" for x y unfolding P
proof(rule impI)
assume Sxy: "S x y" and xy_in_bb: "(x, y) ∈ b × b"
with bij_f have gr_in_aa: "(gr x, gr y) ∈ a × a"
unfolding gr g apply(auto)
using bij_betwE bij_betw_the_inv_into by blast+
from bij_f xy_in_bb have "x = f (gr x)" and "y = f (gr y)"
unfolding gr g using f_the_inv_into_f_bij_betw by fastforce+
with Sxy have S_fgrx_fgry: "S (f (gr x)) (f (gr y))" by simp
from gr_in_aa S_fgrx_fgry have "R (gr x) (gr y)" by (rule S_R)
thus "R⇧+⇧+ (gr x) (gr y)" ..
qed
with bij_f S have
"S⇧+⇧+ x y ⟹ S⇧+⇧+ y z ⟹ x ∈ b ⟹ z ∈ b ⟹ y ∈ b" for x y z
by (auto dest: SigmaD1 tranclpD)
with P have cases_2:
"S⇧+⇧+ x y ⟹ P x y ⟹ S⇧+⇧+ y z ⟹ P y z ⟹ P x z" for x y z
by auto
from Spp cases_1 cases_2 have "P (f x) (f y)" by (rule tranclp_trans_induct)
with bij_f fx_fy_in_bb x_y_in_aa show "R⇧+⇧+ x y"
unfolding P gr g restrict_def bij_betw_def by (simp add: the_inv_into_f_f)
qed
lemma preserve_trancl_inv:
assumes bij_f: "bij_betw f a b"
and r_in_aa: "r ⊆ a × a"
and s_in_bb: "s ⊆ b × b"
and s_r: "(map_prod f f -` s) ∩ (a × a) ⊆ r ∩ (a × a)"
shows "(map_prod f f -` s⇧+) ∩ (a × a) ⊆ r⇧+ ∩ (a × a)"
proof -
from r_in_aa have r_in_aa_set:
"(x, y) ∈ r ⟹ (x, y) ∈ a × a" for x y by auto
from s_in_bb have s_in_bb_set: "⋀x y. (x, y) ∈ s ⟹ (x, y) ∈ b × b" by auto
from s_r have s_r_set:
"(x, y) ∈ a × a ⟹ (f x, f y) ∈ s ⟹ (x, y) ∈ r" for x y
unfolding map_prod_def by auto
from bij_f r_in_aa_set s_in_bb_set s_r_set have
"(x, y) ∈ a × a ⟹ (f x, f y) ∈ s⇧+ ⟹ (x, y) ∈ r⇧+" for x y
by (rule preserve_tranclp_inv[to_set])
thus ?thesis unfolding map_prod_def by clarsimp
qed
lemma preserve_rtranclp:
assumes "⋀x y. R x y ⟹ S (f x) (f y)"
shows "R⇧*⇧* x y ⟹ S⇧*⇧* (f x) (f y)"
by (insert assms, metis Nitpick.rtranclp_unfold preserve_tranclp)
lemma preserve_rtrancl:
assumes "map_prod f f ` r ⊆ s"
shows "map_prod f f ` r⇧* ⊆ s⇧*"
proof -
from assms have "(x, y) ∈ r ⟶ (f x, f y) ∈ s" for x y by auto
then have "(x, y) ∈ r⇧* ⟶ (f x, f y) ∈ s⇧*" for x y
by (metis preserve_rtranclp[to_set])
thus "map_prod f f ` r⇧* ⊆ s⇧*" by clarsimp
qed
lemma preserve_rtranclp_inv:
assumes bij_f: "bij_betw f a b"
and "⋀x y. R x y ⟹ (x, y) ∈ a × a"
and "⋀x y. S x y ⟹ (x, y) ∈ b × b"
and "⋀x y. (x, y) ∈ a × a ⟹ S (f x) (f y) ⟹ R x y"
shows "(x, y) ∈ a × a ⟹ S⇧*⇧* (f x) (f y) ⟹ R⇧*⇧* x y"
proof -
assume xy_in_aa: "(x, y) ∈ a × a" and Spp: "S⇧*⇧* (f x) (f y)"
show "R⇧*⇧* x y"
proof(cases "f x ≠ f y")
case True show ?thesis
proof -
from True Spp obtain z where "S⇧*⇧* (f x) z" and "S z (f y)"
by (auto elim: rtranclp.cases)
then have "S⇧+⇧+ (f x) (f y)" by (rule rtranclp_into_tranclp1)
with assms xy_in_aa have "R⇧+⇧+ x y" by (rule preserve_tranclp_inv)
thus ?thesis by simp
qed
next
case False show ?thesis
proof -
from False xy_in_aa bij_f have "x = y"
unfolding bij_betw_def by (auto dest: SigmaD1 SigmaD2 inj_onD)
thus "R⇧*⇧* x y" by simp
qed
qed
qed
lemma preserve_rtrancl_inv:
assumes bij_f: "bij_betw f a b"
and r_in_aa: "r ⊆ a × a"
and s_in_bb: "s ⊆ b × b"
and as_s_r: "(map_prod f f -` s) ∩ (a × a) ⊆ r ∩ (a × a)"
shows "(map_prod f f -` s⇧*) ∩ (a × a) ⊆ r⇧* ∩ (a × a)"
proof -
from r_in_aa have r_in_aa_set:
"(x, y) ∈ r ⟹ (x, y) ∈ a × a" for x y by auto
from s_in_bb have s_in_bb_set:
"(x, y) ∈ s ⟹ (x, y) ∈ b × b" for x y by auto
from as_s_r have s_r:
"(x, y) ∈ a × a ⟹ (f x, f y) ∈ s ⟹ (x, y) ∈ r" for x y
unfolding map_prod_def by auto
from bij_f r_in_aa_set s_in_bb_set s_r have
"(x, y) ∈ a × a ⟹ (f x, f y) ∈ s⇧* ⟹ (x, y) ∈ r⇧*" for x y
by (rule preserve_rtranclp_inv[to_set])
thus ?thesis unfolding map_prod_def by clarsimp
qed
end

How to lift a transitive relation from elements to lists?

I'm trying to prove that a transitive relation on elements of lists is equivalent to a transitive relation on lists (under some conditions).
Here is a first lemma:
lemma list_all2_rtrancl1:
"(list_all2 P)⇧*⇧* xs ys ⟹
list_all2 P⇧*⇧* xs ys"
apply (induct rule: rtranclp_induct)
apply (simp add: list.rel_refl)
by (smt list_all2_trans rtranclp.rtrancl_into_rtrancl)
And here is a symmetric lemma:
lemma list_all2_rtrancl2:
"(⋀x. P x x) ⟹
list_all2 P⇧*⇧* xs ys ⟹
(list_all2 P)⇧*⇧* xs ys"
apply (erule list_all2_induct)
apply simp
I guess that a relation should be reflexive. But maybe I should use another assumptions. The lemma could be proven given the assumption that P is transitive, however P is not transitive. I'm stuck. Could you suggest what assumptions to choose and how to prove this lemma?
It seems that nitpick gives me a wrong counterexample for the specific case of the last lemma (xs = [0] and ys = [2]):
lemma list_all2_rtrancl2_example:
"list_all2 (λx y. x = y ∨ Suc x = y)⇧*⇧* xs ys ⟹
(list_all2 (λx y. x = y ∨ Suc x = y))⇧*⇧* xs ys"
nitpick
I can prove that the lemma holds for this example:
lemma list_all2_rtrancl2_example_0_2:
"list_all2 (λx y. x = y ∨ Suc x = y)⇧*⇧* [0] [2] ⟹
(list_all2 (λx y. x = y ∨ Suc x = y))⇧*⇧* [0] [2]"
apply (rule_tac ?b="[1]" in converse_rtranclp_into_rtranclp; simp)
apply (rule_tac ?b="[2]" in converse_rtranclp_into_rtranclp; simp)
done
It may be feasible to use listrel instead of list_all2. Indeed, as shown below, they are equivalent (see set_listrel_eq_list_all2). However, there are several theorems in the standard library about listrel that do not have their equivalents for list_all2.
lemma set_listrel_eq_list_all2:
"listrel {(x, y). r x y} = {(xs, ys). list_all2 r xs ys}"
using list_all2_conv_all_nth listrel_iff_nth by fastforce
lemma listrel_tclosure_1: "(listrel r)⇧* ⊆ listrel (r⇧*)"
by
(
simp add:
listrel_rtrancl_eq_rtrancl_listrel1
listrel_subset_rtrancl_listrel1
rtrancl_subset_rtrancl
)
lemma listrel_tclosure_2: "refl r ⟹ listrel (r⇧*) ⊆ (listrel r)⇧*"
by
(
simp add:
listrel1_subset_listrel
listrel_rtrancl_eq_rtrancl_listrel1
rtrancl_mono
)
context
includes lifting_syntax
begin
lemma listrel_list_all2_transfer[transfer_rule]:
"((=) ===> (=) ===> (=) ===> (=))
(λr xs ys. (xs, ys) ∈ listrel {(x, y). r x y}) list_all2"
unfolding rel_fun_def using set_listrel_eq_list_all2 listrel_iff_nth by blast
end
lemma list_all2_rtrancl_1:
"(list_all2 r)⇧*⇧* xs ys ⟹ list_all2 r⇧*⇧* xs ys"
proof transfer
fix r :: "'a ⇒ 'a ⇒ bool" and xs :: "'a list" and ys:: "'a list"
assume "(λxs ys. (xs, ys) ∈ listrel {(x, y). r x y})⇧*⇧* xs ys"
then have "(xs, ys) ∈ (listrel {(x, y). r x y})⇧*"
unfolding rtranclp_def rtrancl_def by auto
then have "(xs, ys) ∈ listrel ({(x, y). r x y}⇧*)"
using listrel_tclosure_1 by auto
then show "(xs, ys) ∈ listrel {(x, y). r⇧*⇧* x y}"
unfolding rtranclp_def rtrancl_def by auto
qed
lemma list_all2_rtrancl_2:
"reflp r ⟹ list_all2 r⇧*⇧* xs ys ⟹ (list_all2 r)⇧*⇧* xs ys"
proof transfer
fix r :: "'a ⇒ 'a ⇒ bool" and xs :: "'a list" and ys :: "'a list"
assume as_reflp: "reflp r" and p_in_lr: "(xs, ys) ∈ listrel {(x, y). r⇧*⇧* x y}"
from as_reflp have refl: "refl {(x, y). r x y}"
using reflp_refl_eq by fastforce
from p_in_lr have "(xs, ys) ∈ listrel ({(x, y). r x y}⇧*)"
unfolding rtranclp_def rtrancl_def by auto
with refl have "(xs, ys) ∈ (listrel {(x, y). r x y})⇧*"
using listrel_tclosure_2 by auto
then show "(λxs ys. (xs, ys) ∈ listrel {(x, y). r x y})⇧*⇧* xs ys"
unfolding rtranclp_def rtrancl_def by auto
qed
A direct proof for list_all2 is also provided (legacy):
list_all2_induct is applied to the lists; the base case is trivial. Thence, it remains to show that (L P)* x#xs y#ys if (L (P*)) xs ys, (L P)* xs ys and P* x y.
The idea is that it is possible to find zs (e.g. xs) such that (L P) xs zs and (L P)+ zs ys.
Then, given that P* x y and P x x, by induction based on the transitive properties of P*, (L P) x#xs y#zs. Therefore, also, (L P)* x#xs y#zs.
Also, given that (L P)+ zs ys and P y y, by induction, (L P)+ y#zs y#ys. Thus, also, (L P)* y#zs y#ys.
From 3 and 4 conclude (L P)* x#xs y#ys.
lemma list_all2_rtrancl2:
assumes as_r: "(⋀x. P x x)"
shows "(list_all2 P⇧*⇧*) xs ys ⟹ (list_all2 P)⇧*⇧* xs ys"
proof(induction rule: list_all2_induct)
case Nil then show ?case by simp
next
case (Cons x xs y ys) show ?case
proof -
from as_r have lp_xs_xs: "list_all2 P xs xs" by (rule list_all2_refl)
from Cons.hyps(1) have x_xs_y_zs: "(list_all2 P)⇧*⇧* (x#xs) (y#xs)"
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: "(list_all2 P)⇧*⇧* (y#xs) (z#xs)"
by (rule r_into_rtranclp, rule list_all2_Cons[THEN iffD2])
(simp add: step.hyps(2) lp_xs_xs)
from step.IH rt_step_2 show ?thesis by (rule rtranclp_trans)
qed
qed
from Cons.IH have "(list_all2 P)⇧*⇧* (y#xs) (y#ys)"
proof(induction rule: rtranclp_induct)
case base then show ?case by simp
next
case (step ya za) show ?case
proof -
have rt_step_2: "(list_all2 P)⇧*⇧* (y#ya) (y#za)"
by (rule r_into_rtranclp, rule list_all2_Cons[THEN iffD2])
(simp add: step.hyps(2) as_r)
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
As a side note, in my view (I know very little about nitpick), nitpick should not provide invalid counterexamples without any warning. I believe, usually, when nitpick 'suspects' that a counterexample may be invalid it notifies the user that the example is 'potentially spurious'. It may be useful to submit a bug report if this issue has not been recorded elsewhere.
Isabelle version: Isabelle2020

How to use different code lemmas for different modes of inductive predicate?

(The question is related to How to define an inductive predicate on fset? but a more concrete)
Here is a simple theory with 2 kinds of values and a casting predicate:
theory FSetIndTest
imports Main "~~/src/HOL/Library/FSet"
begin
datatype val1 = A | B
datatype val2 = C | D
inductive cast_val :: "val1 ⇒ val2 ⇒ bool" where
"cast_val A C"
| "cast_val B D"
code_pred [show_modes] cast_val .
fun cast_val_fun :: "val1 ⇒ val2" where
"cast_val_fun A = C"
| "cast_val_fun B = D"
fun cast_val_fun_inv :: "val2 ⇒ val1" where
"cast_val_fun_inv C = A"
| "cast_val_fun_inv D = B"
I'm trying to define a cast predicate for fsets. It works fine in i ⇒ o ⇒ bool mode, but doesn't support o ⇒ i ⇒ bool mode:
inductive cast_fset1 :: "val1 fset ⇒ val2 fset ⇒ bool" where
"cast_fset1 {||} {||}"
| "cast_val x y ⟹ cast_fset1 xs ys ⟹
cast_fset1 (finsert x xs) (finsert y ys)"
lemma cast_fset1_left [code_pred_intro]:
"fimage cast_val_fun xs = ys ⟹ cast_fset1 xs ys"
apply (induct xs arbitrary: ys)
apply (simp add: cast_fset1.intros(1))
by (metis (full_types) cast_fset1.intros(2) cast_val.intros(1) cast_val.intros(2) cast_val_fun.simps(1) cast_val_fun.simps(2) fimage_finsert val1.exhaust)
lemma cast_fset1_left_inv:
"cast_fset1 xs ys ⟹
fimage cast_val_fun xs = ys"
apply (induct rule: cast_fset1.induct)
apply simp
using cast_val.simps by auto
code_pred [show_modes] cast_fset1
by (simp add: cast_fset1_left_inv)
values "{x. cast_fset1 {|A, B|} x}"
So I try to define a code lemma for both arguments. And as result only i ⇒ i ⇒ bool mode is supported:
inductive cast_fset2 :: "val1 fset ⇒ val2 fset ⇒ bool" where
"cast_fset2 {||} {||}"
| "cast_val x y ⟹ cast_fset2 xs ys ⟹
cast_fset2 (finsert x xs) (finsert y ys)"
lemma cast_fset2_code [code_pred_intro]:
"fimage cast_val_fun xs = ys ⟹ cast_fset2 xs ys"
"fimage cast_val_fun_inv ys = xs ⟹ cast_fset2 xs ys"
apply (auto)
apply (induct xs arbitrary: ys)
apply (simp add: cast_fset2.intros(1))
apply (metis (full_types) cast_fset2.intros(2) cast_val.intros(1) cast_val.intros(2) cast_val_fun.simps(1) cast_val_fun.simps(2) fimage_finsert val1.exhaust)
apply (induct ys arbitrary: xs)
apply (simp add: cast_fset2.intros(1))
by (smt cast_fset2.intros(2) cast_val.intros(1) cast_val.intros(2) cast_val_fun_inv.elims cast_val_fun_inv.simps(1) fimage_finsert)
lemma cast_fset2_code_inv:
"cast_fset2 xs ys ⟹ fimage cast_val_fun xs = ys"
"cast_fset2 xs ys ⟹ fimage cast_val_fun_inv ys = xs"
apply (induct rule: cast_fset2.induct)
apply simp
apply simp
using cast_val.simps cast_val_fun.simps(1) apply auto[1]
using cast_val.simps by auto
code_pred [show_modes] cast_fset2
by (simp add: cast_fset2_code_inv(1))
I'm trying to use [code] annotation instead of [code_pred_intro]:
inductive cast_fset3 :: "val1 fset ⇒ val2 fset ⇒ bool" where
"cast_fset3 {||} {||}"
| "cast_val x y ⟹ cast_fset3 xs ys ⟹
cast_fset3 (finsert x xs) (finsert y ys)"
lemma cast_fset3_left:
"fimage cast_val_fun xs = ys ⟹ cast_fset3 xs ys"
apply (induct xs arbitrary: ys)
apply (simp add: cast_fset3.intros(1))
by (metis (full_types) cast_fset3.intros(2) cast_val.intros(1) cast_val.intros(2) cast_val_fun.simps(1) cast_val_fun.simps(2) fimage_finsert val1.exhaust)
lemma cast_fset3_left_inv:
"cast_fset3 xs ys ⟹
fimage cast_val_fun xs = ys"
apply (induct rule: cast_fset3.induct)
apply simp
using cast_val.simps by auto
lemma cast_fset3_left_code [code]:
"fimage cast_val_fun xs = ys ⟷
cast_fset3 xs ys"
using cast_fset3_left cast_fset3_left_inv by blast
But I get the following warning and the lemma is ignored at all:
Partially applied constant "FSetIndTest.cast_val_fun" on left hand side of equation, in theorem:
cast_val_fun |`| ?xs = ?ys ≡ cast_fset3 ?xs ?ys
Is it possible to use different code lemmas for different modes (i ⇒ o ⇒ bool, o ⇒ i ⇒ bool) of an inductive predicate? How to fix last lemma? Why I get this warning?
Code generation for an inductive predicate always operates on the same set of introduction rules; however you are always free to introduce a copy of an existing inductive predicate and equip that with a different set of introduction rules.
The attribute [code] is just for equations, not for introduction rules.

Basic Isabelle/Isar style (exercise 4.6)

I'm interested in using Isabelle/Isar for writing proofs which are both human-readable and machine checked, and I am looking to improve my style and streamline my proofs.
prog-prove has the following exercise:
Exercise 4.6. Define a recursive function elems :: 'a list ⇒ 'a set and prove x ∈ elems xs ⟹ ∃ ys zs. xs = ys # x # zs ∧ x ∉ elems ys.
Mimicking something similar to what I would write with pen and paper, my solution is
fun elems :: "'a list ⇒ 'a set" where
"elems [] = {}" |
"elems (x # xs) = {x} ∪ elems xs"
fun takeUntil :: "('a ⇒ bool) ⇒ 'a list ⇒ 'a list" where
"takeUntil f [] = []" |
"takeUntil f (x # xs) = (case (f x) of False ⇒ x # takeUntil f xs | True ⇒ [])"
theorem "x ∈ elems xs ⟹ ∃ ys zs. xs = ys # x # zs ∧ x ∉ elems ys"
proof -
assume 1: "x ∈ elems xs"
let ?ys = "takeUntil (λ z. z = x) xs"
let ?zs = "drop (length ?ys + 1) xs"
have "xs = ?ys # x # ?zs ∧ x ∉ elems ?ys"
proof
have 2: "x ∉ elems ?ys"
proof (induction xs)
case Nil
thus ?case by simp
next
case (Cons a xs)
thus ?case
proof -
{
assume "a = x"
hence "takeUntil (λz. z = x) (a # xs) = []" by simp
hence A: ?thesis by simp
}
note eq = this
{
assume "a ≠ x"
hence "takeUntil (λz. z = x) (a # xs) = a # takeUntil (λz. z = x) xs" by simp
hence ?thesis using Cons.IH by auto
}
note noteq = this
have "a = x ∨ a ≠ x" by simp
thus ?thesis using eq noteq by blast
qed
qed
from 1 have "xs = ?ys # x # ?zs"
proof (induction xs)
case Nil
hence False by simp
thus ?case by simp
next
case (Cons a xs)
{
assume 1: "a = x"
hence 2: "takeUntil (λz. z = x) (a # xs) = []" by simp
hence "length (takeUntil (λz. z = x) (a # xs)) + 1 = 1" by simp
hence 3: "drop (length (takeUntil (λz. z = x) (a # xs)) + 1) (a # xs) = xs" by simp
from 1 2 3 have ?case by simp
}
note eq = this
{
assume 1: "a ≠ x"
with Cons.prems have "x ∈ elems xs" by simp
with Cons.IH
have IH: "xs = takeUntil (λz. z = x) xs # x # drop (length (takeUntil (λz. z = x) xs) + 1) xs" by simp
from 1 have 2: "takeUntil (λz. z = x) (a # xs) = a # takeUntil (λz. z = x) (xs)" by simp
from 1 have "drop (length (takeUntil (λz. z = x) (a # xs)) + 1) (a # xs) = drop (length (takeUntil (λz. z = x) xs) + 1) xs" by simp
hence ?case using IH 2 by simp
}
note noteq = this
have "a = x ∨ a ≠ x" by simp
thus ?case using eq noteq by blast
qed
with 2 have 3: ?thesis by blast
thus "xs = takeUntil (λz. z = x) xs # x # drop (length (takeUntil (λz. z = x) xs) + 1) xs" by simp
from 3 show "x ∉ elems (takeUntil (λz. z = x) xs)" by simp
qed
thus ?thesis by blast
qed
but it seems rather long. In particular, I think invoking law of excluded middle here is cumbersome, and I feel like there ought to be some convenient schematic variable like ?goal which can refer to the current goal or something.
How can I make this proof shorter without sacrificing clarity?
Not really an answer to your specific question, but I would nonetheless like to point out, that a more concise prove can still be comprehensible.
lemma "x ∈ elems xs ⟹ ∃ ys zs. xs = ys # x # zs ∧ x ∉ elems ys"
proof (induction)
case (Cons l ls)
thus ?case
proof (cases "x ≠ l")
case True
hence "∃ys zs. ls = ys # x # zs ∧ x ∉ elems ys" using Cons by simp
thus ?thesis using ‹x ≠ l› Cons_eq_appendI by fastforce
qed (fastforce)
qed (simp)
Here's another shorter proof than your own:
fun elems :: ‹'a list ⇒ 'a set› where
‹elems [] = {}› |
‹elems (x#xs) = {x} ∪ elems xs›
lemma elems_prefix_suffix:
assumes ‹x ∈ elems xs›
shows ‹∃pre suf. xs = pre # [x] # suf ∧ x ∉ elems pre›
using assms proof(induction xs)
fix y ys
assume *: ‹x ∈ elems (y#ys)›
and IH: ‹x ∈ elems ys ⟹ ∃pre suf. ys = pre # [x] # suf ∧ x ∉ elems pre›
{
assume ‹x = y›
from this have ‹∃pre suf. y#ys = pre # [x] # suf ∧ x ∉ elems pre›
using * by fastforce
}
note L = this
{
assume ‹x ≠ y› and ‹x ∈ elems ys›
moreover from this obtain pre and suf where ‹ys = pre # [x] # suf› and ‹x ∉ elems pre›
using IH by auto
moreover have ‹y#ys = y#pre # [x] # suf› and ‹x ∉ elems (y#pre)›
by(simp add: calculation)+
ultimately have ‹∃pre suf. y#ys = pre # [x] # suf ∧ x ∉ elems pre›
by(metis append_Cons)
}
from this and L show ‹∃pre suf. y#ys = pre # [x] # suf ∧ x ∉ elems pre›
using * by auto
qed auto ― ‹Base case trivial›
I've used a few features of Isar to compress the proof:
Blocks within the braces {...} allow you to perform hypothetical reasoning.
Facts can be explicitly named using note.
The moreover keyword starts a calculation that implicitly "carries along" facts as they are established. The calculation "comes to a head" with the ultimately keyword. This style can significantly reduce the number of explicitly named facts that you need to introduce over the course of a proof.
The qed auto completes the proof by applying auto to all remaining subgoals. A comment notes that the subgoal remaining is the base case of the induction, which is trivial.

Resources