src/CCL/Type.thy
author wenzelm
Fri Mar 20 15:24:18 2009 +0100 (2009-03-20)
changeset 30607 c3d1590debd8
parent 28272 ed959a0f650b
child 32010 cb1a1c94b4cd
permissions -rw-r--r--
eliminated global SIMPSET, CLASET etc. -- refer to explicit context;
wenzelm@17456
     1
(*  Title:      CCL/Type.thy
clasohm@0
     2
    Author:     Martin Coen
clasohm@0
     3
    Copyright   1993  University of Cambridge
clasohm@0
     4
*)
clasohm@0
     5
wenzelm@17456
     6
header {* Types in CCL are defined as sets of terms *}
wenzelm@17456
     7
wenzelm@17456
     8
theory Type
wenzelm@17456
     9
imports Term
wenzelm@17456
    10
begin
clasohm@0
    11
clasohm@0
    12
consts
clasohm@0
    13
clasohm@0
    14
  Subtype       :: "['a set, 'a => o] => 'a set"
clasohm@0
    15
  Bool          :: "i set"
clasohm@0
    16
  Unit          :: "i set"
wenzelm@24825
    17
  Plus           :: "[i set, i set] => i set"        (infixr "+" 55)
clasohm@0
    18
  Pi            :: "[i set, i => i set] => i set"
clasohm@0
    19
  Sigma         :: "[i set, i => i set] => i set"
clasohm@0
    20
  Nat           :: "i set"
clasohm@0
    21
  List          :: "i set => i set"
clasohm@0
    22
  Lists         :: "i set => i set"
clasohm@0
    23
  ILists        :: "i set => i set"
lcp@999
    24
  TAll          :: "(i set => i set) => i set"       (binder "TALL " 55)
lcp@999
    25
  TEx           :: "(i set => i set) => i set"       (binder "TEX " 55)
lcp@999
    26
  Lift          :: "i set => i set"                  ("(3[_])")
clasohm@0
    27
clasohm@0
    28
  SPLIT         :: "[i, [i, i] => i set] => i set"
clasohm@0
    29
wenzelm@14765
    30
syntax
lcp@999
    31
  "@Pi"         :: "[idt, i set, i set] => i set"    ("(3PROD _:_./ _)"
clasohm@1474
    32
                                [0,0,60] 60)
lcp@999
    33
lcp@999
    34
  "@Sigma"      :: "[idt, i set, i set] => i set"    ("(3SUM _:_./ _)"
clasohm@1474
    35
                                [0,0,60] 60)
wenzelm@17456
    36
lcp@999
    37
  "@->"         :: "[i set, i set] => i set"         ("(_ ->/ _)"  [54, 53] 53)
lcp@999
    38
  "@*"          :: "[i set, i set] => i set"         ("(_ */ _)" [56, 55] 55)
lcp@999
    39
  "@Subtype"    :: "[idt, 'a set, o] => 'a set"      ("(1{_: _ ./ _})")
clasohm@0
    40
clasohm@0
    41
translations
clasohm@0
    42
  "PROD x:A. B" => "Pi(A, %x. B)"
wenzelm@17782
    43
  "A -> B"      => "Pi(A, %_. B)"
clasohm@0
    44
  "SUM x:A. B"  => "Sigma(A, %x. B)"
wenzelm@17782
    45
  "A * B"       => "Sigma(A, %_. B)"
clasohm@0
    46
  "{x: A. B}"   == "Subtype(A, %x. B)"
clasohm@0
    47
wenzelm@17456
    48
print_translation {*
wenzelm@17456
    49
  [("Pi", dependent_tr' ("@Pi", "@->")),
wenzelm@17456
    50
   ("Sigma", dependent_tr' ("@Sigma", "@*"))] *}
clasohm@0
    51
wenzelm@17456
    52
axioms
wenzelm@17456
    53
  Subtype_def: "{x:A. P(x)} == {x. x:A & P(x)}"
wenzelm@17456
    54
  Unit_def:          "Unit == {x. x=one}"
wenzelm@17456
    55
  Bool_def:          "Bool == {x. x=true | x=false}"
wenzelm@17456
    56
  Plus_def:           "A+B == {x. (EX a:A. x=inl(a)) | (EX b:B. x=inr(b))}"
wenzelm@17456
    57
  Pi_def:         "Pi(A,B) == {x. EX b. x=lam x. b(x) & (ALL x:A. b(x):B(x))}"
wenzelm@17456
    58
  Sigma_def:   "Sigma(A,B) == {x. EX a:A. EX b:B(a).x=<a,b>}"
wenzelm@17456
    59
  Nat_def:            "Nat == lfp(% X. Unit + X)"
wenzelm@17456
    60
  List_def:       "List(A) == lfp(% X. Unit + A*X)"
clasohm@0
    61
wenzelm@17456
    62
  Lists_def:     "Lists(A) == gfp(% X. Unit + A*X)"
wenzelm@17456
    63
  ILists_def:   "ILists(A) == gfp(% X.{} + A*X)"
clasohm@0
    64
wenzelm@17456
    65
  Tall_def:   "TALL X. B(X) == Inter({X. EX Y. X=B(Y)})"
wenzelm@17456
    66
  Tex_def:     "TEX X. B(X) == Union({X. EX Y. X=B(Y)})"
wenzelm@17456
    67
  Lift_def:           "[A] == A Un {bot}"
clasohm@0
    68
wenzelm@17456
    69
  SPLIT_def:   "SPLIT(p,B) == Union({A. EX x y. p=<x,y> & A=B(x,y)})"
wenzelm@17456
    70
wenzelm@20140
    71
wenzelm@20140
    72
lemmas simp_type_defs =
wenzelm@20140
    73
    Subtype_def Unit_def Bool_def Plus_def Sigma_def Pi_def Lift_def Tall_def Tex_def
wenzelm@20140
    74
  and ind_type_defs = Nat_def List_def
wenzelm@20140
    75
  and simp_data_defs = one_def inl_def inr_def
wenzelm@20140
    76
  and ind_data_defs = zero_def succ_def nil_def cons_def
wenzelm@20140
    77
wenzelm@20140
    78
lemma subsetXH: "A <= B <-> (ALL x. x:A --> x:B)"
wenzelm@20140
    79
  by blast
wenzelm@20140
    80
wenzelm@20140
    81
wenzelm@20140
    82
subsection {* Exhaustion Rules *}
wenzelm@20140
    83
wenzelm@20140
    84
lemma EmptyXH: "!!a. a : {} <-> False"
wenzelm@20140
    85
  and SubtypeXH: "!!a A P. a : {x:A. P(x)} <-> (a:A & P(a))"
wenzelm@20140
    86
  and UnitXH: "!!a. a : Unit          <-> a=one"
wenzelm@20140
    87
  and BoolXH: "!!a. a : Bool          <-> a=true | a=false"
wenzelm@20140
    88
  and PlusXH: "!!a A B. a : A+B           <-> (EX x:A. a=inl(x)) | (EX x:B. a=inr(x))"
wenzelm@20140
    89
  and PiXH: "!!a A B. a : PROD x:A. B(x) <-> (EX b. a=lam x. b(x) & (ALL x:A. b(x):B(x)))"
wenzelm@20140
    90
  and SgXH: "!!a A B. a : SUM x:A. B(x)  <-> (EX x:A. EX y:B(x).a=<x,y>)"
wenzelm@20140
    91
  unfolding simp_type_defs by blast+
wenzelm@20140
    92
wenzelm@20140
    93
lemmas XHs = EmptyXH SubtypeXH UnitXH BoolXH PlusXH PiXH SgXH
wenzelm@20140
    94
wenzelm@20140
    95
lemma LiftXH: "a : [A] <-> (a=bot | a:A)"
wenzelm@20140
    96
  and TallXH: "a : TALL X. B(X) <-> (ALL X. a:B(X))"
wenzelm@20140
    97
  and TexXH: "a : TEX X. B(X) <-> (EX X. a:B(X))"
wenzelm@20140
    98
  unfolding simp_type_defs by blast+
wenzelm@20140
    99
wenzelm@20140
   100
ML {*
wenzelm@20140
   101
bind_thms ("case_rls", XH_to_Es (thms "XHs"));
wenzelm@20140
   102
*}
wenzelm@20140
   103
wenzelm@20140
   104
wenzelm@20140
   105
subsection {* Canonical Type Rules *}
wenzelm@20140
   106
wenzelm@20140
   107
lemma oneT: "one : Unit"
wenzelm@20140
   108
  and trueT: "true : Bool"
wenzelm@20140
   109
  and falseT: "false : Bool"
wenzelm@20140
   110
  and lamT: "!!b B. [| !!x. x:A ==> b(x):B(x) |] ==> lam x. b(x) : Pi(A,B)"
wenzelm@20140
   111
  and pairT: "!!b B. [| a:A; b:B(a) |] ==> <a,b>:Sigma(A,B)"
wenzelm@20140
   112
  and inlT: "a:A ==> inl(a) : A+B"
wenzelm@20140
   113
  and inrT: "b:B ==> inr(b) : A+B"
wenzelm@20140
   114
  by (blast intro: XHs [THEN iffD2])+
wenzelm@20140
   115
wenzelm@20140
   116
lemmas canTs = oneT trueT falseT pairT lamT inlT inrT
wenzelm@20140
   117
wenzelm@20140
   118
wenzelm@20140
   119
subsection {* Non-Canonical Type Rules *}
wenzelm@20140
   120
wenzelm@20140
   121
lemma lem: "[| a:B(u);  u=v |] ==> a : B(v)"
wenzelm@20140
   122
  by blast
wenzelm@20140
   123
wenzelm@20140
   124
wenzelm@20140
   125
ML {*
wenzelm@20140
   126
local
wenzelm@20140
   127
  val lemma = thm "lem"
wenzelm@20140
   128
  val bspec = thm "bspec"
wenzelm@20140
   129
  val bexE = thm "bexE"
wenzelm@20140
   130
in
wenzelm@20140
   131
wenzelm@23894
   132
  fun mk_ncanT_tac ctxt defs top_crls crls s = prove_goalw (ProofContext.theory_of ctxt) defs s
wenzelm@20140
   133
    (fn major::prems => [(resolve_tac ([major] RL top_crls) 1),
wenzelm@20140
   134
                         (REPEAT_SOME (eresolve_tac (crls @ [exE,bexE,conjE,disjE]))),
wenzelm@23894
   135
                         (ALLGOALS (asm_simp_tac (local_simpset_of ctxt))),
wenzelm@20140
   136
                         (ALLGOALS (ares_tac (prems RL [lemma]) ORELSE'
wenzelm@20140
   137
                                    etac bspec )),
wenzelm@23894
   138
                         (safe_tac (local_claset_of ctxt addSIs prems))])
wenzelm@28272
   139
end
wenzelm@28272
   140
*}
wenzelm@20140
   141
wenzelm@28272
   142
ML {*
wenzelm@28272
   143
  val ncanT_tac = mk_ncanT_tac @{context} [] @{thms case_rls} @{thms case_rls}
wenzelm@20140
   144
*}
wenzelm@20140
   145
wenzelm@20140
   146
ML {*
wenzelm@20140
   147
wenzelm@20140
   148
bind_thm ("ifT", ncanT_tac
wenzelm@20140
   149
  "[| b:Bool; b=true ==> t:A(true); b=false ==> u:A(false) |] ==> if b then t else u : A(b)");
wenzelm@20140
   150
wenzelm@20140
   151
bind_thm ("applyT", ncanT_tac "[| f : Pi(A,B);  a:A |] ==> f ` a : B(a)");
wenzelm@20140
   152
wenzelm@20140
   153
bind_thm ("splitT", ncanT_tac
wenzelm@20140
   154
  "[| p:Sigma(A,B); !!x y. [| x:A;  y:B(x); p=<x,y> |] ==> c(x,y):C(<x,y>) |] ==> split(p,c):C(p)");
wenzelm@20140
   155
wenzelm@20140
   156
bind_thm ("whenT", ncanT_tac
wenzelm@20140
   157
  "[| p:A+B; !!x.[| x:A;  p=inl(x) |] ==> a(x):C(inl(x)); !!y.[| y:B;  p=inr(y) |] ==> b(y):C(inr(y)) |] ==> when(p,a,b) : C(p)");
wenzelm@20140
   158
*}
wenzelm@20140
   159
wenzelm@20140
   160
lemmas ncanTs = ifT applyT splitT whenT
wenzelm@20140
   161
wenzelm@20140
   162
wenzelm@20140
   163
subsection {* Subtypes *}
wenzelm@20140
   164
wenzelm@20140
   165
lemma SubtypeD1: "a : Subtype(A, P) ==> a : A"
wenzelm@20140
   166
  and SubtypeD2: "a : Subtype(A, P) ==> P(a)"
wenzelm@20140
   167
  by (simp_all add: SubtypeXH)
wenzelm@20140
   168
wenzelm@20140
   169
lemma SubtypeI: "[| a:A;  P(a) |] ==> a : {x:A. P(x)}"
wenzelm@20140
   170
  by (simp add: SubtypeXH)
wenzelm@20140
   171
wenzelm@20140
   172
lemma SubtypeE: "[| a : {x:A. P(x)};  [| a:A;  P(a) |] ==> Q |] ==> Q"
wenzelm@20140
   173
  by (simp add: SubtypeXH)
wenzelm@20140
   174
wenzelm@20140
   175
wenzelm@20140
   176
subsection {* Monotonicity *}
wenzelm@20140
   177
wenzelm@20140
   178
lemma idM: "mono (%X. X)"
wenzelm@20140
   179
  apply (rule monoI)
wenzelm@20140
   180
  apply assumption
wenzelm@20140
   181
  done
wenzelm@20140
   182
wenzelm@20140
   183
lemma constM: "mono(%X. A)"
wenzelm@20140
   184
  apply (rule monoI)
wenzelm@20140
   185
  apply (rule subset_refl)
wenzelm@20140
   186
  done
wenzelm@20140
   187
wenzelm@20140
   188
lemma "mono(%X. A(X)) ==> mono(%X.[A(X)])"
wenzelm@20140
   189
  apply (rule subsetI [THEN monoI])
wenzelm@20140
   190
  apply (drule LiftXH [THEN iffD1])
wenzelm@20140
   191
  apply (erule disjE)
wenzelm@20140
   192
   apply (erule disjI1 [THEN LiftXH [THEN iffD2]])
wenzelm@20140
   193
  apply (rule disjI2 [THEN LiftXH [THEN iffD2]])
wenzelm@20140
   194
  apply (drule (1) monoD)
wenzelm@20140
   195
  apply blast
wenzelm@20140
   196
  done
wenzelm@20140
   197
wenzelm@20140
   198
lemma SgM:
wenzelm@20140
   199
  "[| mono(%X. A(X)); !!x X. x:A(X) ==> mono(%X. B(X,x)) |] ==>
wenzelm@20140
   200
    mono(%X. Sigma(A(X),B(X)))"
wenzelm@20140
   201
  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
wenzelm@20140
   202
    dest!: monoD [THEN subsetD])
wenzelm@20140
   203
wenzelm@20140
   204
lemma PiM:
wenzelm@20140
   205
  "[| !!x. x:A ==> mono(%X. B(X,x)) |] ==> mono(%X. Pi(A,B(X)))"
wenzelm@20140
   206
  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
wenzelm@20140
   207
    dest!: monoD [THEN subsetD])
wenzelm@20140
   208
wenzelm@20140
   209
lemma PlusM:
wenzelm@20140
   210
    "[| mono(%X. A(X));  mono(%X. B(X)) |] ==> mono(%X. A(X)+B(X))"
wenzelm@20140
   211
  by (blast intro!: subsetI [THEN monoI] canTs elim!: case_rls
wenzelm@20140
   212
    dest!: monoD [THEN subsetD])
wenzelm@20140
   213
wenzelm@20140
   214
wenzelm@20140
   215
subsection {* Recursive types *}
wenzelm@20140
   216
wenzelm@20140
   217
subsubsection {* Conversion Rules for Fixed Points via monotonicity and Tarski *}
wenzelm@20140
   218
wenzelm@20140
   219
lemma NatM: "mono(%X. Unit+X)";
wenzelm@20140
   220
  apply (rule PlusM constM idM)+
wenzelm@20140
   221
  done
wenzelm@20140
   222
wenzelm@20140
   223
lemma def_NatB: "Nat = Unit + Nat"
wenzelm@20140
   224
  apply (rule def_lfp_Tarski [OF Nat_def])
wenzelm@20140
   225
  apply (rule NatM)
wenzelm@20140
   226
  done
wenzelm@20140
   227
wenzelm@20140
   228
lemma ListM: "mono(%X.(Unit+Sigma(A,%y. X)))"
wenzelm@20140
   229
  apply (rule PlusM SgM constM idM)+
wenzelm@20140
   230
  done
wenzelm@20140
   231
wenzelm@20140
   232
lemma def_ListB: "List(A) = Unit + A * List(A)"
wenzelm@20140
   233
  apply (rule def_lfp_Tarski [OF List_def])
wenzelm@20140
   234
  apply (rule ListM)
wenzelm@20140
   235
  done
wenzelm@20140
   236
wenzelm@20140
   237
lemma def_ListsB: "Lists(A) = Unit + A * Lists(A)"
wenzelm@20140
   238
  apply (rule def_gfp_Tarski [OF Lists_def])
wenzelm@20140
   239
  apply (rule ListM)
wenzelm@20140
   240
  done
wenzelm@20140
   241
wenzelm@20140
   242
lemma IListsM: "mono(%X.({} + Sigma(A,%y. X)))"
wenzelm@20140
   243
  apply (rule PlusM SgM constM idM)+
wenzelm@20140
   244
  done
wenzelm@20140
   245
wenzelm@20140
   246
lemma def_IListsB: "ILists(A) = {} + A * ILists(A)"
wenzelm@20140
   247
  apply (rule def_gfp_Tarski [OF ILists_def])
wenzelm@20140
   248
  apply (rule IListsM)
wenzelm@20140
   249
  done
wenzelm@20140
   250
wenzelm@20140
   251
lemmas ind_type_eqs = def_NatB def_ListB def_ListsB def_IListsB
wenzelm@20140
   252
wenzelm@20140
   253
wenzelm@20140
   254
subsection {* Exhaustion Rules *}
wenzelm@20140
   255
wenzelm@20140
   256
lemma NatXH: "a : Nat <-> (a=zero | (EX x:Nat. a=succ(x)))"
wenzelm@20140
   257
  and ListXH: "a : List(A) <-> (a=[] | (EX x:A. EX xs:List(A).a=x$xs))"
wenzelm@20140
   258
  and ListsXH: "a : Lists(A) <-> (a=[] | (EX x:A. EX xs:Lists(A).a=x$xs))"
wenzelm@20140
   259
  and IListsXH: "a : ILists(A) <-> (EX x:A. EX xs:ILists(A).a=x$xs)"
wenzelm@20140
   260
  unfolding ind_data_defs
wenzelm@20140
   261
  by (rule ind_type_eqs [THEN XHlemma1], blast intro!: canTs elim!: case_rls)+
wenzelm@20140
   262
wenzelm@20140
   263
lemmas iXHs = NatXH ListXH
wenzelm@20140
   264
wenzelm@20140
   265
ML {* bind_thms ("icase_rls", XH_to_Es (thms "iXHs")) *}
wenzelm@20140
   266
wenzelm@20140
   267
wenzelm@20140
   268
subsection {* Type Rules *}
wenzelm@20140
   269
wenzelm@20140
   270
lemma zeroT: "zero : Nat"
wenzelm@20140
   271
  and succT: "n:Nat ==> succ(n) : Nat"
wenzelm@20140
   272
  and nilT: "[] : List(A)"
wenzelm@20140
   273
  and consT: "[| h:A;  t:List(A) |] ==> h$t : List(A)"
wenzelm@20140
   274
  by (blast intro: iXHs [THEN iffD2])+
wenzelm@20140
   275
wenzelm@20140
   276
lemmas icanTs = zeroT succT nilT consT
wenzelm@20140
   277
wenzelm@20140
   278
ML {*
wenzelm@28272
   279
val incanT_tac = mk_ncanT_tac @{context} [] @{thms icase_rls} @{thms case_rls};
wenzelm@28272
   280
*}
wenzelm@20140
   281
wenzelm@28272
   282
ML {*
wenzelm@20140
   283
bind_thm ("ncaseT", incanT_tac
wenzelm@20140
   284
  "[| n:Nat; n=zero ==> b:C(zero); !!x.[| x:Nat;  n=succ(x) |] ==> c(x):C(succ(x)) |] ==> ncase(n,b,c) : C(n)");
wenzelm@20140
   285
wenzelm@20140
   286
bind_thm ("lcaseT", incanT_tac
wenzelm@20140
   287
     "[| l:List(A); l=[] ==> b:C([]); !!h t.[| h:A;  t:List(A); l=h$t |] ==> c(h,t):C(h$t) |] ==> lcase(l,b,c) : C(l)");
wenzelm@20140
   288
*}
wenzelm@20140
   289
wenzelm@20140
   290
lemmas incanTs = ncaseT lcaseT
wenzelm@20140
   291
wenzelm@20140
   292
wenzelm@20140
   293
subsection {* Induction Rules *}
wenzelm@20140
   294
wenzelm@20140
   295
lemmas ind_Ms = NatM ListM
wenzelm@20140
   296
wenzelm@20140
   297
lemma Nat_ind: "[| n:Nat; P(zero); !!x.[| x:Nat; P(x) |] ==> P(succ(x)) |] ==> P(n)"
wenzelm@20140
   298
  apply (unfold ind_data_defs)
wenzelm@20140
   299
  apply (erule def_induct [OF Nat_def _ NatM])
wenzelm@20140
   300
  apply (blast intro: canTs elim!: case_rls)
wenzelm@20140
   301
  done
wenzelm@20140
   302
wenzelm@20140
   303
lemma List_ind:
wenzelm@20140
   304
  "[| l:List(A); P([]); !!x xs.[| x:A;  xs:List(A); P(xs) |] ==> P(x$xs) |] ==> P(l)"
wenzelm@20140
   305
  apply (unfold ind_data_defs)
wenzelm@20140
   306
  apply (erule def_induct [OF List_def _ ListM])
wenzelm@20140
   307
  apply (blast intro: canTs elim!: case_rls)
wenzelm@20140
   308
  done
wenzelm@20140
   309
wenzelm@20140
   310
lemmas inds = Nat_ind List_ind
wenzelm@20140
   311
wenzelm@20140
   312
wenzelm@20140
   313
subsection {* Primitive Recursive Rules *}
wenzelm@20140
   314
wenzelm@20140
   315
lemma nrecT:
wenzelm@20140
   316
  "[| n:Nat; b:C(zero);
wenzelm@20140
   317
      !!x g.[| x:Nat; g:C(x) |] ==> c(x,g):C(succ(x)) |] ==>
wenzelm@20140
   318
      nrec(n,b,c) : C(n)"
wenzelm@20140
   319
  by (erule Nat_ind) auto
wenzelm@20140
   320
wenzelm@20140
   321
lemma lrecT:
wenzelm@20140
   322
  "[| l:List(A); b:C([]);
wenzelm@20140
   323
      !!x xs g.[| x:A;  xs:List(A); g:C(xs) |] ==> c(x,xs,g):C(x$xs) |] ==>
wenzelm@20140
   324
      lrec(l,b,c) : C(l)"
wenzelm@20140
   325
  by (erule List_ind) auto
wenzelm@20140
   326
wenzelm@20140
   327
lemmas precTs = nrecT lrecT
wenzelm@20140
   328
wenzelm@20140
   329
wenzelm@20140
   330
subsection {* Theorem proving *}
wenzelm@20140
   331
wenzelm@20140
   332
lemma SgE2:
wenzelm@20140
   333
  "[| <a,b> : Sigma(A,B);  [| a:A;  b:B(a) |] ==> P |] ==> P"
wenzelm@20140
   334
  unfolding SgXH by blast
wenzelm@20140
   335
wenzelm@20140
   336
(* General theorem proving ignores non-canonical term-formers,             *)
wenzelm@20140
   337
(*         - intro rules are type rules for canonical terms                *)
wenzelm@20140
   338
(*         - elim rules are case rules (no non-canonical terms appear)     *)
wenzelm@20140
   339
wenzelm@20140
   340
ML {* bind_thms ("XHEs", XH_to_Es (thms "XHs")) *}
wenzelm@20140
   341
wenzelm@20140
   342
lemmas [intro!] = SubtypeI canTs icanTs
wenzelm@20140
   343
  and [elim!] = SubtypeE XHEs
wenzelm@20140
   344
wenzelm@20140
   345
wenzelm@20140
   346
subsection {* Infinite Data Types *}
wenzelm@20140
   347
wenzelm@20140
   348
lemma lfp_subset_gfp: "mono(f) ==> lfp(f) <= gfp(f)"
wenzelm@20140
   349
  apply (rule lfp_lowerbound [THEN subset_trans])
wenzelm@20140
   350
   apply (erule gfp_lemma3)
wenzelm@20140
   351
  apply (rule subset_refl)
wenzelm@20140
   352
  done
wenzelm@20140
   353
wenzelm@20140
   354
lemma gfpI:
wenzelm@20140
   355
  assumes "a:A"
wenzelm@20140
   356
    and "!!x X.[| x:A;  ALL y:A. t(y):X |] ==> t(x) : B(X)"
wenzelm@20140
   357
  shows "t(a) : gfp(B)"
wenzelm@20140
   358
  apply (rule coinduct)
wenzelm@20140
   359
   apply (rule_tac P = "%x. EX y:A. x=t (y)" in CollectI)
wenzelm@20140
   360
   apply (blast intro!: prems)+
wenzelm@20140
   361
  done
wenzelm@20140
   362
wenzelm@20140
   363
lemma def_gfpI:
wenzelm@20140
   364
  "[| C==gfp(B);  a:A;  !!x X.[| x:A;  ALL y:A. t(y):X |] ==> t(x) : B(X) |] ==>
wenzelm@20140
   365
    t(a) : C"
wenzelm@20140
   366
  apply unfold
wenzelm@20140
   367
  apply (erule gfpI)
wenzelm@20140
   368
  apply blast
wenzelm@20140
   369
  done
wenzelm@20140
   370
wenzelm@20140
   371
(* EG *)
wenzelm@20140
   372
lemma "letrec g x be zero$g(x) in g(bot) : Lists(Nat)"
wenzelm@20140
   373
  apply (rule refl [THEN UnitXH [THEN iffD2], THEN Lists_def [THEN def_gfpI]])
wenzelm@20140
   374
  apply (subst letrecB)
wenzelm@20140
   375
  apply (unfold cons_def)
wenzelm@20140
   376
  apply blast
wenzelm@20140
   377
  done
wenzelm@20140
   378
wenzelm@20140
   379
wenzelm@20140
   380
subsection {* Lemmas and tactics for using the rule @{text
wenzelm@20140
   381
  "coinduct3"} on @{text "[="} and @{text "="} *}
wenzelm@20140
   382
wenzelm@20140
   383
lemma lfpI: "[| mono(f);  a : f(lfp(f)) |] ==> a : lfp(f)"
wenzelm@20140
   384
  apply (erule lfp_Tarski [THEN ssubst])
wenzelm@20140
   385
  apply assumption
wenzelm@20140
   386
  done
wenzelm@20140
   387
wenzelm@20140
   388
lemma ssubst_single: "[| a=a';  a' : A |] ==> a : A"
wenzelm@20140
   389
  by simp
wenzelm@20140
   390
wenzelm@20140
   391
lemma ssubst_pair: "[| a=a';  b=b';  <a',b'> : A |] ==> <a,b> : A"
wenzelm@20140
   392
  by simp
wenzelm@20140
   393
wenzelm@20140
   394
wenzelm@20140
   395
(***)
wenzelm@20140
   396
wenzelm@20140
   397
ML {*
wenzelm@20140
   398
wenzelm@20140
   399
local
wenzelm@20140
   400
  val lfpI = thm "lfpI"
wenzelm@20140
   401
  val coinduct3_mono_lemma = thm "coinduct3_mono_lemma"
wenzelm@20140
   402
  fun mk_thm s = prove_goal (the_context ()) s (fn mono::prems =>
wenzelm@26342
   403
       [fast_tac (@{claset} addIs ((mono RS coinduct3_mono_lemma RS lfpI)::prems)) 1])
wenzelm@20140
   404
in
wenzelm@20140
   405
val ci3_RI    = mk_thm "[|  mono(Agen);  a : R |] ==> a : lfp(%x. Agen(x) Un R Un A)"
wenzelm@20140
   406
val ci3_AgenI = mk_thm "[|  mono(Agen);  a : Agen(lfp(%x. Agen(x) Un R Un A)) |] ==> a : lfp(%x. Agen(x) Un R Un A)"
wenzelm@20140
   407
val ci3_AI    = mk_thm "[|  mono(Agen);  a : A |] ==> a : lfp(%x. Agen(x) Un R Un A)"
wenzelm@20140
   408
wenzelm@20140
   409
fun mk_genIs thy defs genXH gen_mono s = prove_goalw thy defs s
wenzelm@20140
   410
      (fn prems => [rtac (genXH RS iffD2) 1,
wenzelm@30607
   411
                    simp_tac (simpset_of thy) 1,
wenzelm@26342
   412
                    TRY (fast_tac (@{claset} addIs
wenzelm@20140
   413
                            ([genXH RS iffD2,gen_mono RS coinduct3_mono_lemma RS lfpI]
wenzelm@20140
   414
                             @ prems)) 1)])
wenzelm@20140
   415
end;
wenzelm@20140
   416
wenzelm@20140
   417
bind_thm ("ci3_RI", ci3_RI);
wenzelm@20140
   418
bind_thm ("ci3_AgenI", ci3_AgenI);
wenzelm@20140
   419
bind_thm ("ci3_AI", ci3_AI);
wenzelm@20140
   420
*}
wenzelm@20140
   421
wenzelm@20140
   422
wenzelm@20140
   423
subsection {* POgen *}
wenzelm@20140
   424
wenzelm@20140
   425
lemma PO_refl: "<a,a> : PO"
wenzelm@20140
   426
  apply (rule po_refl [THEN PO_iff [THEN iffD1]])
wenzelm@20140
   427
  done
wenzelm@20140
   428
wenzelm@20140
   429
ML {*
wenzelm@20140
   430
wenzelm@20140
   431
val POgenIs = map (mk_genIs (the_context ()) (thms "data_defs") (thm "POgenXH") (thm "POgen_mono"))
wenzelm@20140
   432
  ["<true,true> : POgen(R)",
wenzelm@20140
   433
   "<false,false> : POgen(R)",
wenzelm@20140
   434
   "[| <a,a'> : R;  <b,b'> : R |] ==> <<a,b>,<a',b'>> : POgen(R)",
wenzelm@20140
   435
   "[|!!x. <b(x),b'(x)> : R |] ==><lam x. b(x),lam x. b'(x)> : POgen(R)",
wenzelm@20140
   436
   "<one,one> : POgen(R)",
wenzelm@20140
   437
   "<a,a'> : lfp(%x. POgen(x) Un R Un PO) ==> <inl(a),inl(a')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
wenzelm@20140
   438
   "<b,b'> : lfp(%x. POgen(x) Un R Un PO) ==> <inr(b),inr(b')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
wenzelm@20140
   439
   "<zero,zero> : POgen(lfp(%x. POgen(x) Un R Un PO))",
wenzelm@20140
   440
   "<n,n'> : lfp(%x. POgen(x) Un R Un PO) ==> <succ(n),succ(n')> : POgen(lfp(%x. POgen(x) Un R Un PO))",
wenzelm@20140
   441
   "<[],[]> : POgen(lfp(%x. POgen(x) Un R Un PO))",
wenzelm@20140
   442
   "[| <h,h'> : lfp(%x. POgen(x) Un R Un PO);  <t,t'> : lfp(%x. POgen(x) Un R Un PO) |] ==> <h$t,h'$t'> : POgen(lfp(%x. POgen(x) Un R Un PO))"];
wenzelm@20140
   443
wenzelm@30607
   444
fun POgen_tac ctxt (rla,rlb) i =
wenzelm@30607
   445
  SELECT_GOAL (safe_tac (local_claset_of ctxt)) i THEN
wenzelm@20140
   446
  rtac (rlb RS (rla RS (thm "ssubst_pair"))) i THEN
wenzelm@20140
   447
  (REPEAT (resolve_tac (POgenIs @ [thm "PO_refl" RS (thm "POgen_mono" RS ci3_AI)] @
wenzelm@20140
   448
    (POgenIs RL [thm "POgen_mono" RS ci3_AgenI]) @ [thm "POgen_mono" RS ci3_RI]) i));
wenzelm@20140
   449
wenzelm@20140
   450
*}
wenzelm@20140
   451
wenzelm@20140
   452
wenzelm@20140
   453
subsection {* EQgen *}
wenzelm@20140
   454
wenzelm@20140
   455
lemma EQ_refl: "<a,a> : EQ"
wenzelm@20140
   456
  apply (rule refl [THEN EQ_iff [THEN iffD1]])
wenzelm@20140
   457
  done
wenzelm@20140
   458
wenzelm@20140
   459
ML {*
wenzelm@20140
   460
wenzelm@20140
   461
val EQgenIs = map (mk_genIs (the_context ()) (thms "data_defs") (thm "EQgenXH") (thm "EQgen_mono"))
wenzelm@20140
   462
  ["<true,true> : EQgen(R)",
wenzelm@20140
   463
   "<false,false> : EQgen(R)",
wenzelm@20140
   464
   "[| <a,a'> : R;  <b,b'> : R |] ==> <<a,b>,<a',b'>> : EQgen(R)",
wenzelm@20140
   465
   "[|!!x. <b(x),b'(x)> : R |] ==> <lam x. b(x),lam x. b'(x)> : EQgen(R)",
wenzelm@20140
   466
   "<one,one> : EQgen(R)",
wenzelm@20140
   467
   "<a,a'> : lfp(%x. EQgen(x) Un R Un EQ) ==> <inl(a),inl(a')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
wenzelm@20140
   468
   "<b,b'> : lfp(%x. EQgen(x) Un R Un EQ) ==> <inr(b),inr(b')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
wenzelm@20140
   469
   "<zero,zero> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
wenzelm@20140
   470
   "<n,n'> : lfp(%x. EQgen(x) Un R Un EQ) ==> <succ(n),succ(n')> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
wenzelm@20140
   471
   "<[],[]> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))",
wenzelm@20140
   472
   "[| <h,h'> : lfp(%x. EQgen(x) Un R Un EQ); <t,t'> : lfp(%x. EQgen(x) Un R Un EQ) |] ==> <h$t,h'$t'> : EQgen(lfp(%x. EQgen(x) Un R Un EQ))"];
wenzelm@20140
   473
wenzelm@20140
   474
fun EQgen_raw_tac i =
wenzelm@23894
   475
  (REPEAT (resolve_tac (EQgenIs @ [@{thm EQ_refl} RS (@{thm EQgen_mono} RS ci3_AI)] @
wenzelm@23894
   476
    (EQgenIs RL [@{thm EQgen_mono} RS ci3_AgenI]) @ [@{thm EQgen_mono} RS ci3_RI]) i))
wenzelm@20140
   477
wenzelm@20140
   478
(* Goals of the form R <= EQgen(R) - rewrite elements <a,b> : EQgen(R) using rews and *)
wenzelm@20140
   479
(* then reduce this to a goal <a',b'> : R (hopefully?)                                *)
wenzelm@20140
   480
(*      rews are rewrite rules that would cause looping in the simpifier              *)
wenzelm@20140
   481
wenzelm@23894
   482
fun EQgen_tac ctxt rews i =
wenzelm@20140
   483
 SELECT_GOAL
wenzelm@23894
   484
   (TRY (safe_tac (local_claset_of ctxt)) THEN
wenzelm@23894
   485
    resolve_tac ((rews@[refl]) RL ((rews@[refl]) RL [@{thm ssubst_pair}])) i THEN
wenzelm@23894
   486
    ALLGOALS (simp_tac (local_simpset_of ctxt)) THEN
wenzelm@20140
   487
    ALLGOALS EQgen_raw_tac) i
wenzelm@20140
   488
*}
clasohm@0
   489
clasohm@0
   490
end