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.
Related
I have the following code:
assume H: "x ≠ xa ∧ x ∈ elems xs" (is "?H1 ∧ ?H2")
hence "?H1" and "?H2" by auto
from Cons.IH[OF `?H2` ] have 1: "∃ys zs. xs = ys # x # zs ∧ x ∉ elems ys" by simp
then obtain ys zs where 2: "xs = ys # x # zs ∧ x ∉ elems ys" (is "?C1 ∧ ?C2") by blast
hence "?C1" and "?C2" by auto
from `?C1` have R1: "xa # xs = (xa # ys) # x # zs" by simp
from `x ≠ xa` and `x ∉ elems ys` have R2: "x ∉ elems (xa#ys)" by auto
from R1 R2 show ?case by blast
Without the lines : hence "?H1" and "?H2" by auto and hence "?C1" and "?C2" by auto I cannot refer to the literal facts `?C1` and `?H2`. (I also cannot refer to the terms the "unkowns/abbreviations/metavariables/" ?<name> expand to; I get the same error. The metavariables are actually expanded to the literal facts they refer to in the error message (e.g. for `?H2` I get
Failed to retrieve literal fact⌂:
x ∈ elems xs
, so they must be in scope somehow??)
My question is:
Why does this not work?
is there a better workaround than my hence … by auto?
Expanding on Javier's comment, the (is "?H1 ∧ ?H2") creates two macro variables. Those are in scope, such as is ?case for instance. ?H1 and ?H2 refer to the terms x ≠ xa and x ∈ elems xs, but this does not mean that they are proven facts. What changes, are the term bindings, as you can inspect by:
assume H: "x ≠ xa ∧ x ∈ elems xs" (is "?H1 ∧ ?H2")
print_term_bindings
>>>>
?H1 ≡ ¬ x = xa
?H2 ≡ x ∈ elems xs
...
print_facts
>>>>
H: x ≠ xa ∧ x ∈ elems xs
...
Your snippet is just a sugared way of writing:
assume H: "x ≠ xa ∧ x ∈ elems xs"
hence "x ≠ xa" and "x ∈ elems xs" by auto
from Cons.IH[OF `x ∈ elems xs`] have 1: "∃ys zs. xs = ys # x # zs ∧ x ∉ elems ys" by simp
then obtain ys zs where 2: "xs = ys # x # zs ∧ x ∉ elems ys" by blast
hence "xs = ys # x # zs" and "x ∉ elems ys" by auto
from `xs = ys # x # zs` have R1: "xa # xs = (xa # ys) # x # zs" by simp
from `x ≠ xa` and `x ∉ elems ys` have R2: "x ∉ elems (xa#ys)" by auto
from R1 R2 show [whatever ?case expands to] by blast
Clearly, this proof does not work if you drop the line hence "x ≠ xa" and "x ∈ elems xs" by auto, which proves the literal fact x ∈ elems xs. Without it, Isabelle cannot accept Cons.IH[OF `x ∈ elems xs`], which causes the error you cite.
Regarding the question of how to write an equivalent proof without the need for hence … by auto: You can't, really. There needs to be some proof that the conjuncts are facts.
The most lightweight way to refer to sub-conjuncts of facts as facts is with conjunct1/2[OF ...]: Just write from Cons.IH[OF conjunct2[OF H]] have... instead of from Cons.IH[OF `?H2`] have....
However, what you are emulating here through term bindings is actually the “array” feature of Isabelle's facts.
If one writes a fact as a chain of sub-facts H: ‹x ≠ xa› ‹x ∈ elems xs› instead of H: ‹x ≠ xa ∧ x ∈ elems xs›, one can afterwards refer to the first part as H(1) and to the second one as H(2). In your example, one would have to slightly adapt the surrounding proof (using safe or clarify) in order for the changed assumption to be okay. It would then read something like:
proof (..., safe)
assume H: "x ≠ xa" "x ∈ elems xs"
from Cons.IH[OF H(2)] have 1: "∃ys zs. xs = ys # x # zs ∧ x ∉ elems ys" by simp
then obtain ys zs where C: "xs = ys # x # zs" "x ∉ elems ys" by blast
from C(1) have R1: "xa # xs = (xa # ys) # x # zs" by simp
from `x ≠ xa` and `x ∉ elems ys` have R2: "x ∉ elems (xa#ys)" by auto
from R1 R2 show ?case by blast
next ...
No macros for literal-fact names or unpacking needed!
My general experience is that there are very limited reasons to use the macros for naming literal facts when you can use the conventional naming of facts. Even more generally, most of the time when one can express a conjunction or an implication at the meta level, opting for meta will make life easier: assumes P: "a" "b" shows "c" is more handy than shows "a /\ b ==> c".
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 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
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
I am trying to solve Exercise 4.6 in “Programming and Proving in Isabelle/HOL”. It asks to define a function elems :: "'a list ⇒ 'a set" that converts a list into a set, and to prove the lemma "x ∈ elems xs ⟹ ∃ ys zs . xs = ys # x # zs ∧ x ∉ elems ys". Until now, I have come that far:
fun elems :: "'a list ⇒ 'a set" where
"elems [] = {}" |
"elems (x # xs) = {x} ∪ elems xs"
lemma first_occ: "x ∈ elems xs ⟹ ∃ ys zs . xs = ys # x # zs ∧ x ∉ elems ys"
proof (induction xs)
case Nil
thus ?case by simp
next
case (Cons u us)
show ?case
proof cases
assume "x = u"
thus ?case
proof
⟨…⟩
At this point, I get the error message “Failed to apply initial proof method”. This is strange, since the goal, ?case, is the proposition ∃ ys zs . u # us = ys # x # zs ∧ x ∉ elems ys, and it should be possible to prove existential propositions by showing the proposition under the ∃ for a specific witness.
the problem with your line proof is that it proof is meant to apply some default rule. In the above proof, Isabelle is not able to figure out that you want to perform existential introduction. So, you probably want to explicitly tell the system to do so, e.g., by continue with something like proof (intro exI).
I hope, this helps,
René