src/HOL/Predicate_Compile_Examples/Specialisation_Examples.thy
author bulwahn
Mon Mar 29 17:30:56 2010 +0200 (2010-03-29)
changeset 36040 fcd7bea01a93
parent 36033 7106f079bd05
child 36054 93d62439506c
permissions -rw-r--r--
adding skip_proof in the examples because proof procedure cannot handle alternative compilations yet
     1 theory Specialisation_Examples
     2 imports Main "../ex/Predicate_Compile_Alternative_Defs"
     3 begin
     4 
     5 section {* Specialisation Examples *}
     6 
     7 fun nth_el'
     8 where
     9   "nth_el' [] i = None"
    10 | "nth_el' (x # xs) i = (case i of 0 => Some x | Suc j => nth_el' xs j)"
    11 
    12 definition
    13   "greater_than_index xs = (\<forall>i x. nth_el' xs i = Some x --> x > i)"
    14 
    15 code_pred (expected_modes: i => bool) [inductify] greater_than_index .
    16 ML {* Predicate_Compile_Core.intros_of @{theory} @{const_name specialised_nth_el'P} *}
    17 
    18 thm greater_than_index.equation
    19 
    20 values [expected "{()}"] "{x. greater_than_index [1,2,4,6]}"
    21 values [expected "{}"] "{x. greater_than_index [0,2,3,2]}"
    22 
    23 subsection {* Common subterms *}
    24 
    25 text {* If a predicate is called with common subterms as arguments,
    26   this predicate should be specialised. 
    27 *}
    28 
    29 definition max_nat :: "nat => nat => nat"
    30   where "max_nat a b = (if a <= b then b else a)"
    31 
    32 lemma [code_pred_inline]:
    33   "max = max_nat"
    34 by (simp add: expand_fun_eq max_def max_nat_def)
    35 
    36 definition
    37   "max_of_my_Suc x = max x (Suc x)"
    38 
    39 text {* In this example, max is specialised, hence the mode o => i => bool is possible *}
    40 
    41 code_pred (modes: o => i => bool) [inductify] max_of_my_Suc .
    42 
    43 thm max_of_my_SucP.equation
    44 
    45 ML {* Predicate_Compile_Core.intros_of @{theory} @{const_name specialised_max_natP} *}
    46 
    47 values "{x. max_of_my_SucP x 6}"
    48 
    49 subsection {* Sorts *}
    50 
    51 code_pred [inductify] sorted .
    52 thm sorted.equation
    53 
    54 section {* Specialisation in POPLmark theory *}
    55 
    56 notation
    57   Some ("\<lfloor>_\<rfloor>")
    58 
    59 notation
    60   None ("\<bottom>")
    61 
    62 notation
    63   length ("\<parallel>_\<parallel>")
    64 
    65 notation
    66   Cons ("_ \<Colon>/ _" [66, 65] 65)
    67 
    68 primrec
    69   nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
    70 where
    71   "[]\<langle>i\<rangle> = \<bottom>"
    72 | "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> \<lfloor>x\<rfloor> | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"
    73 
    74 primrec assoc :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" ("_\<langle>_\<rangle>\<^isub>?" [90, 0] 91)
    75 where
    76   "[]\<langle>a\<rangle>\<^isub>? = \<bottom>"
    77 | "(x # xs)\<langle>a\<rangle>\<^isub>? = (if fst x = a then \<lfloor>snd x\<rfloor> else xs\<langle>a\<rangle>\<^isub>?)"
    78 
    79 primrec unique :: "('a \<times> 'b) list \<Rightarrow> bool"
    80 where
    81   "unique [] = True"
    82 | "unique (x # xs) = (xs\<langle>fst x\<rangle>\<^isub>? = \<bottom> \<and> unique xs)"
    83 
    84 datatype type =
    85     TVar nat
    86   | Top
    87   | Fun type type    (infixr "\<rightarrow>" 200)
    88   | TyAll type type  ("(3\<forall><:_./ _)" [0, 10] 10)
    89 
    90 datatype binding = VarB type | TVarB type
    91 types env = "binding list"
    92 
    93 primrec is_TVarB :: "binding \<Rightarrow> bool"
    94 where
    95   "is_TVarB (VarB T) = False"
    96 | "is_TVarB (TVarB T) = True"
    97 
    98 primrec type_ofB :: "binding \<Rightarrow> type"
    99 where
   100   "type_ofB (VarB T) = T"
   101 | "type_ofB (TVarB T) = T"
   102 
   103 primrec mapB :: "(type \<Rightarrow> type) \<Rightarrow> binding \<Rightarrow> binding"
   104 where
   105   "mapB f (VarB T) = VarB (f T)"
   106 | "mapB f (TVarB T) = TVarB (f T)"
   107 
   108 datatype trm =
   109     Var nat
   110   | Abs type trm   ("(3\<lambda>:_./ _)" [0, 10] 10)
   111   | TAbs type trm  ("(3\<lambda><:_./ _)" [0, 10] 10)
   112   | App trm trm    (infixl "\<bullet>" 200)
   113   | TApp trm type  (infixl "\<bullet>\<^isub>\<tau>" 200)
   114 
   115 primrec liftT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type" ("\<up>\<^isub>\<tau>")
   116 where
   117   "\<up>\<^isub>\<tau> n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
   118 | "\<up>\<^isub>\<tau> n k Top = Top"
   119 | "\<up>\<^isub>\<tau> n k (T \<rightarrow> U) = \<up>\<^isub>\<tau> n k T \<rightarrow> \<up>\<^isub>\<tau> n k U"
   120 | "\<up>\<^isub>\<tau> n k (\<forall><:T. U) = (\<forall><:\<up>\<^isub>\<tau> n k T. \<up>\<^isub>\<tau> n (k + 1) U)"
   121 
   122 primrec lift :: "nat \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm" ("\<up>")
   123 where
   124   "\<up> n k (Var i) = (if i < k then Var i else Var (i + n))"
   125 | "\<up> n k (\<lambda>:T. t) = (\<lambda>:\<up>\<^isub>\<tau> n k T. \<up> n (k + 1) t)"
   126 | "\<up> n k (\<lambda><:T. t) = (\<lambda><:\<up>\<^isub>\<tau> n k T. \<up> n (k + 1) t)"
   127 | "\<up> n k (s \<bullet> t) = \<up> n k s \<bullet> \<up> n k t"
   128 | "\<up> n k (t \<bullet>\<^isub>\<tau> T) = \<up> n k t \<bullet>\<^isub>\<tau> \<up>\<^isub>\<tau> n k T"
   129 
   130 primrec substTT :: "type \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("_[_ \<mapsto>\<^isub>\<tau> _]\<^isub>\<tau>" [300, 0, 0] 300)
   131 where
   132   "(TVar i)[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau> =
   133      (if k < i then TVar (i - 1) else if i = k then \<up>\<^isub>\<tau> k 0 S else TVar i)"
   134 | "Top[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau> = Top"
   135 | "(T \<rightarrow> U)[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau> = T[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau> \<rightarrow> U[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau>"
   136 | "(\<forall><:T. U)[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau> = (\<forall><:T[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau>. U[k+1 \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau>)"
   137 
   138 primrec decT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("\<down>\<^isub>\<tau>")
   139 where
   140   "\<down>\<^isub>\<tau> 0 k T = T"
   141 | "\<down>\<^isub>\<tau> (Suc n) k T = \<down>\<^isub>\<tau> n k (T[k \<mapsto>\<^isub>\<tau> Top]\<^isub>\<tau>)"
   142 
   143 primrec subst :: "trm \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm"  ("_[_ \<mapsto> _]" [300, 0, 0] 300)
   144 where
   145   "(Var i)[k \<mapsto> s] = (if k < i then Var (i - 1) else if i = k then \<up> k 0 s else Var i)"
   146 | "(t \<bullet> u)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet> u[k \<mapsto> s]"
   147 | "(t \<bullet>\<^isub>\<tau> T)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet>\<^isub>\<tau> \<down>\<^isub>\<tau> 1 k T"
   148 | "(\<lambda>:T. t)[k \<mapsto> s] = (\<lambda>:\<down>\<^isub>\<tau> 1 k T. t[k+1 \<mapsto> s])"
   149 | "(\<lambda><:T. t)[k \<mapsto> s] = (\<lambda><:\<down>\<^isub>\<tau> 1 k T. t[k+1 \<mapsto> s])"
   150 
   151 primrec substT :: "trm \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> trm"    ("_[_ \<mapsto>\<^isub>\<tau> _]" [300, 0, 0] 300)
   152 where
   153   "(Var i)[k \<mapsto>\<^isub>\<tau> S] = (if k < i then Var (i - 1) else Var i)"
   154 | "(t \<bullet> u)[k \<mapsto>\<^isub>\<tau> S] = t[k \<mapsto>\<^isub>\<tau> S] \<bullet> u[k \<mapsto>\<^isub>\<tau> S]"
   155 | "(t \<bullet>\<^isub>\<tau> T)[k \<mapsto>\<^isub>\<tau> S] = t[k \<mapsto>\<^isub>\<tau> S] \<bullet>\<^isub>\<tau> T[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau>"
   156 | "(\<lambda>:T. t)[k \<mapsto>\<^isub>\<tau> S] = (\<lambda>:T[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau>. t[k+1 \<mapsto>\<^isub>\<tau> S])"
   157 | "(\<lambda><:T. t)[k \<mapsto>\<^isub>\<tau> S] = (\<lambda><:T[k \<mapsto>\<^isub>\<tau> S]\<^isub>\<tau>. t[k+1 \<mapsto>\<^isub>\<tau> S])"
   158 
   159 primrec liftE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env" ("\<up>\<^isub>e")
   160 where
   161   "\<up>\<^isub>e n k [] = []"
   162 | "\<up>\<^isub>e n k (B \<Colon> \<Gamma>) = mapB (\<up>\<^isub>\<tau> n (k + \<parallel>\<Gamma>\<parallel>)) B \<Colon> \<up>\<^isub>e n k \<Gamma>"
   163 
   164 primrec substE :: "env \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> env"  ("_[_ \<mapsto>\<^isub>\<tau> _]\<^isub>e" [300, 0, 0] 300)
   165 where
   166   "[][k \<mapsto>\<^isub>\<tau> T]\<^isub>e = []"
   167 | "(B \<Colon> \<Gamma>)[k \<mapsto>\<^isub>\<tau> T]\<^isub>e = mapB (\<lambda>U. U[k + \<parallel>\<Gamma>\<parallel> \<mapsto>\<^isub>\<tau> T]\<^isub>\<tau>) B \<Colon> \<Gamma>[k \<mapsto>\<^isub>\<tau> T]\<^isub>e"
   168 
   169 primrec decE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env"  ("\<down>\<^isub>e")
   170 where
   171   "\<down>\<^isub>e 0 k \<Gamma> = \<Gamma>"
   172 | "\<down>\<^isub>e (Suc n) k \<Gamma> = \<down>\<^isub>e n k (\<Gamma>[k \<mapsto>\<^isub>\<tau> Top]\<^isub>e)"
   173 
   174 inductive
   175   well_formed :: "env \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^bsub>wf\<^esub> _" [50, 50] 50)
   176 where
   177   wf_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> TVar i"
   178 | wf_Top: "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> Top"
   179 | wf_arrow: "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> T \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> U \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> T \<rightarrow> U"
   180 | wf_all: "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> T \<Longrightarrow> TVarB T \<Colon> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> U \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> (\<forall><:T. U)"
   181 
   182 inductive
   183   well_formedE :: "env \<Rightarrow> bool"  ("_ \<turnstile>\<^bsub>wf\<^esub>" [50] 50)
   184   and well_formedB :: "env \<Rightarrow> binding \<Rightarrow> bool"  ("_ \<turnstile>\<^bsub>wfB\<^esub> _" [50, 50] 50)
   185 where
   186   "\<Gamma> \<turnstile>\<^bsub>wfB\<^esub> B \<equiv> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> type_ofB B"
   187 | wf_Nil: "[] \<turnstile>\<^bsub>wf\<^esub>"
   188 | wf_Cons: "\<Gamma> \<turnstile>\<^bsub>wfB\<^esub> B \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> \<Longrightarrow> B \<Colon> \<Gamma> \<turnstile>\<^bsub>wf\<^esub>"
   189 
   190 inductive_cases well_formed_cases:
   191   "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> TVar i"
   192   "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> Top"
   193   "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> T \<rightarrow> U"
   194   "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> (\<forall><:T. U)"
   195 
   196 inductive_cases well_formedE_cases:
   197   "B \<Colon> \<Gamma> \<turnstile>\<^bsub>wf\<^esub>"
   198 
   199 inductive
   200   subtyping :: "env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ <: _" [50, 50, 50] 50)
   201 where
   202   SA_Top: "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> S \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
   203 | SA_refl_TVar: "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> \<Longrightarrow> \<Gamma> \<turnstile>\<^bsub>wf\<^esub> TVar i \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: TVar i"
   204 | SA_trans_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB U\<rfloor> \<Longrightarrow>
   205     \<Gamma> \<turnstile> \<up>\<^isub>\<tau> (Suc i) 0 U <: T \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: T"
   206 | SA_arrow: "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1 \<Longrightarrow> \<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2 \<Longrightarrow> \<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T\<^isub>1 \<rightarrow> T\<^isub>2"
   207 | SA_all: "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1 \<Longrightarrow> TVarB T\<^isub>1 \<Colon> \<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2 \<Longrightarrow>
   208     \<Gamma> \<turnstile> (\<forall><:S\<^isub>1. S\<^isub>2) <: (\<forall><:T\<^isub>1. T\<^isub>2)"
   209 
   210 inductive
   211   typing :: "env \<Rightarrow> trm \<Rightarrow> type \<Rightarrow> bool"    ("_ \<turnstile> _ : _" [50, 50, 50] 50)
   212 where
   213   T_Var: "\<Gamma> \<turnstile>\<^bsub>wf\<^esub> \<Longrightarrow> \<Gamma>\<langle>i\<rangle> = \<lfloor>VarB U\<rfloor> \<Longrightarrow> T = \<up>\<^isub>\<tau> (Suc i) 0 U \<Longrightarrow> \<Gamma> \<turnstile> Var i : T"
   214 | T_Abs: "VarB T\<^isub>1 \<Colon> \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>:T\<^isub>1. t\<^isub>2) : T\<^isub>1 \<rightarrow> \<down>\<^isub>\<tau> 1 0 T\<^isub>2"
   215 | T_App: "\<Gamma> \<turnstile> t\<^isub>1 : T\<^isub>1\<^isub>1 \<rightarrow> T\<^isub>1\<^isub>2 \<Longrightarrow> \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1 \<Longrightarrow> \<Gamma> \<turnstile> t\<^isub>1 \<bullet> t\<^isub>2 : T\<^isub>1\<^isub>2"
   216 | T_TAbs: "TVarB T\<^isub>1 \<Colon> \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda><:T\<^isub>1. t\<^isub>2) : (\<forall><:T\<^isub>1. T\<^isub>2)"
   217 | T_TApp: "\<Gamma> \<turnstile> t\<^isub>1 : (\<forall><:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2) \<Longrightarrow> \<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1 \<Longrightarrow>
   218     \<Gamma> \<turnstile> t\<^isub>1 \<bullet>\<^isub>\<tau> T\<^isub>2 : T\<^isub>1\<^isub>2[0 \<mapsto>\<^isub>\<tau> T\<^isub>2]\<^isub>\<tau>"
   219 | T_Sub: "\<Gamma> \<turnstile> t : S \<Longrightarrow> \<Gamma> \<turnstile> S <: T \<Longrightarrow> \<Gamma> \<turnstile> t : T"
   220 
   221 code_pred [inductify, skip_proof] typing .
   222 
   223 thm typing.equation
   224 
   225 values 6 "{(E, t, T). typing E t T}"
   226 
   227 subsection {* Higher-order predicate *}
   228 
   229 code_pred [inductify] mapB .
   230 
   231 subsection {* Multiple instances *}
   232 
   233 inductive subtype_refl' where
   234   "\<Gamma> \<turnstile> t : T ==> \<not> (\<Gamma> \<turnstile> T <: T) ==> subtype_refl' t T"
   235 
   236 code_pred (modes: i => i => bool, o => i => bool, i => o => bool, o => o => bool) [inductify] subtype_refl' .
   237 
   238 thm subtype_refl'.equation
   239 
   240 
   241 end