Consider the following simplified lambda-calculus with the peculiarity that bound variables can occur on the bound type:
theory Example
imports "Nominal2.Nominal2"
begin
atom_decl vrs
nominal_datatype ty =
Top
nominal_datatype trm =
Var "vrs"
| Abs x::"vrs" t::"trm" T::"ty" binds x in t T
nominal_function
fv :: "trm ⇒ vrs set"
where
"fv (Var x) = {x}"
| "fv (Abs x t T) = (fv t) - {x}"
using [[simproc del: alpha_lst]]
subgoal by(simp add: fv_graph_aux_def eqvt_def eqvt_at_def)
subgoal by simp
subgoal for P x
apply(rule trm.strong_exhaust[of x P])
by( simp_all add: fresh_star_def fresh_Pair)
apply simp_all
subgoal for x T t xa Ta ta
sorry
end
I have been unable to show the last goal:
eqvt_at fv_sumC T ⟹ eqvt_at fv_sumC Ta ⟹
[[atom x]]lst. (T, t) = [[atom xa]]lst. (Ta, ta) ⟹
fv_sumC T - {x} = fv_sumC Ta - {xa}
despite my efforts of a day.
Solution
subgoal for x T t xa Ta ta
proof -
assume 1: "[[atom x]]lst. (t, T) = [[atom xa]]lst. (ta, Ta)"
" eqvt_at fv_sumC t" " eqvt_at fv_sumC ta"
then have 2: "[[atom x]]lst. t = [[atom xa]]lst. ta"
by(auto simp add: Abs1_eq_iff'(3) fresh_Pair)
show "removeAll x (fv_sumC t) = removeAll xa (fv_sumC ta)"
apply(rule Abs_lst1_fcb2'[OF 2, of _ "[]"])
apply (simp add: fresh_removeAll)
apply (simp add: fresh_star_list(3))
using 1 Abs_lst1_fcb2' unfolding eqvt_at_def
by auto
qed
I am glad that you were able to work out the solution. Nonetheless, I would still like to elaborate on the comment that I previously made. In particular, I would like to emphasize that nominal_datatype already provides a very similar function automatically: it is the function fv_trm. This function is, effectively, equivalent to the function fv in your question. Here is a rough sketch (the proof will need to be refined) of a theory that demonstrates this:
theory Scratch
imports "Nominal2.Nominal2"
begin
atom_decl vrs
nominal_datatype ty =
Top
nominal_datatype trm =
Var vrs
| Abs x::vrs t::trm T::ty binds x in t T
lemma supp_ty: "supp (ty::ty) = {}"
by (metis (full_types) ty.strong_exhaust ty.supp)
lemmas fv_trm = trm.fv_defs[unfolded supp_ty supp_at_base, simplified]
lemma dom_fv_trm:
"a ∈ fv_trm x ⟹ a ∈ {a. sort_of a = Sort ''Scratch.vrs'' []}"
apply(induction rule: trm.induct)
unfolding fv_trm
by auto
lemma inj_on_Abs_vrs: "inj_on Abs_vrs (fv_trm x)"
using dom_fv_trm by (simp add: Abs_vrs_inject inj_on_def)
definition fv where "fv x = Abs_vrs ` fv_trm x"
lemma fv_Var: "fv (Var x) = {x}"
unfolding fv_def fv_trm using Rep_vrs_inverse atom_vrs_def by auto
(*I leave it to you to work out the details,
but Sledgehammer already finds something sensible*)
lemma fv_Abs: "fv (Abs x t T) = fv t - {x}"
using inj_on_Abs_vrs
unfolding fv_def fv_trm
sorry
end
Related
Consider the following datatypes with bindings in Nominal Isabelle:
theory Example
imports "Nominal2.Nominal2"
begin
atom_decl vrs
nominal_datatype ty =
Tvar "vrs"
| Arrow x::vrs T::"ty" binds x in T
nominal_datatype trm =
Var "vrs"
| Abs x::"vrs" t::"trm" binds x in t
inductive
typing :: "trm ⇒ ty ⇒ bool" ("_ , _" [60,60] 60)
where
T_Abs[intro]: "(Abs x t) , (Arrow x T)"
equivariance typing
nominal_inductive typing done
lemma
assumes "(Abs x t), (Arrow y T)"
shows "x = y"
using assms
I want to prove that the two bindings appearing in the relation are equal. I see two ways an Isabelle user could help:
If you know Nominal Isabelle is it possible to do this?
Otherwise, are the two occurrences of x in the rule T_Abs equal for the assistant or are they sort of bound variable with different identity?
If you know Nominal Isabelle is it possible to do this?
Unfortunately, it is not possible to prove the theorem that you are trying to prove. Here is a counterexample (the proofs were Sledgehammered):
theory Scratch
imports "Nominal2.Nominal2"
begin
atom_decl vrs
nominal_datatype ty =
Tvar "vrs"
| Arrow x::vrs T::"ty" binds x in T
nominal_datatype trm =
Var "vrs"
| Abs x::"vrs" t::"trm" binds x in t
inductive
typing :: "trm ⇒ ty ⇒ bool" ("_ , _" [60,60] 60)
where
T_Abs[intro]: "(Abs x t) , (Arrow x T)"
equivariance typing
nominal_inductive typing .
abbreviation s where "s ≡ Sort ''Scratch.vrs'' []"
abbreviation v where "v n ≡ Abs_vrs (Atom s n)"
lemma neq: "Abs (v 1) (Var (v 0)), Arrow (v (Suc (Suc 0))) (Tvar (v 0))"
(is "?a, ?b")
proof-
have a_def: "Abs (v 1) (Var (v 0)) = Abs (v (Suc (Suc 0))) (Var (v 0))"
(*Sledgehammered*)
by simp (smt Abs_vrs_inverse atom.inject flip_at_base_simps(3) fresh_PairD(2)
fresh_at_base(2) mem_Collect_eq nat.distinct(1) sort_of.simps trm.fresh(1))
from typing.simps[of ?a ?b, unfolded this, THEN iffD2] have
"Abs (v (Suc (Suc 0))) (Var (v 0)) , Arrow (v (Suc (Suc 0))) (Tvar (v 0))"
by auto
then show ?thesis unfolding a_def by clarsimp
qed
lemma "∃x y t T. x ≠ y ∧ (Abs x t), (Arrow y T)"
proof(intro exI conjI)
show "v 1 ≠ v (Suc (Suc 0))"
(*Sledgehammered*)
by (smt Abs_vrs_inverse One_nat_def atom.inject mem_Collect_eq n_not_Suc_n
sort_of.simps)
show "Abs (v 1) (Var (v 0)) , Arrow (v (Suc (Suc 0))) (Tvar (v 0))"
by (rule neq)
qed
end
Otherwise, are the two occurrences of x in the rule T_Abs equal for
the assistant or are they sort of bound variable with different
identity?
I believe that you are thinking along the right lines and, hopefully, the example above will clarify any confusion that you might have. Generally, you could interpret the meaning of Abs x t1 = Abs y t2 as the alpha-equivalence of (λx. t1) and (λy. t2). Of course, (λx. t1) and (λy. t2) may be alpha equivalent without x and y being equal.
Isabelle has some automation for quotient reasoning through the quotient package. I would like to see if that automation is of any use for my example. The relevant definitions is:
definition e_proj where "e_proj = e'_aff_bit // gluing"
So I try to write:
typedef e_aff_t = e'_aff_bit
quotient_type e_proj_t = "e'_aff_bit" / "gluing
However, I get the error:
Extra type variables in representing set: "'a"
The error(s) above occurred in typedef "e_aff_t"
Because as Manuel Eberl explains here, we cannot have type definitions that depend on type parameters. In the past, I was suggested to use the type-to-sets approach.
How would that approach work in my example? Would it lead to more automation?
In the past, I was suggested to use the type-to-sets approach ...
The suggestion that was made in my previous answer was to use the standard set-based infrastructure for reasoning about quotients. I only mentioned that there exist other options for completeness.
I still believe that it is best not to use Types-To-Sets, provided that the definition of a quotient type is the only reason why you wish to use Types-To-Sets:
Even with Types-To-Sets, you will only be able to mimic the behavior of a quotient type in a local context with certain additional assumptions. Upon leaving the local context, the theorems that use locally defined quotient types would need to be converted to the set-based theorems that would inevitably rely on the standard set-based infrastructure for reasoning about quotients.
One would need to develop additional Isabelle/ML infrastructure before Local Typedef Rule can be used to define quotient types locally conveniently. It should not be too difficult to develop an infrastructure that is useable, but it would take some time to develop something that is universally applicable. Personally, I do not consider this application to be sufficiently important to invest my time in it.
In my view, it is only viable to use Types-To-Sets for the definition of quotient types locally if you are already using Types-To-Sets for its intended purpose in a given development. Then, the possibility of using the framework for the definition of quotient types locally can be seen as a 'value-added benefit'.
For completeness, I provide an example that I developed for an answer on the mailing list some time ago. Of course, this is merely the demonstration of the concept, not a solution that can be used for work that is meant to be published in some form. To make this useable, one would need to convert this development to an Isabelle/ML command that would take care of all the details automatically.
theory Scratch
imports Main
"HOL-Types_To_Sets.Prerequisites"
"HOL-Types_To_Sets.Types_To_Sets"
begin
locale local_typedef =
fixes R :: "['a, 'a] ⇒ bool"
assumes is_equivalence: "equivp R"
begin
(*The exposition subsumes some of the content of
HOL/Types_To_Sets/Examples/Prerequisites.thy*)
context
fixes S and s :: "'s itself"
defines S: "S ≡ {x. ∃u. x = {v. R u v}}"
assumes Ex_type_definition_S:
"∃(Rep::'s ⇒ 'a set) (Abs::'a set ⇒ 's). type_definition Rep Abs S"
begin
definition "rep = fst (SOME (Rep::'s ⇒ 'a set, Abs). type_definition Rep
Abs S)"
definition "Abs = snd (SOME (Rep::'s ⇒ 'a set, Abs). type_definition Rep
Abs S)"
definition "rep' a = (SOME x. a ∈ S ⟶ x ∈ a)"
definition "Abs' x = (SOME a. a ∈ S ∧ a = {v. R x v})"
definition "rep'' = rep' o rep"
definition "Abs'' = Abs o Abs'"
lemma type_definition_S: "type_definition rep Abs S"
unfolding Abs_def rep_def split_beta'
by (rule someI_ex) (use Ex_type_definition_S in auto)
lemma rep_in_S[simp]: "rep x ∈ S"
and rep_inverse[simp]: "Abs (rep x) = x"
and Abs_inverse[simp]: "y ∈ S ⟹ rep (Abs y) = y"
using type_definition_S
unfolding type_definition_def by auto
definition cr_S where "cr_S ≡ λs b. s = rep b"
lemmas Domainp_cr_S = type_definition_Domainp[OF type_definition_S
cr_S_def, transfer_domain_rule]
lemmas right_total_cr_S = typedef_right_total[OF type_definition_S
cr_S_def, transfer_rule]
and bi_unique_cr_S = typedef_bi_unique[OF type_definition_S cr_S_def,
transfer_rule]
and left_unique_cr_S = typedef_left_unique[OF type_definition_S cr_S_def,
transfer_rule]
and right_unique_cr_S = typedef_right_unique[OF type_definition_S
cr_S_def, transfer_rule]
lemma cr_S_rep[intro, simp]: "cr_S (rep a) a" by (simp add: cr_S_def)
lemma cr_S_Abs[intro, simp]: "a∈S ⟹ cr_S a (Abs a)" by (simp add: cr_S_def)
(* this part was sledgehammered - please do not pay attention to the
(absence of) proof style *)
lemma r1: "∀a. Abs'' (rep'' a) = a"
unfolding Abs''_def rep''_def comp_def
proof-
{
fix s'
note repS = rep_in_S[of s']
then have "∃x. x ∈ rep s'" using S equivp_reflp is_equivalence by force
then have "rep' (rep s') ∈ rep s'"
using repS unfolding rep'_def by (metis verit_sko_ex')
moreover with is_equivalence repS have "rep s' = {v. R (rep' (rep s'))
v}"
by (smt CollectD S equivp_def)
ultimately have arr: "Abs' (rep' (rep s')) = rep s'"
unfolding Abs'_def by (smt repS some_sym_eq_trivial verit_sko_ex')
have "Abs (Abs' (rep' (rep s'))) = s'" unfolding arr by (rule
rep_inverse)
}
then show "∀a. Abs (Abs' (rep' (rep a))) = a" by auto
qed
lemma r2: "∀a. R (rep'' a) (rep'' a)"
unfolding rep''_def rep'_def
using is_equivalence unfolding equivp_def by blast
lemma r3: "∀r s. R r s = (R r r ∧ R s s ∧ Abs'' r = Abs'' s)"
apply(intro allI)
apply standard
subgoal unfolding Abs''_def Abs'_def
using is_equivalence unfolding equivp_def by auto
subgoal unfolding Abs''_def Abs'_def
using is_equivalence unfolding equivp_def
by (smt Abs''_def Abs'_def CollectD S comp_apply local.Abs_inverse
mem_Collect_eq someI_ex)
done
definition cr_Q where "cr_Q = (λx y. R x x ∧ Abs'' x = y)"
lemma quotient_Q: "Quotient R Abs'' rep'' cr_Q"
unfolding Quotient_def
apply(intro conjI)
subgoal by (rule r1)
subgoal by (rule r2)
subgoal by (rule r3)
subgoal by (rule cr_Q_def)
done
(* instantiate the quotient lemmas from the theory Lifting *)
lemmas Q_Quotient_abs_rep = Quotient_abs_rep[OF quotient_Q]
(*...*)
(* prove the statements about the quotient type 's *)
(*...*)
(* transfer the results back to 'a using the capabilities of transfer -
not demonstrated in the example *)
lemma aa: "(a::'a) = (a::'a)"
by auto
end
thm aa[cancel_type_definition]
(* this shows {x. ∃u. x = {v. R u v}} ≠ {} ⟹ ?a = ?a *)
end
I am doing Exercise 2.6 from the Concrete Semantics book:
Starting from the type 'a tree defined in the text, define a function contents :: 'a tree ⇒ 'a list that collects all values in a tree in a list, in any order, without removing duplicates. Then define a function sum_tree :: nat tree ⇒ nat that sums up all values in a tree of natural numbers and prove sum_tree t = sum_list (contents t) (where sum_list is predefined).
I have started to prove the theorem not using auto but guiding Isabelle to use the necessary theorems:
theory Minimal
imports Main
begin
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
fun contents :: "'a tree ⇒ 'a list" where
"contents Tip = []"
| "contents (Node l a r) = a # (contents l) # (contents r)"
fun sum_tree :: "nat tree ⇒ nat" where
"sum_tree Tip = 0"
| "sum_tree (Node l a r) = a + (sum_tree l) + (sum_tree r)"
lemma sum_list_contents:
"sum_list (contents t1) + sum_list (contents t2) = sum_list (contents t1 # contents t2)"
apply auto
done
lemma sum_commutes: "sum_tree(t) = sum_list(contents(t))"
apply (induction t)
apply (simp only: sum_tree.simps contents.simps sum_list.Nil)
apply (simp only: sum_list.Cons contents.simps sum_tree.simps sum_list_contents)
Here it arrives to a proof state
proof (prove)
goal (1 subgoal):
1. ⋀t1 x2 t2.
sum_tree t1 = sum_list (contents t1) ⟹
sum_tree t2 = sum_list (contents t2) ⟹
x2 + sum_list (contents t1) + sum_list (contents t2) = x2 + sum_list (contents t1 # contents t2)
Where I wonder why simp did not use the provided sum_list_contents lemma. I know simple simp would solve the equation.
What does general simp contain that simp only would not use in this case?
As pointed out in the comments, the missing piece is associativity of addition for natural numbers. Adding add.assoc to the simpplification rules solves the equation.
Alternatively, the order of operands when defining the tree sum could be changed:
fun sum_tree_1 :: "nat tree ⇒ nat" where
"sum_tree_1 Tip = 0"
| "sum_tree_1 (Node l a r) = a + ((sum_tree_1 l) + (sum_tree_1 r))"
Then the associativity is not required:
lemma sum_commutes_1: "sum_tree_1(t) = sum_list(contents(t))"
apply (induction t)
apply (simp only: sum_tree_1.simps contents.simps sum_list.Nil)
apply (simp only: sum_list.Cons contents.simps sum_tree_1.simps sum_list_contents)
done
Here is a sample datatype with a deterministic relation.
datatype ty1 = A | B | C ty1 | D ty1
inductive rel1 where
"rel1 A (C B)"
| "rel1 (C B) (D A)"
lemma rel1_det:
"rel1 x y ⟹ rel1 x z ⟹ y = z"
by (elim rel1.cases; auto)
I'm trying to lift the lemma for the following type:
datatype 'a ty2 = E 'a | F 'a
abbreviation "rel2 ≡ rel_ty2 rel1"
lemma rel2_det:
"rel2 x y ⟹ rel2 x z ⟹ y = z"
apply (cases x; cases y; auto)
apply (metis rel1_det right_uniqueD right_uniqueI ty2.rel_intros(1) ty2.right_unique_rel)
by (metis rel1_det right_uniqueD right_uniqueI ty2.rel_intros(2) ty2.right_unique_rel)
But the proof is very ugly. I guess it could be simplified using a transfer method, a lifting package or something else. Could you suggest how to use it?
I don't know about using the transfer package to prove this; however, it is easy to prove if you use the predicate right_unique from the library and the rules for it that the datatype package gives you for free:
lemma right_unique_rel1: "right_unique rel1"
by (auto simp: right_unique_def elim: rel1.cases)
lemma right_unique_rel2: "right_unique rel2"
by (intro ty2.right_unique_rel right_unique_rel1)
Here is a sample theory:
datatype ty = A | B | C
inductive test where
"test A B"
| "test B C"
inductive test2 where
"¬(∃z. test x z) ⟹ test2 x"
code_pred [show_modes] test .
code_pred [show_modes] test2 .
values "{x. test2 A}"
The generated code tries to enumerate over ty. And so it fails.
I'm tring to define an executable version of test predicate:
definition "test_ex x ≡ ∃y. test x y"
definition "test_ex_fun x ≡
Predicate.singleton (λ_. False)
(Predicate.map (λ_. True) (test_i_o x))"
lemma test_ex_code [code_abbrev, simp]:
"test_ex_fun = test_ex"
apply (intro ext)
unfolding test_ex_def test_ex_fun_def Predicate.singleton_def
apply (simp split: if_split)
But I can't prove the lemma. Could you suggest a better approach?
Existential quantifiers over an argument to an inductive predicate can be made executable by introducing another inductive predicate. For example:
inductive test2_aux where "test x z ==> test2_aux x"
inductive test2 where "~ test2_aux x ==> test2 x"
with appropriate code_pred statements. The free variable z in the premise of test2_aux acts like an existential. Since this transformation is canonical, code_pred has a preprocessor to do so:
code_pred [inductify] test2 .
does the job.
Well, values complains about the fact that ty is not of sort enum. So, in this particular case it is easiest to perform this instantiation.
instantiation ty :: enum
begin
definition enum_ty :: "ty list" where
"enum_ty = [A,B,C]"
definition "enum_all_ty f = list_all f [A,B,C]"
definition "enum_ex_ty f = list_ex f [A,B,C]"
instance
proof (intro_classes)
let ?U = "UNIV :: ty set"
show id: "?U = set enum_class.enum"
unfolding enum_ty_def
using ty.exhaust by auto
fix P
show "enum_class.enum_all P = Ball ?U P"
"enum_class.enum_ex P = Bex ?U P"
unfolding id enum_all_ty_def enum_ex_ty_def enum_ty_def by auto
show "distinct (enum_class.enum :: ty list)" unfolding enum_ty_def by auto
qed
Afterwards, your values-command evaluates without problems.
I thought that the lemma is unprovable, and I should find another approach. But it can be proven as follows:
lemma test_ex_code [code_abbrev, simp]:
"Predicate.singleton (λ_. False)
(Predicate.map (λ_. True) (test_i_o x)) = (∃y. test x y)"
apply (intro ext iffI)
unfolding Predicate.singleton_def
apply (simp_all split: if_split)
apply (metis SUP1_E mem_Collect_eq pred.sel test_i_o_def)
apply (intro conjI impI)
apply (smt SUP1_E the_equality)
apply (metis (full_types) SUP1_E SUP1_I mem_Collect_eq pred.sel test_i_o_def)
done
The interesting thing is that the lemma structure and the proof structure seems to be independent of the concrete predicate. I guess there could be a general solution for any predicate.