src/HOL/Tools/BNF/bnf_def.ML
author kuncar
Thu, 10 Apr 2014 17:48:16 +0200
changeset 56522 f54003750e7d
parent 56376 5a93b8f928a2
child 56523 2ae16e3d8b6d
permissions -rw-r--r--
don't forget to init Interpretation and transfer theorems in the interpretation hook
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
55061
a0adf838e2d1 adjusted comments
blanchet
parents: 55060
diff changeset
     1
(*  Title:      HOL/Tools/BNF/bnf_def.ML
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     2
    Author:     Dmitriy Traytel, TU Muenchen
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     3
    Author:     Jasmin Blanchette, TU Muenchen
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     4
    Copyright   2012
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     5
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     6
Definition of bounded natural functors.
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     7
*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     8
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
     9
signature BNF_DEF =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    10
sig
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    11
  type bnf
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    12
  type nonemptiness_witness = {I: int list, wit: term, prop: thm list}
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    13
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    14
  val morph_bnf: morphism -> bnf -> bnf
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
    15
  val morph_bnf_defs: morphism -> bnf -> bnf
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    16
  val bnf_of: Proof.context -> string -> bnf option
56346
42533f8f4729 added BNF interpretation hook
blanchet
parents: 56016
diff changeset
    17
  val bnf_interpretation: (bnf -> theory -> theory) -> theory -> theory
42533f8f4729 added BNF interpretation hook
blanchet
parents: 56016
diff changeset
    18
  val register_bnf: string -> bnf -> local_theory -> local_theory
49434
433dc7e028c8 separated registration of BNFs from bnf_def (BNFs are now stored only for bnf_def and (co)data commands)
traytel
parents: 49430
diff changeset
    19
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    20
  val name_of_bnf: bnf -> binding
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    21
  val T_of_bnf: bnf -> typ
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    22
  val live_of_bnf: bnf -> int
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    23
  val lives_of_bnf: bnf -> typ list
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    24
  val dead_of_bnf: bnf -> int
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    25
  val deads_of_bnf: bnf -> typ list
56346
42533f8f4729 added BNF interpretation hook
blanchet
parents: 56016
diff changeset
    26
  val bd_of_bnf: bnf -> term
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    27
  val nwits_of_bnf: bnf -> int
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    28
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    29
  val mapN: string
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
    30
  val relN: string
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    31
  val setN: string
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    32
  val mk_setN: int -> string
55025
1ac0a0194428 support declaration of nonemptiness witnesses in bnf_decl
traytel
parents: 54921
diff changeset
    33
  val mk_witN: int -> string
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    34
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    35
  val map_of_bnf: bnf -> term
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    36
  val sets_of_bnf: bnf -> term list
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    37
  val rel_of_bnf: bnf -> term
49214
2a3cb4c71b87 construct the right iterator theorem in the recursive case
blanchet
parents: 49123
diff changeset
    38
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    39
  val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    40
  val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    41
  val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    42
  val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    43
  val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    44
  val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    45
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    46
  val bd_Card_order_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    47
  val bd_Cinfinite_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    48
  val bd_Cnotzero_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    49
  val bd_card_order_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    50
  val bd_cinfinite_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    51
  val collect_set_map_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    52
  val in_bd_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    53
  val in_cong_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    54
  val in_mono_of_bnf: bnf -> thm
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    55
  val in_rel_of_bnf: bnf -> thm
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
    56
  val map_comp0_of_bnf: bnf -> thm
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
    57
  val map_comp_of_bnf: bnf -> thm
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    58
  val map_cong0_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    59
  val map_cong_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    60
  val map_def_of_bnf: bnf -> thm
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
    61
  val map_id0_of_bnf: bnf -> thm
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
    62
  val map_id_of_bnf: bnf -> thm
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
    63
  val map_transfer_of_bnf: bnf -> thm
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
    64
  val le_rel_OO_of_bnf: bnf -> thm
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    65
  val rel_def_of_bnf: bnf -> thm
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    66
  val rel_Grp_of_bnf: bnf -> thm
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    67
  val rel_OO_of_bnf: bnf -> thm
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    68
  val rel_OO_Grp_of_bnf: bnf -> thm
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    69
  val rel_cong_of_bnf: bnf -> thm
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    70
  val rel_conversep_of_bnf: bnf -> thm
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
    71
  val rel_mono_of_bnf: bnf -> thm
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
    72
  val rel_mono_strong_of_bnf: bnf -> thm
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    73
  val rel_eq_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    74
  val rel_flip_of_bnf: bnf -> thm
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    75
  val set_bd_of_bnf: bnf -> thm list
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    76
  val set_defs_of_bnf: bnf -> thm list
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
    77
  val set_map0_of_bnf: bnf -> thm list
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
    78
  val set_map_of_bnf: bnf -> thm list
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    79
  val wit_thms_of_bnf: bnf -> thm list
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    80
  val wit_thmss_of_bnf: bnf -> thm list list
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    81
54236
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
    82
  val mk_map: int -> typ list -> typ list -> term -> term
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
    83
  val mk_rel: int -> typ list -> typ list -> term -> term
54237
7cc6e286fe28 made sugared 'coinduct' theorem construction n2m-proof
blanchet
parents: 54236
diff changeset
    84
  val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
7cc6e286fe28 made sugared 'coinduct' theorem construction n2m-proof
blanchet
parents: 54236
diff changeset
    85
  val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
54246
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
    86
  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
    87
  val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
    88
    'a list
54236
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
    89
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    90
  val mk_witness: int list * term -> thm list -> nonemptiness_witness
49103
3caaa80f53a4 generalized signature
traytel
parents: 49021
diff changeset
    91
  val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
    92
  val wits_of_bnf: bnf -> nonemptiness_witness list
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    93
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
    94
  val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
49456
fa8302c8dea1 adapted BNF composition to new relator approach
blanchet
parents: 49455
diff changeset
    95
55854
ee270328a781 make 'typedef' optional, depending on size of original type
blanchet
parents: 55480
diff changeset
    96
  datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
49538
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
    97
  datatype fact_policy = Dont_Note | Note_Some | Note_All
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
    98
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
    99
  val bnf_note_all: bool Config.T
53143
ba80154a1118 configuration option to control timing output for (co)datatypes
traytel
parents: 53126
diff changeset
   100
  val bnf_timing: bool Config.T
49435
483007ddbdc2 bnf_note_all mode for "pre_"-BNFs
traytel
parents: 49434
diff changeset
   101
  val user_policy: fact_policy -> Proof.context -> fact_policy
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   102
  val note_bnf_thms: fact_policy -> (binding -> binding) -> binding -> bnf -> Proof.context ->
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   103
    Proof.context
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   104
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   105
  val print_bnfs: Proof.context -> unit
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   106
  val prepare_def: inline_policy -> (Proof.context -> fact_policy) -> bool ->
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   107
    (binding -> binding) -> (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) ->
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   108
    typ list option -> binding -> binding -> binding list ->
54601
91a1e4aa7c80 command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents: 54490
diff changeset
   109
    (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
91a1e4aa7c80 command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents: 54490
diff changeset
   110
    string * term list *
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
   111
    ((Proof.context -> thm list -> tactic) option * term list list) *
54601
91a1e4aa7c80 command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents: 54490
diff changeset
   112
    ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
91a1e4aa7c80 command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents: 54490
diff changeset
   113
    local_theory * thm list
91a1e4aa7c80 command for axiomatic declaration of bnfs---allow theoreticians to fix an arbitrary type with functorial structure and work abstractly on it
traytel
parents: 54490
diff changeset
   114
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   115
  val define_bnf_consts: inline_policy -> fact_policy -> bool -> typ list option ->
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   116
    binding -> binding -> binding list ->
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   117
    (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   118
      ((typ list * typ list * typ list * typ) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   119
       (term * term list * term * (int list * term) list * term) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   120
       (thm * thm list * thm * thm list * thm) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   121
       ((typ list -> typ list -> typ list -> term) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   122
        (typ list -> typ list -> term -> term) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   123
        (typ list -> typ list -> typ -> typ) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   124
        (typ list -> typ list -> typ list -> term) *
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   125
        (typ list -> typ list -> typ list -> term))) * local_theory
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   126
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   127
  val bnf_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> (binding -> binding) ->
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
   128
    (Proof.context -> tactic) list ->
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
   129
    (Proof.context -> tactic) -> typ list option -> binding ->
51767
bbcdd8519253 honor user-specified name for relator + generalize syntax
blanchet
parents: 51766
diff changeset
   130
    binding -> binding list ->
54421
632be352a5a3 more explicit syntax for defining a bnf
traytel
parents: 54285
diff changeset
   131
    (((((binding * typ) * term) * term list) * term) * term list) * term option ->
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
   132
    local_theory -> bnf * local_theory
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   133
end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   134
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   135
structure BNF_Def : BNF_DEF =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   136
struct
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   137
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   138
open BNF_Util
49463
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   139
open BNF_Tactics
49284
5f39b7940b49 spin off "bnf_def_tactics.ML"
blanchet
parents: 49279
diff changeset
   140
open BNF_Def_Tactics
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   141
54624
36301c99ed26 revert making 'map_cong' a 'cong' -- it breaks too many proofs in the AFP
blanchet
parents: 54620
diff changeset
   142
val fundefcong_attrs = @{attributes [fundef_cong]};
51765
224b6eb2313a added "fundef_cong" attribute to "map_cong"
blanchet
parents: 51762
diff changeset
   143
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   144
type axioms = {
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
   145
  map_id0: thm,
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
   146
  map_comp0: thm,
51761
4c9f08836d87 renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents: 51758
diff changeset
   147
  map_cong0: thm,
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   148
  set_map0: thm list,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   149
  bd_card_order: thm,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   150
  bd_cinfinite: thm,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   151
  set_bd: thm list,
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   152
  le_rel_OO: thm,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   153
  rel_OO_Grp: thm
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   154
};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   155
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   156
fun mk_axioms' ((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel) =
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   157
  {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   158
   bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   159
51930
52fd62618631 prefer explicitly qualified exceptions, which is particular important for robust handlers;
wenzelm
parents: 51917
diff changeset
   160
fun dest_cons [] = raise List.Empty
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   161
  | dest_cons (x :: xs) = (x, xs);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   162
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   163
fun mk_axioms n thms = thms
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   164
  |> map the_single
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   165
  |> dest_cons
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   166
  ||>> dest_cons
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   167
  ||>> dest_cons
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   168
  ||>> chop n
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   169
  ||>> dest_cons
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   170
  ||>> dest_cons
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   171
  ||>> chop n
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   172
  ||>> dest_cons
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   173
  ||> the_single
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   174
  |> mk_axioms';
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   175
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   176
fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   177
  [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel];
49460
4dd451a075ce fixed infinite loop with trivial rel_O_Gr + tuning
blanchet
parents: 49459
diff changeset
   178
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   179
fun dest_axioms {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   180
  le_rel_OO, rel_OO_Grp} =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   181
  zip_axioms map_id0 map_comp0 map_cong0 set_map0 bd_card_order bd_cinfinite set_bd le_rel_OO
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   182
    rel_OO_Grp;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   183
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   184
fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   185
  le_rel_OO, rel_OO_Grp} =
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
   186
  {map_id0 = f map_id0,
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
   187
    map_comp0 = f map_comp0,
51761
4c9f08836d87 renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents: 51758
diff changeset
   188
    map_cong0 = f map_cong0,
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   189
    set_map0 = map f set_map0,
49463
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   190
    bd_card_order = f bd_card_order,
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   191
    bd_cinfinite = f bd_cinfinite,
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   192
    set_bd = map f set_bd,
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   193
    le_rel_OO = f le_rel_OO,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   194
    rel_OO_Grp = f rel_OO_Grp};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   195
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   196
val morph_axioms = map_axioms o Morphism.thm;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   197
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   198
type defs = {
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   199
  map_def: thm,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   200
  set_defs: thm list,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   201
  rel_def: thm
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   202
}
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   203
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   204
fun mk_defs map sets rel = {map_def = map, set_defs = sets, rel_def = rel};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   205
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   206
fun map_defs f {map_def, set_defs, rel_def} =
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   207
  {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   208
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   209
val morph_defs = map_defs o Morphism.thm;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   210
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   211
type facts = {
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   212
  bd_Card_order: thm,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   213
  bd_Cinfinite: thm,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   214
  bd_Cnotzero: thm,
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
   215
  collect_set_map: thm lazy,
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
   216
  in_bd: thm lazy,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   217
  in_cong: thm lazy,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   218
  in_mono: thm lazy,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   219
  in_rel: thm lazy,
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   220
  map_comp: thm lazy,
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   221
  map_cong: thm lazy,
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   222
  map_id: thm lazy,
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   223
  map_transfer: thm lazy,
49591
91b228e26348 generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents: 49585
diff changeset
   224
  rel_eq: thm lazy,
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   225
  rel_flip: thm lazy,
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
   226
  set_map: thm lazy list,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   227
  rel_cong: thm lazy,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   228
  rel_mono: thm lazy,
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   229
  rel_mono_strong: thm lazy,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   230
  rel_Grp: thm lazy,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   231
  rel_conversep: thm lazy,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   232
  rel_OO: thm lazy
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   233
};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   234
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
   235
fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   236
    map_comp map_cong map_id map_transfer rel_eq rel_flip set_map rel_cong rel_mono
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   237
    rel_mono_strong rel_Grp rel_conversep rel_OO = {
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   238
  bd_Card_order = bd_Card_order,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   239
  bd_Cinfinite = bd_Cinfinite,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   240
  bd_Cnotzero = bd_Cnotzero,
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
   241
  collect_set_map = collect_set_map,
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
   242
  in_bd = in_bd,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   243
  in_cong = in_cong,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   244
  in_mono = in_mono,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   245
  in_rel = in_rel,
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   246
  map_comp = map_comp,
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   247
  map_cong = map_cong,
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   248
  map_id = map_id,
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   249
  map_transfer = map_transfer,
49591
91b228e26348 generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents: 49585
diff changeset
   250
  rel_eq = rel_eq,
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   251
  rel_flip = rel_flip,
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
   252
  set_map = set_map,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   253
  rel_cong = rel_cong,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   254
  rel_mono = rel_mono,
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   255
  rel_mono_strong = rel_mono_strong,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   256
  rel_Grp = rel_Grp,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   257
  rel_conversep = rel_conversep,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   258
  rel_OO = rel_OO};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   259
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   260
fun map_facts f {
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   261
  bd_Card_order,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   262
  bd_Cinfinite,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   263
  bd_Cnotzero,
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
   264
  collect_set_map,
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
   265
  in_bd,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   266
  in_cong,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   267
  in_mono,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   268
  in_rel,
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   269
  map_comp,
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   270
  map_cong,
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   271
  map_id,
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   272
  map_transfer,
49591
91b228e26348 generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents: 49585
diff changeset
   273
  rel_eq,
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   274
  rel_flip,
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
   275
  set_map,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   276
  rel_cong,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   277
  rel_mono,
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   278
  rel_mono_strong,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   279
  rel_Grp,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   280
  rel_conversep,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   281
  rel_OO} =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   282
  {bd_Card_order = f bd_Card_order,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   283
    bd_Cinfinite = f bd_Cinfinite,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   284
    bd_Cnotzero = f bd_Cnotzero,
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
   285
    collect_set_map = Lazy.map f collect_set_map,
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
   286
    in_bd = Lazy.map f in_bd,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   287
    in_cong = Lazy.map f in_cong,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   288
    in_mono = Lazy.map f in_mono,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   289
    in_rel = Lazy.map f in_rel,
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   290
    map_comp = Lazy.map f map_comp,
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   291
    map_cong = Lazy.map f map_cong,
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   292
    map_id = Lazy.map f map_id,
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   293
    map_transfer = Lazy.map f map_transfer,
49591
91b228e26348 generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents: 49585
diff changeset
   294
    rel_eq = Lazy.map f rel_eq,
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   295
    rel_flip = Lazy.map f rel_flip,
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
   296
    set_map = map (Lazy.map f) set_map,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   297
    rel_cong = Lazy.map f rel_cong,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   298
    rel_mono = Lazy.map f rel_mono,
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   299
    rel_mono_strong = Lazy.map f rel_mono_strong,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   300
    rel_Grp = Lazy.map f rel_Grp,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   301
    rel_conversep = Lazy.map f rel_conversep,
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   302
    rel_OO = Lazy.map f rel_OO};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   303
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   304
val morph_facts = map_facts o Morphism.thm;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   305
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   306
type nonemptiness_witness = {
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   307
  I: int list,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   308
  wit: term,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   309
  prop: thm list
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   310
};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   311
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   312
fun mk_witness (I, wit) prop = {I = I, wit = wit, prop = prop};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   313
fun map_witness f g {I, wit, prop} = {I = I, wit = f wit, prop = map g prop};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   314
fun morph_witness phi = map_witness (Morphism.term phi) (Morphism.thm phi);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   315
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
   316
datatype bnf = BNF of {
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   317
  name: binding,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   318
  T: typ,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   319
  live: int,
53261
3c26a7042d8e removed outdated comments
panny
parents: 53143
diff changeset
   320
  lives: typ list, (*source type variables of map*)
3c26a7042d8e removed outdated comments
panny
parents: 53143
diff changeset
   321
  lives': typ list, (*target type variables of map*)
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   322
  dead: int,
53261
3c26a7042d8e removed outdated comments
panny
parents: 53143
diff changeset
   323
  deads: typ list,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   324
  map: term,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   325
  sets: term list,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   326
  bd: term,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   327
  axioms: axioms,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   328
  defs: defs,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   329
  facts: facts,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   330
  nwits: int,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   331
  wits: nonemptiness_witness list,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   332
  rel: term
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   333
};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   334
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   335
(* getters *)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   336
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   337
fun rep_bnf (BNF bnf) = bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   338
val name_of_bnf = #name o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   339
val T_of_bnf = #T o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   340
fun mk_T_of_bnf Ds Ts bnf =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   341
  let val bnf_rep = rep_bnf bnf
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   342
  in Term.typ_subst_atomic ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#T bnf_rep) end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   343
val live_of_bnf = #live o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   344
val lives_of_bnf = #lives o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   345
val dead_of_bnf = #dead o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   346
val deads_of_bnf = #deads o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   347
val axioms_of_bnf = #axioms o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   348
val facts_of_bnf = #facts o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   349
val nwits_of_bnf = #nwits o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   350
val wits_of_bnf = #wits o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   351
53031
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   352
fun flatten_type_args_of_bnf bnf dead_x xs =
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   353
  let
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   354
    val Type (_, Ts) = T_of_bnf bnf;
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   355
    val lives = lives_of_bnf bnf;
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   356
    val deads = deads_of_bnf bnf;
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   357
  in
55480
59cc4a8bc28a allow different functions to recurse on the same type, like in the old package
blanchet
parents: 55444
diff changeset
   358
    permute_like_unique (op =) (deads @ lives) Ts (replicate (length deads) dead_x @ xs)
53031
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   359
  end;
83cbe188855a moved useful library functions upstream
blanchet
parents: 52957
diff changeset
   360
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   361
(*terms*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   362
val map_of_bnf = #map o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   363
val sets_of_bnf = #sets o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   364
fun mk_map_of_bnf Ds Ts Us bnf =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   365
  let val bnf_rep = rep_bnf bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   366
  in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   367
    Term.subst_atomic_types
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   368
      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#map bnf_rep)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   369
  end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   370
fun mk_sets_of_bnf Dss Tss bnf =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   371
  let val bnf_rep = rep_bnf bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   372
  in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   373
    map2 (fn (Ds, Ts) => Term.subst_atomic_types
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   374
      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts))) (Dss ~~ Tss) (#sets bnf_rep)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   375
  end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   376
val bd_of_bnf = #bd o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   377
fun mk_bd_of_bnf Ds Ts bnf =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   378
  let val bnf_rep = rep_bnf bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   379
  in Term.subst_atomic_types ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#bd bnf_rep) end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   380
fun mk_wits_of_bnf Dss Tss bnf =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   381
  let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   382
    val bnf_rep = rep_bnf bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   383
    val wits = map (fn x => (#I x, #wit x)) (#wits bnf_rep);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   384
  in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   385
    map2 (fn (Ds, Ts) => apsnd (Term.subst_atomic_types
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   386
      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)))) (Dss ~~ Tss) wits
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   387
  end;
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   388
val rel_of_bnf = #rel o rep_bnf;
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   389
fun mk_rel_of_bnf Ds Ts Us bnf =
49462
blanchet
parents: 49461
diff changeset
   390
  let val bnf_rep = rep_bnf bnf;
blanchet
parents: 49461
diff changeset
   391
  in
blanchet
parents: 49461
diff changeset
   392
    Term.subst_atomic_types
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   393
      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
49462
blanchet
parents: 49461
diff changeset
   394
  end;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   395
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   396
(*thms*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   397
val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   398
val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   399
val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   400
val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   401
val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
   402
val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
   403
val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   404
val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   405
val in_mono_of_bnf = Lazy.force o #in_mono o #facts o rep_bnf;
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   406
val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   407
val map_def_of_bnf = #map_def o #defs o rep_bnf;
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
   408
val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   409
val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
   410
val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   411
val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
51761
4c9f08836d87 renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents: 51758
diff changeset
   412
val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   413
val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
52731
dacd47a0633f transfer rule for {c,d}tor_{,un}fold
traytel
parents: 52725
diff changeset
   414
val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   415
val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   416
val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
49591
91b228e26348 generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents: 49585
diff changeset
   417
val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   418
val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   419
val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   420
val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   421
val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
   422
val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   423
val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   424
val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   425
val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   426
val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   427
val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   428
val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   429
val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   430
val wit_thms_of_bnf = maps #prop o wits_of_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   431
val wit_thmss_of_bnf = map #prop o wits_of_bnf;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   432
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   433
fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   434
  BNF {name = name, T = T,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   435
       live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   436
       map = map, sets = sets, bd = bd,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   437
       axioms = axioms, defs = defs, facts = facts,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   438
       nwits = length wits, wits = wits, rel = rel};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   439
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   440
fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   441
  (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   442
  dead = dead, deads = deads, map = map, sets = sets, bd = bd,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   443
  axioms = axioms, defs = defs, facts = facts,
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   444
  nwits = nwits, wits = wits, rel = rel}) =
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   445
  BNF {name = f1 name, T = f2 T,
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   446
       live = f3 live, lives = f4 lives, lives' = f5 lives', dead = f6 dead, deads = f7 deads,
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   447
       map = f8 map, sets = f9 sets, bd = f10 bd,
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   448
       axioms = f11 axioms, defs = f12 defs, facts = f13 facts,
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   449
       nwits = f14 nwits, wits = f15 wits, rel = f16 rel};
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   450
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   451
fun morph_bnf phi =
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   452
  let
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   453
    val Tphi = Morphism.typ phi;
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   454
    val tphi = Morphism.term phi;
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   455
  in
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   456
    map_bnf (Morphism.binding phi) Tphi I (map Tphi) (map Tphi) I (map Tphi) tphi (map tphi) tphi
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   457
      (morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   458
  end;
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   459
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   460
fun morph_bnf_defs phi = map_bnf I I I I I I I I I I I (morph_defs phi) I I I I;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   461
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   462
structure Data = Generic_Data
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   463
(
51837
087498724486 lowercase type constructor, for consistency (cf. fp_result not FP_result nor FP_Result)
blanchet
parents: 51836
diff changeset
   464
  type T = bnf Symtab.table;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   465
  val empty = Symtab.empty;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   466
  val extend = I;
55394
d5ebe055b599 more liberal merging of BNFs and constructor sugar
blanchet
parents: 55356
diff changeset
   467
  fun merge data : T = Symtab.merge (K true) data;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   468
);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   469
53126
f4d2c64c7aa8 transfer stored fp_sugar theorems into the "current" theory when retrieving an fp_sugar (avoids non-trivial merges)
traytel
parents: 53040
diff changeset
   470
fun bnf_of ctxt =
f4d2c64c7aa8 transfer stored fp_sugar theorems into the "current" theory when retrieving an fp_sugar (avoids non-trivial merges)
traytel
parents: 53040
diff changeset
   471
  Symtab.lookup (Data.get (Context.Proof ctxt))
54740
91f54d386680 maintain morphism names for diagnostic purposes;
wenzelm
parents: 54624
diff changeset
   472
  #> Option.map (morph_bnf (Morphism.transfer_morphism (Proof_Context.theory_of ctxt)));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   473
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   474
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   475
(* Utilities *)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   476
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   477
fun normalize_set insts instA set =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   478
  let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   479
    val (T, T') = dest_funT (fastype_of set);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   480
    val A = fst (Term.dest_TVar (HOLogic.dest_setT T'));
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   481
    val params = Term.add_tvar_namesT T [];
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   482
  in Term.subst_TVars ((A :: params) ~~ (instA :: insts)) set end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   483
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   484
fun normalize_rel ctxt instTs instA instB rel =
49462
blanchet
parents: 49461
diff changeset
   485
  let
blanchet
parents: 49461
diff changeset
   486
    val thy = Proof_Context.theory_of ctxt;
blanchet
parents: 49461
diff changeset
   487
    val tyenv =
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   488
      Sign.typ_match thy (fastype_of rel, Library.foldr (op -->) (instTs, mk_pred2T instA instB))
49463
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   489
        Vartab.empty;
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   490
  in Envir.subst_term (tyenv, Vartab.empty) rel end
49453
ff0e540d8758 add rel as first-class citizen of BNF
blanchet
parents: 49452
diff changeset
   491
  handle Type.TYPE_MATCH => error "Bad relator";
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   492
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   493
fun normalize_wit insts CA As wit =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   494
  let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   495
    fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   496
        if Type.raw_instance (CA, T) then (Ts, T) else strip_param (T1 :: Ts, T2)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   497
      | strip_param x = x;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   498
    val (Ts, T) = strip_param ([], fastype_of wit);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   499
    val subst = Term.add_tvar_namesT T [] ~~ insts;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   500
    fun find y = find_index (fn x => x = y) As;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   501
  in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   502
    (map (find o Term.typ_subst_TVars subst) (rev Ts), Term.subst_TVars subst wit)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   503
  end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   504
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   505
fun minimize_wits wits =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   506
 let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   507
   fun minimize done [] = done
49103
3caaa80f53a4 generalized signature
traytel
parents: 49021
diff changeset
   508
     | minimize done ((I, wit) :: todo) =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   509
       if exists (fn (J, _) => subset (op =) (J, I)) (done @ todo)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   510
       then minimize done todo
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   511
       else minimize ((I, wit) :: done) todo;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   512
 in minimize [] wits end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   513
54236
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   514
fun mk_map live Ts Us t =
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   515
  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   516
    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   517
  end;
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   518
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   519
fun mk_rel live Ts Us t =
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   520
  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   521
    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   522
  end;
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   523
54237
7cc6e286fe28 made sugared 'coinduct' theorem construction n2m-proof
blanchet
parents: 54236
diff changeset
   524
fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
54236
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   525
  let
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   526
    fun build (TU as (T, U)) =
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   527
      if T = U then
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   528
        const T
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   529
      else
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   530
        (case TU of
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   531
          (Type (s, Ts), Type (s', Us)) =>
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   532
          if s = s' then
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   533
            let
54237
7cc6e286fe28 made sugared 'coinduct' theorem construction n2m-proof
blanchet
parents: 54236
diff changeset
   534
              val bnf = the (bnf_of ctxt s);
54236
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   535
              val live = live_of_bnf bnf;
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   536
              val mapx = mk live Ts Us (of_bnf bnf);
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   537
              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   538
            in Term.list_comb (mapx, map build TUs') end
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   539
          else
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   540
            build_simple TU
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   541
        | _ => build_simple TU);
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   542
  in build end;
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   543
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   544
val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
e00009523727 moved code around
blanchet
parents: 54189
diff changeset
   545
val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   546
54246
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   547
fun map_flattened_map_args ctxt s map_args fs =
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   548
  let
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   549
    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   550
    val flat_fs' = map_args flat_fs;
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   551
  in
55480
59cc4a8bc28a allow different functions to recurse on the same type, like in the old package
blanchet
parents: 55444
diff changeset
   552
    permute_like_unique (op aconv) flat_fs fs flat_fs'
54246
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   553
  end;
8fdb4dc08ed1 split 'primrec_new' and 'primcorec' code (to ease bootstrapping, e.g. dependency on datatype 'String' in 'primcorec')
blanchet
parents: 54237
diff changeset
   554
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   555
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   556
(* Names *)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   557
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   558
val mapN = "map";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   559
val setN = "set";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   560
fun mk_setN i = setN ^ nonzero_string_of_int i;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   561
val bdN = "bd";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   562
val witN = "wit";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   563
fun mk_witN i = witN ^ nonzero_string_of_int i;
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   564
val relN = "rel";
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   565
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   566
val bd_card_orderN = "bd_card_order";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   567
val bd_cinfiniteN = "bd_cinfinite";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   568
val bd_Card_orderN = "bd_Card_order";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   569
val bd_CinfiniteN = "bd_Cinfinite";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   570
val bd_CnotzeroN = "bd_Cnotzero";
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
   571
val collect_set_mapN = "collect_set_map";
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   572
val in_bdN = "in_bd";
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   573
val in_monoN = "in_mono";
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   574
val in_relN = "in_rel";
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
   575
val map_id0N = "map_id0";
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   576
val map_idN = "map_id";
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
   577
val map_comp0N = "map_comp0";
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   578
val map_compN = "map_comp";
51761
4c9f08836d87 renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents: 51758
diff changeset
   579
val map_cong0N = "map_cong0";
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   580
val map_congN = "map_cong";
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   581
val map_transferN = "map_transfer";
49591
91b228e26348 generate high-level "coinduct" and "strong_coinduct" properties
blanchet
parents: 49585
diff changeset
   582
val rel_eqN = "rel_eq";
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   583
val rel_flipN = "rel_flip";
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   584
val set_map0N = "set_map0";
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
   585
val set_mapN = "set_map";
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
   586
val set_bdN = "set_bd";
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   587
val rel_GrpN = "rel_Grp";
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   588
val rel_conversepN = "rel_conversep";
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   589
val rel_monoN = "rel_mono"
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   590
val rel_mono_strongN = "rel_mono_strong"
54620
blanchet
parents: 54619
diff changeset
   591
val rel_comppN = "rel_compp";
blanchet
parents: 54619
diff changeset
   592
val rel_compp_GrpN = "rel_compp_Grp";
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   593
55854
ee270328a781 make 'typedef' optional, depending on size of original type
blanchet
parents: 55480
diff changeset
   594
datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   595
49538
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
   596
datatype fact_policy = Dont_Note | Note_Some | Note_All;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   597
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   598
val bnf_note_all = Attrib.setup_config_bool @{binding bnf_note_all} (K false);
53143
ba80154a1118 configuration option to control timing output for (co)datatypes
traytel
parents: 53126
diff changeset
   599
val bnf_timing = Attrib.setup_config_bool @{binding bnf_timing} (K false);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   600
49538
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
   601
fun user_policy policy ctxt = if Config.get ctxt bnf_note_all then Note_All else policy;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   602
55854
ee270328a781 make 'typedef' optional, depending on size of original type
blanchet
parents: 55480
diff changeset
   603
val smart_max_inline_term_size = 25; (*FUDGE*)
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   604
54045
369a4a14583a keep the qualification of bindings when noting bnf theorems
traytel
parents: 53561
diff changeset
   605
fun note_bnf_thms fact_policy qualify' bnf_b bnf =
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   606
  let
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   607
    val axioms = axioms_of_bnf bnf;
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   608
    val facts = facts_of_bnf bnf;
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   609
    val wits = wits_of_bnf bnf;
54045
369a4a14583a keep the qualification of bindings when noting bnf theorems
traytel
parents: 53561
diff changeset
   610
    val qualify =
369a4a14583a keep the qualification of bindings when noting bnf theorems
traytel
parents: 53561
diff changeset
   611
      let val (_, qs, _) = Binding.dest bnf_b;
369a4a14583a keep the qualification of bindings when noting bnf theorems
traytel
parents: 53561
diff changeset
   612
      in fold_rev (fn (s, mand) => Binding.qualify mand s) qs #> qualify' end;
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   613
  in
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   614
    (if fact_policy = Note_All then
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   615
      let
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   616
        val witNs = if length wits = 1 then [witN] else map mk_witN (1 upto length wits);
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   617
        val notes =
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   618
          [(bd_card_orderN, [#bd_card_order axioms]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   619
            (bd_cinfiniteN, [#bd_cinfinite axioms]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   620
            (bd_Card_orderN, [#bd_Card_order facts]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   621
            (bd_CinfiniteN, [#bd_Cinfinite facts]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   622
            (bd_CnotzeroN, [#bd_Cnotzero facts]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   623
            (collect_set_mapN, [Lazy.force (#collect_set_map facts)]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   624
            (in_bdN, [Lazy.force (#in_bd facts)]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   625
            (in_monoN, [Lazy.force (#in_mono facts)]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   626
            (in_relN, [Lazy.force (#in_rel facts)]),
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
   627
            (map_comp0N, [#map_comp0 axioms]),
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
   628
            (map_id0N, [#map_id0 axioms]),
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   629
            (map_transferN, [Lazy.force (#map_transfer facts)]),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   630
            (rel_mono_strongN, [Lazy.force (#rel_mono_strong facts)]),
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   631
            (set_map0N, #set_map0 axioms),
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   632
            (set_bdN, #set_bd axioms)] @
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   633
            (witNs ~~ wit_thmss_of_bnf bnf)
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   634
            |> map (fn (thmN, thms) =>
53265
cc9a2976f836 qualify BNF constants properly
blanchet
parents: 53261
diff changeset
   635
              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)), []),
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   636
              [(thms, [])]));
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   637
        in
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   638
          Local_Theory.notes notes #> snd
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   639
        end
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   640
      else
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   641
        I)
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   642
    #> (if fact_policy <> Dont_Note then
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   643
        let
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   644
          val notes =
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
   645
            [(map_compN, [Lazy.force (#map_comp facts)], []),
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   646
            (map_cong0N, [#map_cong0 axioms], []),
54624
36301c99ed26 revert making 'map_cong' a 'cong' -- it breaks too many proofs in the AFP
blanchet
parents: 54620
diff changeset
   647
            (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
   648
            (map_idN, [Lazy.force (#map_id facts)], []),
54620
blanchet
parents: 54619
diff changeset
   649
            (rel_comppN, [Lazy.force (#rel_OO facts)], []),
blanchet
parents: 54619
diff changeset
   650
            (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
blanchet
parents: 54619
diff changeset
   651
            (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   652
            (rel_eqN, [Lazy.force (#rel_eq facts)], []),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   653
            (rel_flipN, [Lazy.force (#rel_flip facts)], []),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   654
            (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   655
            (rel_monoN, [Lazy.force (#rel_mono facts)], []),
54620
blanchet
parents: 54619
diff changeset
   656
            (set_mapN, map Lazy.force (#set_map facts), [])]
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   657
            |> filter_out (null o #2)
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   658
            |> map (fn (thmN, thms, attrs) =>
53265
cc9a2976f836 qualify BNF constants properly
blanchet
parents: 53261
diff changeset
   659
              ((qualify (Binding.qualify true (Binding.name_of bnf_b) (Binding.name thmN)),
52720
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   660
                attrs), [(thms, [])]));
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   661
        in
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   662
          Local_Theory.notes notes #> snd
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   663
        end
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   664
      else
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   665
        I)
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   666
  end;
fdc04f9bf906 separate ML interface to note facts of a bnf
traytel
parents: 52719
diff changeset
   667
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   668
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   669
(* Define new BNFs *)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   670
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   671
fun define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b set_bs
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   672
  ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   673
  let
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   674
    val live = length set_rhss;
53265
cc9a2976f836 qualify BNF constants properly
blanchet
parents: 53261
diff changeset
   675
54156
a8cf84bfa9be conceal even more ugly constructions
blanchet
parents: 54045
diff changeset
   676
    val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
53265
cc9a2976f836 qualify BNF constants properly
blanchet
parents: 53261
diff changeset
   677
54490
930409d43211 use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents: 54426
diff changeset
   678
    fun mk_prefix_binding pre = Binding.prefix_name (pre ^ "_") bnf_b;
49434
433dc7e028c8 separated registration of BNFs from bnf_def (BNFs are now stored only for bnf_def and (co)data commands)
traytel
parents: 49430
diff changeset
   679
49463
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   680
    fun maybe_define user_specified (b, rhs) lthy =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   681
      let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   682
        val inline =
49538
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
   683
          (user_specified orelse fact_policy = Dont_Note) andalso
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   684
          (case const_policy of
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   685
            Dont_Inline => false
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   686
          | Hardly_Inline => Term.is_Free rhs orelse Term.is_Const rhs
55854
ee270328a781 make 'typedef' optional, depending on size of original type
blanchet
parents: 55480
diff changeset
   687
          | Smart_Inline => Term.size_of_term rhs <= smart_max_inline_term_size
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   688
          | Do_Inline => true)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   689
      in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   690
        if inline then
49460
4dd451a075ce fixed infinite loop with trivial rel_O_Gr + tuning
blanchet
parents: 49459
diff changeset
   691
          ((rhs, Drule.reflexive_thm), lthy)
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   692
        else
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   693
          let val b = b () in
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   694
            apfst (apsnd snd)
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   695
              ((if internal then Local_Theory.define_internal else Local_Theory.define)
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   696
                ((b, NoSyn), ((Thm.def_binding b, []), rhs)) lthy)
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   697
          end
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   698
      end;
49459
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   699
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   700
    fun maybe_restore lthy_old lthy =
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   701
      lthy |> not (pointer_eq (lthy_old, lthy)) ? Local_Theory.restore;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   702
51758
55963309557b honor user-specified name for map function
blanchet
parents: 51757
diff changeset
   703
    val map_bind_def =
54490
930409d43211 use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents: 54426
diff changeset
   704
      (fn () => def_qualify (if Binding.is_empty map_b then mk_prefix_binding mapN else map_b),
53265
cc9a2976f836 qualify BNF constants properly
blanchet
parents: 53261
diff changeset
   705
         map_rhs);
49459
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   706
    val set_binds_defs =
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   707
      let
51757
7babcb61aa5c honor user-specified set function names
blanchet
parents: 51551
diff changeset
   708
        fun set_name i get_b =
7babcb61aa5c honor user-specified set function names
blanchet
parents: 51551
diff changeset
   709
          (case try (nth set_bs) (i - 1) of
7babcb61aa5c honor user-specified set function names
blanchet
parents: 51551
diff changeset
   710
            SOME b => if Binding.is_empty b then get_b else K b
53265
cc9a2976f836 qualify BNF constants properly
blanchet
parents: 53261
diff changeset
   711
          | NONE => get_b) #> def_qualify;
54490
930409d43211 use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents: 54426
diff changeset
   712
        val bs = if live = 1 then [set_name 1 (fn () => mk_prefix_binding setN)]
930409d43211 use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents: 54426
diff changeset
   713
          else map (fn i => set_name i (fn () => mk_prefix_binding (mk_setN i))) (1 upto live);
51757
7babcb61aa5c honor user-specified set function names
blanchet
parents: 51551
diff changeset
   714
      in bs ~~ set_rhss end;
54490
930409d43211 use suffix '_list' etc. instead of prefix 'list_' for constants not present in the old package
blanchet
parents: 54426
diff changeset
   715
    val bd_bind_def = (fn () => def_qualify (mk_prefix_binding bdN), bd_rhs);
49459
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   716
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
   717
    val ((((bnf_map_term, raw_map_def),
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   718
      (bnf_set_terms, raw_set_defs)),
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
   719
      (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   720
        no_defs_lthy
49463
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   721
        |> maybe_define true map_bind_def
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   722
        ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
83ac281bcdc2 provide predicator, define relator
blanchet
parents: 49462
diff changeset
   723
        ||>> maybe_define true bd_bind_def
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   724
        ||> `(maybe_restore no_defs_lthy);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   725
49459
3f8e2b5249ec adapted FP code to new relator approach
blanchet
parents: 49458
diff changeset
   726
    val phi = Proof_Context.export_morphism lthy_old lthy;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   727
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   728
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   729
    val bnf_map_def = Morphism.thm phi raw_map_def;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   730
    val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   731
    val bnf_bd_def = Morphism.thm phi raw_bd_def;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   732
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   733
    val bnf_map = Morphism.term phi bnf_map_term;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   734
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   735
    (*TODO: handle errors*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   736
    (*simple shape analysis of a map function*)
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   737
    val ((alphas, betas), (Calpha, _)) =
49395
323414474c1f use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents: 49386
diff changeset
   738
      fastype_of bnf_map
323414474c1f use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents: 49386
diff changeset
   739
      |> strip_typeN live
323414474c1f use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents: 49386
diff changeset
   740
      |>> map_split dest_funT
323414474c1f use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents: 49386
diff changeset
   741
      ||> dest_funT
323414474c1f use strip_typeN in bnf_def (instead of repairing strip_type)
traytel
parents: 49386
diff changeset
   742
      handle TYPE _ => error "Bad map function";
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   743
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   744
    val Calpha_params = map TVar (Term.add_tvarsT Calpha []);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   745
54426
edb87aac9cca prohibit locally fixed type variables in bnf definitions
traytel
parents: 54425
diff changeset
   746
    val bnf_T = Morphism.typ phi T_rhs;
edb87aac9cca prohibit locally fixed type variables in bnf definitions
traytel
parents: 54425
diff changeset
   747
    val bad_args = Term.add_tfreesT bnf_T [];
edb87aac9cca prohibit locally fixed type variables in bnf definitions
traytel
parents: 54425
diff changeset
   748
    val _ = if null bad_args then () else error ("Locally fixed type arguments " ^
edb87aac9cca prohibit locally fixed type variables in bnf definitions
traytel
parents: 54425
diff changeset
   749
      commas_quote (map (Syntax.string_of_typ no_defs_lthy o TFree) bad_args));
edb87aac9cca prohibit locally fixed type variables in bnf definitions
traytel
parents: 54425
diff changeset
   750
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   751
    val bnf_sets =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   752
      map2 (normalize_set Calpha_params) alphas (map (Morphism.term phi) bnf_set_terms);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   753
    val bnf_bd =
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   754
      Term.subst_TVars (Term.add_tvar_namesT bnf_T [] ~~ Calpha_params)
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   755
        (Morphism.term phi bnf_bd_term);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   756
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   757
    (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   758
    val deads = (case Ds_opt of
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   759
      NONE => subtract (op =) (alphas @ betas) (map TVar (Term.add_tvars bnf_map []))
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   760
    | SOME Ds => map (Morphism.typ phi) Ds);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   761
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   762
    (*TODO: further checks of type of bnf_map*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   763
    (*TODO: check types of bnf_sets*)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   764
    (*TODO: check type of bnf_bd*)
49507
8826d5a4332b renamed "pred" to "rel" (relator)
blanchet
parents: 49506
diff changeset
   765
    (*TODO: check type of bnf_rel*)
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   766
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   767
    fun mk_bnf_map Ds As' Bs' =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   768
      Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As') @ (betas ~~ Bs')) bnf_map;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   769
    fun mk_bnf_t Ds As' = Term.subst_atomic_types ((deads ~~ Ds) @ (alphas ~~ As'));
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   770
    fun mk_bnf_T Ds As' = Term.typ_subst_atomic ((deads ~~ Ds) @ (alphas ~~ As'));
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   771
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   772
    val (((As, Bs), Ds), names_lthy) = lthy
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   773
      |> mk_TFrees live
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   774
      ||>> mk_TFrees live
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   775
      ||>> mk_TFrees (length deads);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   776
    val RTs = map2 (curry HOLogic.mk_prodT) As Bs;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   777
    val pred2RTs = map2 mk_pred2T As Bs;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   778
    val (Rs, Rs') = names_lthy |> mk_Frees' "R" pred2RTs |> fst
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   779
    val CA = mk_bnf_T Ds As Calpha;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   780
    val CR = mk_bnf_T Ds RTs Calpha;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   781
    val setRs =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   782
      map3 (fn R => fn T => fn U =>
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   783
          HOLogic.Collect_const (HOLogic.mk_prodT (T, U)) $ HOLogic.mk_split R) Rs As Bs;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   784
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   785
    (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   786
      Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   787
    val OO_Grp =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   788
      let
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   789
        val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   790
        val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   791
        val bnf_in = mk_in setRs (map (mk_bnf_t Ds RTs) bnf_sets) CR;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   792
      in
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   793
        mk_rel_compp (mk_conversep (mk_Grp bnf_in map1), mk_Grp bnf_in map2)
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   794
        |> fold_rev Term.absfree Rs'
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   795
      end;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   796
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   797
    val rel_rhs = the_default OO_Grp rel_rhs_opt;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   798
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   799
    val rel_bind_def =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   800
      (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   801
         rel_rhs);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   802
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   803
    val wit_rhss =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   804
      if null wit_rhss then
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   805
        [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   806
          map2 (fn T => fn i => Term.absdummy T (Bound i)) As (live downto 1)) $
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   807
          Const (@{const_name undefined}, CA))]
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   808
      else wit_rhss;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   809
    val nwits = length wit_rhss;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   810
    val wit_binds_defs =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   811
      let
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   812
        val bs = if nwits = 1 then [fn () => def_qualify (mk_prefix_binding witN)]
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   813
          else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   814
      in bs ~~ wit_rhss end;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   815
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   816
    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   817
      lthy
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   818
      |> maybe_define (is_some rel_rhs_opt) rel_bind_def
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   819
      ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   820
      ||> `(maybe_restore lthy);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   821
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   822
    val phi = Proof_Context.export_morphism lthy_old lthy;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   823
    val bnf_rel_def = Morphism.thm phi raw_rel_def;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   824
    val bnf_rel = Morphism.term phi bnf_rel_term;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   825
    fun mk_bnf_rel Ds As' Bs' =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   826
      normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   827
        bnf_rel;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   828
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   829
    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   830
    val bnf_wits =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   831
      map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   832
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   833
    fun mk_OO_Grp Ds' As' Bs' =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   834
      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) OO_Grp;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   835
  in
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   836
    (((alphas, betas, deads, Calpha),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   837
     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   838
     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   839
     (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_OO_Grp)), lthy)
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   840
  end;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   841
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   842
fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term Ds_opt map_b rel_b
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   843
  set_bs ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   844
  no_defs_lthy =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   845
  let
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   846
    val fact_policy = mk_fact_policy no_defs_lthy;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   847
    val bnf_b = qualify raw_bnf_b;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   848
    val live = length raw_sets;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   849
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   850
    val T_rhs = prep_typ no_defs_lthy raw_bnf_T;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   851
    val map_rhs = prep_term no_defs_lthy raw_map;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   852
    val set_rhss = map (prep_term no_defs_lthy) raw_sets;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   853
    val bd_rhs = prep_term no_defs_lthy raw_bd;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   854
    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   855
    val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   856
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   857
    fun err T =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   858
      error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   859
        " as unnamed BNF");
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   860
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   861
    val (bnf_b, key) =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   862
      if Binding.eq_name (bnf_b, Binding.empty) then
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   863
        (case T_rhs of
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   864
          Type (C, Ts) => if forall (can dest_TFree) Ts
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   865
            then (Binding.qualified_name C, C) else err T_rhs
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   866
        | T => err T)
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   867
      else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   868
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   869
    val (((alphas, betas, deads, Calpha),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   870
     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   871
     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   872
     (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, mk_OO_Grp)), lthy) =
56016
8875cdcfc85b unfold intermediate definitions after sealing the bnf
traytel
parents: 55945
diff changeset
   873
       define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b set_bs
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   874
         ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   875
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   876
    val dead = length deads;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   877
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   878
    val ((((((As', Bs'), Cs), Ds), B1Ts), B2Ts), (Ts, T)) = lthy
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   879
      |> mk_TFrees live
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   880
      ||>> mk_TFrees live
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   881
      ||>> mk_TFrees live
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   882
      ||>> mk_TFrees dead
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   883
      ||>> mk_TFrees live
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   884
      ||>> mk_TFrees live
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   885
      ||> fst o mk_TFrees 1
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   886
      ||> the_single
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   887
      ||> `(replicate live);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   888
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   889
    val mk_bnf_map = mk_bnf_map_Ds Ds;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   890
    val mk_bnf_t = mk_bnf_t_Ds Ds;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   891
    val mk_bnf_T = mk_bnf_T_Ds Ds;
49453
ff0e540d8758 add rel as first-class citizen of BNF
blanchet
parents: 49452
diff changeset
   892
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   893
    val pred2RTs = map2 mk_pred2T As' Bs';
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   894
    val pred2RTsAsCs = map2 mk_pred2T As' Cs;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   895
    val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   896
    val pred2RT's = map2 mk_pred2T Bs' As';
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   897
    val self_pred2RTs = map2 mk_pred2T As' As';
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   898
    val transfer_domRTs = map2 mk_pred2T As' B1Ts;
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   899
    val transfer_ranRTs = map2 mk_pred2T Bs' B2Ts;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   900
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   901
    val CA' = mk_bnf_T As' Calpha;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   902
    val CB' = mk_bnf_T Bs' Calpha;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   903
    val CC' = mk_bnf_T Cs Calpha;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   904
    val CB1 = mk_bnf_T B1Ts Calpha;
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   905
    val CB2 = mk_bnf_T B2Ts Calpha;
49453
ff0e540d8758 add rel as first-class citizen of BNF
blanchet
parents: 49452
diff changeset
   906
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   907
    val bnf_map_AsAs = mk_bnf_map As' As';
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   908
    val bnf_map_AsBs = mk_bnf_map As' Bs';
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   909
    val bnf_map_AsCs = mk_bnf_map As' Cs;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   910
    val bnf_map_BsCs = mk_bnf_map Bs' Cs;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   911
    val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   912
    val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   913
    val bnf_bd_As = mk_bnf_t As' bnf_bd;
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   914
    fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   915
49595
e8c57e59cbf8 got rid of other instance of shaky "Thm.generalize"
blanchet
parents: 49594
diff changeset
   916
    val pre_names_lthy = lthy;
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   917
    val (((((((((((((((fs, gs), hs), x), y), zs), ys), As),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   918
      As_copy), bs), Rs), Rs_copy), Ss),
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   919
      transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy
52923
traytel
parents: 52844
diff changeset
   920
      |> mk_Frees "f" (map2 (curry op -->) As' Bs')
traytel
parents: 52844
diff changeset
   921
      ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs)
traytel
parents: 52844
diff changeset
   922
      ||>> mk_Frees "h" (map2 (curry op -->) As' Ts)
51894
traytel
parents: 51893
diff changeset
   923
      ||>> yield_singleton (mk_Frees "x") CA'
traytel
parents: 51893
diff changeset
   924
      ||>> yield_singleton (mk_Frees "y") CB'
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   925
      ||>> mk_Frees "z" As'
51916
eac9e9a45bf5 stronger monotonicity property for relators
traytel
parents: 51915
diff changeset
   926
      ||>> mk_Frees "y" Bs'
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   927
      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   928
      ||>> mk_Frees "A" (map HOLogic.mk_setT As')
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   929
      ||>> mk_Frees "b" As'
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   930
      ||>> mk_Frees "R" pred2RTs
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   931
      ||>> mk_Frees "R" pred2RTs
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   932
      ||>> mk_Frees "S" pred2RTsBsCs
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   933
      ||>> mk_Frees "R" transfer_domRTs
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   934
      ||>> mk_Frees "S" transfer_ranRTs;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   935
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   936
    val fs_copy = map2 (retype_free o fastype_of) fs gs;
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   937
    val x_copy = retype_free CA' y;
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   938
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
   939
    val rel = mk_bnf_rel pred2RTs CA' CB';
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
   940
    val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
   941
    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
   942
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
   943
    val map_id0_goal =
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   944
      let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   945
        mk_Trueprop_eq (bnf_map_app_id, HOLogic.id_const CA')
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   946
      end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   947
53287
271b34513bfb renamed BNF axiom
blanchet
parents: 53285
diff changeset
   948
    val map_comp0_goal =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   949
      let
49018
b2884253b421 renamed ML function for consistency
blanchet
parents: 49016
diff changeset
   950
        val bnf_map_app_comp = Term.list_comb (bnf_map_AsCs, map2 (curry HOLogic.mk_comp) gs fs);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   951
        val comp_bnf_map_app = HOLogic.mk_comp
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   952
          (Term.list_comb (bnf_map_BsCs, gs), Term.list_comb (bnf_map_AsBs, fs));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   953
      in
49123
263b0e330d8b more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents: 49111
diff changeset
   954
        fold_rev Logic.all (fs @ gs) (mk_Trueprop_eq (bnf_map_app_comp, comp_bnf_map_app))
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   955
      end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   956
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   957
    fun mk_map_cong_prem x z set f f_copy =
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   958
      Logic.all z (Logic.mk_implies
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   959
        (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set $ x)),
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   960
        mk_Trueprop_eq (f $ z, f_copy $ z)));
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   961
51761
4c9f08836d87 renamed "map_cong" axiom to "map_cong0" in preparation for real "map_cong"
blanchet
parents: 51758
diff changeset
   962
    val map_cong0_goal =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   963
      let
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   964
        val prems = map4 (mk_map_cong_prem x) zs bnf_sets_As fs fs_copy;
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   965
        val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   966
          Term.list_comb (bnf_map_AsBs, fs_copy) $ x);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   967
      in
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
   968
        fold_rev Logic.all (x :: fs @ fs_copy) (Logic.list_implies (prems, eq))
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   969
      end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   970
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
   971
    val set_map0s_goal =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   972
      let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   973
        fun mk_goal setA setB f =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   974
          let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   975
            val set_comp_map =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   976
              HOLogic.mk_comp (setB, Term.list_comb (bnf_map_AsBs, fs));
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   977
            val image_comp_set = HOLogic.mk_comp (mk_image f, setA);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   978
          in
49123
263b0e330d8b more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents: 49111
diff changeset
   979
            fold_rev Logic.all fs (mk_Trueprop_eq (set_comp_map, image_comp_set))
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   980
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   981
      in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   982
        map3 mk_goal bnf_sets_As bnf_sets_Bs fs
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   983
      end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   984
49458
blanchet
parents: 49456
diff changeset
   985
    val card_order_bd_goal = HOLogic.mk_Trueprop (mk_card_order bnf_bd_As);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   986
49458
blanchet
parents: 49456
diff changeset
   987
    val cinfinite_bd_goal = HOLogic.mk_Trueprop (mk_cinfinite bnf_bd_As);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   988
49458
blanchet
parents: 49456
diff changeset
   989
    val set_bds_goal =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   990
      let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   991
        fun mk_goal set =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   992
          Logic.all x (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (set $ x)) bnf_bd_As));
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   993
      in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   994
        map mk_goal bnf_sets_As
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   995
      end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
   996
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   997
    val relAsCs = mk_bnf_rel pred2RTsAsCs CA' CC';
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   998
    val relBsCs = mk_bnf_rel pred2RTsBsCs CB' CC';
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
   999
    val rel_OO_lhs = Term.list_comb (relAsCs, map2 (curry mk_rel_compp) Rs Ss);
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1000
    val rel_OO_rhs = mk_rel_compp (Term.list_comb (rel, Rs), Term.list_comb (relBsCs, Ss));
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1001
    val le_rel_OO_goal =
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1002
      fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1003
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1004
    val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1005
      Term.list_comb (mk_OO_Grp Ds As' Bs', Rs)));
49453
ff0e540d8758 add rel as first-class citizen of BNF
blanchet
parents: 49452
diff changeset
  1006
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
  1007
    val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1008
      card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1009
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1010
    fun mk_wit_goals (I, wit) =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1011
      let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1012
        val xs = map (nth bs) I;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1013
        fun wit_goal i =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1014
          let
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1015
            val z = nth zs i;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1016
            val set_wit = nth bnf_sets_As i $ Term.list_comb (wit, xs);
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1017
            val concl = HOLogic.mk_Trueprop
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1018
              (if member (op =) I i then HOLogic.mk_eq (z, nth bs i)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1019
              else @{term False});
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1020
          in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1021
            fold_rev Logic.all (z :: xs)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1022
              (Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_mem (z, set_wit)), concl))
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1023
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1024
      in
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1025
        map wit_goal (0 upto live - 1)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1026
      end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1027
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1028
    fun triv_wit_tac ctxt = mk_trivial_wit_tac ctxt bnf_wit_defs;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1029
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1030
    val wit_goalss =
54921
862c36b6e57c avoid schematic variable in goal, which sometimes gets instantiated by tactic
blanchet
parents: 54841
diff changeset
  1031
      (if null raw_wits then SOME triv_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1032
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1033
    fun after_qed mk_wit_thms thms lthy =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1034
      let
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1035
        val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1036
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1037
        val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1038
        val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1039
        val bd_Cnotzero = bd_Cinfinite RS @{thm Cinfinite_Cnotzero};
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1040
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
  1041
        fun mk_collect_set_map () =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1042
          let
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1043
            val defT = mk_bnf_T Ts Calpha --> HOLogic.mk_setT T;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1044
            val collect_map = HOLogic.mk_comp
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1045
              (mk_collect (map (mk_bnf_t Ts) bnf_sets) defT,
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1046
              Term.list_comb (mk_bnf_map As' Ts, hs));
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1047
            val image_collect = mk_collect
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1048
              (map2 (fn h => fn set => HOLogic.mk_comp (mk_image h, set)) hs bnf_sets_As)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1049
              defT;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1050
            (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
49123
263b0e330d8b more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents: 49111
diff changeset
  1051
            val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1052
          in
53289
5e0623448bdb renamed BNF axiom
blanchet
parents: 53288
diff changeset
  1053
            Goal.prove_sorry lthy [] [] goal (K (mk_collect_set_map_tac (#set_map0 axioms)))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1054
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1055
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1056
51766
f19a4d0ab1bf renamed "set_natural" to "set_map", reflecting {Bl,Po,Tr} concensus
blanchet
parents: 51765
diff changeset
  1057
        val collect_set_map = Lazy.lazy mk_collect_set_map;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1058
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1059
        fun mk_in_mono () =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1060
          let
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1061
            val prems_mono = map2 (HOLogic.mk_Trueprop oo mk_leq) As As_copy;
49458
blanchet
parents: 49456
diff changeset
  1062
            val in_mono_goal =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1063
              fold_rev Logic.all (As @ As_copy)
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1064
                (Logic.list_implies (prems_mono, HOLogic.mk_Trueprop
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1065
                  (mk_leq (mk_in As bnf_sets_As CA') (mk_in As_copy bnf_sets_As CA'))));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1066
          in
51551
88d1d19fb74f tuned signature and module arrangement;
wenzelm
parents: 49631
diff changeset
  1067
            Goal.prove_sorry lthy [] [] in_mono_goal (K (mk_in_mono_tac live))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1068
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1069
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1070
49538
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
  1071
        val in_mono = Lazy.lazy mk_in_mono;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1072
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1073
        fun mk_in_cong () =
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1074
          let
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1075
            val prems_cong = map2 (curry mk_Trueprop_eq) As As_copy;
49458
blanchet
parents: 49456
diff changeset
  1076
            val in_cong_goal =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1077
              fold_rev Logic.all (As @ As_copy)
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1078
                (Logic.list_implies (prems_cong,
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1079
                  mk_Trueprop_eq (mk_in As bnf_sets_As CA', mk_in As_copy bnf_sets_As CA')));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1080
          in
51798
ad3a241def73 uniform Proof.context for hyp_subst_tac;
wenzelm
parents: 51790
diff changeset
  1081
            Goal.prove_sorry lthy [] [] in_cong_goal
ad3a241def73 uniform Proof.context for hyp_subst_tac;
wenzelm
parents: 51790
diff changeset
  1082
              (K ((TRY o hyp_subst_tac lthy THEN' rtac refl) 1))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1083
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1084
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1085
49538
c90818b63599 simplified fact policies
blanchet
parents: 49537
diff changeset
  1086
        val in_cong = Lazy.lazy mk_in_cong;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1087
53285
f09645642984 renamed BNF fact
blanchet
parents: 53270
diff changeset
  1088
        val map_id = Lazy.lazy (fn () => mk_map_id (#map_id0 axioms));
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
  1089
        val map_comp = Lazy.lazy (fn () => mk_map_comp (#map_comp0 axioms));
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1090
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1091
        fun mk_map_cong () =
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1092
          let
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1093
            val prem0 = mk_Trueprop_eq (x, x_copy);
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1094
            val prems = map4 (mk_map_cong_prem x_copy) zs bnf_sets_As fs fs_copy;
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1095
            val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1096
              Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1097
            val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1098
              (Logic.list_implies (prem0 :: prems, eq));
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1099
          in
51798
ad3a241def73 uniform Proof.context for hyp_subst_tac;
wenzelm
parents: 51790
diff changeset
  1100
            Goal.prove_sorry lthy [] [] goal (fn _ => mk_map_cong_tac lthy (#map_cong0 axioms))
51762
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1101
            |> Thm.close_derivation
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1102
          end;
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1103
219a3063ed29 derive "map_cong"
blanchet
parents: 51761
diff changeset
  1104
        val map_cong = Lazy.lazy mk_map_cong;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1105
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
  1106
        val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1107
54189
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1108
        val wit_thms =
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1109
          if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
c0186a0d8cb3 define a trivial nonemptiness witness if none is provided
traytel
parents: 54158
diff changeset
  1110
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1111
        fun mk_in_bd () =
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1112
          let
52813
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1113
            val bdT = fst (dest_relT (fastype_of bnf_bd_As));
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1114
            val bdTs = replicate live bdT;
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1115
            val bd_bnfT = mk_bnf_T bdTs Calpha;
52813
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1116
            val surj_imp_ordLeq_inst = (if live = 0 then TrueI else
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1117
              let
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1118
                val ranTs = map (fn AT => mk_sumT (AT, HOLogic.unitT)) As';
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1119
                val funTs = map (fn T => bdT --> T) ranTs;
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1120
                val ran_bnfT = mk_bnf_T ranTs Calpha;
52813
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1121
                val (revTs, Ts) = `rev (bd_bnfT :: funTs);
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1122
                val cTs = map (SOME o certifyT lthy) [ran_bnfT, Library.foldr1 HOLogic.mk_prodT Ts];
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1123
                val tinst = fold (fn T => fn t => HOLogic.mk_split (Term.absdummy T t)) (tl revTs)
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1124
                  (Term.absdummy (hd revTs) (Term.list_comb (mk_bnf_map bdTs ranTs,
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1125
                    map Bound (live - 1 downto 0)) $ Bound live));
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1126
                val cts = [NONE, SOME (certify lthy tinst)];
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1127
              in
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1128
                Drule.instantiate' cTs cts @{thm surj_imp_ordLeq}
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1129
              end);
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1130
            val bd = mk_cexp
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1131
              (if live = 0 then ctwo
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1132
                else mk_csum (Library.foldr1 (uncurry mk_csum) (map mk_card_of As)) ctwo)
52813
963297a24206 more robust tactic
traytel
parents: 52731
diff changeset
  1133
              (mk_csum bnf_bd_As (mk_card_of (HOLogic.mk_UNIV bd_bnfT)));
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1134
            val in_bd_goal =
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1135
              fold_rev Logic.all As
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1136
                (HOLogic.mk_Trueprop (mk_ordLeq (mk_card_of (mk_in As bnf_sets_As CA')) bd));
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1137
          in
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1138
            Goal.prove_sorry lthy [] [] in_bd_goal
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1139
              (fn {context = ctxt, prems = _} => mk_in_bd_tac ctxt live surj_imp_ordLeq_inst
53288
050d0bc9afa5 renamed BNF fact
blanchet
parents: 53287
diff changeset
  1140
                (Lazy.force map_comp) (Lazy.force map_id) (#map_cong0 axioms)
53290
b6c3be868217 renamed BNF fact
blanchet
parents: 53289
diff changeset
  1141
                (map Lazy.force set_map) (#set_bd axioms) (#bd_card_order axioms)
52635
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1142
                bd_Card_order bd_Cinfinite bd_Cnotzero)
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1143
            |> Thm.close_derivation
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1144
          end;
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1145
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1146
        val in_bd = Lazy.lazy mk_in_bd;
4f84b730c489 got rid of in_bd BNF property (derivable from set_bd+map_cong+map_comp+map_id)
traytel
parents: 51930
diff changeset
  1147
53561
92bcac4f9ac9 simplified derivation of in_rel
traytel
parents: 53290
diff changeset
  1148
        val rel_OO_Grp = #rel_OO_Grp axioms;
92bcac4f9ac9 simplified derivation of in_rel
traytel
parents: 53290
diff changeset
  1149
        val rel_OO_Grps = no_refl [rel_OO_Grp];
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1150
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1151
        fun mk_rel_Grp () =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1152
          let
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1153
            val lhs = Term.list_comb (rel, map2 mk_Grp As fs);
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1154
            val rhs = mk_Grp (mk_in As bnf_sets_As CA') (Term.list_comb (bnf_map_AsBs, fs));
49123
263b0e330d8b more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents: 49111
diff changeset
  1155
            val goal = fold_rev Logic.all (As @ fs) (mk_Trueprop_eq (lhs, rhs));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1156
          in
51551
88d1d19fb74f tuned signature and module arrangement;
wenzelm
parents: 49631
diff changeset
  1157
            Goal.prove_sorry lthy [] [] goal
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1158
              (fn {context = ctxt, prems = _} => mk_rel_Grp_tac ctxt rel_OO_Grps (#map_id0 axioms)
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1159
                (#map_cong0 axioms) (Lazy.force map_id) (Lazy.force map_comp)
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1160
                (map Lazy.force set_map))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1161
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1162
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1163
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1164
        val rel_Grp = Lazy.lazy mk_rel_Grp;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1165
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1166
        fun mk_rel_prems f = map2 (HOLogic.mk_Trueprop oo f) Rs Rs_copy
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1167
        fun mk_rel_concl f = HOLogic.mk_Trueprop
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1168
          (f (Term.list_comb (rel, Rs), Term.list_comb (rel, Rs_copy)));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1169
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1170
        fun mk_rel_mono () =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1171
          let
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1172
            val mono_prems = mk_rel_prems mk_leq;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1173
            val mono_concl = mk_rel_concl (uncurry mk_leq);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1174
          in
51551
88d1d19fb74f tuned signature and module arrangement;
wenzelm
parents: 49631
diff changeset
  1175
            Goal.prove_sorry lthy [] []
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1176
              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (mono_prems, mono_concl)))
52844
66fa0f602cc4 more robust tactics (don't use unfolding when RHS might contain schematics not contained on the LHS)
traytel
parents: 52813
diff changeset
  1177
              (K (mk_rel_mono_tac rel_OO_Grps (Lazy.force in_mono)))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1178
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1179
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1180
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1181
        fun mk_rel_cong () =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1182
          let
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1183
            val cong_prems = mk_rel_prems (curry HOLogic.mk_eq);
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1184
            val cong_concl = mk_rel_concl HOLogic.mk_eq;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1185
          in
51551
88d1d19fb74f tuned signature and module arrangement;
wenzelm
parents: 49631
diff changeset
  1186
            Goal.prove_sorry lthy [] []
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1187
              (fold_rev Logic.all (Rs @ Rs_copy) (Logic.list_implies (cong_prems, cong_concl)))
51798
ad3a241def73 uniform Proof.context for hyp_subst_tac;
wenzelm
parents: 51790
diff changeset
  1188
              (fn _ => (TRY o hyp_subst_tac lthy THEN' rtac refl) 1)
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1189
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1190
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1191
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1192
        val rel_mono = Lazy.lazy mk_rel_mono;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1193
        val rel_cong = Lazy.lazy mk_rel_cong;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1194
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1195
        fun mk_rel_eq () =
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
  1196
          Goal.prove_sorry lthy [] []
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
  1197
            (mk_Trueprop_eq (Term.list_comb (relAsAs, map HOLogic.eq_const As'),
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
  1198
              HOLogic.eq_const CA'))
53270
c8628119d18e renamed BNF axiom
blanchet
parents: 53265
diff changeset
  1199
            (K (mk_rel_eq_tac live (Lazy.force rel_Grp) (Lazy.force rel_cong) (#map_id0 axioms)))
52719
480a3479fa47 transfer rule for map (not yet registered as a transfer rule)
traytel
parents: 52635
diff changeset
  1200
          |> Thm.close_derivation;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1201
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1202
        val rel_eq = Lazy.lazy mk_rel_eq;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1203
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1204
        fun mk_rel_conversep () =
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1205
          let
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1206
            val relBsAs = mk_bnf_rel pred2RT's CB' CA';
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1207
            val lhs = Term.list_comb (relBsAs, map mk_conversep Rs);
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1208
            val rhs = mk_conversep (Term.list_comb (rel, Rs));
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1209
            val le_goal = fold_rev Logic.all Rs (HOLogic.mk_Trueprop (mk_leq lhs rhs));
51551
88d1d19fb74f tuned signature and module arrangement;
wenzelm
parents: 49631
diff changeset
  1210
            val le_thm = Goal.prove_sorry lthy [] [] le_goal
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1211
              (fn {context = ctxt, prems = _} => mk_rel_conversep_le_tac ctxt rel_OO_Grps
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1212
                (Lazy.force rel_eq) (#map_cong0 axioms) (Lazy.force map_comp)
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1213
                (map Lazy.force set_map))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1214
              |> Thm.close_derivation
49123
263b0e330d8b more work on sugar + simplify Trueprop + eq idiom everywhere
blanchet
parents: 49111
diff changeset
  1215
            val goal = fold_rev Logic.all Rs (mk_Trueprop_eq (lhs, rhs));
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1216
          in
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1217
            Goal.prove_sorry lthy [] [] goal
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1218
              (K (mk_rel_conversep_tac le_thm (Lazy.force rel_mono)))
49109
0e5b859e1c91 no more aliases for Local_Theory.note; use Thm.close_derivation in internal theorems;
traytel
parents: 49103
diff changeset
  1219
            |> Thm.close_derivation
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1220
          end;
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1221
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1222
        val rel_conversep = Lazy.lazy mk_rel_conversep;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1223
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1224
        fun mk_rel_OO () =
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1225
          Goal.prove_sorry lthy [] []
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1226
            (fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_lhs rel_OO_rhs)))
55197
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1227
            (fn {context = ctxt, prems = _} => mk_rel_OO_le_tac ctxt rel_OO_Grps (Lazy.force rel_eq)
5a54ed681ba2 less hermetic tactics
traytel
parents: 55061
diff changeset
  1228
              (#map_cong0 axioms) (Lazy.force map_comp) (map Lazy.force set_map))
54841
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1229
          |> Thm.close_derivation
af71b753c459 express weak pullback property of bnfs only in terms of the relator
traytel
parents: 54740
diff changeset
  1230
          |> (fn thm => @{thm antisym} OF [thm, #le_rel_OO axioms]);
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1231
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1232
        val rel_OO = Lazy.lazy mk_rel_OO;
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1233
53561
92bcac4f9ac9 simplified derivation of in_rel
traytel
parents: 53290
diff changeset
  1234
        fun mk_in_rel () = trans OF [rel_OO_Grp, @{thm OO_Grp_alt}] RS @{thm predicate2_eqD};
48975
7f79f94a432c added new (co)datatype package + theories of ordinals and cardinals (with Dmitriy and Andrei)
blanchet
parents:
diff changeset
  1235
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1236
        val in_rel = Lazy.lazy mk_in_rel;
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
  1237
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
  1238
        fun mk_rel_flip () =
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
  1239
          let
51893
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1240
            val rel_conversep_thm = Lazy.force rel_conversep;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1241
            val cts = map (SOME o certify lthy) Rs;
596baae88a88 got rid of the set based relator---use (binary) predicate based relator instead
traytel
parents: 51837
diff changeset
  1242
            val rel_conversep_thm' = cterm_instantiate_pos cts rel_conversep_thm;
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536
diff changeset
  1243
          in
51917
f964a9887713 store proper theorems even for fixed points that have no passive live variables
traytel
parents: 51916
diff changeset
  1244
            unfold_thms lthy @{thms conversep_iff} (rel_conversep_thm' RS @{thm predicate2_eqD})
49595
e8c57e59cbf8 got rid of other instance of shaky "Thm.generalize"
blanchet
parents: 49594
diff changeset
  1245
            |> singleton (Proof_Context.export names_lthy pre_names_lthy)
49537
fe1deee434b6 generate "rel_as_srel" and "rel_flip" properties
blanchet
parents: 49536