Up to index of Isabelle/HOL/Predicate_Compile_Examples
theory Specialisation_Examplestheory Specialisation_Examples
imports Main Predicate_Compile_Alternative_Defs
begin
section {* Specialisation Examples *}
fun nth_el'
where
"nth_el' [] i = None"
| "nth_el' (x # xs) i = (case i of 0 => Some x | Suc j => nth_el' xs j)"
definition
"greater_than_index xs = (∀i x. nth_el' xs i = Some x --> x > i)"
code_pred (expected_modes: i => bool) [inductify, skip_proof, specialise] greater_than_index .
ML {* Predicate_Compile_Core.intros_of @{context} @{const_name specialised_nth_el'P} *}
thm greater_than_index.equation
values [expected "{()}"] "{x. greater_than_index [1,2,4,6]}"
values [expected "{}"] "{x. greater_than_index [0,2,3,2]}"
subsection {* Common subterms *}
text {* If a predicate is called with common subterms as arguments,
this predicate should be specialised.
*}
definition max_nat :: "nat => nat => nat"
where "max_nat a b = (if a <= b then b else a)"
lemma [code_pred_inline]:
"max = max_nat"
by (simp add: expand_fun_eq max_def max_nat_def)
definition
"max_of_my_Suc x = max x (Suc x)"
text {* In this example, max is specialised, hence the mode o => i => bool is possible *}
code_pred (modes: o => i => bool) [inductify, specialise, skip_proof] max_of_my_Suc .
thm max_of_my_SucP.equation
ML {* Predicate_Compile_Core.intros_of @{context} @{const_name specialised_max_natP} *}
values "{x. max_of_my_SucP x 6}"
subsection {* Sorts *}
code_pred [inductify] sorted .
thm sorted.equation
section {* Specialisation in POPLmark theory *}
notation
Some ("⌊_⌋")
notation
None ("⊥")
notation
length ("\<parallel>_\<parallel>")
notation
Cons ("_ ::/ _" [66, 65] 65)
primrec
nth_el :: "'a list => nat => 'a option" ("_〈_〉" [90, 0] 91)
where
"[]〈i〉 = ⊥"
| "(x # xs)〈i〉 = (case i of 0 => ⌊x⌋ | Suc j => xs 〈j〉)"
primrec assoc :: "('a × 'b) list => 'a => 'b option" ("_〈_〉\<^isub>?" [90, 0] 91)
where
"[]〈a〉\<^isub>? = ⊥"
| "(x # xs)〈a〉\<^isub>? = (if fst x = a then ⌊snd x⌋ else xs〈a〉\<^isub>?)"
primrec unique :: "('a × 'b) list => bool"
where
"unique [] = True"
| "unique (x # xs) = (xs〈fst x〉\<^isub>? = ⊥ ∧ unique xs)"
datatype type =
TVar nat
| Top
| Fun type type (infixr "->" 200)
| TyAll type type ("(3∀<:_./ _)" [0, 10] 10)
datatype binding = VarB type | TVarB type
types env = "binding list"
primrec is_TVarB :: "binding => bool"
where
"is_TVarB (VarB T) = False"
| "is_TVarB (TVarB T) = True"
primrec type_ofB :: "binding => type"
where
"type_ofB (VarB T) = T"
| "type_ofB (TVarB T) = T"
primrec mapB :: "(type => type) => binding => binding"
where
"mapB f (VarB T) = VarB (f T)"
| "mapB f (TVarB T) = TVarB (f T)"
datatype trm =
Var nat
| Abs type trm ("(3λ:_./ _)" [0, 10] 10)
| TAbs type trm ("(3λ<:_./ _)" [0, 10] 10)
| App trm trm (infixl "•" 200)
| TApp trm type (infixl "•\<^isub>τ" 200)
primrec liftT :: "nat => nat => type => type" ("\<up>\<^isub>τ")
where
"\<up>\<^isub>τ n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
| "\<up>\<^isub>τ n k Top = Top"
| "\<up>\<^isub>τ n k (T -> U) = \<up>\<^isub>τ n k T -> \<up>\<^isub>τ n k U"
| "\<up>\<^isub>τ n k (∀<:T. U) = (∀<:\<up>\<^isub>τ n k T. \<up>\<^isub>τ n (k + 1) U)"
primrec lift :: "nat => nat => trm => trm" ("\<up>")
where
"\<up> n k (Var i) = (if i < k then Var i else Var (i + n))"
| "\<up> n k (λ:T. t) = (λ:\<up>\<^isub>τ n k T. \<up> n (k + 1) t)"
| "\<up> n k (λ<:T. t) = (λ<:\<up>\<^isub>τ n k T. \<up> n (k + 1) t)"
| "\<up> n k (s • t) = \<up> n k s • \<up> n k t"
| "\<up> n k (t •\<^isub>τ T) = \<up> n k t •\<^isub>τ \<up>\<^isub>τ n k T"
primrec substTT :: "type => nat => type => type" ("_[_ \<mapsto>\<^isub>τ _]\<^isub>τ" [300, 0, 0] 300)
where
"(TVar i)[k \<mapsto>\<^isub>τ S]\<^isub>τ =
(if k < i then TVar (i - 1) else if i = k then \<up>\<^isub>τ k 0 S else TVar i)"
| "Top[k \<mapsto>\<^isub>τ S]\<^isub>τ = Top"
| "(T -> U)[k \<mapsto>\<^isub>τ S]\<^isub>τ = T[k \<mapsto>\<^isub>τ S]\<^isub>τ -> U[k \<mapsto>\<^isub>τ S]\<^isub>τ"
| "(∀<:T. U)[k \<mapsto>\<^isub>τ S]\<^isub>τ = (∀<:T[k \<mapsto>\<^isub>τ S]\<^isub>τ. U[k+1 \<mapsto>\<^isub>τ S]\<^isub>τ)"
primrec decT :: "nat => nat => type => type" ("\<down>\<^isub>τ")
where
"\<down>\<^isub>τ 0 k T = T"
| "\<down>\<^isub>τ (Suc n) k T = \<down>\<^isub>τ n k (T[k \<mapsto>\<^isub>τ Top]\<^isub>τ)"
primrec subst :: "trm => nat => trm => trm" ("_[_ \<mapsto> _]" [300, 0, 0] 300)
where
"(Var i)[k \<mapsto> s] = (if k < i then Var (i - 1) else if i = k then \<up> k 0 s else Var i)"
| "(t • u)[k \<mapsto> s] = t[k \<mapsto> s] • u[k \<mapsto> s]"
| "(t •\<^isub>τ T)[k \<mapsto> s] = t[k \<mapsto> s] •\<^isub>τ \<down>\<^isub>τ 1 k T"
| "(λ:T. t)[k \<mapsto> s] = (λ:\<down>\<^isub>τ 1 k T. t[k+1 \<mapsto> s])"
| "(λ<:T. t)[k \<mapsto> s] = (λ<:\<down>\<^isub>τ 1 k T. t[k+1 \<mapsto> s])"
primrec substT :: "trm => nat => type => trm" ("_[_ \<mapsto>\<^isub>τ _]" [300, 0, 0] 300)
where
"(Var i)[k \<mapsto>\<^isub>τ S] = (if k < i then Var (i - 1) else Var i)"
| "(t • u)[k \<mapsto>\<^isub>τ S] = t[k \<mapsto>\<^isub>τ S] • u[k \<mapsto>\<^isub>τ S]"
| "(t •\<^isub>τ T)[k \<mapsto>\<^isub>τ S] = t[k \<mapsto>\<^isub>τ S] •\<^isub>τ T[k \<mapsto>\<^isub>τ S]\<^isub>τ"
| "(λ:T. t)[k \<mapsto>\<^isub>τ S] = (λ:T[k \<mapsto>\<^isub>τ S]\<^isub>τ. t[k+1 \<mapsto>\<^isub>τ S])"
| "(λ<:T. t)[k \<mapsto>\<^isub>τ S] = (λ<:T[k \<mapsto>\<^isub>τ S]\<^isub>τ. t[k+1 \<mapsto>\<^isub>τ S])"
primrec liftE :: "nat => nat => env => env" ("\<up>\<^isub>e")
where
"\<up>\<^isub>e n k [] = []"
| "\<up>\<^isub>e n k (B :: Γ) = mapB (\<up>\<^isub>τ n (k + \<parallel>Γ\<parallel>)) B :: \<up>\<^isub>e n k Γ"
primrec substE :: "env => nat => type => env" ("_[_ \<mapsto>\<^isub>τ _]\<^isub>e" [300, 0, 0] 300)
where
"[][k \<mapsto>\<^isub>τ T]\<^isub>e = []"
| "(B :: Γ)[k \<mapsto>\<^isub>τ T]\<^isub>e = mapB (λU. U[k + \<parallel>Γ\<parallel> \<mapsto>\<^isub>τ T]\<^isub>τ) B :: Γ[k \<mapsto>\<^isub>τ T]\<^isub>e"
primrec decE :: "nat => nat => env => env" ("\<down>\<^isub>e")
where
"\<down>\<^isub>e 0 k Γ = Γ"
| "\<down>\<^isub>e (Suc n) k Γ = \<down>\<^isub>e n k (Γ[k \<mapsto>\<^isub>τ Top]\<^isub>e)"
inductive
well_formed :: "env => type => bool" ("_ \<turnstile>\<^bsub>wf\<^esub> _" [50, 50] 50)
where
wf_TVar: "Γ〈i〉 = ⌊TVarB T⌋ ==> Γ \<turnstile>\<^bsub>wf\<^esub> TVar i"
| wf_Top: "Γ \<turnstile>\<^bsub>wf\<^esub> Top"
| wf_arrow: "Γ \<turnstile>\<^bsub>wf\<^esub> T ==> Γ \<turnstile>\<^bsub>wf\<^esub> U ==> Γ \<turnstile>\<^bsub>wf\<^esub> T -> U"
| wf_all: "Γ \<turnstile>\<^bsub>wf\<^esub> T ==> TVarB T :: Γ \<turnstile>\<^bsub>wf\<^esub> U ==> Γ \<turnstile>\<^bsub>wf\<^esub> (∀<:T. U)"
inductive
well_formedE :: "env => bool" ("_ \<turnstile>\<^bsub>wf\<^esub>" [50] 50)
and well_formedB :: "env => binding => bool" ("_ \<turnstile>\<^bsub>wfB\<^esub> _" [50, 50] 50)
where
"Γ \<turnstile>\<^bsub>wfB\<^esub> B ≡ Γ \<turnstile>\<^bsub>wf\<^esub> type_ofB B"
| wf_Nil: "[] \<turnstile>\<^bsub>wf\<^esub>"
| wf_Cons: "Γ \<turnstile>\<^bsub>wfB\<^esub> B ==> Γ \<turnstile>\<^bsub>wf\<^esub> ==> B :: Γ \<turnstile>\<^bsub>wf\<^esub>"
inductive_cases well_formed_cases:
"Γ \<turnstile>\<^bsub>wf\<^esub> TVar i"
"Γ \<turnstile>\<^bsub>wf\<^esub> Top"
"Γ \<turnstile>\<^bsub>wf\<^esub> T -> U"
"Γ \<turnstile>\<^bsub>wf\<^esub> (∀<:T. U)"
inductive_cases well_formedE_cases:
"B :: Γ \<turnstile>\<^bsub>wf\<^esub>"
inductive
subtyping :: "env => type => type => bool" ("_ \<turnstile> _ <: _" [50, 50, 50] 50)
where
SA_Top: "Γ \<turnstile>\<^bsub>wf\<^esub> ==> Γ \<turnstile>\<^bsub>wf\<^esub> S ==> Γ \<turnstile> S <: Top"
| SA_refl_TVar: "Γ \<turnstile>\<^bsub>wf\<^esub> ==> Γ \<turnstile>\<^bsub>wf\<^esub> TVar i ==> Γ \<turnstile> TVar i <: TVar i"
| SA_trans_TVar: "Γ〈i〉 = ⌊TVarB U⌋ ==>
Γ \<turnstile> \<up>\<^isub>τ (Suc i) 0 U <: T ==> Γ \<turnstile> TVar i <: T"
| SA_arrow: "Γ \<turnstile> T\<^isub>1 <: S\<^isub>1 ==> Γ \<turnstile> S\<^isub>2 <: T\<^isub>2 ==> Γ \<turnstile> S\<^isub>1 -> S\<^isub>2 <: T\<^isub>1 -> T\<^isub>2"
| SA_all: "Γ \<turnstile> T\<^isub>1 <: S\<^isub>1 ==> TVarB T\<^isub>1 :: Γ \<turnstile> S\<^isub>2 <: T\<^isub>2 ==>
Γ \<turnstile> (∀<:S\<^isub>1. S\<^isub>2) <: (∀<:T\<^isub>1. T\<^isub>2)"
inductive
typing :: "env => trm => type => bool" ("_ \<turnstile> _ : _" [50, 50, 50] 50)
where
T_Var: "Γ \<turnstile>\<^bsub>wf\<^esub> ==> Γ〈i〉 = ⌊VarB U⌋ ==> T = \<up>\<^isub>τ (Suc i) 0 U ==> Γ \<turnstile> Var i : T"
| T_Abs: "VarB T\<^isub>1 :: Γ \<turnstile> t\<^isub>2 : T\<^isub>2 ==> Γ \<turnstile> (λ:T\<^isub>1. t\<^isub>2) : T\<^isub>1 -> \<down>\<^isub>τ 1 0 T\<^isub>2"
| T_App: "Γ \<turnstile> t\<^isub>1 : T\<^isub>1\<^isub>1 -> T\<^isub>1\<^isub>2 ==> Γ \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1 ==> Γ \<turnstile> t\<^isub>1 • t\<^isub>2 : T\<^isub>1\<^isub>2"
| T_TAbs: "TVarB T\<^isub>1 :: Γ \<turnstile> t\<^isub>2 : T\<^isub>2 ==> Γ \<turnstile> (λ<:T\<^isub>1. t\<^isub>2) : (∀<:T\<^isub>1. T\<^isub>2)"
| T_TApp: "Γ \<turnstile> t\<^isub>1 : (∀<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2) ==> Γ \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1 ==>
Γ \<turnstile> t\<^isub>1 •\<^isub>τ T\<^isub>2 : T\<^isub>1\<^isub>2[0 \<mapsto>\<^isub>τ T\<^isub>2]\<^isub>τ"
| T_Sub: "Γ \<turnstile> t : S ==> Γ \<turnstile> S <: T ==> Γ \<turnstile> t : T"
code_pred [inductify, skip_proof, specialise] typing .
thm typing.equation
values 6 "{(E, t, T). typing E t T}"
subsection {* Higher-order predicate *}
code_pred [inductify] mapB .
subsection {* Multiple instances *}
inductive subtype_refl' where
"Γ \<turnstile> t : T ==> ¬ (Γ \<turnstile> T <: T) ==> subtype_refl' t T"
code_pred (modes: i => i => bool, o => i => bool, i => o => bool, o => o => bool) [inductify] subtype_refl' .
thm subtype_refl'.equation
end