header {* Internal domain package proofs done manually *}
theory Domain_Proofs
imports HOLCF
begin
default_sort rep
subsection {* Step 1: Define the new type combinators *}
text {* Start with the one-step non-recursive version *}
definition
foo_bar_baz_deflF ::
"TypeRep -> TypeRep × TypeRep × TypeRep -> TypeRep × TypeRep × TypeRep"
where
"foo_bar_baz_deflF = (Λ a. Abs_CFun (λ(t1, t2, t3).
( ssum_defl·REP(one)·(sprod_defl·(u_defl·a)·(u_defl·t2))
, u_defl·(cfun_defl·t3·REP(tr))
, u_defl·(cfun_defl·(convex_defl·t1)·REP(tr)))))"
lemma foo_bar_baz_deflF_beta:
"foo_bar_baz_deflF·a·t =
( ssum_defl·REP(one)·(sprod_defl·(u_defl·a)·(u_defl·(fst (snd t))))
, u_defl·(cfun_defl·(snd (snd t))·REP(tr))
, u_defl·(cfun_defl·(convex_defl·(fst t))·REP(tr)))"
unfolding foo_bar_baz_deflF_def
by (simp add: split_def)
text {* Individual type combinators are projected from the fixed point. *}
definition foo_defl :: "TypeRep -> TypeRep"
where "foo_defl = (Λ a. fst (fix·(foo_bar_baz_deflF·a)))"
definition bar_defl :: "TypeRep -> TypeRep"
where "bar_defl = (Λ a. fst (snd (fix·(foo_bar_baz_deflF·a))))"
definition baz_defl :: "TypeRep -> TypeRep"
where "baz_defl = (Λ a. snd (snd (fix·(foo_bar_baz_deflF·a))))"
lemma defl_apply_thms:
"foo_defl·a = fst (fix·(foo_bar_baz_deflF·a))"
"bar_defl·a = fst (snd (fix·(foo_bar_baz_deflF·a)))"
"baz_defl·a = snd (snd (fix·(foo_bar_baz_deflF·a)))"
unfolding foo_defl_def bar_defl_def baz_defl_def by simp_all
text {* Unfold rules for each combinator. *}
lemma foo_defl_unfold:
"foo_defl·a = ssum_defl·REP(one)·(sprod_defl·(u_defl·a)·(u_defl·(bar_defl·a)))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
lemma bar_defl_unfold: "bar_defl·a = u_defl·(cfun_defl·(baz_defl·a)·REP(tr))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
lemma baz_defl_unfold: "baz_defl·a = u_defl·(cfun_defl·(convex_defl·(foo_defl·a))·REP(tr))"
unfolding defl_apply_thms by (subst fix_eq, simp add: foo_bar_baz_deflF_beta)
text "The automation for the previous steps will be quite similar to
how the fixrec package works."
subsection {* Step 2: Define types, prove class instances *}
text {* Use @{text pcpodef} with the appropriate type combinator. *}
pcpodef (open) 'a foo = "{x. x ::: foo_defl·REP('a)}"
by (simp_all add: adm_in_deflation)
pcpodef (open) 'a bar = "{x. x ::: bar_defl·REP('a)}"
by (simp_all add: adm_in_deflation)
pcpodef (open) 'a baz = "{x. x ::: baz_defl·REP('a)}"
by (simp_all add: adm_in_deflation)
text {* Prove rep instance using lemma @{text typedef_rep_class}. *}
instantiation foo :: (rep) rep
begin
definition emb_foo :: "'a foo -> udom"
where "emb_foo ≡ (Λ x. Rep_foo x)"
definition prj_foo :: "udom -> 'a foo"
where "prj_foo ≡ (Λ y. Abs_foo (cast·(foo_defl·REP('a))·y))"
definition approx_foo :: "nat => 'a foo -> 'a foo"
where "approx_foo ≡ repdef_approx Rep_foo Abs_foo (foo_defl·REP('a))"
instance
apply (rule typedef_rep_class)
apply (rule type_definition_foo)
apply (rule below_foo_def)
apply (rule emb_foo_def)
apply (rule prj_foo_def)
apply (rule approx_foo_def)
done
end
instantiation bar :: (rep) rep
begin
definition emb_bar :: "'a bar -> udom"
where "emb_bar ≡ (Λ x. Rep_bar x)"
definition prj_bar :: "udom -> 'a bar"
where "prj_bar ≡ (Λ y. Abs_bar (cast·(bar_defl·REP('a))·y))"
definition approx_bar :: "nat => 'a bar -> 'a bar"
where "approx_bar ≡ repdef_approx Rep_bar Abs_bar (bar_defl·REP('a))"
instance
apply (rule typedef_rep_class)
apply (rule type_definition_bar)
apply (rule below_bar_def)
apply (rule emb_bar_def)
apply (rule prj_bar_def)
apply (rule approx_bar_def)
done
end
instantiation baz :: (rep) rep
begin
definition emb_baz :: "'a baz -> udom"
where "emb_baz ≡ (Λ x. Rep_baz x)"
definition prj_baz :: "udom -> 'a baz"
where "prj_baz ≡ (Λ y. Abs_baz (cast·(baz_defl·REP('a))·y))"
definition approx_baz :: "nat => 'a baz -> 'a baz"
where "approx_baz ≡ repdef_approx Rep_baz Abs_baz (baz_defl·REP('a))"
instance
apply (rule typedef_rep_class)
apply (rule type_definition_baz)
apply (rule below_baz_def)
apply (rule emb_baz_def)
apply (rule prj_baz_def)
apply (rule approx_baz_def)
done
end
text {* Prove REP rules using lemma @{text typedef_REP}. *}
lemma REP_foo: "REP('a foo) = foo_defl·REP('a)"
apply (rule typedef_REP)
apply (rule type_definition_foo)
apply (rule below_foo_def)
apply (rule emb_foo_def)
apply (rule prj_foo_def)
done
lemma REP_bar: "REP('a bar) = bar_defl·REP('a)"
apply (rule typedef_REP)
apply (rule type_definition_bar)
apply (rule below_bar_def)
apply (rule emb_bar_def)
apply (rule prj_bar_def)
done
lemma REP_baz: "REP('a baz) = baz_defl·REP('a)"
apply (rule typedef_REP)
apply (rule type_definition_baz)
apply (rule below_baz_def)
apply (rule emb_baz_def)
apply (rule prj_baz_def)
done
text {* Prove REP equations using type combinator unfold lemmas. *}
lemma REP_foo': "REP('a foo) = REP(one ⊕ 'a\<^sub>⊥ ⊗ ('a bar)\<^sub>⊥)"
unfolding REP_foo REP_bar REP_baz REP_simps
by (rule foo_defl_unfold)
lemma REP_bar': "REP('a bar) = REP(('a baz -> tr)\<^sub>⊥)"
unfolding REP_foo REP_bar REP_baz REP_simps
by (rule bar_defl_unfold)
lemma REP_baz': "REP('a baz) = REP(('a foo convex_pd -> tr)\<^sub>⊥)"
unfolding REP_foo REP_bar REP_baz REP_simps REP_convex
by (rule baz_defl_unfold)
subsection {* Step 3: Define rep and abs functions *}
text {* Define them all using @{text coerce}! *}
definition foo_rep :: "'a foo -> one ⊕ ('a\<^sub>⊥ ⊗ ('a bar)\<^sub>⊥)"
where "foo_rep ≡ coerce"
definition foo_abs :: "one ⊕ ('a\<^sub>⊥ ⊗ ('a bar)\<^sub>⊥) -> 'a foo"
where "foo_abs ≡ coerce"
definition bar_rep :: "'a bar -> ('a baz -> tr)\<^sub>⊥"
where "bar_rep ≡ coerce"
definition bar_abs :: "('a baz -> tr)\<^sub>⊥ -> 'a bar"
where "bar_abs ≡ coerce"
definition baz_rep :: "'a baz -> ('a foo convex_pd -> tr)\<^sub>⊥"
where "baz_rep ≡ coerce"
definition baz_abs :: "('a foo convex_pd -> tr)\<^sub>⊥ -> 'a baz"
where "baz_abs ≡ coerce"
text {* Prove isomorphism rules. *}
lemma foo_abs_iso: "foo_rep·(foo_abs·x) = x"
by (rule domain_abs_iso [OF REP_foo' foo_abs_def foo_rep_def])
lemma foo_rep_iso: "foo_abs·(foo_rep·x) = x"
by (rule domain_rep_iso [OF REP_foo' foo_abs_def foo_rep_def])
lemma bar_abs_iso: "bar_rep·(bar_abs·x) = x"
by (rule domain_abs_iso [OF REP_bar' bar_abs_def bar_rep_def])
lemma bar_rep_iso: "bar_abs·(bar_rep·x) = x"
by (rule domain_rep_iso [OF REP_bar' bar_abs_def bar_rep_def])
lemma baz_abs_iso: "baz_rep·(baz_abs·x) = x"
by (rule domain_abs_iso [OF REP_baz' baz_abs_def baz_rep_def])
lemma baz_rep_iso: "baz_abs·(baz_rep·x) = x"
by (rule domain_rep_iso [OF REP_baz' baz_abs_def baz_rep_def])
text {* Prove isodefl rules using @{text isodefl_coerce}. *}
lemma isodefl_foo_abs:
"isodefl d t ==> isodefl (foo_abs oo d oo foo_rep) t"
by (rule isodefl_abs_rep [OF REP_foo' foo_abs_def foo_rep_def])
lemma isodefl_bar_abs:
"isodefl d t ==> isodefl (bar_abs oo d oo bar_rep) t"
by (rule isodefl_abs_rep [OF REP_bar' bar_abs_def bar_rep_def])
lemma isodefl_baz_abs:
"isodefl d t ==> isodefl (baz_abs oo d oo baz_rep) t"
by (rule isodefl_abs_rep [OF REP_baz' baz_abs_def baz_rep_def])
subsection {* Step 4: Define map functions, prove isodefl property *}
text {* Start with the one-step non-recursive version. *}
text {* Note that the type of the map function depends on which
variables are used in positive and negative positions. *}
definition
foo_bar_baz_mapF ::
"('a -> 'b) ->
('a foo -> 'b foo) × ('a bar -> 'b bar) × ('b baz -> 'a baz) ->
('a foo -> 'b foo) × ('a bar -> 'b bar) × ('b baz -> 'a baz)"
where
"foo_bar_baz_mapF = (Λ f. Abs_CFun (λ(d1, d2, d3).
(
foo_abs oo
ssum_map·ID·(sprod_map·(u_map·f)·(u_map·d2))
oo foo_rep
,
bar_abs oo u_map·(cfun_map·d3·ID) oo bar_rep
,
baz_abs oo u_map·(cfun_map·(convex_map·d1)·ID) oo baz_rep
)))"
lemma foo_bar_baz_mapF_beta:
"foo_bar_baz_mapF·f·d =
(
foo_abs oo
ssum_map·ID·(sprod_map·(u_map·f)·(u_map·(fst (snd d))))
oo foo_rep
,
bar_abs oo u_map·(cfun_map·(snd (snd d))·ID) oo bar_rep
,
baz_abs oo u_map·(cfun_map·(convex_map·(fst d))·ID) oo baz_rep
)"
unfolding foo_bar_baz_mapF_def
by (simp add: split_def)
text {* Individual map functions are projected from the fixed point. *}
definition foo_map :: "('a -> 'b) -> ('a foo -> 'b foo)"
where "foo_map = (Λ f. fst (fix·(foo_bar_baz_mapF·f)))"
definition bar_map :: "('a -> 'b) -> ('a bar -> 'b bar)"
where "bar_map = (Λ f. fst (snd (fix·(foo_bar_baz_mapF·f))))"
definition baz_map :: "('a -> 'b) -> ('b baz -> 'a baz)"
where "baz_map = (Λ f. snd (snd (fix·(foo_bar_baz_mapF·f))))"
lemma map_apply_thms:
"foo_map·f = fst (fix·(foo_bar_baz_mapF·f))"
"bar_map·f = fst (snd (fix·(foo_bar_baz_mapF·f)))"
"baz_map·f = snd (snd (fix·(foo_bar_baz_mapF·f)))"
unfolding foo_map_def bar_map_def baz_map_def by simp_all
text {* Prove isodefl rules for all map functions simultaneously. *}
lemma isodefl_foo_bar_baz:
assumes isodefl_d: "isodefl d t"
shows
"isodefl (foo_map·d) (foo_defl·t) ∧
isodefl (bar_map·d) (bar_defl·t) ∧
isodefl (baz_map·d) (baz_defl·t)"
unfolding map_apply_thms defl_apply_thms
apply (rule parallel_fix_ind)
apply (intro adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id)
apply (simp only: fst_strict snd_strict isodefl_bottom simp_thms)
apply (simp only: foo_bar_baz_mapF_beta
foo_bar_baz_deflF_beta
fst_conv snd_conv)
apply (elim conjE)
apply (intro
conjI
isodefl_foo_abs
isodefl_bar_abs
isodefl_baz_abs
isodefl_ssum isodefl_sprod isodefl_ID_REP
isodefl_u isodefl_convex isodefl_cfun
isodefl_d
)
apply assumption+
done
lemmas isodefl_foo = isodefl_foo_bar_baz [THEN conjunct1]
lemmas isodefl_bar = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct1]
lemmas isodefl_baz = isodefl_foo_bar_baz [THEN conjunct2, THEN conjunct2]
text {* Prove map ID lemmas, using isodefl_REP_imp_ID *}
lemma foo_map_ID: "foo_map·ID = ID"
apply (rule isodefl_REP_imp_ID)
apply (subst REP_foo)
apply (rule isodefl_foo)
apply (rule isodefl_ID_REP)
done
lemma bar_map_ID: "bar_map·ID = ID"
apply (rule isodefl_REP_imp_ID)
apply (subst REP_bar)
apply (rule isodefl_bar)
apply (rule isodefl_ID_REP)
done
lemma baz_map_ID: "baz_map·ID = ID"
apply (rule isodefl_REP_imp_ID)
apply (subst REP_baz)
apply (rule isodefl_baz)
apply (rule isodefl_ID_REP)
done
subsection {* Step 5: Define take functions, prove lub-take lemmas *}
definition
foo_bar_baz_takeF ::
"('a foo -> 'a foo) × ('a bar -> 'a bar) × ('a baz -> 'a baz) ->
('a foo -> 'a foo) × ('a bar -> 'a bar) × ('a baz -> 'a baz)"
where
"foo_bar_baz_takeF = (Λ p.
( foo_abs oo
ssum_map·ID·(sprod_map·(u_map·ID)·(u_map·(fst (snd p))))
oo foo_rep
, bar_abs oo
u_map·(cfun_map·(snd (snd p))·ID) oo bar_rep
, baz_abs oo
u_map·(cfun_map·(convex_map·(fst p))·ID) oo baz_rep
))"
lemma foo_bar_baz_takeF_beta:
"foo_bar_baz_takeF·p =
( foo_abs oo
ssum_map·ID·(sprod_map·(u_map·ID)·(u_map·(fst (snd p))))
oo foo_rep
, bar_abs oo
u_map·(cfun_map·(snd (snd p))·ID) oo bar_rep
, baz_abs oo
u_map·(cfun_map·(convex_map·(fst p))·ID) oo baz_rep
)"
unfolding foo_bar_baz_takeF_def by (rule beta_cfun, simp)
definition
foo_take :: "nat => 'a foo -> 'a foo"
where
"foo_take = (λn. fst (iterate n·foo_bar_baz_takeF·⊥))"
definition
bar_take :: "nat => 'a bar -> 'a bar"
where
"bar_take = (λn. fst (snd (iterate n·foo_bar_baz_takeF·⊥)))"
definition
baz_take :: "nat => 'a baz -> 'a baz"
where
"baz_take = (λn. snd (snd (iterate n·foo_bar_baz_takeF·⊥)))"
lemma chain_take_thms: "chain foo_take" "chain bar_take" "chain baz_take"
unfolding foo_take_def bar_take_def baz_take_def
by (intro ch2ch_fst ch2ch_snd chain_iterate)+
lemma take_0_thms: "foo_take 0 = ⊥" "bar_take 0 = ⊥" "baz_take 0 = ⊥"
unfolding foo_take_def bar_take_def baz_take_def
by (simp only: iterate_0 fst_strict snd_strict)+
lemma take_Suc_thms:
"foo_take (Suc n) =
foo_abs oo ssum_map·ID·(sprod_map·(u_map·ID)·(u_map·(bar_take n))) oo foo_rep"
"bar_take (Suc n) =
bar_abs oo u_map·(cfun_map·(baz_take n)·ID) oo bar_rep"
"baz_take (Suc n) =
baz_abs oo u_map·(cfun_map·(convex_map·(foo_take n))·ID) oo baz_rep"
unfolding foo_take_def bar_take_def baz_take_def
by (simp only: iterate_Suc foo_bar_baz_takeF_beta fst_conv snd_conv)+
lemma lub_take_lemma:
"(\<Squnion>n. foo_take n, \<Squnion>n. bar_take n, \<Squnion>n. baz_take n)
= (foo_map·(ID::'a -> 'a), bar_map·(ID::'a -> 'a), baz_map·(ID::'a -> 'a))"
apply (simp only: thelub_Pair [symmetric] ch2ch_Pair chain_take_thms)
apply (simp only: map_apply_thms pair_collapse)
apply (simp only: fix_def2)
apply (rule lub_eq)
apply (rule nat.induct)
apply (simp only: iterate_0 Pair_strict take_0_thms)
apply (simp only: iterate_Suc Pair_fst_snd_eq fst_conv snd_conv
foo_bar_baz_mapF_beta take_Suc_thms simp_thms)
done
lemma lub_foo_take: "(\<Squnion>n. foo_take n) = ID"
apply (rule trans [OF _ foo_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done
lemma lub_bar_take: "(\<Squnion>n. bar_take n) = ID"
apply (rule trans [OF _ bar_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done
lemma lub_baz_take: "(\<Squnion>n. baz_take n) = ID"
apply (rule trans [OF _ baz_map_ID])
using lub_take_lemma
apply (elim Pair_inject)
apply assumption
done
end