datatype 'a list = Cons 'a "'a list" | Nil
instantiation list :: (order) order
begin
fun less_eq_list :: "'a list ⇒ 'a list ⇒ bool" where
"less_eq_list Nil Nil = True" |
"less_eq_list (Cons _ _) Nil = True" |
"less_eq_list Nil (Cons _ _) = False" |
"less_eq_list (Cons _ a) (Cons _ b) = less_eq_list a b"
instance
proof
fix x y:: "'a list"
show "x ≤ x"
apply(induct_tac x)
apply(auto)
done
(* at this point the state is
show x ≤ x
Successful attempt to solve goal by exported rule:
?x2 ≤ ?x2
proof (state)
this:
x ≤ x
goal (3 subgoals):
1. ⋀x y. (x < y) = (x ≤ y ∧ ¬ y ≤ x)
2. ⋀x y z. x ≤ y ⟹ y ≤ z ⟹ x ≤ z
3. ⋀x y. x ≤ y ⟹ y ≤ x ⟹ x = y
*)
show "(x < y) = (x ≤ y ∧ ¬ y ≤ x)"
(* I get an error here
Failed to refine any pending goal
Local statement fails to refine any pending goal
Failed attempt to solve goal by exported rule:
(?x2 < ?y2) = (?x2 ≤ ?y2 ∧ ¬ ?y2 ≤ ?x2)
*)
qed
end
What is wrong with this? The proof of "x ≤ x" worked like a charm. Somehow "(x < y) = (x ≤ y ∧ ¬ y ≤ x)" doesn't match any subgoal.
Class order is a subclass of preorder, which in turn is a subclass of ord. Class ord requires you to define both less_eq (≤) and less (<). In your code, you have correctly defined less_eq_list but forgot to define less_list, and that's why you got an error when trying to prove (x < y) = (x ≤ y ∧ ¬ y ≤ x).
proof universal quantifiers from narrow to large range. There are two theorems. `
lemma "(∀l k. l< i ∧ k<j⟶ (f l k))
⟹ (∀l. l< i⟶ (f l j))
⟹ (∀l k. l<i ∧ k≤j⟶ (f l k))"
oops
``
lemma "(∀l k. l< i ∧ k<j⟶ (f l k)) ⟹
(∀l. l< i⟶ (f l j)) ⟹ (∀k. k<j⟶ (f i k)) ⟹ f i j
⟹ (∀l k. l≤ i ∧ k≤j⟶ (f l k))"
oops
`
The universal quantifier modifies two small range can be proved; can it prove the large range?
You forget to add a type annotations to force the variables to have type int or nat.
After fixing that, the proofs works exactly as you would do it by hand.
Here is a simple theory:
datatype t1 = A | B | C
datatype t2 = D | E t1 | F | G
inductive R where
"R A B"
| "R B C"
inductive_cases [elim]: "R x B" "R x A" "R x C"
inductive S where
"S D (E _)"
| "R x y ⟹ S (E x) (E y)"
inductive_cases [elim]: "S x D" "S x (E y)"
I can prove lemma elim using two helper lemmas:
lemma tranclp_S_x_E:
"S⇧+⇧+ x (E y) ⟹ x = D ∨ (∃z. x = E z)"
by (induct rule: converse_tranclp_induct; auto)
(* Let's assume that it's proven *)
lemma reflect_tranclp_E:
"S⇧+⇧+ (E x) (E y) ⟹ R⇧+⇧+ x y"
sorry
lemma elim:
"S⇧+⇧+ x (E y) ⟹
(x = D ⟹ P) ⟹ (⋀z. x = E z ⟹ R⇧+⇧+ z y ⟹ P) ⟹ P"
using reflect_tranclp_E tranclp_S_x_E by blast
I need to prove elim using Isar:
lemma elim:
assumes "S⇧+⇧+ x (E y)"
shows "(x = D ⟹ P) ⟹ (⋀z. x = E z ⟹ R⇧+⇧+ z y ⟹ P) ⟹ P"
proof -
assume "S⇧+⇧+ x (E y)"
then obtain z where "x = D ∨ x = E z"
by (induct rule: converse_tranclp_induct; auto)
also have "S⇧+⇧+ (E z) (E y) ⟹ R⇧+⇧+ z y"
sorry
finally show ?thesis
But I get the following errors:
No matching trans rules for calculation:
x = D ∨ x = E z
S⇧+⇧+ (E z) (E y) ⟹ R⇧+⇧+ z y
Failed to refine any pending goal
Local statement fails to refine any pending goal
Failed attempt to solve goal by exported rule:
(S⇧+⇧+ x (E y)) ⟹ P
How to fix them?
I guess that this lemma could have a simpler proof. But I need to prove it in two steps:
Show the possible values of x
Show that E reflects transitive closure
I think also that this lemma could be proven by cases on x. But my real data types have too many cases. So, it's not a preferred solution.
This variant seems to work:
lemma elim:
assumes "S⇧+⇧+ x (E y)"
and "x = D ⟹ P"
and "⋀z. x = E z ⟹ R⇧+⇧+ z y ⟹ P"
shows "P"
proof -
have "S⇧+⇧+ x (E y)" by (simp add: assms(1))
then obtain z where "x = D ∨ x = E z"
by (induct rule: converse_tranclp_induct; auto)
moreover
have "S⇧+⇧+ (E z) (E y) ⟹ R⇧+⇧+ z y"
sorry
ultimately show ?thesis
using assms by auto
qed
Assumptions should be separated from the goal.
As a first statement I shoud use have instead of assume. It's not a new assumption, just the existing one.
Instead of finally I should use ultimately. It seems that the later one has a simpler application logic.
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
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.