src/HOL/W0/W0.thy
author nipkow
Wed Aug 18 11:09:40 2004 +0200 (2004-08-18)
changeset 15140 322485b816ac
parent 14981 e73f8140af78
child 15236 f289e8ba2bb3
permissions -rw-r--r--
import -> imports
wenzelm@12944
     1
(*  Title:      HOL/W0/W0.thy
wenzelm@12944
     2
    ID:         $Id$
wenzelm@12945
     3
    Author:     Dieter Nazareth, Tobias Nipkow, Thomas Stauner, Markus Wenzel
wenzelm@12944
     4
*)
wenzelm@12944
     5
nipkow@15140
     6
theory W0
nipkow@15140
     7
imports Main
nipkow@15140
     8
begin
wenzelm@12944
     9
wenzelm@12944
    10
section {* Universal error monad *}
wenzelm@12944
    11
wenzelm@12944
    12
datatype 'a maybe = Ok 'a | Fail
wenzelm@12944
    13
wenzelm@12944
    14
constdefs
wenzelm@12944
    15
  bind :: "'a maybe \<Rightarrow> ('a \<Rightarrow> 'b maybe) \<Rightarrow> 'b maybe"    (infixl "\<bind>" 60)
wenzelm@12944
    16
  "m \<bind> f \<equiv> case m of Ok r \<Rightarrow> f r | Fail \<Rightarrow> Fail"
wenzelm@12944
    17
wenzelm@12944
    18
syntax
wenzelm@12944
    19
  "_bind" :: "patterns \<Rightarrow> 'a maybe \<Rightarrow> 'b \<Rightarrow> 'c"    ("(_ := _;//_)" 0)
wenzelm@12944
    20
translations
wenzelm@12944
    21
  "P := E; F" == "E \<bind> (\<lambda>P. F)"
wenzelm@12944
    22
wenzelm@12944
    23
lemma bind_Ok [simp]: "(Ok s) \<bind> f = (f s)"
wenzelm@12944
    24
  by (simp add: bind_def)
wenzelm@12944
    25
wenzelm@12944
    26
lemma bind_Fail [simp]: "Fail \<bind> f = Fail"
wenzelm@12944
    27
  by (simp add: bind_def)
wenzelm@12944
    28
wenzelm@12944
    29
lemma split_bind:
wenzelm@12944
    30
    "P (res \<bind> f) = ((res = Fail \<longrightarrow> P Fail) \<and> (\<forall>s. res = Ok s \<longrightarrow> P (f s)))"
wenzelm@12944
    31
  by (induct res) simp_all
wenzelm@12944
    32
wenzelm@12944
    33
lemma split_bind_asm:
wenzelm@12944
    34
  "P (res \<bind> f) = (\<not> (res = Fail \<and> \<not> P Fail \<or> (\<exists>s. res = Ok s \<and> \<not> P (f s))))"
wenzelm@12944
    35
  by (simp split: split_bind)
wenzelm@12944
    36
wenzelm@12944
    37
lemmas bind_splits = split_bind split_bind_asm
wenzelm@12944
    38
wenzelm@12944
    39
lemma bind_eq_Fail [simp]:
wenzelm@12944
    40
  "((m \<bind> f) = Fail) = ((m = Fail) \<or> (\<exists>p. m = Ok p \<and> f p = Fail))"
wenzelm@12944
    41
  by (simp split: split_bind)
wenzelm@12944
    42
wenzelm@12944
    43
lemma rotate_Ok: "(y = Ok x) = (Ok x = y)"
wenzelm@12944
    44
  by (rule eq_sym_conv)
wenzelm@12944
    45
wenzelm@12944
    46
wenzelm@12944
    47
section {* MiniML-types and type substitutions *}
wenzelm@12944
    48
wenzelm@12944
    49
axclass type_struct \<subseteq> type
wenzelm@12944
    50
  -- {* new class for structures containing type variables *}
wenzelm@12944
    51
wenzelm@12944
    52
datatype "typ" = TVar nat | TFun "typ" "typ"    (infixr "->" 70)
wenzelm@12944
    53
  -- {* type expressions *}
wenzelm@12944
    54
wenzelm@12944
    55
types subst = "nat => typ"
wenzelm@12944
    56
  -- {* type variable substitution *}
wenzelm@12944
    57
wenzelm@12944
    58
instance "typ" :: type_struct ..
wenzelm@12944
    59
instance list :: (type_struct) type_struct ..
wenzelm@12944
    60
instance fun :: (type, type_struct) type_struct ..
wenzelm@12944
    61
wenzelm@12944
    62
wenzelm@12944
    63
subsection {* Substitutions *}
wenzelm@12944
    64
wenzelm@12944
    65
consts
wenzelm@12944
    66
  app_subst :: "subst \<Rightarrow> 'a::type_struct \<Rightarrow> 'a::type_struct"    ("$")
wenzelm@12944
    67
  -- {* extension of substitution to type structures *}
wenzelm@13537
    68
primrec (app_subst_typ)
wenzelm@12944
    69
  app_subst_TVar: "$s (TVar n) = s n"
wenzelm@12944
    70
  app_subst_Fun: "$s (t1 -> t2) = $s t1 -> $s t2"
wenzelm@12944
    71
wenzelm@12944
    72
defs (overloaded)
wenzelm@12944
    73
  app_subst_list: "$s \<equiv> map ($s)"
wenzelm@12944
    74
wenzelm@12944
    75
consts
wenzelm@12944
    76
  free_tv :: "'a::type_struct \<Rightarrow> nat set"
wenzelm@12944
    77
  -- {* @{text "free_tv s"}: the type variables occuring freely in the type structure @{text s} *}
wenzelm@12944
    78
wenzelm@13537
    79
primrec (free_tv_typ)
wenzelm@12944
    80
  "free_tv (TVar m) = {m}"
wenzelm@12944
    81
  "free_tv (t1 -> t2) = free_tv t1 \<union> free_tv t2"
wenzelm@12944
    82
wenzelm@13537
    83
primrec (free_tv_list)
wenzelm@12944
    84
  "free_tv [] = {}"
wenzelm@12944
    85
  "free_tv (x # xs) = free_tv x \<union> free_tv xs"
wenzelm@12944
    86
wenzelm@12944
    87
constdefs
wenzelm@12944
    88
  dom :: "subst \<Rightarrow> nat set"
wenzelm@12944
    89
  "dom s \<equiv> {n. s n \<noteq> TVar n}"
wenzelm@12944
    90
  -- {* domain of a substitution *}
wenzelm@12944
    91
wenzelm@12944
    92
  cod :: "subst \<Rightarrow> nat set"
wenzelm@12944
    93
  "cod s \<equiv> \<Union>m \<in> dom s. free_tv (s m)"
wenzelm@12944
    94
  -- {* codomain of a substitutions: the introduced variables *}
wenzelm@12944
    95
wenzelm@12944
    96
defs
wenzelm@12944
    97
  free_tv_subst: "free_tv s \<equiv> dom s \<union> cod s"
wenzelm@12944
    98
wenzelm@12944
    99
text {*
wenzelm@12944
   100
  @{text "new_tv s n"} checks whether @{text n} is a new type variable
wenzelm@12944
   101
  wrt.\ a type structure @{text s}, i.e.\ whether @{text n} is greater
wenzelm@12944
   102
  than any type variable occuring in the type structure.
wenzelm@12944
   103
*}
wenzelm@12944
   104
wenzelm@12944
   105
constdefs
wenzelm@12944
   106
  new_tv :: "nat \<Rightarrow> 'a::type_struct \<Rightarrow> bool"
wenzelm@12944
   107
  "new_tv n ts \<equiv> \<forall>m. m \<in> free_tv ts \<longrightarrow> m < n"
wenzelm@12944
   108
wenzelm@12944
   109
wenzelm@12944
   110
subsubsection {* Identity substitution *}
wenzelm@12944
   111
wenzelm@12944
   112
constdefs
wenzelm@12944
   113
  id_subst :: subst
wenzelm@12944
   114
  "id_subst \<equiv> \<lambda>n. TVar n"
wenzelm@12944
   115
wenzelm@12944
   116
lemma app_subst_id_te [simp]:
wenzelm@12944
   117
  "$id_subst = (\<lambda>t::typ. t)"
wenzelm@12944
   118
  -- {* application of @{text id_subst} does not change type expression *}
wenzelm@12944
   119
proof
wenzelm@12944
   120
  fix t :: "typ"
wenzelm@12944
   121
  show "$id_subst t = t"
wenzelm@12944
   122
    by (induct t) (simp_all add: id_subst_def)
wenzelm@12944
   123
qed
wenzelm@12944
   124
wenzelm@12944
   125
lemma app_subst_id_tel [simp]: "$id_subst = (\<lambda>ts::typ list. ts)"
wenzelm@12944
   126
  -- {* application of @{text id_subst} does not change list of type expressions *}
wenzelm@12944
   127
proof
wenzelm@12944
   128
  fix ts :: "typ list"
wenzelm@12944
   129
  show "$id_subst ts = ts"
wenzelm@12944
   130
    by (induct ts) (simp_all add: app_subst_list)
wenzelm@12944
   131
qed
wenzelm@12944
   132
wenzelm@12944
   133
lemma o_id_subst [simp]: "$s o id_subst = s"
wenzelm@12944
   134
  by (rule ext) (simp add: id_subst_def)
wenzelm@12944
   135
wenzelm@12944
   136
lemma dom_id_subst [simp]: "dom id_subst = {}"
nipkow@13890
   137
  by (simp add: dom_def id_subst_def)
wenzelm@12944
   138
wenzelm@12944
   139
lemma cod_id_subst [simp]: "cod id_subst = {}"
wenzelm@12944
   140
  by (simp add: cod_def)
wenzelm@12944
   141
wenzelm@12944
   142
lemma free_tv_id_subst [simp]: "free_tv id_subst = {}"
wenzelm@12944
   143
  by (simp add: free_tv_subst)
wenzelm@12944
   144
wenzelm@12944
   145
wenzelm@12944
   146
lemma cod_app_subst [simp]:
wenzelm@12944
   147
  assumes free: "v \<in> free_tv (s n)"
wenzelm@12944
   148
    and neq: "v \<noteq> n"
wenzelm@12944
   149
  shows "v \<in> cod s"
wenzelm@12944
   150
proof -
wenzelm@12944
   151
  have "s n \<noteq> TVar n"
wenzelm@12944
   152
  proof
wenzelm@12944
   153
    assume "s n = TVar n"
wenzelm@12944
   154
    with free have "v = n" by simp
wenzelm@12944
   155
    with neq show False ..
wenzelm@12944
   156
  qed
wenzelm@12944
   157
  with free show ?thesis
wenzelm@12944
   158
    by (auto simp add: dom_def cod_def)
wenzelm@12944
   159
qed
wenzelm@12944
   160
wenzelm@12944
   161
lemma subst_comp_te: "$g ($f t :: typ) = $(\<lambda>x. $g (f x)) t"
wenzelm@12944
   162
  -- {* composition of substitutions *}
wenzelm@12944
   163
  by (induct t) simp_all
wenzelm@12944
   164
wenzelm@12944
   165
lemma subst_comp_tel: "$g ($f ts :: typ list) = $(\<lambda>x. $g (f x)) ts"
wenzelm@12944
   166
  by (induct ts) (simp_all add: app_subst_list subst_comp_te)
wenzelm@12944
   167
wenzelm@12944
   168
wenzelm@12944
   169
lemma app_subst_Nil [simp]: "$s [] = []"
wenzelm@12944
   170
  by (simp add: app_subst_list)
wenzelm@12944
   171
wenzelm@12944
   172
lemma app_subst_Cons [simp]: "$s (t # ts) = ($s t) # ($s ts)"
wenzelm@12944
   173
  by (simp add: app_subst_list)
wenzelm@12944
   174
wenzelm@12944
   175
lemma new_tv_TVar [simp]: "new_tv n (TVar m) = (m < n)"
wenzelm@12944
   176
  by (simp add: new_tv_def)
wenzelm@12944
   177
wenzelm@12944
   178
lemma new_tv_Fun [simp]:
wenzelm@12944
   179
  "new_tv n (t1 -> t2) = (new_tv n t1 \<and> new_tv n t2)"
wenzelm@12944
   180
  by (auto simp add: new_tv_def)
wenzelm@12944
   181
wenzelm@12944
   182
lemma new_tv_Nil [simp]: "new_tv n []"
wenzelm@12944
   183
  by (simp add: new_tv_def)
wenzelm@12944
   184
wenzelm@12944
   185
lemma new_tv_Cons [simp]: "new_tv n (t # ts) = (new_tv n t \<and> new_tv n ts)"
wenzelm@12944
   186
  by (auto simp add: new_tv_def)
wenzelm@12944
   187
wenzelm@12944
   188
lemma new_tv_id_subst [simp]: "new_tv n id_subst"
wenzelm@12944
   189
  by (simp add: id_subst_def new_tv_def free_tv_subst dom_def cod_def)
wenzelm@12944
   190
wenzelm@12944
   191
lemma new_tv_subst:
wenzelm@12944
   192
  "new_tv n s =
wenzelm@12944
   193
    ((\<forall>m. n \<le> m \<longrightarrow> s m = TVar m) \<and>
wenzelm@12944
   194
     (\<forall>l. l < n \<longrightarrow> new_tv n (s l)))"
wenzelm@12944
   195
  apply (unfold new_tv_def)
wenzelm@12944
   196
  apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   197
  -- {* @{text \<Longrightarrow>} *}
wenzelm@12944
   198
    apply (tactic {* fast_tac (HOL_cs addDs [leD] addss (simpset()
wenzelm@12944
   199
      addsimps [thm "free_tv_subst", thm "dom_def"])) 1 *})
wenzelm@12944
   200
   apply (subgoal_tac "m \<in> cod s \<or> s l = TVar l")
wenzelm@12944
   201
    apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   202
     apply (tactic {* fast_tac (HOL_cs addDs [UnI2] addss (simpset()
wenzelm@12944
   203
       addsimps [thm "free_tv_subst"])) 1 *})
wenzelm@12944
   204
    apply (drule_tac P = "\<lambda>x. m \<in> free_tv x" in subst, assumption)
wenzelm@12944
   205
    apply simp
wenzelm@12944
   206
   apply (tactic {* fast_tac (set_cs addss (simpset()
wenzelm@12944
   207
     addsimps [thm "free_tv_subst", thm "cod_def", thm "dom_def"])) 1 *})
wenzelm@12944
   208
  -- {* @{text \<Longleftarrow>} *}
wenzelm@12944
   209
  apply (unfold free_tv_subst cod_def dom_def)
wenzelm@12944
   210
  apply (tactic "safe_tac set_cs")
wenzelm@12944
   211
   apply (cut_tac m = m and n = n in less_linear)
wenzelm@12944
   212
   apply (tactic "fast_tac (HOL_cs addSIs [less_or_eq_imp_le]) 1")
wenzelm@12944
   213
  apply (cut_tac m = ma and n = n in less_linear)
wenzelm@12944
   214
  apply (fast intro!: less_or_eq_imp_le)
wenzelm@12944
   215
  done
wenzelm@12944
   216
wenzelm@12944
   217
lemma new_tv_list: "new_tv n x = (\<forall>y \<in> set x. new_tv n y)"
wenzelm@12944
   218
  by (induct x) simp_all
wenzelm@12944
   219
wenzelm@12944
   220
lemma subst_te_new_tv [simp]:
wenzelm@12944
   221
  "new_tv n (t::typ) \<longrightarrow> $(\<lambda>x. if x = n then t' else s x) t = $s t"
wenzelm@12944
   222
  -- {* substitution affects only variables occurring freely *}
wenzelm@12944
   223
  by (induct t) simp_all
wenzelm@12944
   224
wenzelm@12944
   225
lemma subst_tel_new_tv [simp]:
wenzelm@12944
   226
  "new_tv n (ts::typ list) \<longrightarrow> $(\<lambda>x. if x = n then t else s x) ts = $s ts"
wenzelm@12944
   227
  by (induct ts) simp_all
wenzelm@12944
   228
wenzelm@12944
   229
lemma new_tv_le: "n \<le> m \<Longrightarrow> new_tv n (t::typ) \<Longrightarrow> new_tv m t"
wenzelm@12944
   230
  -- {* all greater variables are also new *}
wenzelm@12944
   231
proof (induct t)
wenzelm@12944
   232
  case (TVar n)
wenzelm@12944
   233
  thus ?case by (auto intro: less_le_trans)
wenzelm@12944
   234
next
wenzelm@12944
   235
  case TFun
wenzelm@12944
   236
  thus ?case by simp
wenzelm@12944
   237
qed
wenzelm@12944
   238
wenzelm@12944
   239
lemma [simp]: "new_tv n t \<Longrightarrow> new_tv (Suc n) (t::typ)"
wenzelm@12944
   240
  by (rule lessI [THEN less_imp_le [THEN new_tv_le]])
wenzelm@12944
   241
wenzelm@12944
   242
lemma new_tv_list_le:
wenzelm@12944
   243
  "n \<le> m \<Longrightarrow> new_tv n (ts::typ list) \<Longrightarrow> new_tv m ts"
wenzelm@12944
   244
proof (induct ts)
wenzelm@12944
   245
  case Nil
wenzelm@12944
   246
  thus ?case by simp
wenzelm@12944
   247
next
wenzelm@12944
   248
  case Cons
wenzelm@12944
   249
  thus ?case by (auto intro: new_tv_le)
wenzelm@12944
   250
qed
wenzelm@12944
   251
wenzelm@12944
   252
lemma [simp]: "new_tv n ts \<Longrightarrow> new_tv (Suc n) (ts::typ list)"
wenzelm@12944
   253
  by (rule lessI [THEN less_imp_le [THEN new_tv_list_le]])
wenzelm@12944
   254
wenzelm@12944
   255
lemma new_tv_subst_le: "n \<le> m \<Longrightarrow> new_tv n (s::subst) \<Longrightarrow> new_tv m s"
wenzelm@12944
   256
  apply (simp add: new_tv_subst)
wenzelm@12944
   257
  apply clarify
wenzelm@12944
   258
  apply (rule_tac P = "l < n" and Q = "n <= l" in disjE)
wenzelm@12944
   259
    apply clarify
wenzelm@12944
   260
    apply (simp_all add: new_tv_le)
wenzelm@12944
   261
  done
wenzelm@12944
   262
wenzelm@12944
   263
lemma [simp]: "new_tv n s \<Longrightarrow> new_tv (Suc n) (s::subst)"
wenzelm@12944
   264
  by (rule lessI [THEN less_imp_le [THEN new_tv_subst_le]])
wenzelm@12944
   265
wenzelm@12944
   266
lemma new_tv_subst_var:
wenzelm@12944
   267
    "n < m \<Longrightarrow> new_tv m (s::subst) \<Longrightarrow> new_tv m (s n)"
wenzelm@12944
   268
  -- {* @{text new_tv} property remains if a substitution is applied *}
wenzelm@12944
   269
  by (simp add: new_tv_subst)
wenzelm@12944
   270
wenzelm@12944
   271
lemma new_tv_subst_te [simp]:
wenzelm@12944
   272
    "new_tv n s \<Longrightarrow> new_tv n (t::typ) \<Longrightarrow> new_tv n ($s t)"
wenzelm@12944
   273
  by (induct t) (auto simp add: new_tv_subst)
wenzelm@12944
   274
wenzelm@12944
   275
lemma new_tv_subst_tel [simp]:
wenzelm@12944
   276
    "new_tv n s \<Longrightarrow> new_tv n (ts::typ list) \<Longrightarrow> new_tv n ($s ts)"
wenzelm@12944
   277
  by (induct ts) (fastsimp simp add: new_tv_subst)+
wenzelm@12944
   278
wenzelm@12944
   279
lemma new_tv_Suc_list: "new_tv n ts --> new_tv (Suc n) (TVar n # ts)"
wenzelm@12944
   280
  -- {* auxilliary lemma *}
wenzelm@12944
   281
  by (simp add: new_tv_list)
wenzelm@12944
   282
wenzelm@12944
   283
lemma new_tv_subst_comp_1 [simp]:
wenzelm@12944
   284
    "new_tv n (s::subst) \<Longrightarrow> new_tv n r \<Longrightarrow> new_tv n ($r o s)"
wenzelm@12944
   285
  -- {* composition of substitutions preserves @{text new_tv} proposition *}
wenzelm@12944
   286
  by (simp add: new_tv_subst)
wenzelm@12944
   287
wenzelm@12944
   288
lemma new_tv_subst_comp_2 [simp]:
wenzelm@12944
   289
    "new_tv n (s::subst) \<Longrightarrow> new_tv n r \<Longrightarrow> new_tv n (\<lambda>v. $r (s v))"
wenzelm@12944
   290
  by (simp add: new_tv_subst)
wenzelm@12944
   291
wenzelm@12944
   292
lemma new_tv_not_free_tv [simp]: "new_tv n ts \<Longrightarrow> n \<notin> free_tv ts"
wenzelm@12944
   293
  -- {* new type variables do not occur freely in a type structure *}
wenzelm@12944
   294
  by (auto simp add: new_tv_def)
wenzelm@12944
   295
wenzelm@12944
   296
lemma ftv_mem_sub_ftv_list [simp]:
wenzelm@12944
   297
    "(t::typ) \<in> set ts \<Longrightarrow> free_tv t \<subseteq> free_tv ts"
wenzelm@12944
   298
  by (induct ts) auto
wenzelm@12944
   299
wenzelm@12944
   300
text {*
wenzelm@12944
   301
  If two substitutions yield the same result if applied to a type
wenzelm@12944
   302
  structure the substitutions coincide on the free type variables
wenzelm@12944
   303
  occurring in the type structure.
wenzelm@12944
   304
*}
wenzelm@12944
   305
wenzelm@12944
   306
lemma eq_subst_te_eq_free:
wenzelm@12944
   307
    "$s1 (t::typ) = $s2 t \<Longrightarrow> n \<in> free_tv t \<Longrightarrow> s1 n = s2 n"
wenzelm@12944
   308
  by (induct t) auto
wenzelm@12944
   309
wenzelm@12944
   310
lemma eq_free_eq_subst_te:
wenzelm@12944
   311
    "(\<forall>n. n \<in> free_tv t --> s1 n = s2 n) \<Longrightarrow> $s1 (t::typ) = $s2 t"
wenzelm@12944
   312
  by (induct t) auto
wenzelm@12944
   313
wenzelm@12944
   314
lemma eq_subst_tel_eq_free:
wenzelm@12944
   315
    "$s1 (ts::typ list) = $s2 ts \<Longrightarrow> n \<in> free_tv ts \<Longrightarrow> s1 n = s2 n"
wenzelm@12944
   316
  by (induct ts) (auto intro: eq_subst_te_eq_free)
wenzelm@12944
   317
wenzelm@12944
   318
lemma eq_free_eq_subst_tel:
wenzelm@12944
   319
    "(\<forall>n. n \<in> free_tv ts --> s1 n = s2 n) \<Longrightarrow> $s1 (ts::typ list) = $s2 ts"
wenzelm@12944
   320
  by (induct ts) (auto intro: eq_free_eq_subst_te)
wenzelm@12944
   321
wenzelm@12944
   322
text {*
wenzelm@12944
   323
  \medskip Some useful lemmas.
wenzelm@12944
   324
*}
wenzelm@12944
   325
wenzelm@12944
   326
lemma codD: "v \<in> cod s \<Longrightarrow> v \<in> free_tv s"
wenzelm@12944
   327
  by (simp add: free_tv_subst)
wenzelm@12944
   328
wenzelm@12944
   329
lemma not_free_impl_id: "x \<notin> free_tv s \<Longrightarrow> s x = TVar x"
wenzelm@12944
   330
  by (simp add: free_tv_subst dom_def)
wenzelm@12944
   331
wenzelm@12944
   332
lemma free_tv_le_new_tv: "new_tv n t \<Longrightarrow> m \<in> free_tv t \<Longrightarrow> m < n"
wenzelm@12944
   333
  by (unfold new_tv_def) fast
wenzelm@12944
   334
wenzelm@12944
   335
lemma free_tv_subst_var: "free_tv (s (v::nat)) \<le> insert v (cod s)"
wenzelm@12944
   336
  by (cases "v \<in> dom s") (auto simp add: cod_def dom_def)
wenzelm@12944
   337
wenzelm@12944
   338
lemma free_tv_app_subst_te: "free_tv ($s (t::typ)) \<subseteq> cod s \<union> free_tv t"
wenzelm@12944
   339
  by (induct t) (auto simp add: free_tv_subst_var)
wenzelm@12944
   340
wenzelm@12944
   341
lemma free_tv_app_subst_tel: "free_tv ($s (ts::typ list)) \<subseteq> cod s \<union> free_tv ts"
wenzelm@12944
   342
  apply (induct ts)
wenzelm@12944
   343
   apply simp
wenzelm@12944
   344
  apply (cut_tac free_tv_app_subst_te)
wenzelm@12944
   345
  apply fastsimp
wenzelm@12944
   346
  done
wenzelm@12944
   347
wenzelm@12944
   348
lemma free_tv_comp_subst:
wenzelm@12944
   349
    "free_tv (\<lambda>u::nat. $s1 (s2 u) :: typ) \<subseteq> free_tv s1 \<union> free_tv s2"
wenzelm@12944
   350
  apply (unfold free_tv_subst dom_def)
wenzelm@12944
   351
  apply (tactic {*
wenzelm@12944
   352
    fast_tac (set_cs addSDs [thm "free_tv_app_subst_te" RS subsetD,
wenzelm@12944
   353
    thm "free_tv_subst_var" RS subsetD]
wenzelm@12944
   354
    addss (simpset() delsimps bex_simps
wenzelm@12944
   355
    addsimps [thm "cod_def", thm "dom_def"])) 1 *})
wenzelm@12944
   356
  done
wenzelm@12944
   357
wenzelm@12944
   358
wenzelm@12944
   359
subsection {* Most general unifiers *}
wenzelm@12944
   360
wenzelm@12944
   361
consts
wenzelm@12944
   362
  mgu :: "typ \<Rightarrow> typ \<Rightarrow> subst maybe"
wenzelm@12944
   363
axioms
wenzelm@12944
   364
  mgu_eq [simp]: "mgu t1 t2 = Ok u \<Longrightarrow> $u t1 = $u t2"
wenzelm@12944
   365
  mgu_mg [simp]: "mgu t1 t2 = Ok u \<Longrightarrow> $s t1 = $s t2 \<Longrightarrow> \<exists>r. s = $r o u"
wenzelm@12944
   366
  mgu_Ok: "$s t1 = $s t2 \<Longrightarrow> \<exists>u. mgu t1 t2 = Ok u"
wenzelm@12944
   367
  mgu_free [simp]: "mgu t1 t2 = Ok u \<Longrightarrow> free_tv u \<subseteq> free_tv t1 \<union> free_tv t2"
wenzelm@12944
   368
wenzelm@12944
   369
lemma mgu_new: "mgu t1 t2 = Ok u \<Longrightarrow> new_tv n t1 \<Longrightarrow> new_tv n t2 \<Longrightarrow> new_tv n u"
wenzelm@12944
   370
  -- {* @{text mgu} does not introduce new type variables *}
wenzelm@12944
   371
  by (unfold new_tv_def) (blast dest: mgu_free)
wenzelm@12944
   372
wenzelm@12944
   373
wenzelm@12944
   374
section {* Mini-ML with type inference rules *}
wenzelm@12944
   375
wenzelm@12944
   376
datatype
wenzelm@12944
   377
  expr = Var nat | Abs expr | App expr expr
wenzelm@12944
   378
wenzelm@12944
   379
wenzelm@12944
   380
text {* Type inference rules. *}
wenzelm@12944
   381
wenzelm@12944
   382
consts
wenzelm@12944
   383
  has_type :: "(typ list \<times> expr \<times> typ) set"
wenzelm@12944
   384
wenzelm@12944
   385
syntax
wenzelm@12944
   386
  "_has_type" :: "typ list \<Rightarrow> expr \<Rightarrow> typ \<Rightarrow> bool"
wenzelm@12944
   387
    ("((_) |-/ (_) :: (_))" [60, 0, 60] 60)
wenzelm@12944
   388
translations
wenzelm@12944
   389
  "a |- e :: t" == "(a, e, t) \<in> has_type"
wenzelm@12944
   390
wenzelm@12944
   391
inductive has_type
wenzelm@12944
   392
  intros
wenzelm@12944
   393
    Var: "n < length a \<Longrightarrow> a |- Var n :: a ! n"
wenzelm@12944
   394
    Abs: "t1#a |- e :: t2 \<Longrightarrow> a |- Abs e :: t1 -> t2"
wenzelm@12944
   395
    App: "a |- e1 :: t2 -> t1 \<Longrightarrow> a |- e2 :: t2
wenzelm@12944
   396
      \<Longrightarrow> a |- App e1 e2 :: t1"
wenzelm@12944
   397
wenzelm@12944
   398
wenzelm@12944
   399
text {* Type assigment is closed wrt.\ substitution. *}
wenzelm@12944
   400
wenzelm@12944
   401
lemma has_type_subst_closed: "a |- e :: t ==> $s a |- e :: $s t"
wenzelm@12944
   402
proof -
wenzelm@12944
   403
  assume "a |- e :: t"
wenzelm@12944
   404
  thus ?thesis (is "?P a e t")
wenzelm@12944
   405
  proof induct
wenzelm@12944
   406
    case (Var a n)
wenzelm@12944
   407
    hence "n < length (map ($ s) a)" by simp
wenzelm@12944
   408
    hence "map ($ s) a |- Var n :: map ($ s) a ! n"
wenzelm@12944
   409
      by (rule has_type.Var)
wenzelm@12944
   410
    also have "map ($ s) a ! n = $ s (a ! n)"
wenzelm@12944
   411
      by (rule nth_map)
wenzelm@12944
   412
    also have "map ($ s) a = $ s a"
wenzelm@12944
   413
      by (simp only: app_subst_list)
wenzelm@12944
   414
    finally show "?P a (Var n) (a ! n)" .
wenzelm@12944
   415
  next
wenzelm@12944
   416
    case (Abs a e t1 t2)
wenzelm@12944
   417
    hence "$ s t1 # map ($ s) a |- e :: $ s t2"
wenzelm@12944
   418
      by (simp add: app_subst_list)
wenzelm@12944
   419
    hence "map ($ s) a |- Abs e :: $ s t1 -> $ s t2"
wenzelm@12944
   420
      by (rule has_type.Abs)
wenzelm@12944
   421
    thus "?P a (Abs e) (t1 -> t2)"
wenzelm@12944
   422
      by (simp add: app_subst_list)
wenzelm@12944
   423
  next
wenzelm@12944
   424
    case App
wenzelm@12944
   425
    thus ?case by (simp add: has_type.App)
wenzelm@12944
   426
  qed
wenzelm@12944
   427
qed
wenzelm@12944
   428
wenzelm@12944
   429
wenzelm@12961
   430
section {* Correctness and completeness of the type inference algorithm W *}
wenzelm@12944
   431
wenzelm@12944
   432
consts
wenzelm@12944
   433
  W :: "expr \<Rightarrow> typ list \<Rightarrow> nat \<Rightarrow> (subst \<times> typ \<times> nat) maybe"  ("\<W>")
wenzelm@12944
   434
wenzelm@12944
   435
primrec
wenzelm@12944
   436
  "\<W> (Var i) a n =
wenzelm@12944
   437
    (if i < length a then Ok (id_subst, a ! i, n) else Fail)"
wenzelm@12944
   438
  "\<W> (Abs e) a n =
wenzelm@12944
   439
    ((s, t, m) := \<W> e (TVar n # a) (Suc n);
wenzelm@12944
   440
     Ok (s, (s n) -> t, m))"
wenzelm@12944
   441
  "\<W> (App e1 e2) a n =
wenzelm@12944
   442
    ((s1, t1, m1) := \<W> e1 a n;
wenzelm@12944
   443
     (s2, t2, m2) := \<W> e2 ($s1 a) m1;
wenzelm@12944
   444
     u := mgu ($ s2 t1) (t2 -> TVar m2);
wenzelm@12944
   445
     Ok ($u o $s2 o s1, $u (TVar m2), Suc m2))"
wenzelm@12944
   446
wenzelm@12944
   447
theorem W_correct: "!!a s t m n. Ok (s, t, m) = \<W> e a n ==> $s a |- e :: t"
wenzelm@12944
   448
  (is "PROP ?P e")
wenzelm@12944
   449
proof (induct e)
wenzelm@12944
   450
  fix a s t m n
wenzelm@12944
   451
  {
wenzelm@12944
   452
    fix i
wenzelm@12944
   453
    assume "Ok (s, t, m) = \<W> (Var i) a n"
wenzelm@12944
   454
    thus "$s a |- Var i :: t" by (simp add: has_type.Var split: if_splits)
wenzelm@12944
   455
  next
wenzelm@12944
   456
    fix e assume hyp: "PROP ?P e"
wenzelm@12944
   457
    assume "Ok (s, t, m) = \<W> (Abs e) a n"
wenzelm@12944
   458
    then obtain t' where "t = s n -> t'"
wenzelm@12944
   459
        and "Ok (s, t', m) = \<W> e (TVar n # a) (Suc n)"
wenzelm@12944
   460
      by (auto split: bind_splits)
wenzelm@12944
   461
    with hyp show "$s a |- Abs e :: t"
wenzelm@12944
   462
      by (force intro: has_type.Abs)
wenzelm@12944
   463
  next
wenzelm@12944
   464
    fix e1 e2 assume hyp1: "PROP ?P e1" and hyp2: "PROP ?P e2"
wenzelm@12944
   465
    assume "Ok (s, t, m) = \<W> (App e1 e2) a n"
wenzelm@12944
   466
    then obtain s1 t1 n1 s2 t2 n2 u where
wenzelm@12944
   467
          s: "s = $u o $s2 o s1"
wenzelm@12944
   468
        and t: "t = u n2"
wenzelm@12944
   469
        and mgu_ok: "mgu ($s2 t1) (t2 -> TVar n2) = Ok u"
wenzelm@12944
   470
        and W1_ok: "Ok (s1, t1, n1) = \<W> e1 a n"
wenzelm@12944
   471
        and W2_ok: "Ok (s2, t2, n2) = \<W> e2 ($s1 a) n1"
wenzelm@12944
   472
      by (auto split: bind_splits simp: that)
wenzelm@12944
   473
    show "$s a |- App e1 e2 :: t"
wenzelm@12944
   474
    proof (rule has_type.App)
wenzelm@12944
   475
      from s have s': "$u ($s2 ($s1 a)) = $s a"
wenzelm@12944
   476
        by (simp add: subst_comp_tel o_def)
wenzelm@12944
   477
      show "$s a |- e1 :: $u t2 -> t"
wenzelm@12944
   478
      proof -
wenzelm@12944
   479
        from W1_ok have "$s1 a |- e1 :: t1" by (rule hyp1)
wenzelm@12944
   480
        hence "$u ($s2 ($s1 a)) |- e1 :: $u ($s2 t1)"
wenzelm@12944
   481
          by (intro has_type_subst_closed)
wenzelm@12944
   482
        with s' t mgu_ok show ?thesis by simp
wenzelm@12944
   483
      qed
wenzelm@12944
   484
      show "$s a |- e2 :: $u t2"
wenzelm@12944
   485
      proof -
wenzelm@12944
   486
        from W2_ok have "$s2 ($s1 a) |- e2 :: t2" by (rule hyp2)
wenzelm@12944
   487
        hence "$u ($s2 ($s1 a)) |- e2 :: $u t2"
wenzelm@12944
   488
          by (rule has_type_subst_closed)
wenzelm@12944
   489
        with s' show ?thesis by simp
wenzelm@12944
   490
      qed
wenzelm@12944
   491
    qed
wenzelm@12944
   492
  }
wenzelm@12944
   493
qed
wenzelm@12944
   494
wenzelm@12944
   495
wenzelm@12944
   496
inductive_cases has_type_casesE:
wenzelm@12944
   497
  "s |- Var n :: t"
wenzelm@12944
   498
  "s |- Abs e :: t"
wenzelm@12944
   499
  "s |- App e1 e2 ::t"
wenzelm@12944
   500
wenzelm@12944
   501
wenzelm@12944
   502
lemmas [simp] = Suc_le_lessD
wenzelm@12944
   503
  and [simp del] = less_imp_le ex_simps all_simps
wenzelm@12944
   504
wenzelm@12944
   505
lemma W_var_ge [simp]: "!!a n s t m. \<W> e a n = Ok (s, t, m) \<Longrightarrow> n \<le> m"
wenzelm@12944
   506
  -- {* the resulting type variable is always greater or equal than the given one *}
wenzelm@12944
   507
  apply (atomize (full))
wenzelm@12944
   508
  apply (induct e)
wenzelm@12944
   509
    txt {* case @{text "Var n"} *}
wenzelm@12944
   510
    apply clarsimp
wenzelm@12944
   511
   txt {* case @{text "Abs e"} *}
wenzelm@12944
   512
   apply (simp split add: split_bind)
wenzelm@12944
   513
   apply (fast dest: Suc_leD)
wenzelm@12944
   514
  txt {* case @{text "App e1 e2"} *}
wenzelm@12944
   515
  apply (simp (no_asm) split add: split_bind)
wenzelm@12944
   516
  apply (intro strip)
wenzelm@12944
   517
  apply (rename_tac s t na sa ta nb sb)
wenzelm@12944
   518
  apply (erule_tac x = a in allE)
wenzelm@12944
   519
  apply (erule_tac x = n in allE)
wenzelm@12944
   520
  apply (erule_tac x = "$s a" in allE)
wenzelm@12944
   521
  apply (erule_tac x = s in allE)
wenzelm@12944
   522
  apply (erule_tac x = t in allE)
wenzelm@12944
   523
  apply (erule_tac x = na in allE)
wenzelm@12944
   524
  apply (erule_tac x = na in allE)
wenzelm@12944
   525
  apply (simp add: eq_sym_conv)
wenzelm@12944
   526
  done
wenzelm@12944
   527
wenzelm@12944
   528
lemma W_var_geD: "Ok (s, t, m) = \<W> e a n \<Longrightarrow> n \<le> m"
wenzelm@12944
   529
  by (simp add: eq_sym_conv)
wenzelm@12944
   530
wenzelm@12944
   531
lemma new_tv_W: "!!n a s t m.
wenzelm@12944
   532
  new_tv n a \<Longrightarrow> \<W> e a n = Ok (s, t, m) \<Longrightarrow> new_tv m s & new_tv m t"
wenzelm@12944
   533
  -- {* resulting type variable is new *}
wenzelm@12944
   534
  apply (atomize (full))
wenzelm@12944
   535
  apply (induct e)
wenzelm@12944
   536
    txt {* case @{text "Var n"} *}
wenzelm@12944
   537
    apply clarsimp
wenzelm@12944
   538
    apply (force elim: list_ball_nth simp add: id_subst_def new_tv_list new_tv_subst)
wenzelm@12944
   539
   txt {* case @{text "Abs e"} *}
wenzelm@12944
   540
   apply (simp (no_asm) add: new_tv_subst new_tv_Suc_list split add: split_bind)
wenzelm@12944
   541
   apply (intro strip)
wenzelm@12944
   542
   apply (erule_tac x = "Suc n" in allE)
wenzelm@12944
   543
   apply (erule_tac x = "TVar n # a" in allE)
wenzelm@12944
   544
   apply (fastsimp simp add: new_tv_subst new_tv_Suc_list)
wenzelm@12944
   545
  txt {* case @{text "App e1 e2"} *}
wenzelm@12944
   546
  apply (simp (no_asm) split add: split_bind)
wenzelm@12944
   547
  apply (intro strip)
wenzelm@12944
   548
  apply (rename_tac s t na sa ta nb sb)
wenzelm@12944
   549
  apply (erule_tac x = n in allE)
wenzelm@12944
   550
  apply (erule_tac x = a in allE)
wenzelm@12944
   551
  apply (erule_tac x = s in allE)
wenzelm@12944
   552
  apply (erule_tac x = t in allE)
wenzelm@12944
   553
  apply (erule_tac x = na in allE)
wenzelm@12944
   554
  apply (erule_tac x = na in allE)
wenzelm@12944
   555
  apply (simp add: eq_sym_conv)
wenzelm@12944
   556
  apply (erule_tac x = "$s a" in allE)
wenzelm@12944
   557
  apply (erule_tac x = sa in allE)
wenzelm@12944
   558
  apply (erule_tac x = ta in allE)
wenzelm@12944
   559
  apply (erule_tac x = nb in allE)
wenzelm@12944
   560
  apply (simp add: o_def rotate_Ok)
wenzelm@12944
   561
  apply (rule conjI)
wenzelm@12944
   562
   apply (rule new_tv_subst_comp_2)
wenzelm@12944
   563
    apply (rule new_tv_subst_comp_2)
wenzelm@12944
   564
     apply (rule lessI [THEN less_imp_le, THEN new_tv_subst_le])
wenzelm@12944
   565
     apply (rule_tac n = na in new_tv_subst_le)
wenzelm@12944
   566
      apply (simp add: rotate_Ok)
wenzelm@12944
   567
     apply (simp (no_asm_simp))
wenzelm@12944
   568
    apply (fast dest: W_var_geD intro: new_tv_list_le new_tv_subst_tel
wenzelm@12944
   569
      lessI [THEN less_imp_le, THEN new_tv_subst_le])
wenzelm@12944
   570
   apply (erule sym [THEN mgu_new])
wenzelm@12944
   571
    apply (best dest: W_var_geD intro: new_tv_subst_te new_tv_list_le new_tv_subst_tel
wenzelm@12944
   572
      lessI [THEN less_imp_le, THEN new_tv_le] lessI [THEN less_imp_le, THEN new_tv_subst_le]
wenzelm@12944
   573
      new_tv_le)
wenzelm@12944
   574
   apply (tactic {* fast_tac (HOL_cs addDs [thm "W_var_geD"]
wenzelm@12944
   575
     addIs [thm "new_tv_list_le", thm "new_tv_subst_tel", thm "new_tv_le"]
wenzelm@12944
   576
     addss (simpset())) 1 *})
wenzelm@12944
   577
  apply (rule lessI [THEN new_tv_subst_var])
wenzelm@12944
   578
  apply (erule sym [THEN mgu_new])
wenzelm@12944
   579
    apply (bestsimp intro!: lessI [THEN less_imp_le, THEN new_tv_le] new_tv_subst_te
wenzelm@12944
   580
      dest!: W_var_geD intro: new_tv_list_le new_tv_subst_tel
wenzelm@12944
   581
        lessI [THEN less_imp_le, THEN new_tv_subst_le] new_tv_le)
wenzelm@12944
   582
  apply (tactic {* fast_tac (HOL_cs addDs [thm "W_var_geD"]
wenzelm@12944
   583
    addIs [thm "new_tv_list_le", thm "new_tv_subst_tel", thm "new_tv_le"]
wenzelm@12944
   584
    addss (simpset())) 1 *})
wenzelm@12944
   585
  done
wenzelm@12944
   586
wenzelm@12944
   587
lemma free_tv_W: "!!n a s t m v. \<W> e a n = Ok (s, t, m) \<Longrightarrow>
wenzelm@12944
   588
    (v \<in> free_tv s \<or> v \<in> free_tv t) \<Longrightarrow> v < n \<Longrightarrow> v \<in> free_tv a"
wenzelm@12944
   589
  apply (atomize (full))
wenzelm@12944
   590
  apply (induct e)
wenzelm@12944
   591
    txt {* case @{text "Var n"} *}
wenzelm@12944
   592
    apply clarsimp
wenzelm@12944
   593
    apply (tactic {* fast_tac (HOL_cs addIs [nth_mem, subsetD, thm "ftv_mem_sub_ftv_list"]) 1 *})
wenzelm@12944
   594
   txt {* case @{text "Abs e"} *}
wenzelm@12944
   595
   apply (simp add: free_tv_subst split add: split_bind)
wenzelm@12944
   596
   apply (intro strip)
wenzelm@12944
   597
   apply (rename_tac s t n1 v)
wenzelm@12944
   598
   apply (erule_tac x = "Suc n" in allE)
wenzelm@12944
   599
   apply (erule_tac x = "TVar n # a" in allE)
wenzelm@12944
   600
   apply (erule_tac x = s in allE)
wenzelm@12944
   601
   apply (erule_tac x = t in allE)
wenzelm@12944
   602
   apply (erule_tac x = n1 in allE)
wenzelm@12944
   603
   apply (erule_tac x = v in allE)
wenzelm@12944
   604
   apply (force elim!: allE intro: cod_app_subst)
wenzelm@12944
   605
  txt {* case @{text "App e1 e2"} *}
wenzelm@12944
   606
  apply (simp (no_asm) split add: split_bind)
wenzelm@12944
   607
  apply (intro strip)
wenzelm@12944
   608
  apply (rename_tac s t n1 s1 t1 n2 s3 v)
wenzelm@12944
   609
  apply (erule_tac x = n in allE)
wenzelm@12944
   610
  apply (erule_tac x = a in allE)
wenzelm@12944
   611
  apply (erule_tac x = s in allE)
wenzelm@12944
   612
  apply (erule_tac x = t in allE)
wenzelm@12944
   613
  apply (erule_tac x = n1 in allE)
wenzelm@12944
   614
  apply (erule_tac x = n1 in allE)
wenzelm@12944
   615
  apply (erule_tac x = v in allE)
wenzelm@12944
   616
  txt {* second case *}
wenzelm@12944
   617
  apply (erule_tac x = "$ s a" in allE)
wenzelm@12944
   618
  apply (erule_tac x = s1 in allE)
wenzelm@12944
   619
  apply (erule_tac x = t1 in allE)
wenzelm@12944
   620
  apply (erule_tac x = n2 in allE)
wenzelm@12944
   621
  apply (erule_tac x = v in allE)
wenzelm@12944
   622
  apply (tactic "safe_tac (empty_cs addSIs [conjI, impI] addSEs [conjE])")
wenzelm@12944
   623
   apply (simp add: rotate_Ok o_def)
wenzelm@12944
   624
   apply (drule W_var_geD)
wenzelm@12944
   625
   apply (drule W_var_geD)
wenzelm@12944
   626
   apply (frule less_le_trans, assumption)
wenzelm@12944
   627
   apply (fastsimp dest: free_tv_comp_subst [THEN subsetD] sym [THEN mgu_free] codD
wenzelm@12944
   628
     free_tv_app_subst_te [THEN subsetD] free_tv_app_subst_tel [THEN subsetD] subsetD elim: UnE)
wenzelm@12944
   629
  apply simp
wenzelm@12944
   630
  apply (drule sym [THEN W_var_geD])
wenzelm@12944
   631
  apply (drule sym [THEN W_var_geD])
wenzelm@12944
   632
  apply (frule less_le_trans, assumption)
wenzelm@12944
   633
  apply (tactic {* fast_tac (HOL_cs addDs [thm "mgu_free", thm "codD",
wenzelm@12944
   634
    thm "free_tv_subst_var" RS subsetD,
wenzelm@12944
   635
    thm "free_tv_app_subst_te" RS subsetD,
wenzelm@12944
   636
    thm "free_tv_app_subst_tel" RS subsetD, less_le_trans, subsetD]
wenzelm@12944
   637
    addSEs [UnE] addss (simpset() setSolver unsafe_solver)) 1 *})
wenzelm@12944
   638
      -- {* builtin arithmetic in simpset messes things up *}
wenzelm@12944
   639
  done
wenzelm@12944
   640
wenzelm@12944
   641
text {*
wenzelm@12944
   642
  \medskip Completeness of @{text \<W>} wrt.\ @{text has_type}.
wenzelm@12944
   643
*}
wenzelm@12944
   644
wenzelm@12944
   645
lemma W_complete_aux: "!!s' a t' n. $s' a |- e :: t' \<Longrightarrow> new_tv n a \<Longrightarrow>
wenzelm@12944
   646
    (\<exists>s t. (\<exists>m. \<W> e a n = Ok (s, t, m)) \<and> (\<exists>r. $s' a = $r ($s a) \<and> t' = $r t))"
wenzelm@12944
   647
  apply (atomize (full))
wenzelm@12944
   648
  apply (induct e)
wenzelm@12944
   649
    txt {* case @{text "Var n"} *}
wenzelm@12944
   650
    apply (intro strip)
wenzelm@12944
   651
    apply (simp (no_asm) cong add: conj_cong)
wenzelm@12944
   652
    apply (erule has_type_casesE)
wenzelm@12944
   653
    apply (simp add: eq_sym_conv app_subst_list)
wenzelm@12944
   654
    apply (rule_tac x = s' in exI)
wenzelm@12944
   655
    apply simp
wenzelm@12944
   656
   txt {* case @{text "Abs e"} *}
wenzelm@12944
   657
   apply (intro strip)
wenzelm@12944
   658
   apply (erule has_type_casesE)
wenzelm@12944
   659
   apply (erule_tac x = "\<lambda>x. if x = n then t1 else (s' x)" in allE)
wenzelm@12944
   660
   apply (erule_tac x = "TVar n # a" in allE)
wenzelm@12944
   661
   apply (erule_tac x = t2 in allE)
wenzelm@12944
   662
   apply (erule_tac x = "Suc n" in allE)
wenzelm@12944
   663
   apply (fastsimp cong add: conj_cong split add: split_bind)
wenzelm@12944
   664
  txt {* case @{text "App e1 e2"} *}
wenzelm@12944
   665
  apply (intro strip)
wenzelm@12944
   666
  apply (erule has_type_casesE)
wenzelm@12944
   667
  apply (erule_tac x = s' in allE)
wenzelm@12944
   668
  apply (erule_tac x = a in allE)
wenzelm@12944
   669
  apply (erule_tac x = "t2 -> t'" in allE)
wenzelm@12944
   670
  apply (erule_tac x = n in allE)
wenzelm@12944
   671
  apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   672
  apply (erule_tac x = r in allE)
wenzelm@12944
   673
  apply (erule_tac x = "$s a" in allE)
wenzelm@12944
   674
  apply (erule_tac x = t2 in allE)
wenzelm@12944
   675
  apply (erule_tac x = m in allE)
wenzelm@12944
   676
  apply simp
wenzelm@12944
   677
  apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   678
   apply (tactic {* fast_tac (HOL_cs addIs [sym RS thm "W_var_geD",
wenzelm@12944
   679
     thm "new_tv_W" RS conjunct1, thm "new_tv_list_le", thm "new_tv_subst_tel"]) 1 *})
wenzelm@12944
   680
  apply (subgoal_tac
wenzelm@12944
   681
    "$(\<lambda>x. if x = ma then t' else (if x \<in> free_tv t - free_tv sa then r x
wenzelm@12944
   682
      else ra x)) ($ sa t) =
wenzelm@12944
   683
    $(\<lambda>x. if x = ma then t' else (if x \<in> free_tv t - free_tv sa then r x
wenzelm@12944
   684
      else ra x)) (ta -> (TVar ma))")
wenzelm@12944
   685
   apply (rule_tac [2] t = "$(\<lambda>x. if x = ma then t'
wenzelm@12944
   686
     else (if x \<in> (free_tv t - free_tv sa) then r x else ra x)) ($sa t)" and
wenzelm@12944
   687
     s = "($ ra ta) -> t'" in ssubst)
wenzelm@12944
   688
    prefer 2
wenzelm@12944
   689
    apply (simp add: subst_comp_te)
wenzelm@12944
   690
    apply (rule eq_free_eq_subst_te)
wenzelm@12944
   691
    apply (intro strip)
wenzelm@12944
   692
    apply (subgoal_tac "na \<noteq> ma")
wenzelm@12944
   693
     prefer 2
wenzelm@12944
   694
     apply (fast dest: new_tv_W sym [THEN W_var_geD] new_tv_not_free_tv new_tv_le)
wenzelm@12944
   695
    apply (case_tac "na \<in> free_tv sa")
wenzelm@12944
   696
     txt {* @{text "na \<notin> free_tv sa"} *}
wenzelm@12944
   697
     prefer 2
wenzelm@12944
   698
     apply (frule not_free_impl_id)
wenzelm@12944
   699
     apply simp
wenzelm@12944
   700
    txt {* @{text "na \<in> free_tv sa"} *}
berghofe@13601
   701
    apply (drule_tac ts1 = "$s a" and r = "$ r ($ s a)" in subst_comp_tel [THEN [2] trans])
wenzelm@12944
   702
    apply (drule_tac eq_subst_tel_eq_free)
wenzelm@12944
   703
     apply (fast intro: free_tv_W free_tv_le_new_tv dest: new_tv_W)
wenzelm@12944
   704
    apply simp
wenzelm@12944
   705
    apply (case_tac "na \<in> dom sa")
wenzelm@12944
   706
     prefer 2
wenzelm@12944
   707
     txt {* @{text "na \<noteq> dom sa"} *}
wenzelm@12944
   708
     apply (simp add: dom_def)
wenzelm@12944
   709
    txt {* @{text "na \<in> dom sa"} *}
wenzelm@12944
   710
    apply (rule eq_free_eq_subst_te)
wenzelm@12944
   711
    apply (intro strip)
wenzelm@12944
   712
    apply (subgoal_tac "nb \<noteq> ma")
wenzelm@12944
   713
     prefer 2
wenzelm@12944
   714
     apply (frule new_tv_W, assumption)
wenzelm@12944
   715
     apply (erule conjE)
wenzelm@12944
   716
     apply (drule new_tv_subst_tel)
wenzelm@12944
   717
      apply (fast intro: new_tv_list_le dest: sym [THEN W_var_geD])
wenzelm@12944
   718
     apply (fastsimp dest: new_tv_W new_tv_not_free_tv simp add: cod_def free_tv_subst)
wenzelm@12944
   719
    apply (fastsimp simp add: cod_def free_tv_subst)
wenzelm@12944
   720
   prefer 2
wenzelm@12944
   721
   apply (simp (no_asm))
wenzelm@12944
   722
   apply (rule eq_free_eq_subst_te)
wenzelm@12944
   723
   apply (intro strip)
wenzelm@12944
   724
   apply (subgoal_tac "na \<noteq> ma")
wenzelm@12944
   725
    prefer 2
wenzelm@12944
   726
    apply (frule new_tv_W, assumption)
wenzelm@12944
   727
    apply (erule conjE)
wenzelm@12944
   728
    apply (drule sym [THEN W_var_geD])
wenzelm@12944
   729
    apply (fast dest: new_tv_list_le new_tv_subst_tel new_tv_W new_tv_not_free_tv)
wenzelm@12944
   730
   apply (case_tac "na \<in> free_tv t - free_tv sa")
wenzelm@12944
   731
    prefer 2
wenzelm@12944
   732
    txt {* case @{text "na \<notin> free_tv t - free_tv sa"} *}
wenzelm@12944
   733
    apply simp
wenzelm@12944
   734
    defer
wenzelm@12944
   735
    txt {* case @{text "na \<in> free_tv t - free_tv sa"} *}
wenzelm@12944
   736
    apply simp
berghofe@13601
   737
    apply (drule_tac ts1 = "$s a" and r = "$ r ($ s a)" in subst_comp_tel [THEN [2] trans])
wenzelm@12944
   738
    apply (drule eq_subst_tel_eq_free)
wenzelm@12944
   739
     apply (fast intro: free_tv_W free_tv_le_new_tv dest: new_tv_W)
wenzelm@12944
   740
    apply (simp add: free_tv_subst dom_def)
wenzelm@12944
   741
   prefer 2 apply fast
wenzelm@12944
   742
  apply (simp (no_asm_simp) split add: split_bind)
wenzelm@12944
   743
  apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   744
   apply (drule mgu_Ok)
wenzelm@12944
   745
   apply fastsimp
wenzelm@12944
   746
  apply (drule mgu_mg, assumption)
wenzelm@12944
   747
  apply (erule exE)
wenzelm@12944
   748
  apply (rule_tac x = rb in exI)
wenzelm@12944
   749
  apply (rule conjI)
wenzelm@12944
   750
   prefer 2
wenzelm@12944
   751
   apply (drule_tac x = ma in fun_cong)
wenzelm@12944
   752
   apply (simp add: eq_sym_conv)
wenzelm@12944
   753
  apply (simp (no_asm) add: o_def subst_comp_tel [symmetric])
wenzelm@12944
   754
  apply (rule subst_comp_tel [symmetric, THEN [2] trans])
wenzelm@12944
   755
  apply (simp add: o_def eq_sym_conv)
wenzelm@12944
   756
  apply (rule eq_free_eq_subst_tel)
wenzelm@12944
   757
  apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   758
  apply (subgoal_tac "ma \<noteq> na")
wenzelm@12944
   759
   prefer 2
wenzelm@12944
   760
   apply (frule new_tv_W, assumption)
wenzelm@12944
   761
   apply (erule conjE)
wenzelm@12944
   762
   apply (drule new_tv_subst_tel)
wenzelm@12944
   763
    apply (fast intro: new_tv_list_le dest: sym [THEN W_var_geD])
wenzelm@12944
   764
   apply (frule_tac n = m in new_tv_W, assumption)
wenzelm@12944
   765
   apply (erule conjE)
wenzelm@12944
   766
   apply (drule free_tv_app_subst_tel [THEN subsetD])
wenzelm@12944
   767
   apply (tactic {* fast_tac (set_cs addDs [sym RS thm "W_var_geD", thm "new_tv_list_le",
wenzelm@12944
   768
     thm "codD", thm "new_tv_not_free_tv"]) 1 *})
wenzelm@12944
   769
  apply (case_tac "na \<in> free_tv t - free_tv sa")
wenzelm@12944
   770
   prefer 2
wenzelm@12944
   771
   txt {* case @{text "na \<notin> free_tv t - free_tv sa"} *}
wenzelm@12944
   772
   apply simp
wenzelm@12944
   773
   defer
wenzelm@12944
   774
   txt {* case @{text "na \<in> free_tv t - free_tv sa"} *}
wenzelm@12944
   775
   apply simp
wenzelm@12944
   776
   apply (drule free_tv_app_subst_tel [THEN subsetD])
wenzelm@12944
   777
   apply (fastsimp dest: codD subst_comp_tel [THEN [2] trans]
wenzelm@12944
   778
     eq_subst_tel_eq_free simp add: free_tv_subst dom_def)
wenzelm@12944
   779
  apply fast
wenzelm@12944
   780
  done
wenzelm@12944
   781
wenzelm@12944
   782
lemma W_complete: "[] |- e :: t' ==>
wenzelm@12944
   783
    \<exists>s t. (\<exists>m. \<W> e [] n = Ok (s, t, m)) \<and> (\<exists>r. t' = $r t)"
wenzelm@12944
   784
  apply (cut_tac a = "[]" and s' = id_subst and e = e and t' = t' in W_complete_aux)
wenzelm@12944
   785
    apply simp_all
wenzelm@12944
   786
  done
wenzelm@12944
   787
wenzelm@12944
   788
wenzelm@12961
   789
section {* Equivalence of W and I *}
wenzelm@12944
   790
wenzelm@12944
   791
text {*
wenzelm@12944
   792
  Recursive definition of type inference algorithm @{text \<I>} for
wenzelm@12944
   793
  Mini-ML.
wenzelm@12944
   794
*}
wenzelm@12944
   795
wenzelm@12944
   796
consts
wenzelm@12944
   797
  I :: "expr \<Rightarrow> typ list \<Rightarrow> nat \<Rightarrow> subst \<Rightarrow> (subst \<times> typ \<times> nat) maybe"  ("\<I>")
wenzelm@12944
   798
primrec
wenzelm@12944
   799
  "\<I> (Var i) a n s = (if i < length a then Ok (s, a ! i, n) else Fail)"
wenzelm@12944
   800
  "\<I> (Abs e) a n s = ((s, t, m) := \<I> e (TVar n # a) (Suc n) s;
wenzelm@12944
   801
    Ok (s, TVar n -> t, m))"
wenzelm@12944
   802
  "\<I> (App e1 e2) a n s =
wenzelm@12944
   803
    ((s1, t1, m1) := \<I> e1 a n s;
wenzelm@12944
   804
    (s2, t2, m2) := \<I> e2 a m1 s1;
wenzelm@12944
   805
    u := mgu ($s2 t1) ($s2 t2 -> TVar m2);
wenzelm@12944
   806
    Ok($u o s2, TVar m2, Suc m2))"
wenzelm@12944
   807
wenzelm@12944
   808
text {* \medskip Correctness. *}
wenzelm@12944
   809
wenzelm@12944
   810
lemma I_correct_wrt_W: "!!a m s s' t n.
wenzelm@12944
   811
    new_tv m a \<and> new_tv m s \<Longrightarrow> \<I> e a m s = Ok (s', t, n) \<Longrightarrow>
wenzelm@12944
   812
    \<exists>r. \<W> e ($s a) m = Ok (r, $s' t, n) \<and> s' = ($r o s)"
wenzelm@12944
   813
  apply (atomize (full))
wenzelm@12944
   814
  apply (induct e)
wenzelm@12944
   815
    txt {* case @{text "Var n"} *}
wenzelm@12944
   816
    apply (simp add: app_subst_list split: split_if)
wenzelm@12944
   817
   txt {* case @{text "Abs e"} *}
wenzelm@12944
   818
   apply (tactic {* asm_full_simp_tac
wenzelm@12944
   819
     (simpset() setloop (split_inside_tac [thm "split_bind"])) 1 *})
wenzelm@12944
   820
   apply (intro strip)
wenzelm@12944
   821
   apply (rule conjI)
wenzelm@12944
   822
    apply (intro strip)
wenzelm@12944
   823
    apply (erule allE)+
wenzelm@12944
   824
    apply (erule impE)
wenzelm@12944
   825
     prefer 2 apply (fastsimp simp add: new_tv_subst)
wenzelm@12944
   826
    apply (tactic {* fast_tac (HOL_cs addIs [thm "new_tv_Suc_list" RS mp,
wenzelm@12944
   827
      thm "new_tv_subst_le", less_imp_le, lessI]) 1 *})
wenzelm@12944
   828
   apply (intro strip)
wenzelm@12944
   829
   apply (erule allE)+
wenzelm@12944
   830
   apply (erule impE)
wenzelm@12944
   831
    prefer 2 apply (fastsimp simp add: new_tv_subst)
wenzelm@12944
   832
   apply (tactic {* fast_tac (HOL_cs addIs [thm "new_tv_Suc_list" RS mp,
wenzelm@12944
   833
     thm "new_tv_subst_le", less_imp_le, lessI]) 1 *})
wenzelm@12944
   834
  txt {* case @{text "App e1 e2"} *}
wenzelm@12944
   835
  apply (tactic {* simp_tac (simpset () setloop (split_inside_tac [thm "split_bind"])) 1 *})
wenzelm@12944
   836
  apply (intro strip)
wenzelm@12944
   837
  apply (rename_tac s1' t1 n1 s2' t2 n2 sa)
wenzelm@12944
   838
  apply (rule conjI)
wenzelm@12944
   839
   apply fastsimp
wenzelm@12944
   840
  apply (intro strip)
wenzelm@12944
   841
  apply (rename_tac s1 t1' n1')
wenzelm@12944
   842
  apply (erule_tac x = a in allE)
wenzelm@12944
   843
  apply (erule_tac x = m in allE)
wenzelm@12944
   844
  apply (erule_tac x = s in allE)
wenzelm@12944
   845
  apply (erule_tac x = s1' in allE)
wenzelm@12944
   846
  apply (erule_tac x = t1 in allE)
wenzelm@12944
   847
  apply (erule_tac x = n1 in allE)
wenzelm@12944
   848
  apply (erule_tac x = a in allE)
wenzelm@12944
   849
  apply (erule_tac x = n1 in allE)
wenzelm@12944
   850
  apply (erule_tac x = s1' in allE)
wenzelm@12944
   851
  apply (erule_tac x = s2' in allE)
wenzelm@12944
   852
  apply (erule_tac x = t2 in allE)
wenzelm@12944
   853
  apply (erule_tac x = n2 in allE)
wenzelm@12944
   854
  apply (rule conjI)
wenzelm@12944
   855
   apply (intro strip)
wenzelm@12944
   856
   apply (rule notI)
wenzelm@12944
   857
   apply simp
wenzelm@12944
   858
   apply (erule impE)
wenzelm@12944
   859
    apply (frule new_tv_subst_tel, assumption)
wenzelm@12944
   860
    apply (drule_tac a = "$s a" in new_tv_W, assumption)
wenzelm@12944
   861
    apply (fastsimp dest: sym [THEN W_var_geD] new_tv_subst_le new_tv_list_le)
wenzelm@12944
   862
   apply (fastsimp simp add: subst_comp_tel)
wenzelm@12944
   863
  apply (intro strip)
wenzelm@12944
   864
  apply (rename_tac s2 t2' n2')
wenzelm@12944
   865
  apply (rule conjI)
wenzelm@12944
   866
   apply (intro strip)
wenzelm@12944
   867
   apply (rule notI)
wenzelm@12944
   868
   apply simp
wenzelm@12944
   869
   apply (erule impE)
wenzelm@12944
   870
   apply (frule new_tv_subst_tel, assumption)
wenzelm@12944
   871
   apply (drule_tac a = "$s a" in new_tv_W, assumption)
wenzelm@12944
   872
    apply (fastsimp dest: sym [THEN W_var_geD] new_tv_subst_le new_tv_list_le)
wenzelm@12944
   873
   apply (fastsimp simp add: subst_comp_tel subst_comp_te)
wenzelm@12944
   874
  apply (intro strip)
wenzelm@12944
   875
  apply (erule (1) notE impE)
wenzelm@12944
   876
  apply (erule (1) notE impE)
wenzelm@12944
   877
  apply (erule exE)
wenzelm@12944
   878
  apply (erule conjE)
wenzelm@12944
   879
  apply (erule impE)
wenzelm@12944
   880
   apply (frule new_tv_subst_tel, assumption)
wenzelm@12944
   881
   apply (drule_tac a = "$s a" in new_tv_W, assumption)
wenzelm@12944
   882
   apply (fastsimp dest: sym [THEN W_var_geD] new_tv_subst_le new_tv_list_le)
wenzelm@12944
   883
  apply (erule (1) notE impE)
wenzelm@12944
   884
  apply (erule exE conjE)+
berghofe@13601
   885
  apply (simp (asm_lr) add: subst_comp_tel subst_comp_te o_def, (erule conjE)+, hypsubst)+
wenzelm@12944
   886
  apply (subgoal_tac "new_tv n2 s \<and> new_tv n2 r \<and> new_tv n2 ra")
wenzelm@12944
   887
   apply (simp add: new_tv_subst)
wenzelm@12944
   888
  apply (frule new_tv_subst_tel, assumption)
wenzelm@12944
   889
  apply (drule_tac a = "$s a" in new_tv_W, assumption)
wenzelm@12944
   890
  apply (tactic "safe_tac HOL_cs")
wenzelm@12944
   891
    apply (bestsimp dest: sym [THEN W_var_geD] new_tv_subst_le new_tv_list_le)
wenzelm@12944
   892
   apply (fastsimp dest: sym [THEN W_var_geD] new_tv_subst_le new_tv_list_le)
wenzelm@12944
   893
  apply (drule_tac e = expr1 in sym [THEN W_var_geD])
wenzelm@12944
   894
  apply (drule new_tv_subst_tel, assumption)
wenzelm@12944
   895
  apply (drule_tac ts = "$s a" in new_tv_list_le, assumption)
wenzelm@12944
   896
  apply (drule new_tv_subst_tel, assumption)
wenzelm@12944
   897
  apply (bestsimp dest: new_tv_W simp add: subst_comp_tel)
wenzelm@12944
   898
  done
wenzelm@12944
   899
wenzelm@12944
   900
lemma I_complete_wrt_W: "!!a m s.
wenzelm@12944
   901
    new_tv m a \<and> new_tv m s \<Longrightarrow> \<I> e a m s = Fail \<Longrightarrow> \<W> e ($s a) m = Fail"
wenzelm@12944
   902
  apply (atomize (full))
wenzelm@12944
   903
  apply (induct e)
wenzelm@12944
   904
    apply (simp add: app_subst_list)
wenzelm@12944
   905
   apply (simp (no_asm))
wenzelm@12944
   906
   apply (intro strip)
wenzelm@12944
   907
   apply (subgoal_tac "TVar m # $s a = $s (TVar m # a)")
wenzelm@12944
   908
    apply (tactic {* asm_simp_tac (HOL_ss addsimps
wenzelm@12944
   909
      [thm "new_tv_Suc_list", lessI RS less_imp_le RS thm "new_tv_subst_le"]) 1 *})
wenzelm@12944
   910
    apply (erule conjE)
wenzelm@12944
   911
    apply (drule new_tv_not_free_tv [THEN not_free_impl_id])
wenzelm@12944
   912
    apply (simp (no_asm_simp))
wenzelm@12944
   913
  apply (simp (no_asm_simp))
wenzelm@12944
   914
  apply (intro strip)
wenzelm@12944
   915
  apply (erule exE)+
wenzelm@12944
   916
  apply (erule conjE)+
wenzelm@12944
   917
  apply (drule I_correct_wrt_W [COMP swap_prems_rl])
wenzelm@12944
   918
   apply fast
wenzelm@12944
   919
  apply (erule exE)
wenzelm@12944
   920
  apply (erule conjE)
wenzelm@12944
   921
  apply hypsubst
wenzelm@12944
   922
  apply (simp (no_asm_simp))
wenzelm@12944
   923
  apply (erule disjE)
wenzelm@12944
   924
   apply (rule disjI1)
wenzelm@12944
   925
   apply (simp (no_asm_use) add: o_def subst_comp_tel)
wenzelm@12944
   926
   apply (erule allE, erule allE, erule allE, erule impE, erule_tac [2] impE,
wenzelm@12944
   927
     erule_tac [2] asm_rl, erule_tac [2] asm_rl)
wenzelm@12944
   928
   apply (rule conjI)
wenzelm@12944
   929
    apply (fast intro: W_var_ge [THEN new_tv_list_le])
wenzelm@12944
   930
   apply (rule new_tv_subst_comp_2)
wenzelm@12944
   931
    apply (fast intro: W_var_ge [THEN new_tv_subst_le])
wenzelm@12944
   932
   apply (fast intro!: new_tv_subst_tel intro: new_tv_W [THEN conjunct1])
wenzelm@12944
   933
  apply (rule disjI2)
wenzelm@12944
   934
  apply (erule exE)+
wenzelm@12944
   935
  apply (erule conjE)
wenzelm@12944
   936
  apply (drule I_correct_wrt_W [COMP swap_prems_rl])
wenzelm@12944
   937
   apply (rule conjI)
wenzelm@12944
   938
   apply (fast intro: W_var_ge [THEN new_tv_list_le])
wenzelm@12944
   939
   apply (rule new_tv_subst_comp_1)
wenzelm@12944
   940
   apply (fast intro: W_var_ge [THEN new_tv_subst_le])
wenzelm@12944
   941
   apply (fast intro!: new_tv_subst_tel intro: new_tv_W [THEN conjunct1])
wenzelm@12944
   942
  apply (erule exE)
wenzelm@12944
   943
  apply (erule conjE)
wenzelm@12944
   944
  apply hypsubst
wenzelm@12944
   945
  apply (simp add: o_def subst_comp_te [symmetric] subst_comp_tel [symmetric])
wenzelm@12944
   946
  done
wenzelm@12944
   947
wenzelm@12944
   948
end